;; 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. ;; The top level function is MAIN, called with no arguments. ;; It prompts for the name of a file containing the program to be simulated. ;; In this language, the main program (more precisely, the main ;; function) statically encloses any subsidiary functions used. ;; Selectors and constructors are provided for activation records and ;; environments. Also for functions, for lists, and for offset pairs. ;; 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 (-1, k). ;; During a simulated run, the values of all actual values bound to ;; formal parameters are printed. ;; The functions corresponding to grammar rules read and write a ;; global variable SUCCESS so that termination is graceful in ;; the case of errors. ;; The grammar for the language is: ;; ::= . ;; ::= function [] ;; begin [] [] end ;; ::= {} ;; ::= {} ;; ::= {} ;; ::= call {} (define CONST_FLAG -1) ; for distinguishing constants from variables ; used in the first component of an offset pair (define ERROR_FLAG -1) (define handle) ; representation of an open file (define token) ; the most recent token of the program (define target) ; for debugging -- stores a rep. of a compiled function (define success #t) ; for error checking during parsing ;;;;;;;;;;;;;;;;;;;;;;;; DATA TYPES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Selectors and constructors for offset pairs (define (first o) (car o)) (define (second o) (cdr o)) (define (build_offset f s) (cons f s)) ; Constructors and selectors for activation records ; The first constructor is used for the top-level simulated function ; call, so it needs no arguments ; The second constructor is used in general. It takes arguments ; representing the 5 components of an activation record ; the control link, the access link, the list of actual arguments, ; the functions local to the corresponding block, and the ; name of the function defined in the corresponding block ; The last of these is for debugging only. ; One (nondestructive) mutator is defined to update the control and ; access links of an activation record. (define (build_dummy_activation) (list '() '() '() '() 'dummy)) (define (build_activation c a acts fctns n) (list c a acts fctns n)) (define (control a) (car a)) (define (access_link a) (cadr a)) (define (actuals a) (caddr a)) (define (fctns a) (cadddr a)) (define (f_name a) (car (cddddr a))) (define (update_control_and_access c act a) (build_activation c a (actuals act) (fctns act) (f_name act))) ; Selectors and constructors for environments ; An environment has only one component -- the top-level activation ; record. ; One (nondestructive) mutator is also defined -- to update the activation ; record. This is used when the activation record itself is modified. (define (build_environment a) (list a)) (define (activation e) (car e)) (define (update_actuals e act) (let ((a (activation e))) (set-car! e (build_activation (control a) (access_link a) act (fctns a) (f_name a))))) ; For representation of functions. The parameters, subroutine ; names (i.e., names of other functions defined in the current ; function's block) and instructions (i.e., the list of calls ; making up the function body) are represented as lists of ; symbols in the source language. The environment pointer ; "ep" is represented at compile time simply as a pointer ; to the calling function. ; Components needed at run time are the translated body, ; which is stored as the value of the CODE component, ; and information about the function's subroutines. This ; latter information is stored simply as a list FUNCTIONs ; Operators on FUNCTIONs include a constructor, and functions ; to translate (i.e., construct offset pairs for) functions and ; variables. The constructor expects a function name, a (pointer ; to a) caller, a list of formal parameters, and a list of subroutines. ; Other member functions simply return the name, the environment ; pointer, the formal parameters, the subroutines, and the arity ; (number of parameters) of a function. ; The constructor only expects four of the seven components ; (which are the name of the function, the calling function, the ; list of parameters, the list of names of local functions, ; the list of the local functions themselves, the untranslated ; body of the function, and the translated body. ; The others will be given values by the mutators defined below. (define (build_function n e p s) (if e (update_subr_names! e n)) (list n e p '() s '() '())) (define (name f) (car f)) (define (ep f) (cadr f)) (define (parameter f) (caddr f)) (define (subr_names f) (cadddr f)) (define (subroutines f) (car (cddddr f))) (define (instrs f) (cadr (cddddr f))) (define (code f) (caddr (cddddr f))) ; Mutators for functions -- these are destructive (define (update_subr_names! f n) (set-car! (cdddr f) (insert n (subr_names f)))) (define (update_instrs! f i) (set-car! (cdr (cddddr f)) i)) (define (update_code! f c) (set-car! (cddr (cddddr f)) c)) ; This mutator is called from FUNCTION, where F represents the caller ; For the top-level function, there is no caller, so a check ; is made for null F. (define (update_subroutines2! f s) (if f (set-car! (cddddr f) (insert s (subroutines f))))) ;///////////// OPERATORS ON THE DATA TYPES DEFINED ABOVE ////////////////// ; Find the activation record N links back in a chain of activation ; records beginning at A (define (find_act a n) (cond ((zero? n) a) (else (find_act (access_link a) (sub1 n))))) ; PUSH and POP activation records to/from an environment ; Note in our application we never need to inspect the item popped ; The 2nd argument to PUSH is a numeric argument telling how far ; back to set the new access link. (define (push act n env) (let ((a (find_act (activation env) n))) (cons (update_control_and_access (activation env) act a) env))) (define (pop env) (cdr env)) ; Insert an item X at the end of a list S. (define (insert x s) (append s (list x))) ; Print an environment -- for debugging only (define (print_env env) (define (print_control a) (cond ((null? a) #f) (else (prin1 (f_name a)) (prin1 '_) (print_control (control a))))) (define (print_access a) (cond ((null? a) #f) (else (prin1 (f_name a)) (prin1 '_) (print_access (access_link a))))) (let ((a (activation env))) (newline) (print_control a) (newline) (print_access a))) ; Find the position of the element X in the list S. ; Return FALSE if missing. (define (search x s) (let ((len (length s)) (ans (search_rec x s))) (if (< ans len) ans #f))) (define (search_rec x s) (cond ((null? s) 1) ((eq? x (car s)) 0) (else (add1 (search_rec x (cdr s)))))) ; Find the position of the function named X in the list S. ; Return FALSE if missing. (define (search_list_of_functions x s) (let ((len (length s)) (ans (search_l_of_f_rec x s))) (if (< ans len) ans #f))) (define (search_l_of_f_rec x s) (cond ((null? s) 1) ((eq? x (name (car s))) 0) (else (add1 (search_l_of_f_rec x (cdr s)))))) ; Get the activation record at a given distance OFFSET1 back ; from the beginning of the environment ENV. The distance ; is measured in the number of access links to follow. (define (get_activation offset1 env) (get_activation_rec offset1 (activation env))) (define (get_activation_rec offset1 act) (if (zero? offset1) act (get_activation_rec (sub1 offset1) (access_link act)))) ; Lists of offsets are used to represent function calls in the ; target language, so a version of the constructor is provided ; to do the translation. The first argument is the source ; language version of the call; the second is a pointer to a ; function object. This function object contains the information ; about block structure needed to translate the call to the ; corresponding function. ; Thus the constructor can merely translate the function name by ; a call to "search_f" and each argument by a call to "search_v". ; If any search fails, the constructor signals an error by ; returning an error flag in the "size" field of the constructed ; list. (define (build_list_of_offsets instr f) (let ((o (search_f (car instr) (length instr) f))) (if o (cons o (map (lambda (x) (search_v x f)) (cdr instr))) (begin (set! success #f) #f) ) ) ) ; This constructor translates the body of the function f from ; the source language to the target language by calling the ; list_of_offsets constructor once for each instruction. ; Like this latter constructor, it returns an error flag in the ; "size" field if an error is discovered. (define (build_list_of_encodings f) (map (lambda (x) (build_list_of_offsets x f)) (instrs f))) ; Create a new activation for a given function F ; The access and control links will be filled in later (define (build_activation_from_function f) (build_activation '?? '?? '() (subroutines f) (name f) )) ; look up a function symbol in the environment given a pair ; (i,j) of integers by following the access link i times ; and looking in position j in the resulting activation record. (define (get_function offset env) (list-ref (fctns (get_activation (first offset) env)) (second offset))) ; return the (run-time) value stored at a given offset ; note that by assumption the new activation record has already ; been pushed onto the stack when this function is called, ; so that the first activation record checked is first->control (define (my_eval offset env) (let ((o1 (first offset))) (if (eq? o1 CONST_FLAG) offset (eval_rec (control (activation env)) (first offset) (second offset))))) (define (eval_rec act o1 o2) (cond ((zero? o1) (list-ref (actuals act) o2)) (else (eval_rec (access_link act) (sub1 o1) o2)))) ; Initializes lists of actual parameters. Note that the "actuals" ; field contains the entire the function call, so it has one extra ; initial element -- the function name ; There should be no errors -- there is no type checking, and number ; of actual arguments should be correct since compilation succeeded. ; Returns a new environment with its first activation record updated ; to contain the new bindings (define (bind call env) (let ((actual_args (map (lambda (x) (my_eval x env)) (cdr call)))) (print actual_args) (update_actuals env actual_args))) ; It is assumed that the activation record for the function to be ; run has already been pushed onto the environment, but that the ; bindings of formals to actuals have not been made. ; After performing this binding, for each call in the code for f, ; look up the encoded function in the current environment (w/o bindings??), ; create an activation for it and push it onto the run-time stack ; and execute the call in the new environment ; When all the calls in f are complete, pop the run-time stack ; and return the result ; Recall that we are not assuming any constants in this ; (unrealistically) simple programming language. (define (run_rec call f env) (let ((env2 (bind call env))) (for-each (lambda (new_call) (let ((ff (get_function (car new_call) env))) (run_rec new_call ff (push (build_activation_from_function ff) (first (car new_call)) env2)))) (code f))) (pop env)) ; RUN a top-level function by constructing an (encoded) call and ; an appropriate environment, and passing them to the general version ; of "run" ; Note that the initial environment already has a dummy activation ; record on it. ; The INSERT_CONSTANTS function creates a dummy list of actual ; arguments for the top-level call (define (insert_constants n arg_list) (cond ((zero? n) (cons (build_offset 0 0) arg_list)) (else (insert_constants (sub1 n) (cons (build_offset CONST_FLAG (sub1 n)) arg_list))))) (define (run f env) (let ((call (insert_constants (length (parameter f)) '()))) (let ((a (build_activation_from_function f))) (run_rec call f (bind call (push a 0 env)))))) ; for functions ; return an encoding of the run-time position of a given identifier ; Search outward from the current function, following the links ; given by environment pointers. Print an error message and ; return #f if the variable is not found. (define (search_v var f) (search_v_rec var f 0)) (define (search_v_rec var f counter) (cond ((null? f) (print "undeclared argument") (set! success #f) #f) (else (let ((posn (search var (parameter f)))) (if (not posn) (search_v_rec var (ep f) (add1 counter)) (build_offset counter posn)))))) ; return an encoding of the run-time position of a given function ; works as above, except that a function is being sought, and that ; an error message is printed and NULL is returned if there is a ; mismatch in the number of arguments. (define (search_f fname call_size f) (search_f_rec fname call_size f 0)) (define (search_f_rec fname call_size f counter) (cond ((null? f) (print "undefined function") #f) (else (let ((posn (search fname (subr_names f)))) (if (not posn) (search_f_rec fname call_size (ep f) (add1 counter)) (if (= call_size (add1 (length (parameter (list-ref (subroutines f) posn))))) (build_offset counter posn) ; mismatch in number of parameters (begin (print "expecting ") (print (length (parameter (list-ref (subroutines f) posn)))) (print "args -- called with") (print call_size) (set! success #f) #f))))))) ;//////////////////// UTILITY FUNCTIONS FOR THE PARSER /////////////////// ; Get the next token from the input file and assign it to the ; global variable "token". ; for now, uses global variable "handle" (define (get_token) (set! token (read handle)) (prin1 token) (princ " ")) ; Determine whether the input string "w" represents a reserved word (define (reserved? w) (member w '(function begin end call local *))) (define (id? w) (not (reserved? w))) ; Print error message re unexpected token (define (token_error expected unexpected) (prin1 "found token ") (prin1 unexpected) (prin1 ", expected token ") (prin1 expected) (newline) (set! success #f) #f) ;//////////////// RECOGNITION FUNCTIONS FOR NONTERMINALS /////////////// ; recognition functions for nonterminal categories (define (id) (if (reserved? token) (begin (set! success #f) #f) (begin0 token (get_token)))) ; encodes the rule ::= {} ; Returns a list of parameter names (empty if the rule fails) (define (params caller) (let ((i (id))) (if success (begin (let ((is (params_rec caller '()))) (if success (cons i is) '()))) '()))) (define (params_rec caller output) (if (id? token) (let ((i (id))) (if success (let ((is (params_rec caller output))) (if success (cons i is) output)) output)) output)) ; encodes the rule ::= call {} ; Returns a representation of the call (empty if the rule fails) (define (call caller) (if (eq? token 'call) (begin (get_token) (let ((i (id))) (if success (let ((is (call_rec caller '()))) (if success (cons i is) '())) '()))) (token_error 'call token))) (define (call_rec caller output) (if (id? token) (let ((i (id))) (if success (let ((is (call_rec caller output))) (if success (cons i is) output)) output)) output)) ; encodes the rule ::= {} ; Returns a list of representations of calls (empty if the rule fails) (define (body caller) (let ((c (call caller))) (if success (body_rec caller (list c)) '()))) (define (body_rec caller output) (if (eq? token 'call) (let ((c (call caller))) (if success (let ((cs (body_rec caller output))) (if success (insert c cs) output)) output)) output)) ; encodes the rule ; ::= function [] begin [] [] end ; returns a representation of the function ; side effect: fname is put on callers' subr_names list by BUILD_FUNCTION ; what is argument of call to BODY? ; more?? (define (function caller) (define fname) ; temporary for the function name (define plist '()) ; need to initialize in case there are no params (define f) (define flist) ; temporaries (define blist) ; " (set! success #t) (if (eq? token 'function) (begin (get_token) (set! fname token) (if (id) ; get the function name (begin (if (id? token) (set! plist (params caller))) ; get the parameters (if (and success (eq? token 'begin)) (begin (get_token) (set! f (build_function fname caller plist '())) (if (and success (eq? token 'function)) (begin (set! flist (functions f)) ; get local functions )) (if (and success (eq? token 'call)) (begin (set! blist (body caller)) ; get the body (if success (begin (update_instrs! f blist) ; store it (update_code! ; and its encoding f (build_list_of_encodings f)))))) (if success (begin (if (eq? token 'end) ; if 'end' seen, add f (begin (get_token) ; to subroutines of (update_subroutines2! caller f) ;caller f) (token_error 'end token))) #f)) (token_error 'begin token))) (token_error "FUNCTION NAME" token))) (token_error 'function token))) ; encodes the rule ::= {} ; Install the compiled versions of all functions local to a ; given function CALLER. Return a list of these functions. ; Return TRUE in SUCCESS iff there are no errors. ; Want to insert into representation of caller so that searches ; for nonlocal variables succeed. (define (functions caller) (let ((f (function caller))) (if success (functions_rec caller (list f)) '()))) (define (functions_rec caller output) (if (eq? token 'function) (let ((f (function caller))) (if success (functions_rec caller (insert f output)) output)) output)) ; encodes the rule ::= * ; Returns a representation of the function if successful (define (program caller) (let ((f (function caller))) (if success (if (eq? token '*) f (sequence (set! success #f) (print "no period") #f)) #f))) ; The top-level parsing function (define (compile) (get_token) (program '() )) ; parse as function with no caller ; This top-level function merely prompts for a file name, attempts ; to compile the function in the file (storing the result in F) ; and then runs the file in the case of success. The file is ; then closed. (define (main) (print "enter filename (as a Scheme string (in quotes):") (set! handle (open-input-file (eval (read)))) (if handle (let ((f (compile))) (set! target f) ; for debugging only (if f (run f (build_environment (build_dummy_activation))) "failed to compile") (close-input-port handle)) "file not found ")) ; for ease in testing (define data1 "\\jeff\\classes\\152\\a3\\data1") (define data2 "\\jeff\\classes\\152\\a3\\data2") (define data3 "\\jeff\\classes\\152\\a3\\data3") (define data4 "\\jeff\\classes\\152\\a3\\data4") (define data5 "\\jeff\\classes\\152\\a3\\data5") (define data6 "\\jeff\\classes\\152\\a3\\data6") (define data7 "\\jeff\\classes\\152\\a3\\data7")