;;;SM.SCM                                                Mar. 8, 2003

;;              A SUBSTITUTION MODEL INTERPRETER FOR SCHEME
;;                       by Prof. Albert R. Meyer

;The Substitution Model we describe here differs from the one outlined in
;the Abelson/Sussman book and in MIT 6.001 in one essential way: when a
;lambda-expression is applied to arguments, the values of the arguments are
;substituted for the formal parameters step-by-step instead of all at once.
;For example, by substituting all at once, a combination such as
;       (+ ((lambda (x y) (if (< x y) 1 (+ x y x x y y))) 2 5) 11)
;would rewrite into
;       (+                (if (< 2 5) 1 (+ 2 5 2 2 5 5))       11),
;This then simplifies to
;       (+                (if   #t    1 (+ 2 5 2 2 5 5))       11),
;       (+                            1                        11),
;and finally to the value 12.  Note that we wind up throwing away the
;alternative of the IF (that is, the "false" branch) into which we did most of
;the substitutions.

;Instead of substituting all at once, the Substitution Model below substitutes
;values for variables only when the variable needs to be evaluated.  So
;       (+ ((lambda (x y) (if (< x y) 1 (+ x y x x y y))) 2 5) 11)
;would esentially be rewritten successively as
;       (+                (if (< x 5) 1 (+ x y x x y y))       11),
;       (+                (if (< 2 5) 1  (+ x y x x y y))      11),
;       (+                (if    #t   1 (+ x y x x y y))       11),
;       (+                            1                        11),
;and again finally 12, but this time avoiding unnecesssary substitutions
;into the alternative.

;In order to keep track of the values 2 and 5 which should be substituted
;for x and y, these bindings of the variables must be recorded somehow.
;This Substitution Model records such "environment bindings" in an outermost
;LETREC.  For example, assuming nothing has previously been bound in the
;environment, the combination above would actually be represented as
;   (letrec ()                              ;initially empty environment
;     (+ ((lambda (x y) (if (< x y) 1 (+ x y x x y y))) 2 5) 11)
;     )
;and would first rewrite to
;   (letrec ((x 2) (y 5))                   ;the current environment
;     (+ (              (if (< x y) 1 (+ x y x x y y)))      11)
;     )
;and then penultimately rewrite to
;   (letrec ((x 2) (y 5))
;     12)
;Now since there aren't any more x's or y's to substitute for, the
;environment bindings can be discarded yielding the final result 12.

;This Substitution Model is accurate for all the main features of Scheme,
;including ASSIGNMENTS (SET!) and global DEFINES.  (This also contrasts
;with the Substitution Model described in 6.001.)  Scheme evaluation is
;modelled by rewriting Scheme expressions solely into Scheme expressions.
;In particular, suppose EXPR is evaluated in the Substitution Model and at
;successive steps is rewritten to EXPR_1, EXPR_2, ... , EXPR_n, where
;EXPR_n is a PRINTABLE final value returned.  Then evaluation in REAL Scheme
;of any one of EXPR, EXPR_1,..., EXPR_n would return the same printable value
;("same" in the sense of EQUAL?).

;The only significant Scheme feature not modelled is the STORE, i.e., mutable
;lists with operations SET-CAR!, SET-CDR!, and sharing, because our list
;notation does not reflect sharing.  This could be overcome by introducing
;DrScheme shared-list notation, for example, but then we would no longer 
;be rewriting solely to Scheme expressions.

;There is one complication which comes up in all substitution models:
;how to keep track of different bindings for parameters with the same
;name.  For example, in the expression
;   (letrec ((x 2) (y 5))                   ;current environment
;     (+ ((lambda (x) (+ x 1)) 3) ((lambda (z) (+ x y 11)) 99))
;     ),
;the parameter x should be bound to 3 by the lefthand lambda application.
;But the environment binding of x to 2 will be needed for the righthand
;application.  To keep track of this, the Substitution Model chooses a
;unique integer suffix to add to the "new" x.  So this expression would
;rewrite directly to
;   (letrec ((x 2) (y 5) (x_0 3))           ;current environment
;     (+              (+ x_0 1)  ((lambda (z) (+ x y 11)) 99))
;     )
;Variable suffixes are introduced by applying the procedure ENFORCE to an
;expression.  ENFORCE adds suffixes to variables in an expression as needed
;to avoid the above problem.  (For further explanation, see ENFORCE below.)



;;                         OPERATING INSTRUCTIONS

;THIS FILE SHOULD BE LOADED BY EVALUATING ONE OF THE INITIALIZATION
;FILES <SCHEME DIALECT>-LOADSM.SCM.

;START the interpreter by evaluating (NEW-SUBMODEL) in Scheme.
;Exit the interpreter by evaluating (EXIT) in the Submodel interpreter.
;To restart the interpreter without erasing previously defined global
;definitions evaluate (RESUME-SUBMODEL).

;WARNINGS:
;(1) internal DEFINEs are disallowed: use LETREC instead.
;(2) BODIES must consist of a SINGLE EXPRESSION.  (Enclose
;    sequences of expressions in a BEGIN form.)
;(3) PROCEDURE CONSTANTS (see PROCEDURE-CONSTANT? below)
;    must NOT be used as VARIABLES, because these constants are
;    treated by the Substitution Model rewrite rules as actual
;    procedure values.  For example, the Substitution Model barfs on
;            (let (( sin                  my-sine)) ...)
;    because it essentially gets treated as the ill-formed expression
;            (let (( (lambda (x) (sin x)) my-sine)) ...)


;OUTPUT CONTROL:  Evaluate
;                      (PRINT-STEPS-TO-FILE! "<FILE NAME>")
;for the steps of substitution model evaluations to print to the file
;<file name> instead of being displayed through the user output port.
;(This can avoid overflowing Emacs/Edwin interaction buffers.)
;Evaluate
;                      (PRINT-STEPS-TO-FILE! #f)
;for the steps to display as usual.
;Evaluate
;                       (SHOW-SUBMODEL-ENVIRONMENT)
;to display the interpreter's current global environment.

;By default, every rewriting step is shown.  To skip displaying 
;trivial steps, e.g., the step where (+ 2 1) is rewritten
;to 3, evaluate
;     (HIDE-TRIVIAL-STEPS! #t)
;Evaluate (HIDE-TRIVIAL-STEPS! #f) to go back to showing every step.
;See the declaration below of the internal procedure print-step! for a 
;definition of "trivial" step.

;To see only the final result, evaluate
;     (HIDE-ALL-STEPS! #t)
;Evaluate (HIDE-ALL-STEPS! #f) to go back to displaying selected steps.

;All these output-controlling procedures can be executed in the Scheme OR
;the submodel evaluator.



(load "match.scm")                      ;the pattern matching code



;   Rewriting semantics of SCHEME specifies special SCHEME CONTROL
;   CONTEXTS in which rewrite rules may be applied.  Context-variables
;   which are restricted to match only control contexts are called
;   CONTROL-VARIABLEs.  Since Scheme rewrite rules can be formulated using
;   only one control-variable, we single out the variable, $%R, to be the
;   unique control-variable which may appear in patterns and rules.
;   Although matching of $%R could be handled by installing a predicate
;   restricting $%R to only match control contexts, doing so would be
;   unacceptably inefficient, so $%R matches are handled by a special
;   procedure MATCH-CONTROL-PAT, for which we add a new dispatch clause
;   in the definition of the MATCH procedure:


(define (match pat dat)
  (cond ((exact-match? pat)
         (if (equal? pat dat)
             (list the-empty-dictionary)
             '()))
        ((qmark-variable? pat)
         (match-qmark-variable pat dat))
        ((initial-tilde-variable? pat)
         (match-initial-tildevar (car pat) (cdr pat) dat))
        ((control-pattern? pat)         ;NEW CLAUSE
         (match-control-pat
          (context-pattern.pattern pat) dat))
        ((context-pattern? pat)
         (match-cpat (context-pattern.var pat)
                     (context-pattern.pattern pat)
                     dat))
        ((pair? pat)
         (match-pair-pat (car pat) (cdr pat) dat))
        (else (error "MATCH: unknown pattern" pat))))


;;              CONTROL-CONTEXTS FOR THE REWRITING MODEL OF SCHEME

;The control-variable is fixed to be $%R.

(define (control-pattern? pat)
  (and (pair? pat)
       (eq? '$%R (car pat))))

(define (match-control-pat hole-pat expr)
  (call-with-values
      (lambda () (control-parse expr))
    (lambda (cntrl-cntxt hole-exp)
      (map
       (make-dictionary-extender '$%R cntrl-cntxt)
       (match hole-pat hole-exp)))))


;If EXPR is a nonvalue Scheme expression, then
;                (CONTROL-PARSE EXPR)
;calls Scheme's builtin VALUES procedure with two
;arguments, CNTXT, a (necessarily unique) control context, and an (also
;necessarily unique) "immediate redex," HOLE-EXP, such that
;                   EXPR = (INSERT-INTO-HOLE CNTXT HOLE-EXP).
;If EXPR is a syntactic value, then (VALUES hole EXPR) is called.
(define (control-parse expr)
  (cond ((or (syntactic-value? expr)
             (scheme-immediate-redex? expr))
         (values hole expr))
        ((null? expr) (error "CONTROL-PARSE: () is not an R4RS expression"))
        (else
         (call-with-values
             (lambda () (top-level-parse expr))
           (lambda (top-cntxt top-hole-exp)
             (call-with-values
                 (lambda () (control-parse top-hole-exp))
               (lambda (control-cntxt hole-exp)
                 (values
                  (insert-into-hole top-cntxt control-cntxt)
                  hole-exp))))))))

(define (scheme-immediate-redex? expr)
  (or (scheme-variable? expr)
      (match? '(if ?%val ? ?) expr)
      (match? '(?%let (~%val-binds) ?) expr)
      (match? '(begin ?) expr)
      (match? '(begin ?%val ~) expr)
      (match? '(set! ? ?%val) expr)
      (match? '(define ? ?) expr)
      (match? '(?%val ~%vals) expr)))         ;ready to apply

;If EXPR is a nonvalue Scheme expression, then
;  (TOP-LEVEL-PARSE EXPR)
;calls Scheme's builtin VALUES procedure with two
;arguments, CNTXT, a (necessarily unique) "top-level" control context,
;and an (also necessarily unique) HOLE-EXP, such that
;                   EXPR = (INSERT-INTO-HOLE CNTXT HOLE-EXP).

(define (top-level-parse expr)
  (let ((active-pat
         (case (car expr)
           ((if) '(if ?%not-val ?c ?a))
           ((begin) '(begin ?%not-val ~exps))
           ((set!) '(set! ?var ?%not-val))
           ((let letrec let*)
            '(?%let (~%val-binds (?var ?%not-val) ~binds) ?expr))
           (else '(~%vals ?%not-val ~exps)))))
    (let ((dicts (match active-pat expr)))
      (if (pair? dicts)
          (let ((top-control-context-pat        ;same as ACTIVE-PAT with <> for ?%NOT-VAL
                 (case (car expr)
                   ((if) '(if <> ?c ?a))
                   ((begin) '(begin <> ~exps))
                   ((set!) '(set! ?var <>))
                   ((let letrec let*)
                    '(?%let (~%val-binds (?var <>) ~binds) ?expr))
                   (else '(~%vals <> ~exps)))))
            (values
             (instantiate top-control-context-pat (car dicts)) ;the top-level context
             (lookup '?%not-val (car dicts)))) ;the non-value in the hole
          (error "TOP-LEVEL-PARSE: " expr)))))



;;;                   SCHEME SUBSTITUTION MODEL RULES



;MAKE-SIMPLE-RULES: LIST(PATTERN X TEMPLATE)-->LIST(SIMPLE-RULE)
(define (make-simple-rules l)
  (map (lambda (pattern&template)
         (apply make-simple-rule pattern&template))
       l))


;;;in the Sub Model, the USELESS-VALUE will be a SUBMODEL SYMBOL
(define submodel-useless-value  ''useless-value)
(define (submodel-useless-value? expr) (equal? expr submodel-useless-value))

(define drules:cond
  (make-simple-rules
   `( ((cond (?%not-else ?expr) ~clauses) (if ?%not-else ?expr (cond ~clauses)))
      ((cond (else ?expr)) ?expr)
      ((cond) ,submodel-useless-value ) )))


(define drule:if-no-alternative
  (make-simple-rule
   '(if ?test ?consequent)
   `(if ?test ?consequent ,submodel-useless-value)))
    

(define drule:define
  (make-simple-rule
   '(define (?f ~vars) ?expr)
   '(define ?f (lambda (~vars) ?expr))))


(define drules:and
  (make-simple-rules
   '( ((and ?exp1 ?exp2 ~exps) (if ?exp1 (and ?exp2 ~exps) #f))
      ((and ?expr) ?expr)
      ((and) #t) )))


(define drules:or
  (make-simple-rules
   (list '((or) #f)
         '((or ?expr) ?expr)
         (let ((exp (gensym 'exp)))      ;exp must not be free in remaining expressions
           `((or ?exp1 ?exp2 ~exps)
             (let ((,exp ?exp1))
               (if ,exp ,exp (or ?exp2 ~exps))))) )))
                                   ;see comment on crule:call/cc on avoiding gensym

(define drules:let*
  (make-simple-rules
   '( ((let* () ?expr) ?expr)
      ((let* ((?var ?init) ~binds) ?expr)
       (let  ((?var ?init)) (let* (~binds) ?expr))) )))


(define submodel-nil
  (if (null? #f) #f ''()))      ;hack to handle nil = #f as in MIT Scheme


;Simple-rules for QUOTE and QUASIQUOTE -- these are NOT safe
;to "use anywhere" in the presence of nested quotes.

(define drules:quote
  (make-simple-rules
   '( ((quote (?thing ~things)) (cons (quote ?thing) (quote (~things))))
;                  ('(?THING ~THINGS) (CONS '?THING '(~THINGS)))
      ((quote ?%self) ?%self) )))
;                  ('?%SELF ?%SELF)


(define drules:quasiquote
  '( ((quasiquote (unquote ?expr)) ?expr)
;                     (`,?EXPR ?EXPR)
     ((quasiquote (?%not-unquoted ~things))
      (cons (quasiquote ?%not-unquoted) (quasiquote (~things))))
;     (`(?%NOT-UNQUOTED ~THINGS) (CONS `?%NOT-UNQUOTED `~THINGS))
     ((quasiquote ((unquote-splicing ?expr) ~suf)) (append ?expr (quasiquote (~suf))))
;                  ((`(,@?EXPR ~SUF) ~SUF) (APPEND ?EXPR `~SUF))
     ((quasiquote ?%self) ?%self)
;                  (`?%SELF ?%SELF)
     ((quasiquote ?%Scheme-symbol) (quote ?%Scheme-symbol)) ))
;                  (`?%SCHEME-SYMBOL '?%SCHEME-SYMBOL)


(define desugar-rules
  (append
   drules:quote
   drules:quasiquote
   drules:cond
   (list drule:define)
   drules:and
   drules:or
   drules:let*
   (list drule:if-no-alternative)))


(define (desugar expr)
  (let ((flag hide-rule-application?))  ;HIDE-RULE-APPLICATION? from "match.scm"
    (set! hide-rule-application? #t)          ;no need to watch desugaring
    (let ((result (one-topdown-final-form desugar-rules expr)))
      (set! hide-rule-application? flag)
      result)))


;;                       SIMPLE RULES WITH CONTROL CONTEXTS

(define (make-simple-control-rule pattern template)
        ;pick any a variable ?environment not in pattern or template:
  (let ((?environment
         (get-cleaned-variable          ;from "match.scm"
          '?environment
          (match-variables-of (list pattern template)))))
    (make-simple-rule
     `(letrec ,?environment ($%R ,pattern))
     `(letrec ,?environment ($%R ,template)))))


;MAKE-SIMPLE-CONTROL-RULES: LIST(PATTERN X TEMPLATE)-->LIST(SIMPLE-RULE)
(define (make-simple-control-rules l)
  (map (lambda (pattern&template)
         (apply make-simple-control-rule pattern&template))
       l))


(define crules:if
  (make-simple-control-rules
   '( ((if #f ?consequent ?alternative) ?alternative)
      ((if ?%nonfalse-val ?consequent ?alternative) ?consequent) )))
;For example,
;>>(pp crules:if)
;;(((letrec ?environment ($%r (if #f ?consequent ?alternative)))
;;  (letrec ?environment ($%r ?alternative)))
;; ((letrec ?environment
;;          ($%r (if ?%nonfalse-val ?consequent ?alternative)))
;;  (letrec ?environment ($%r ?consequent))))


(define crules:lists
  (make-simple-control-rules
   `( ((cons ?thing ?%nil) (list ?thing))
      ((cons ?thing (list ~things)) (list ?thing ~things))
      ((car (list ?thing ~%vals)) ?thing)
      ((cdr (list ?%val ~things)) (list ~things))
      ((pair? ?%nonpair-val) #f)
      ((pair? (list ?%val ~%vals)) #t)
      ((null? ?%nil) #t) 
      ((null? ?%nonnull-val) #f)
      ((pair? (cons ?%val1 ?%val2)) #t)
      ((list) ,submodel-nil)
      ((car (cons ?thing ?%val)) ?thing) 
      ((cdr (cons ?%val ?thing)) ?thing)
      ((apply ?proc (list ~things)) (?proc ~things)) )))


(define rules:lambda
  (cons
   (make-simple-control-rule
    '((lambda () ?expr)) '?expr)
   (make-simple-rules
    '( ((letrec (~environment-binds)
          ($%R ((lambda (?param ~params) ?expr) ?%val ~args)))
        (letrec (~environment-binds (?param ?%val))
          ($%R ((lambda (~params) ?expr) ~args))))
       ((letrec (~environment-binds)
          ($%R ((lambda ?%var ?expr) ~%vals)))
        (letrec (~environment-binds (?%var (list ~%vals)))
          ($%R ?expr))) ))))

(define rule:lets                       ;same rule for LET, LETREC, LET* --
                                        ;the differences in binding appear in
                                        ;enforcing the Variable Convention
   (make-simple-rule
    '(letrec (~environment-binds)
            ($%R (?%let (~%val-binds) ?expr)))
    '(letrec (~environment-binds ~%val-binds)
            ($%R ?expr))))


;All known Scheme implementations will generate an error on at least one of the
;following "circular" LETREC's:
;                   (letrec ((x 1) (y x)) y), (letrec ((y x) (x 1)) y),

;depending on the order in which the letrec bindings are evaluated.  Since
;the Scheme manual explicitly allows the order in which bindings are
;evaluated to be implementation dependent, it is also OK for an
;implementation to generate an error on BOTH the above LETREC's.  This is
;what happens as a consequence of the instantiation rule above, namely,
;rewritings gets stuck in both cases.  To force left to right evaluation of
;LETREC's, so the first example,
;                   (letrec ((x 1) (y x)) y)
;would return 1, we could add the following rule
;(make-simple-control-rule
;    '(letrec
;         (~%val-binds1 (?var1 ?%val) ~%val-binds2 (?var2 ($%R1 ?var1)) ~binds)
;       ?exp)
;    '(letrec
;         (~%val-binds1 (?var1 ?%val) ~%val-binds2 (?var2 ($%R1 ?%val)) ~binds)
;       ?exp))
;To make this work, we would also have to allow $%R1 as an
;additional control-context variable.


(define rule:instantiate
  (make-simple-rule
   '(letrec (~environment-binds1 (?var ?val) ~environment-binds2)
      ($%R ?var))
   '(letrec (~environment-binds1 (?var ?val) ~environment-binds2)
      ($%R ?val))))


;;;in the Sub Model, SET! returns a SUBMODEL SYMBOL
(define set!-return-value ''set!-done)

(define rule:set!
  (make-simple-rule
   '(letrec (~environment-binds1 (?var ?) ~environment-binds2)
      ($%R (set! ?var ?%val)))
   `(letrec (~environment-binds1 (?var ?%val) ~environment-binds2)
      ($%R ,set!-return-value))))


(define crules:begin
  (make-simple-control-rules
   '( ((begin ?expr) ?expr)
      ((begin ?%val ?expr ~exps) (begin ?expr ~exps)) )))


(define crule:call/cc
  (let ((v (gensym 'v)))        ;V must not have any free occurrences
                                ;in the control context which $%R matches.
    (make-simple-control-rule
     '(call/cc ?%val)
     `(?%val (lambda (,v) (abort ($%R ,v)))))))

;Use of GENSYM above could be avoided by using a general rule (see below)
;(make-general-control-rule
; '(call/cc ?%val)
; (lambda (receiver-proc context)
;   (let ((v (get-cleaned-variable
;             (match-variables-of
;              (list context)))))
;     `(,receiver-proc
;       (lambda (,v) (abort ,(insert-into-hole context v))))))


(define rule:abort
  (make-simple-rule
   '(letrec ?environment ($%R (abort ?%val)))
   '(letrec ?environment ?%val)))       ;the $%R-context gets thrown away!


(define crules:proc?
  (make-simple-control-rules
   '( ((procedure? (lambda ~)) #t)
      ((procedure? ?%proc-constant) #t) ;MUST NOT REDEFINE PROCEDURE CONSTANTS
      ((procedure? ?%nonproc-val) #f)) ))


(define crules:symbol?
  (make-simple-control-rules
    '( ((symbol? (quote ?%Scheme-symbol)) #t)
       ((symbol? ?%non-submodelsymbol-val) #f) )))


;;                                        GENERAL CONTROL RULES

(define (make-general-control-rule pattern proc)
  (let ((?environment                   ;pick variable ?environment not in pattern:
         (get-cleaned-variable          ;from "match.scm"
          '?environment
          (match-variables-of pattern))))
    (make-general-rule
     `(letrec ,?environment ($%R ,pattern))
     (lambda (env control-context . vals)
       (let ((result (apply proc vals)))
         (if (fail? result)
             (fail)
             `(letrec ,env
                ,(insert-into-hole control-context result))))))))

;EXAMPLE:
;(define crule:builtin-+
;  (make-general-control-rule
;   '(+ ~%nums)
;   (lambda (nums) (apply + nums))))
;AND MORE GENERALLY:

(define crule:builtin-app
  (make-general-control-rule
   '(?%builtin-op ~%vals)
   (lambda (op-name vals)
     (apply (cadr (assq op-name (builtin-ops-table))) vals))))
;For example,
;>>(pp crule:builtin-app)
;;((general-rule) (letrec ?environment ($%r (?%builtin-op ~%vals)))
;;                #[compound-procedure 9])

;Since our list notation does not reflect sharing, EQ? can't be defined
;to work properly on lists.  This could be overcome by introducing DrScheme
;shared-list notation, for example, but we choose not to extend Scheme in
;this nonstandard way.
;Our specification of EQ? using CLEAN-SUFFIXES below will yield behavior unlike
;any known implementation of Scheme, but we believe it is consistent with
;official R5RS Scheme.
(define crule:eq?
  (make-general-control-rule
   '(eq? ?%val1 ?%val2)
   (lambda (v1 v2)                      ;WRONG FOR SHARED LISTS
     (equal? (clean-suffixes v1) (clean-suffixes v2)))))

(define (non-submodelsymbol-val? expr)
  (and (not (match? '(quote ?) expr))
       (syntactic-value? expr)))

(define crule:exit
  (make-general-control-rule
   '(exit)
   (lambda () (abort "EXITED SUBMODEL"))))


(define crules:display
  (list
   (make-general-control-rule
    '(display ?%val)
    (lambda (val)
      (set! displays-list (cons val displays-list))
      submodel-useless-value))
   (make-general-control-rule
    '(newline)
    (lambda ()
      (set! displays-list (cons '(newline) displays-list))
      submodel-useless-value))))

(define displays-list '())

  
(define crule:set!global
  (make-general-control-rule
   '(set! ?var ?%val)
   (lambda (var val)
     (let ((binding (assq var (global-environment))))
       (if binding
           (begin (set-car! (cdr binding) val)
                  set!-return-value)
           (fail))))))


(define rule:define-global             ;the only kind of DEFINE allowed
  (make-general-rule
   '(letrec ?environment (define ?%var ?expr))
   (lambda (env var expr)
     (let ((binding (assq var defined-bindings)))
       (if (not binding)
           (set! defined-bindings       ;install uninitialized defined VAR
                 (cons
                  (make-binding var "uninitialized-value")
                  defined-bindings)))
       `(letrec ,env (set! ,var ,expr))))))


(define crule:instantiate-global
  (make-general-control-rule
   '?%var
   (lambda (var)
     (let ((binding (assq var (global-environment))))
       (if binding (cadr binding) (fail))))))



                     ;;;COMPLETE LIST OF SUBMODEL RULES

(define tagged-sm-rules      ;attached tags control printouts of rewriting steps.
  (let ((tag-attacher (lambda (tag) (lambda (rule) (cons `(,tag) rule)))))
    (append
     (list ((tag-attacher 'instantiate-global) crule:instantiate-global))
     (map (tag-attacher 'lambda) rules:lambda)
     (list ((tag-attacher 'lets) rule:lets))
     (list ((tag-attacher 'instantiate) rule:instantiate))
     (list ((tag-attacher 'builtin) crule:builtin-app))
     (map (tag-attacher 'if) crules:if)
     (map (tag-attacher 'lists) crules:lists)
     (list ((tag-attacher 'set!) rule:set!))
     (map (tag-attacher 'begin) crules:begin)
     (list ((tag-attacher 'exit) crule:exit))
     (list ((tag-attacher 'eq?) crule:eq?))
     (map (tag-attacher 'symbol?) crules:symbol?)
     (map (tag-attacher 'display) crules:display)
     (list ((tag-attacher 'set!-global) crule:set!global))
     (list ((tag-attacher 'define-global) rule:define-global))
     (list ((tag-attacher 'call/cc) crule:call/cc))
     (list ((tag-attacher 'abort) rule:abort))
     (map (tag-attacher 'proc?) crules:proc?))))


(define (tag-of tagged-rule)
  (caar tagged-rule))

(define (rule-of tagged-rule)
  (cdr tagged-rule))


                                       ;;SYNTACTIC VALUES

(define (nonpair-value? expr)
  (or (self-evaluating? expr)
      (procedure-constant? expr)         ;MUST NOT RE-DEFINE PROCEDURE CONSTANTS
      (submodel-nil? expr)
      (match? '(quote ?%Scheme-symbol) expr)
      (match? '(lambda ~) expr)))

(define (self-evaluating? expr)
  (or (number? expr)
      (boolean? expr)
      (string? expr)))

(define (syntactic-value? expr)
  (or (nonpair-value? expr)
      (match? '(list ?%val ~%vals) expr)
      (match? '(cons ?%val ?%nonlist-val) expr)))

(define (not-syntactic-value? expr)
  (not (syntactic-value? expr)))

(define (nonlist-value? expr)
  (and (not (submodel-nil? expr))
       (or (nonpair-value? expr)
           (match? '(cons ?%val ?%nonlist-val) expr))))

(define (nonnull-val? expr)
  (and (syntactic-value? expr)
       (not (submodel-nil? expr))))

(define (nonfalse-val? expr)
  (and expr (syntactic-value? expr)))

(define (non-procedure-value? expr)
  (and (not (procedure-constant? expr))
       (not (match? '(lambda ~) expr))
       (syntactic-value? expr)))

(define (procedure-constant? arg)
  (or (builtin-procedure-constant? arg)
      (rule-specified-procedure-constant? arg)))


(define (builtin-procedure-constant? arg)
    (assq arg (builtin-ops-table)))

(define (builtin-ops-table)
  `((+ ,+)
    (- ,-)
    (* ,*)
    (/ ,/)
    (= ,=)
    (< ,<)
    (> ,>)
    (>= ,>=)
    (<= ,<=)
    (quotient ,quotient)
    (sqrt ,sqrt)
    (expt ,expt)
    (round ,round)
    (abs ,abs)
    (gcd ,gcd)
    (max ,max)
    (min ,min)
    (remainder ,remainder)
    (modulo ,modulo)
    (zero? ,zero?)
    (positive? ,positive?)
    (negative? ,negative?)
    (odd? ,odd?)
    (even? ,even?)
    (exp ,exp)
    (log ,log)
    (sin ,sin)
    (cos ,cos)
    (tan ,tan)
    (asin ,asin)
    (acos ,acos)
    (atan ,atan)
    (number? ,number?)
    (not ,not)
    (boolean? ,boolean?)
    (string? ,string?)
    (integer? ,integer?)
    (string-append ,string-append)
    (string=? ,string=?)
    (print-steps-to-file! ,print-steps-to-file!)
    (hide-trivial-steps! ,hide-trivial-steps!)
    (hide-all-steps! ,hide-all-steps!)
    (show-submodel-environment ,show-submodel-environment)))


(define (rule-specified-procedure-constant? arg)
  (and (symbol? arg)
       (memq arg
             '(car cdr list cons pair? apply abort eq? symbol?
                   call/cc procedure? pair? null? exit display newline))))


(define (let-keyword? expr)
  (or (eq? expr 'let)
      (eq? expr 'letrec)
      (eq? expr 'let*)))


(define (not-unquoted? expr)
  (not (or (eq? expr 'unquote)
           (match? '(unquote-splicing ?expr) expr))))


(define (submodel-nil? expr)
  (equal? expr submodel-nil))

(define restriction-table 'dummy)

(define (install-restriction-table!)
  (set! restriction-table
        `( ($%R             ,constant-true-function) 
                     ;the $%R restriction is handled by MATCH-CONTROL-PAT
           (?%not-unquoted ,not-unquoted?)
           (?%self         ,self-evaluating?)
           (?%nil          ,submodel-nil?)
           (?%not-else     ,not-else?)
           (?%non-submodelsymbol-val ,non-submodelsymbol-val?)
           (?%Scheme-symbol       ,symbol?)
           (?%let          ,let-keyword?)
           (?%val          ,syntactic-value?)
           (?%val1         ,syntactic-value?)
           (?%val2         ,syntactic-value?)
           (~%vals         ,syntactic-value?)
           (?%var          ,scheme-variable?)
           (?%builtin-op   ,builtin-procedure-constant?)
           (?%proc-constant ,procedure-constant?)
           (?%nonfalse-val ,nonfalse-val?)
           (?%nonnull-val  ,nonnull-val?)
           (?%nonlist-val  ,nonlist-value?)
           (?%nonpair-val  ,nonpair-value?)
           (?%nonproc-val  ,non-procedure-value?)
           (~%val-binds    ,value-binding?)
           (?%not-val      ,not-syntactic-value?)))
  'restriction-table-installed)

(define (value-binding? bind)
  (syntactic-value? (datum-of-bind bind)))


                      ;;;SUBMODEL GLOBAL ENVIRONMENT

(define defined-bindings '())
(define hidden-global-bindings '())

(define (global-environment)
  (append defined-bindings hidden-global-bindings))


(define (install-initial-global-environment!)
;          the binding inits are desugared syntactic values
  (set! hidden-global-bindings '())
  (set! defined-bindings
        (make-env
         `((length
            (lambda (l) (if (pair? l) (+ 1 (length (cdr l))) 0)))
           (list?
            (lambda (l) (if (pair? l) (list? (cdr l)) (null? l))))
           (equal?
            (lambda (x y)
              (if (eq? x y)
                  #t
                  (if (symbol? x)
                      #f
                      (if (procedure? x)
                          #f
                          (if (null? x)
                              #f
                              (if (number? x)
                                  (if (number? y) (= x y) #f)
                                  (if (pair? x)
                                      (if (pair? y)
                                          (if (equal? (car x) (car y))
                                              (equal? (cdr x) (cdr y))
                                              #f)
                                          #f)
                                      (if (string? x)
                                          (if (string? y) (string=? x y) #f)
                                          (error "EQUAL?: unknown type of value" x))))))))))
           (append
            (lambda (l m)
              (if (null? l)
                  m
                  (cons (car l) (append (cdr l) m)))))
           (error
            (lambda msgs
              (abort (begin
                       (display "SUBMODEL ERROR: ")
                       (map display msgs)
                       'aborted))))
           (map
            (letrec ((map1
                      (lambda (f l)
                        (if (null? l)
                            ,submodel-nil
                            (cons (f (car l)) (map1 f (cdr l)))))))
              (lambda args
                (if (pair? args)
                    (let ((l (cdr args)))
                      (if (pair? l)
                          (let ((f (car args)))
                            (if (null? (cdr l))
                                (map1 f (car l))
                                (if (null? (car l))
                                    ,submodel-nil
                                    (cons (apply f (map car l))
                                          (apply map (cons f (map cdr l)))))))
                          (error "MAP--no list arg: " args)))
                    (error "MAP--no args "))))))))
  'defined-bindings-installed)


(define (make-env binds)                ;makes mutable list of BINDS ***
  (map 
   (lambda (bind)
     (make-binding (var-of-bind bind) (datum-of-bind bind)))
   binds))


(define (show-submodel-environment)
  (newline)
  (display "EXPLICITLY DEFINED VARIABLES:")
  (newline)
  (pretty-print (variables-of-binds defined-bindings))
  (newline)
  (display "THE GLOBAL ENVIRONMENT")
  (newline)
  (pretty-print (global-environment))
  "submodel-global-environment")



;;                                  ;;SUBMODEL READ-EVAL-PRINT-LOOP

;(SM-RULES-ONCE! EXPR) returns the result of one rewrite of EXP, or fails.
;EXPR is of the form (LETREC LOCAL-ENVIRONMENT EXP1) and obeys the Variable
;Convention.  If the rewrite succeeds, RULE-FLAG is set to show which rule
;was used.  The variable convention is reenforced on the result, if necessary.

(define (sm-rules-once! expr)
  (define (try tagged-rules datum)
    (if (pair? tagged-rules)
        (let* ((tagged-rule (car tagged-rules))
               (rule (rule-of tagged-rule))
               (result (one-rule-application rule datum))) ;customize the rules app?
          (if (fail? result)
              (try (cdr tagged-rules) datum)
              (begin (set! rule-flag (tag-of tagged-rule))
                     result)))
        (fail)))                        ;no more rules to try
  (set! rule-flag 'uninitialized)
  (let ((next-expr (try tagged-sm-rules expr)))
    (if (memq        ;reenforce the variable convention if necessary:
         rule-flag
         '(instantiate call/cc instantiate-global))
        (make-letrec
         (bindings-of-letf next-expr)
         (enforce (expr-of-letf next-expr)))
        next-expr)))

(define rule-flag 'uninitialized)
(define output-port 'uninitialized)
(define user-port (current-output-port))
(define hide-trivial-steps? 'uninitialized)
(define hide-all-steps? 'uninitialized)

(define (new-submodel)                  ;START THE WHOLE THING
  (print-steps-to-file! #f)             ;display steps in buffer
  (hide-all-steps! #f)                  ;don't hide any
  (hide-trivial-steps! #f)              ;not even the trivial steps
  (install-restriction-table!)
  (install-initial-global-environment!)
  (clear-get-fresh-table!)
  (resume-submodel))


(define (resume-submodel)               ;The Submodel REPL
  (newline)
  (newline)
  (display "submodel-eval>> ")
  (show-submodel (read))
  (resume-submodel))


(define show-submodel
  (let ((count 'uninitialized))
    (letrec
        ((show-rewrites-until-fail
          (lambda (expr)
            (let ((next-expr (sm-rules-once! expr)))
              (if (fail? next-expr)
                  (begin
                    (newline)
                    ((if (match? '(letrec ? ?%val) expr)
                         print-final-value!
                         print-stuck!)
                     expr)
                    (print-displays!)
                    'done)
                  (let ((gc-next-exp
                         (if (garbage-collect? next-expr) ;occasional garbage-collection
                             (garbage-collect next-expr)
                             next-expr)))
                    (print-step! gc-next-exp)
                    (set! count (+ count 1))
                    (show-rewrites-until-fail gc-next-exp))))))
         (print-final-value!
          (lambda (expr)
            (let ((result (clean-suffixes (global-garbage-collect! expr))))
              (display "Final value after ")
              (display count)
              (display (if (= count 1) " step:" " steps:"))
              (newline)
              (pretty-print result)
              (if (and (pair? result) (not (eq? (car result) 'lambda)))
                  (begin
                    (newline)
                    (display "which Scheme would print as:")
                    (newline)
                    (pretty-print (call-underlying-scheme result))))
              'val-printed)))
         (print-stuck!
          (lambda (expr)
            (let ((result (clean-suffixes expr)))
              (display "Rewriting stuck after ")
              (display count)
              (display (if (= count 1) " step:" " steps:"))
              (newline)
              (pretty-print result)
              'stuck-printed)))
         (print-displays!
          (lambda ()
            (if (pair? displays-list)
                (begin
                  (newline)
                  (display "The evaluation generated the display:")
                  (newline)
                  (for-each
                   (lambda (output)
                     (if (equal? output '(newline))
                         (newline)
                         (display (call-underlying-scheme output))))
                   (reverse displays-list))
                  'displays-printed))))
         (garbage-collect?              ;a heuristic decision
          (lambda (next-expr)
            (or (and (eq? (car next-expr) 'if)
                     (zero? (remainder count 3)))
                (zero? (remainder count 50)))))
         (print-step!
          (lambda (next-expr)
            (and
	     (not hide-all-steps?)
             (or (not hide-trivial-steps?)
                 (not (memq
                       rule-flag
                       ;these rules are not interesting to watch:
                       '(uninitialized begin proc?
                                       eq? symbol? builtin set!-global))))
             (begin
               (newline output-port)
               (display
                (string-append
                 "==(" (number->string count) ", "
                 (symbol->string rule-flag) ")==> ")
                output-port)
               (newline output-port)
               (pretty-print (clean-suffixes next-expr) output-port)
               'step-printed)))))
         (lambda (expr)
           (set! count 0)
           (set! displays-list '())
           (show-rewrites-until-fail
            `(letrec () ,(enforce (desugar expr))))))))


(define (print-steps-to-file! file)
  (if (output-port? output-port) (close-output-port output-port))
  (if file
      (begin
        (newline)
        (display (string-append "Steps will print to file: " file))
        (newline)
        (display "which will remain locked until PRINT-STEPS-TO-FILE!")
        (newline)
        (display "is called with another argument.")
        (set! output-port (open-output-file file)))
      (begin
        (newline)
        (display "Steps will display in REPL as usual.")
        (set! output-port user-port)))
  "output-port-set")

(define (hide-trivial-steps! boolean)
  (set! hide-trivial-steps? boolean))

(define (hide-all-steps! boolean)
  (set! hide-all-steps? boolean)
  (if boolean ''steps-hidden ''steps-shown))


                         ;;; GARBAGE COLLECTION


;ENVIRONMENT =~ SYMBOL --> VALUE
;ENVIRONMENTS are represented as association lists, namely,
;ENVIRONMENT subset LIST(VAL-BINDING)
;VAL-BINDING = VARIABLE X VALUE

;NEEDED-VARIABLES: (LIST(VARIABLE), ENVIRONMENT) --> LIST(VARIABLE)
(define (needed-variables initially-needed-vars environment)
  (define (node-info node)              ;a NODE is a VARIABLE
    (let ((bind (assq node environment))) 
      (list                             ;the label of a NODE is NIL
       (if (pair? bind)                 ;a variable/node is "adjacent" to the free
                                        ;variables of the expression to which it is bound
           (free-variables (cadr bind))
           '()))))
  (graph-search                         ;from "match.scm"
   node-info
   initially-needed-vars
   constant-true-function))             ;from "match.scm"


;;GARBAGE-COLLECT: LETREC-EXPRESSION --> LETREC-EXPRESSION
(define (garbage-collect expr)           ;EXPR = (LETREC LOCAL-ENV BEXPR)
  (let ((local-env (cadr expr))
        (bexpr (caddr expr)))
    (let ((needed-vars
           (needed-variables
            (append (free-variables bexpr)
                    (variables-of-binds defined-bindings))
            (append local-env (global-environment)))))
      `(letrec
           ,(restrict-to local-env needed-vars)
         ,bexpr))))


(define (restrict-to bindings vars)
    (filter
     (lambda (binding)
       (memq (car binding) vars))
     bindings))


(define (global-garbage-collect! expr)
       ;updates HIDDEN-GLOBAL-BINDINGS by deleting unneeded bindings and
       ;    adding bindings from EXPR needed by DEFINED-BINDINGS
       ;then filters unneeded bindings and hidden-global-bindings from EXPR
  (let* ((local-env (cadr expr))
         (bexpr (caddr expr))
         (complete-env (append local-env (global-environment)))
         (defined-variables
           (variables-of-binds defined-bindings))
         (needed-vars-for-bexpr
          (needed-variables (free-variables bexpr) complete-env))
         (needed-vars-for-global-defines
          (needed-variables defined-variables complete-env)))
    (set! hidden-global-bindings
          (restrict-to
           complete-env
           (list-minus needed-vars-for-global-defines
                       defined-variables)))
    (let ((new-local-env
           (restrict-to
            local-env
            (list-minus needed-vars-for-bexpr
                        needed-vars-for-global-defines))))
      (if (pair? new-local-env)
          `(letrec ,new-local-env ,bexpr)
          bexpr))))


;                    RENAMING-PROCS.SCM

;Routines for Variable Renaming in the Substitution Model for Scheme

;  ENFORCE: SCHEME-EXPRESSION --> ;SCHEME-EXPRESSION
;Enforces the VARIABLE CONVENTION on a Scheme expression:
;Each variable has at most one binding occurrence, e.g., occurrence as a
;formal parameter or variable bound in a LET construct, in the expression,
;and no bound variable is the same as any free variable.
;For example,
;>>(enforce
;   '(a b c d e
;       (let ((a e) (b c))
;         (a b c d e
;            (letrec ((a c)(c b))
;              (a b c d e))))))
;;Value:
;  (a b c d e
;     (let ((a_1 e) (b_0 c))
;       (a_1 b_0 c d e
;           (letrec ((a_2 c_0) (c_0 b_0))
;             (a_2 b_0 c_0 d e)))))


;NOTE: ENFORCE works only on DESUGARED expressions.  Also, it may
;      not work on expressions with numerically suffixed variables (of the form
;      "<var-name>_<nonnegative integer>") which have not been generated during
;      the current submodel invocation, i.e., since the last call of
;      (NEW-SUBMODEL).  This problem could be avoided by using Scheme's GENSYM
;      instead of the GET-FRESH procedure defined below, but we use GET-FRESH
;      because it generally produces shorter, prettier suffixes than GENSYM.


;RENAMING =~ SYMBOL --> SYMBOL
;RENAMING subset LIST(SYMBOL X SYMBOL)
;A RENAMING is a special case of a dictionary or environment which maps
;symbols to symbols (rather than more general data).  Like dictionaries 
;and environments, renamings are represented as association lists.

;The main subprocedure of ENFORCE is ENFORCE-AND-RENAME which takes a Scheme
;expression and a RENAMING, and returns a copy of the
;expression with bound variables renamed to satisfy the Variable Convention,
;but also with each FREE occurrence of a variable renamed by RENAMING.

(define (enforce expr)
  (define (enforce-and-rename expr renaming)
    (cond ((or (self-evaluating? expr)
               (procedure-constant? expr)
               (submodel-nil? expr)
               (match? '(quote ?) expr))
           expr)
          ((scheme-variable? expr)
           (let ((binding (assq expr renaming)))
             (if (pair? binding)
                 (datum-of-bind binding)
                 expr)))
          (else
           (let ((renamer
                  (lambda (expr) (enforce-and-rename expr renaming))))
             (case (car expr)
               ((if)
                (make-if
                 (renamer (test-of-if expr))
                 (renamer (consequent-of expr))
                 (renamer (alternative-of expr))))
               ((begin)
                (make-begin
                 (map renamer (expressions-of-begin expr))))
               ((set!)
                (make-set!
                 (renamer (variable-of-set! expr))
                 (renamer (expression-of-set! expr))))
               ((define)
                (let ((var (variable-of-define expr)))
                  (make-define
                   var
                   (enforce-and-rename
                    (expression-of-define expr)
                    (restrict-from renaming (list var))))))
               ((lambda)
                (let ((formals (formals-of-lambda expr)))
                  (cond ((scheme-variable? formals)
                         (let ((fresh-formal (get-fresh formals)))
                           (make-lambda
                            fresh-formal
                            (enforce-and-rename
                             (expr-of-lambda expr)
                             (append (restrict-from renaming (list formals))
                                     (list (make-binding formals fresh-formal)))))))
                        ((list? formals)
                         (let ((fresh-formals (map get-fresh formals)))
                           (make-lambda
                            fresh-formals
                            (enforce-and-rename
                             (expr-of-lambda expr)
                             (append (restrict-from renaming formals)
                                     (map make-binding formals fresh-formals))))))
                        (else (error "dotted formals not supported" formals)))))
                         
               ((let)
                (let* ((binds (bindings-of-letf expr))
                       (bvars (variables-of-binds binds))
                       (fresh-vars (map get-fresh bvars))
                       (inits (expressions-of-binds binds)))
                  (make-let
                   (map make-binding fresh-vars (map renamer inits))
                   (enforce-and-rename
                    (expr-of-letf expr)
                    (append (restrict-from renaming bvars)
                            (map make-binding bvars fresh-vars))))))
               ((letrec)
                (let* ((binds (bindings-of-letf expr))
                       (bvars (variables-of-binds binds))
                       (fresh-vars (map get-fresh bvars))
                       (new-renaming (append
                                      (restrict-from renaming bvars)
                                      (map make-binding bvars fresh-vars)))
                       (new-renamer
                        (lambda (expr)
                          (enforce-and-rename expr new-renaming))))
                  (make-letrec
                   (map
                    make-binding
                    fresh-vars
                    (map new-renamer (expressions-of-binds binds)))
                   (new-renamer (expr-of-letf expr)))))
               (else
                (make-combination
                 (map renamer
                      (expressions-of-combination expr)))))))))
  (enforce-and-rename expr '()))


(define (restrict-from bindings vars)
    (filter
     (lambda (binding)
       (not (memq (car binding) vars)))
     bindings))



; CLEAN-SUFFIXES: SCHEME-EXPRESSION --> SCHEME-EXPRESSION
;(CLEAN-SUFFIXES EXPR) returns EXPR with its free variables unchanged, but
;its bound variables renamed with no, or minimum, suffixes.  It essentially
;undoes ENFORCE.  It works only on desugared expressions.
;For example,
;>>(clean-suffixes
;   '(a b c d e
;       (let ((a_1 e) (b_0 c))
;         (a_1 b_0 c d e
;              (letrec ((a_2 c_0) (c_0 b_0))
;                (a_2 b_0 c_0 d e))))))
;;Value:
;  (a b c d e
;     (let ((a e) (b c))
;       (a b c d e
;         (letrec ((a c) (c b))
;           (a b c d e)))))

(define (clean-suffixes expr)
  (define (cleans expr renaming)
    (cond
     ((or (self-evaluating? expr)
          (procedure-constant? expr)
          (submodel-nil? expr)
          (match? '(quote ?) expr))
      expr)
     ((scheme-variable? expr)
      (let ((binding (assq expr renaming)))
        (if (pair? binding)
            (datum-of-bind binding)
            expr)))
     (else
      (let ((renamer (lambda (expr) (cleans expr renaming))))
        (case (car expr)
          ((if)
           (make-if
            (renamer (test-of-if expr))
            (renamer (consequent-of expr))
            (renamer (alternative-of expr))))
          ((begin)
           (make-begin
            (map renamer (expressions-of-begin expr))))
          ((set!)
           (make-set!
            (renamer (variable-of-set! expr))
            (renamer (expression-of-set! expr))))
          ((define)
           (let* ((fve (free-variables expr))
                  (fve-renaming (restrict-to renaming fve))
                  (vars-to-avoid
                   (append
                    (expressions-of-binds fve-renaming) ;the range of FVE-RENAMING
                    (list-minus fve (variables-of-binds fve-renaming)))) ;the unrenamed fve
                  (var (variable-of-define expr))
                  (cleaned-var (get-cleaned-variable var vars-to-avoid)))
             (make-define
              cleaned-var
              (cleans (expression-of-define expr)
                      (cons (make-binding var cleaned-var) fve-renaming)))))
          ((lambda)
           (let* ((fve (free-variables expr))
                  (fve-renaming (restrict-to renaming fve))
                  (vars-to-avoid
                   (append
                    (expressions-of-binds fve-renaming) ;the range of FVE-RENAMING
                    (list-minus fve (variables-of-binds fve-renaming)))) ;the unrenamed FVE
                  (formals (formals-of-lambda expr)))
             (cond ((scheme-variable? formals)
                    (let ((clean-formal (get-cleaned-variable formals vars-to-avoid)))
                      (make-lambda
                       clean-formal
                       (cleans
                        (expr-of-lambda expr)
                        (append (cons (make-binding formals clean-formal)
                                      fve-renaming))))))
                   ((list? formals)
                    (let* ((cleaned-formals (map-get-cleaned formals vars-to-avoid))
                           (formals-renaming (map make-binding formals cleaned-formals)))
                      (make-lambda
                       cleaned-formals
                       (cleans
                        (expr-of-lambda expr)
                        (append formals-renaming fve-renaming)))))
                   (else (error "dotted formals not supported" formals)))))
          ((let)
           (let* ((let-bindings (bindings-of-letf expr))
                  (cleaned-inits (map renamer
                                      (expressions-of-binds let-bindings)))
                  (let-vars (variables-of-binds let-bindings))
                  (body (expr-of-letf expr))
                  (unboundvars-in-body
                   (list-minus (free-variables body) let-vars))
                  (unbound-renaming
                   (restrict-to renaming unboundvars-in-body))
                  (vars-to-avoid
                   (append
                                        ;the range of UNBOUND-RENAMING:
                    (expressions-of-binds unbound-renaming)
                                        ;the unrenamed UNBOUNDVARS-IN-BODY
                    (list-minus unboundvars-in-body
                                (variables-of-binds unbound-renaming))))
                  (cleaned-letvars (map-get-cleaned let-vars vars-to-avoid))
                  (letvars-renaming (map make-binding let-vars cleaned-letvars)))
             (make-let
              (map make-binding cleaned-letvars cleaned-inits)
              (cleans body
                      (append letvars-renaming unbound-renaming)))))
          ((letrec)
           (let* ((fve (free-variables expr))
                  (fve-renaming (restrict-to renaming fve))
                  (vars-to-avoid
                   (append
                    (expressions-of-binds fve-renaming) ;the range of FVE-RENAMING
                    (list-minus fve (variables-of-binds fve-renaming)))) ;the unrenamed FVE
                  (let-bindings (bindings-of-letf expr))
                  (let-vars (variables-of-binds let-bindings))
                  (cleaned-letvars (map-get-cleaned let-vars vars-to-avoid))
                  (letvars-renaming (map make-binding let-vars cleaned-letvars))
                  (letrec-renamer
                   (lambda (expr)
                     (cleans expr (append letvars-renaming fve-renaming)))))
             (make-letrec
              (map make-binding cleaned-letvars
                   (map letrec-renamer (expressions-of-binds let-bindings)))
              (letrec-renamer (expr-of-letf expr)))))
          (else
           (make-combination
            (map renamer
                 (expressions-of-combination expr)))))))))
  (cleans expr '()))



;;;                              FREE-VARIABLES


(define (free-variables expr)
  (cond ((or (self-evaluating? expr)
             (procedure-constant? expr)
             (submodel-nil? expr)
             (match? '(quote ?) expr))
         '())
        ((scheme-variable? expr)
         (list expr))
        (else
         (case (car expr)
           ((if)
            (append (free-variables (test-of-if expr))
                    (free-variables (consequent-of expr))
                    (free-variables (alternative-of expr))))
           ((begin)
            (append-map free-variables
                        (expressions-of-begin expr)))
           ((lambda)
            (list-minus (free-variables (expr-of-lambda expr))
                        (let ((formals (formals-of-lambda expr)))
                          (if (scheme-variable? formals)
                              (list formals)
                              formals))))
           ((let)
            (let ((binds (bindings-of-letf expr)))
              (append
               (list-minus (free-variables (expr-of-letf expr))
                           (variables-of-binds binds))
               (append-map free-variables
                           (expressions-of-binds binds)))))
           ((letrec)
            (let ((binds (bindings-of-letf expr)))
              (list-minus
               (append
                (free-variables (expr-of-letf expr))
                (append-map free-variables
                            (expressions-of-binds binds)))
               (variables-of-binds binds))))
           ((set!)
            (cons
             (variable-of-set! expr)
             (free-variables (expression-of-set! expr))))
           ((define)
            (list-minus
             (free-variables (expression-of-define expr))
             (list (variable-of-define expr))))
           (else (append-map free-variables
                             (expressions-of-combination expr)))))))


                            ;;FRESH and CLEANED VARIABLES

;MAP-GET-CLEANED returns fresh copies of VARS with minimum natural number
;suffixes to be distinct from each other and the members of VARS-TO-AVOID.
;For example,
;(map-get-cleaned '(a   b x_0 x   x_2 x_4 a_1) '(a_1 b_2 a x_2))
;Value:            (a_0 b x   x_0 x_1 x_3 a_2)

(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))))))


;;GET-CLEANED-VARIABLE: (SYMBOL, LIST(SYMBOL)) --> SYMBOL
; is defined in MATCH.SCM.

;(GET-CLEANED-VARIABLE SYMB VARS-TO-AVOID) returns a symbol which looks 
;like SYMB but with smallest possible natural number suffix, or no suffix,
;so it is NOT in VARS-TO-AVOID, e.g.,
;(get-cleaned-variable 'x_2 '(x y z_4 x_0))
;Value: x_1
;(get-cleaned-variable 'x_2 '(x_2 y z_4 x_0))
;Value: x

;;GET-FRESH: (SYMBOL + Empty) --> SYMBOL

;; This is essentially our own (less efficient) implementation of Scheme's
;; GENERATE-UNINTERNED-SYMBOL procedure.  Our output is a little prettier
;; mainly because suffixes are usually shorter.

(define clear-get-fresh-table! 'dummy)

(define get-fresh
  (let ((variable-table '()))           ;associations of the form ("VAR-PREFIX" NUM)
    (set! clear-get-fresh-table!
          (lambda () (set! variable-table '())))
    (lambda var
      (let ((var (if (null? var)
                     'no-name-supplied
                     (car var))))
        (let* ((var-string (car (parse-suffix var))) ;PARSE-SUFFIX from "match.scm"
               (var/next-suffix-num (assoc var-string variable-table)))
          (if var/next-suffix-num
              (let ((suffix-num (cdr var/next-suffix-num)))
                (set-cdr! var/next-suffix-num (+ 1 suffix-num))
                (make-suffixed-symbol (cons (car var/next-suffix-num) suffix-num)))
              (begin
                (set! variable-table (cons (cons var-string 1) variable-table))
                                        ;MAKE-SUFFIXED-SYMBOL from "match.scm":
                (make-suffixed-symbol (cons var-string 0)))))))))
               



;                                    ;;SYNTAX CONSTRUCTORS


;;DEFINE
(define (make-define var expr)
    `(define ,var ,expr))
(define variable-of-define cadr)
(define expression-of-define caddr)


;;COMBINATION
(define (make-combination exps) exps)
(define (expressions-of-combination comb) comb)


;;LAMBDA-EXPRESSION
(define (make-lambda formals expr)
  `(lambda ,formals ,expr))
(define formals-of-lambda cadr)
(define expr-of-lambda caddr)


;;IF
(define (make-if test consequent alternative)
  `(if ,test ,consequent ,alternative))
(define test-of-if cadr)
(define consequent-of caddr)
(define alternative-of cadddr)


;;VARIABLE
(define (scheme-variable? expr)
  (and (symbol? expr)
       (not (keyword? expr))
       (not (procedure-constant? expr))))


;;SET!
(define (make-set! var expr)
  `(set! ,var ,expr))
(define variable-of-set! cadr)
(define expression-of-set! caddr)


;;BEGIN
(define (make-begin exps)
  `(begin ,@exps))
(define expressions-of-begin cdr)


;;KEYWORD
(define (keyword? expr)
  (and (symbol? expr)
       (memq expr '(and begin case cond define do else
                   if lambda let let* letrec or quote set!))))

(define (not-else? expr) (not (eq? 'else expr)))



;;LET FORMS
(define bindings-of-letf cadr)
(define expr-of-letf caddr)
(define (make-let bindings expr)
  `(let ,bindings ,expr))
(define (make-letrec bindings expr)
  `(letrec ,bindings ,expr))



;;BINDINGS
(define (make-binding var datum) (list var datum))
(define (var-of-bind bind)
  (car bind))
(define (datum-of-bind bind)
  (cadr bind))
(define (variables-of-binds bindings)
  (map var-of-bind bindings))
(define (expressions-of-binds bindings)
  (map datum-of-bind bindings))


            ;;UTILITIES

(define call/cc call-with-current-continuation)

(define (list-minus l1 l2)              ; returns members of l1 not in l2
    (filter
     (lambda (v) (not (member v l2)))
     l1))