;;;;SMSCOPE.SCM Code for Sample Pset ;;; Procedures for Variable Binding with Lexical Scope in Substitution Model ;FOR THE COMPILER (declare (usual-integrations)) (declare (integrate-external "smfresh")) (declare (integrate-external "smsyntax")) (declare (integrate-operator list-minus)) (declare (integrate-operator filter)) ;;UTILITIES ;;LIST-MINUS: (List(S),List(T)) --> List(S) (define (list-minus l1 l2) ; returns members of l1 not in l2 (filter (lambda (v) (not (member v l2))) l1)) ;;FILTER: ((S --> Sch-Bool), List(S)) --> List(S) ;;(filter pred lst) returns list of element in LST satisfying PRED (define filter (lambda (pred list) (list-transform-positive list pred))) ;;FREE-VARIABLES: --> List() ;;Works only on kernel (desugared) bodies. (define (free-variables body) (cond ((or (self-evaluating? body) (symbol-expression? body) (submodel-null? body)) '()) ((variable? body) (list body)) ((combination? body) (append-map free-variables (cons (operator-of body) (operands-of body)))) ((if? body) (append-map free-variables (list (test-of-if body) (consequent-of body) (alternative-of body)))) ((lambda-expression? body) (list-minus (free-variables (body-of-lambda body)) (formals-of-lambda body))) (else ;body with defs (list-minus (append (append-map (lambda (def) (free-variables (expression-of-define def))) (defines-of-body body)) (free-variables (expression-of-body body))) (map variable-of-define (defines-of-body body)))))) ;;FRESH-RENAME: (List(),) --> ;;assigns fresh names in the list of defines and in the body ;;to variables defined in the list of define's. Returns renamed defines ;;appended to body (define (fresh-rename defs body) (if (null? defs) body (let ((vrbls (map variable-of-define defs)) (exps (map expression-of-define defs))) (let ((fresh-vars (map get-fresh vrbls))) (let ((renaming-operator (make-renaming-operator (map list vrbls fresh-vars)))) (let ((renamed-body (renaming-operator body))) (make-body (append (map make-define fresh-vars (map renaming-operator exps)) (defines-of-body renamed-body)) (expression-of-body renamed-body)))))))) ;;GET-FRESH: --> ;; The procedure GET-FRESH is provided as a primitive procedure. A call ;; (get-fresh 'name) ;; returns a symbol of the form "name#", which differs ;; from any symbol previously returned by a call to GET-FRESH. ;; For example, ;; (get-fresh 'z) ==>z#0 ;; (get-fresh 'z) ==>z#1 ;; (get-fresh 'hello) ==>hello#0 ;;Renaming = List( x ) ;;Renaming-Operator: --> ;;MAKE-RENAMING-OPERATOR: Renaming --> Renaming-Operator ;;The renaming-operator returned will work only on kernel (desugared) bodies. (define (make-renaming-operator renaming) (lambda (body) (cond ((or (self-evaluating? body) (symbol-expression? body) (submodel-null? body)) body) ((variable? body) (let ((binding (assq body renaming))) (if (pair? binding) (cadr binding) body))) ((combination? body) (make-combination ((make-renaming-operator renaming) (operator-of body)) (map (make-renaming-operator renaming) (operands-of body)))) ((lambda-expression? body) (let ((formals (formals-of-lambda body))) (make-lambda formals ((let ((bindings-minus-formals (filter (lambda (binding) (not (memq (car binding) formals))) renaming))) (make-renaming-operator bindings-minus-formals)) (body-of-lambda body))))) ((if? body) (make-if ((make-renaming-operator renaming) (test-of-if body)) ((make-renaming-operator renaming) (consequent-of body)) ((make-renaming-operator renaming) (alternative-of body)))) (else (let ((defs (defines-of-body body))) (let ((vars (map variable-of-define defs))) (let ((renaming-operator (make-renaming-operator (filter (lambda (binding) (not (memq (car binding) vars))) renaming)))) (make-body (map make-define vars (map renaming-operator (map expression-of-define defs))) (renaming-operator (expression-of-body body)))))))))) ;;ENFORCE: --> ;;Enforces the VARIABLE CONVENTION on a Scheme body: ;; no variable is bound more than once, and ;; no bound variable is the same as any free variable. ;;Works only on kernel (desugared) bodies. (define (enforce body) (cond ((or (self-evaluating? body) (symbol-expression? body) (variable? body) (submodel-null? body)) body) ((combination? body) (make-combination (enforce (operator-of body)) (map enforce (operands-of body)))) ((lambda-expression? body) (let ((done-lam-body (enforce (body-of-lambda body))) (formals (formals-of-lambda body))) (let ((fresh-formals (map get-fresh formals))) (make-lambda fresh-formals (let ((fresh-renaming (map list formals fresh-formals))) ((make-renaming-operator fresh-renaming) done-lam-body)))))) ((if? body) (make-if (enforce (test-of-if body)) (enforce (consequent-of body)) (enforce (alternative-of body)))) (else (let ((defs (defines-of-body body)) (done-exp (enforce (expression-of-body body)))) (let ((done-exps (map enforce (map expression-of-define defs))) (vars (map variable-of-define defs))) (let ((fresh-vars (map get-fresh vars))) (let ((fresh-renaming (map list vars fresh-vars))) (let ((renaming-operator (make-renaming-operator fresh-renaming))) (make-body (map make-define fresh-vars (map renaming-operator done-exps)) (renaming-operator done-exp)))))))))) ;; GET-CLEANED-VARIABLE: (, List()) --> ;; The procedure GET-CLEANED-VARIABLE is provided as a primitive. ;; (get-cleaned-variable 'prefix# vars-to-avoid) returns a symbol ;; of the form "prefix", or "prefix#m" with minimal m, which is not in vars-to-avoid. ;; For example, ;; (get-cleaned-variable 'x#2 '()) ==> x ;; (get-cleaned-variable 'x#2 '(x x#3 y)) ==> x#0 ;; (get-cleaned-variable 'x#2 '(x#0 x#3 x#1 y x)) ==> x#2 ;; (get-cleaned-variable 'y '(x#0 x#3 x#1 y x)) ==> y#0 ;; MAP-GET-CLEANED: (List(), List()) --> ;; (get-cleaned-variable vars vars-to-avoid) returns a list of symbols ;; of the same length as vars and with the same prefix as the corresponding ;; symbol in vars. The symbols in the returned list have the minimum suffixes ;; such that they are distinct from each other and the symbols in vars-to-avoid. ;; For example, ;; (map-get-cleaned '(x#2 y y#2) '()) ==> (x y y#0) ;; (map-get-cleaned '(x#2 y y#2) '(x#0 x#3 x#1 y x)) ==> (x#2 y#0 y#1) (define (map-get-cleaned vars vars-to-avoid) (if (null? vars) '() (let ((first-cleaned-var (get-cleaned-variable (car vars) vars-to-avoid))) (cons first-cleaned-var (map-get-cleaned (cdr vars) (cons first-cleaned-var vars-to-avoid)))))) ;;;; CLEAN-SUFFIXES.SCM ;; Return the body with its free variables unchanged, but its bound variables ;; renamed with no, or minimum, suffixes. It will undo ENFORCE. ;; Works only on kernel (desugared) bodies. (define (clean-suffixes body) (cond ((or (self-evaluating? body) (symbol-expression? body) (variable? body) (submodel-null? body)) body) ((combination? body) (make-combination (clean-suffixes (operator-of body)) (map clean-suffixes (operands-of body)))) ((lambda-expression? body) (let ((cleaned-lam-body (clean-suffixes (body-of-lambda body))) (formals (formals-of-lambda body))) (let ((vars-to-avoid (list-minus (free-variables cleaned-lam-body) formals))) (let ((cleaned-formals (map-get-cleaned formals vars-to-avoid))) (make-lambda cleaned-formals (let ((cleaned-renaming (map list formals cleaned-formals))) ((make-renaming-operator cleaned-renaming) cleaned-lam-body))))))) ((if? body) (make-if (clean-suffixes (test-of-if body)) (clean-suffixes (consequent-of body)) (clean-suffixes (alternative-of body)))) (else (let ((defs (defines-of-body body)) (cleaned-exp (clean-suffixes (expression-of-body body)))) (let ((cleaned-exps (map clean-suffixes (map expression-of-define defs))) (vars (map variable-of-define defs))) (let ((cleaned-vars (map-get-cleaned vars (list-minus (append (free-variables cleaned-exp) (append-map free-variables cleaned-exps)) vars)))) (let ((cleaned-renaming (map list vars cleaned-vars))) (let ((renaming-operator (make-renaming-operator cleaned-renaming))) (make-body (map make-define cleaned-vars (map renaming-operator cleaned-exps)) (renaming-operator cleaned-exp))))))))))