-- 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. -- Exceptions are used to recover gracefully from compilation errors. -- 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 filename:string99; -- to hold the input file name filename_size:natural; -- and its length SYNTAX_ERROR:exception; -- a generic exception for compiling 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 functions that return a -- structure. Exceptions are used for error handling. -- 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 -- It will fail if a nonidentifer is the current token, so a call -- to IS_ID may be required before calling ID. procedure id is NO_ID:exception; begin if reserved(token) then raise NO_ID; end if; GetToken(ifs); exception when NO_ID => PUT_LINE("identifier expected"); raise SYNTAX_ERROR; end id; -- encodes the rule ::= {} -- returns a list of parameter symbols if no exception is raised function params return list_of_symbols_ptr is x:symbol_type_ptr; l:list_of_symbols_ptr:=new list_of_symbols; begin x:=new symbol_type; x.all:=token.all; id; insert(l,x); x:=new symbol_type; x.all:=token.all; while is_id loop id; insert(l,x); x:=new symbol_type; x.all:=token.all; end loop; return l; exception when SYNTAX_ERROR => PUT_LINE("bad parameter list"); raise; end params; -- encodes the rule ::= call {} -- returns a list of symbols in the call if no exception is raised. -- FALSE and an unspecified value otherwise function call return 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 NO_CALL,ID_EXPECTED:exception; begin if not equal(token,call_token) then raise NO_CALL; end if; GetToken(ifs); fname.all:=token.all; if not is_id then raise ID_EXPECTED; end if; x:=new symbol_type; x.all:=token.all; while is_id loop id; insert(slist,x); -- insert previous token, so needn't test success x:=new symbol_type; x.all:=token.all; end loop; return slist; exception when NO_CALL => PUT_LINE("token 'call' expected"); raise SYNTAX_ERROR; when ID_EXPECTED => PUT_LINE("identifier expected"); raise SYNTAX_ERROR; when others => raise; end call; -- encodes the rule ::= {} -- returns a list of calls if no exception is raised -- does not raise its own exception, but explicitly propagates others function my_body return list_of_lists_ptr is blist:list_of_lists_ptr:=new list_of_lists; clist:list_of_symbols_ptr:=new list_of_symbols; begin clist:=call; insert(blist,clist); while equal(token,call_token) loop clist:=call; insert(blist,clist); end loop; return blist; exception when others => raise; end my_body; -- forward declaration to avoid indirect recursion between -- the functions "functions" and "funct" function functions(caller:function_ptr) return list_of_functions_ptr; -- encodes the rule -- ::= function [] begin [] [] end -- returns a pointer to a function object if no exception is raised function funct(caller:function_ptr) return function_ptr is NO_BEGIN,NO_END:exception; FUNCTION_EXPECTED:exception; NO_FUNCTION_NAME,BAD_PARAMETER_LIST:exception; 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 if not equal(token,function_token) then raise FUNCTION_EXPECTED; end if; GetToken(ifs); fname:=new symbol_type; fname.all:=token.all; id; if is_id then plist:=params; end if; put_line(token.name(1..token.length)); if not equal(token,begin_token) then PUT_LINE("no BEGIN in function def"); 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 flist:=functions(f); -- can call only after f val found f.subroutines := flist; end if; if equal(token,call_token) then blist:=my_body; f.instrs := blist; f.code:=build_list_of_encodings(f); end if; if not equal(token,end_token) then raise NO_END; end if; GetToken(ifs); return f; exception when FUNCTION_EXPECTED => PUT_LINE("token 'function' expected!"); raise SYNTAX_ERROR; when NO_FUNCTION_NAME => PUT_LINE("no function name!"); raise SYNTAX_ERROR; when NO_BEGIN => PUT_LINE("token 'begin' expected"); raise SYNTAX_ERROR; when NO_END => PUT_LINE("no END to match BEGIN"); raise SYNTAX_ERROR; when others => raise; end funct; -- encodes the rule ::= {} -- Install the compiled versions of all functions local to a -- given function CALLER. -- returns a list of these local functions if no exceptions raised -- does not raise its own exceptions, but explicitly propagates others -- Want to insert into representation of caller so that searches -- for nonlocal variables succeed. function functions(caller:function_ptr) return list_of_functions_ptr is f:function_ptr; fs:list_of_functions_ptr:=new list_of_functions; begin f:=funct(caller); insert(caller.subroutines,f); insert(fs,f); while equal(token,function_token) loop f:=funct(caller); insert(caller.subroutines,f); insert(fs,f); end loop; return fs; exception when others => raise; end functions; -- encodes the rule ::= . -- returns a pointer to the top-level function object if no exception raised -- The only side effects are produced by the call to FUNCT function program(caller:function_ptr) return function_ptr is f:function_ptr; NO_PERIOD:exception; begin f:=funct(caller); if not equal(token,period_token) then raise NO_PERIOD; end if; return f; exception when NO_PERIOD => PUT_LINE("no period at end"); raise SYNTAX_ERROR; when others => raise SYNTAX_ERROR; end program; ---------------------- The top-level parsing function ------------------ function compile return function_ptr is f:function_ptr; begin GetToken(ifs); -- using one symbol of lookahead f:=program(NULL); -- parse as function with no caller return f; exception when SYNTAX_ERROR => raise; -- propagate error 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; PUT_LINE("compiled successfully"); run(e,f); CLOSE(ifs); exception when SYNTAX_ERROR => PUT_LINE("-- failed to compile"); end main;