-- This program simulates execution of a program in an simple, -- invented functional programming language with static scoping, -- using environments and activation records to implement this combination. -- In this language, the main program (more precisely, the main -- function) statically encloses any subsidiary functions used. -- A type is defined for activation records, and one for environments. -- Other types are defined for functions, for lists (of symbols), -- lists of lists, lists of functions, offset pairs (of symbols and -- values), encodings (= lists of such offsets), and list of encodings. -- Symbols are defined as instances of a type SYMBOL_TYPE. Reserved -- words in the grammar are defined as instances of this type. -- An encoding of a function call corresponds to a translation into -- a target language, where both the function called and each of its -- arguments are represented as an offset pair. The first element of the -- pair represents the static distance from the block where the identifier -- is used to the block where is it defined. The second element is -- the offset from the beginning of this latter block to the symbol -- itself. -- No check is made for duplicate indentifers among the parameters -- or local variables of a function block. The actual n arguments -- used for the call to the outermost function are the constants -- 1, 2, ..., n, where the constant k is represented as the offset -- pair (99, k). -- Scopes of function names are assumed to begin at their point of definition -- No storage is reclaimed. -- During a simulated run, the values of all actual values bound to -- formal parameters are printed. -- Global variables "ifs" and "token" are used for the stream associated -- with the input file and for the token last read from this stream. -- The grammar for the language is: -- ::= . -- ::= function [] -- begin [] [] end -- ::= {} -- ::= {} -- ::= {} -- ::= call {} with TEXT_IO; use TEXT_IO; with FUNDAMENTALS; use FUNDAMENTALS; with FUNCT; use FUNCT; with ENVIRONMENT_PKG; use ENVIRONMENT_PKG; procedure main is package INT_IO is new INTEGER_IO(INTEGER); use INT_IO; subtype string99 is string(1..99); -- a type for filenames ifs:FILE_TYPE; -- handle for the input file success:BOOLEAN; -- for propagation of parsing success/failure filename:string99; -- to hold the input file name filename_size:natural; -- and its length f:function_ptr; -- to point to the top-level function e:environment_ptr; -- pointer to the environment a:activation_ptr; -- and its top-level activation record dummy:symbol_type_ptr; -- "dummy" is name of top-level function -- variables for the reserved words in this grammar. -- They are initialized by the function INITIALIZE call_token:symbol_type_ptr; begin_token:symbol_type_ptr; end_token:symbol_type_ptr; function_token:symbol_type_ptr; period_token:symbol_type_ptr; -------------------- UTILITY FUNCTIONS FOR THE PARSER ------------------/ -- Get the next token from the input stream and assign it to the -- global variable "token". -- Note that a delimiter symbols will be read at the end of each -- token and discarded; this is ok since the symbol cannot belong -- to the next token. -- An auxilary function LEGAL_CHARACTER is used to check for delimiters -- and an auxiliary procedure MY_GET handles peculiarities of GET -- regarding end of line and end of file. procedure GetToken(ifs:FILE_TYPE) is c:character; function legal_character(c:character) return BOOLEAN is begin return character'pos(c) in 33..127; end legal_character; procedure my_get(ifs:FILE_TYPE; c:in out character) is begin if end_of_line(ifs) then skip_line(ifs); c:=' '; else GET(ifs,c); end if; end my_get; begin -- GetToken token.name:=(others=>' '); loop MY_GET(ifs,c); if legal_character(c) then token.name(1):=c; token.length:=1; if end_of_file(ifs) then return; end if; MY_GET(ifs,c); exit; end if; end loop; for i in 2..token_size loop if end_of_file(ifs) then exit; elsif not legal_character(c) then exit; else token.name(i):=c; token.length:=i; MY_GET(ifs,c); end if; end loop; PUT_LINE(token.name(1..token_size)); end; -- Determine whether the input string "w" represents a reserved word function reserved(w:symbol_type_ptr) return BOOLEAN is begin if equal(w,begin_token) then return TRUE; elsif equal(w,end_token) then return TRUE; elsif equal(w,call_token) then return TRUE; elsif equal(w,function_token) then return TRUE; elsif equal(w,period_token) then return TRUE; else return FALSE; end if; end reserved; ---------------- RECOGNITION FUNCTIONS FOR NONTERMINALS -------------- -- all except ID (and IS_ID) are written as procedures in order to return -- an indication of SUCCESS as well as return a structure. The structure -- is always passed in the last parameter position. Both it and SUCCESS -- are passed as IN OUT parameters. -- recognizer for identifiers that doesn't consume a token -- For this simple grammar, a token is an identifier iff it -- does not represent a reserved word function is_id return BOOLEAN is begin return not reserved(token); end is_id; -- recognition functions for nonterminal categories. -- This recognizer for the ID category consumes a token function id return BOOLEAN is b:BOOLEAN:=not reserved(token); begin GetToken(ifs); return b; end id; -- encodes the rule ::= {} -- passes back in the IN OUT parameters -- TRUE and a list of parameter symbols if successful -- FALSE and the empty list otherwise procedure params(success:in out BOOLEAN; ls:in out list_of_symbols_ptr) is x:symbol_type_ptr; l:list_of_symbols_ptr:=new list_of_symbols; begin success:=TRUE; x:=new symbol_type; x.all:=token.all; if not id then success:=FALSE; ls:=l; return; end if; insert(l,x); x:=new symbol_type; x.all:=token.all; while is_id loop success:=id; -- gets new token; should always succeed insert(l,x); x:=new symbol_type; x.all:=token.all; end loop; ls:=l; end params; -- encodes the rule ::= call {} -- passes back in the IN OUT parameters -- TRUE and a list of symbols in the call if successful -- FALSE and an unspecified value otherwise procedure call(success:in out BOOLEAN; ls:in out list_of_symbols_ptr) is fname:symbol_type_ptr:=new symbol_type; x:symbol_type_ptr; slist:list_of_symbols_ptr:=new list_of_symbols; -- for uncoded body begin success:=TRUE; if not equal(token,call_token) then success:=FALSE; ls:=slist; return; end if; GetToken(ifs); fname.all:=token.all; if not is_id then success:=FALSE; return; end if; x:=new symbol_type; x.all:=token.all; -- insert(slist,fname); while is_id loop success:=id; -- gets new token; should always succeed insert(slist,x); -- insert previous token, so needn't test success x:=new symbol_type; x.all:=token.all; end loop; ls:=slist; end call; -- /* encodes the rule ::= {} */ -- passes back as IN OUT parameters -- TRUE and a list of calls if successful -- FALSE and an unspecified result otherwise procedure my_body(success:in out BOOLEAN; ll:in out list_of_lists_ptr) is blist:list_of_lists_ptr:=new list_of_lists; clist:list_of_symbols_ptr:=new list_of_symbols; begin call(success,clist); if not success then success:=TRUE; ll:=blist; return; end if; insert(blist,clist); while equal(token,call_token) loop call(success,clist); if success then insert(blist,clist); else return; -- success will have value FALSE end if; end loop; success:=TRUE; -- now useless? ll:=blist; end my_body; -- forward declaration to avoid indirect recursion between -- the functions "functions" and "funct" procedure functions(caller:function_ptr; success:in out BOOLEAN; lf:in out list_of_functions_ptr); -- encodes the rule -- ::= function [] begin [] [] end -- passes back as IN OUT parameters -- TRUE and a pointer to a function object if successful -- FALSE and an unspecified result otherwise procedure funct(caller:function_ptr; success:in out BOOLEAN; fp:in out function_ptr) is f:function_ptr; fname:symbol_type_ptr; plist:list_of_symbols_ptr:=new list_of_symbols; flist:list_of_functions_ptr:=new list_of_functions; blist:list_of_lists_ptr:=new list_of_lists; begin success:=TRUE; if not equal(token,function_token) then success:=FALSE; fp:=NULL; return; end if; GetToken(ifs); fname:=new symbol_type; fname.all:=token.all; if not id then PUT_LINE("no function name!"); success:=FALSE; fp:= NULL; return; end if; if is_id then params(success,plist); if not success then PUT_LINE("bad parameter list"); fp:=NULL; return; -- success has value FALSE end if; end if; put_line(token.name(1..token.length)); if not equal(token,begin_token) then PUT_LINE("no BEGIN in function def"); success:=FALSE; fp:=NULL; return; end if; GetToken(ifs); -- side effect below: fname is put on callers' subr_names list f:=new my_function'(fname,caller,plist, new list_of_symbols, flist, new list_of_lists, new list_of_encodings); -- need all components?? if caller/=NULL then insert(caller.subr_names,fname); end if; if equal(token,function_token) then functions(f,success,flist); -- can call only after f val found if not success then fp:=NULL; return; -- success has value FALSE end if; f.subroutines := flist; end if; if equal(token,call_token) then my_body(success,blist); if not success then fp:=NULL; return; -- success has value FALSE end if; f.instrs := blist; f.code:=build_list_of_encodings(f); if f=NULL then success:=FALSE; fp:=NULL; return; end if; if get_size(f.code)=ERROR_FLAG then success:=FALSE; fp:=NULL; return; end if; end if; if not equal(token,end_token) then PUT_LINE("no END to match BEGIN"); success:=FALSE; fp:=NULL; return; end if; GetToken(ifs); fp:=f; end funct; -- encodes the rule ::= {} -- Install the compiled versions of all functions local to a -- given function CALLER. -- passes back in the IN OUT parameters -- TRUE and a list of these local functions if successful. -- FALSE otherwise -- Want to insert into representation of caller so that searches -- for nonlocal variables succeed. procedure functions(caller:function_ptr; success: in out BOOLEAN; lf:in out list_of_functions_ptr) is f:function_ptr; fs:list_of_functions_ptr:=new list_of_functions; begin funct(caller,success,f); if (not success) then lf:=fs; return; -- success has value FALSE end if; insert(caller.subroutines,f); insert(fs,f); while equal(token,function_token) loop funct(caller,success,f); if (not success) then lf:=fs; return; -- success has value FALSE end if; if f=NULL then success:=TRUE; lf:=fs; return; end if; insert(caller.subroutines,f); insert(fs,f); end loop; lf:=fs; end functions; -- encodes the rule ::= . -- It passes in the IN OUT parameters -- TRUE and a pointer to the top-level function object if successful -- FALSE and an empty pointer otherwise. -- The only side effects are produced by the call to FUNCT procedure program(caller:function_ptr; success:in out BOOLEAN; fp:in out function_ptr) is f:function_ptr; begin funct(caller,success,f); if (not success) then fp:=NULL; return; end if; if not equal(token,period_token) then PUT_LINE("no period at end"); success:=FALSE; fp:=NULL; return; end if; fp:=f; end program; ---------------------- The top-level parsing function ------------------ function compile return function_ptr is f:function_ptr; begin GetToken(ifs); -- using one symbol of lookahead program(NULL,success,f); -- parse as function with no caller return f; end; -- This initialization procedure gives the correct values to the -- reserved word symbols, and creates the initial activation -- and environment procedure initialize is begin call_token:=new symbol_type; call_token.length:=4; call_token.name(1..call_token.length):="call"; begin_token:=new symbol_type; begin_token.length:=5; begin_token.name(1..begin_token.length):="begin"; end_token:=new symbol_type; end_token.length:=3; end_token.name(1..end_token.length):="end"; function_token:=new symbol_type; function_token.length:=8; function_token.name(1..function_token.length):="function"; period_token:=new symbol_type; period_token.length:=1; period_token.name(1..period_token.length):="."; dummy:=new symbol_type; dummy.length:=5; dummy.name(1..dummy.length):="dummy"; a:=new activation'(dummy,NULL,NULL,NULL,NULL); e:=new environment'(first=>a); end; -- The main program. Here "f" corresponds to the main function in -- the simulated program. More precisely, it is an object of type -- "funct". The call to COMPILE corresponds to a parser -- for the simulated program. The call to RUN simulates execution -- of the compiled program. begin initialize; PUT_LINE("enter filename:"); GET_LINE(filename,filename_size); OPEN(ifs,IN_FILE,filename(1..filename_size)); f:=compile; if f=NULL then PUT_LINE("-- failed to compile"); else PUT_LINE("compiled successfully"); run(e,f); end if; CLOSE(ifs); end main;