1  
  2    (define (env-binding env sym-or-term)
  3  
  4      (define (sym-ref alist sym)
  5        (assq sym alist))
  6  
  7      (define (term-ref pair-path-possibs term)
  8        (let ((t-env (term-env term)))
  9  
 10          (define (compare p o vars)
 11            (cond
 12              ((pair? p)
 13               (and (pair? o)
 14                    (let ((vars (compare (car p) (car o) vars)))
 15                      (and vars (compare (cdr p) (cdr o) vars)))))
 16              ((value? p)
 17               (let ((b (binding o t-env)))
 18                 (and b
 19                      (eqv? (value-value p) (binding-val b))
 20                      vars)))
 21              ((variable? p)
 22               (cond
 23                 ((assq p vars) => (lambda (a)
 24                                     (and (equal? o (cdr a))
 25                                          vars)))
 26                 (else
 27                  (let ((vty (variable-type p))
 28                        (oty (eval `(,$type ,o) t-env)))
 29                    (and (eval `((,$vau (oty vty) #F
 30                                   (,includes? oty vty))
 31                                 ,oty ,vty)
 32                               t-env)
 33                         (cons (cons p o) vars))))))
 34              ((symbol? p)
 35               (and (eq? p o)
 36                    (not (binding o t-env))
 37                    vars))
 38              (else
 39               (and (equal? p o)
 40                    vars))))
 41  
 42          (let recur ((ps pair-path-possibs)
 43                      (obj (term-expr term))
 44                      (vars '()))
 45            (and (pair? ps)
 46                 (let ((p (car ps)))
 47                   (cond ((and (pair? p) (pair? obj)
 48                               (compare (car p) (car obj) vars))
 49                          => (lambda (vars) (recur (cdr p) (cdr obj) vars)))
 50                         ((and (end? p)
 51                               (compare (end-possib p) obj vars))
 52                          (end-binding p))
 53                         (else
 54                          (recur (cdr ps) obj vars))))))))
 55  
 56      (if (symbol? sym-or-term)
 57        (sym-ref (environment-symbol-bindings env) sym-or-term)
 58        (term-ref (environment-term-bindings env) sym-or-term)))
 59  
 60  
 61    (define (bind env sym-or-term val)
 62  
 63      (define (sym-bind alist sym val)
 64        (cons (make-binding sym val) alist))
 65  
 66      (define (term-bind pair-path-possibs term val)
 67        (let ((t-env (term-env term)))
 68  
 69          (define (compare p o vars)
 70            (cond
 71              ((pair? p)
 72               (and (pair? o)
 73                    (let ((vars (compare (car p) (car o) vars)))
 74                      (and vars (compare (cdr p) (cdr o) vars)))))
 75              ((value? p)
 76               (and (symbol? o)
 77                    (let ((b (binding o t-env)))
 78                      (and b
 79                           (eqv? (value-value p) (binding-val b))
 80                           vars))))
 81              ((variable? p)
 82               (and (symbol? o)
 83                    (let ((b (binding o t-env)))
 84                      (and b
 85                           (let ((v (binding-val b)))
 86                             (and (variable? v)
 87                                  (eqv? (variable-type p) (variable-type v))
 88                                  (cond ((assq v vars)
 89                                         => (lambda (a) (and (eq? p (cdr a)) vars)))
 90                                        (else (cons (cons v p) vars)))))))))
 91              ((symbol? p)
 92               (and (eq? p o)
 93                    (not (binding o t-env))
 94                    vars))
 95              (else
 96               (and (equal? p o)
 97                    vars))))
 98  
 99          (define (compile o)
100            (cond ((pair? o)
101                   (cons (compile (car o)) (compile (cdr o))))
102                  ((and (symbol? o) (binding o t-env))
103                   => (lambda (b)
104                        (let ((v (binding-val b)))
105                          (if (variable? v) v (make-value v)))))
106                  (else o)))
107  
108          (let recur ((ps pair-path-possibs)
109                      (obj (term-expr term))
110                      (vars '())
111                      (rps '()))
112            (if (pair? ps)
113              (let ((p (car ps)))
114                (define (update np)
115                  (rappend rps (cons np (cdr ps))))
116                (cond
117                  ((and (pair? p) (pair? obj)
118                        (compare (car p) (car obj) vars))
119                   => (lambda (vars)
120                        (update (cons (car p)
121                                      (recur (cdr p) (cdr obj) vars '())))))
122                  ((and (end? p)
123                        (compare (end-possib p) obj vars))
124                   (update (make-end (end-possib p)
125                                     (make-binding term val))))
126                  (else
127                   (recur (cdr ps) obj vars (cons p rps)))))
128              (cons
129               (if (pair? obj)
130                 (cons (compile (car obj))
131                       (recur '() (cdr obj) '() '()))
132                 (make-end (compile obj)
133                           (make-binding term val)))
134               (reverse rps))))))
135  
136      (if (symbol? sym-or-term)
137        (make-environment
138         (sym-bind (environment-symbol-bindings env) sym-or-term val)
139         (environment-term-bindings env))
140        (make-environment
141         (environment-symbol-bindings env)
142         (term-bind (environment-term-bindings env) sym-or-term val))))
143  
144  
145  (define (rappend rl l)
146    (fold-left (lambda (a x) (cons x a)) l rl))
147  
148  (define (binding expr env)
149    (cond ((pair? expr) (env-binding env (make-term expr env)))
150          ((symbol? expr) (env-binding env expr))
151          (else (make-binding #F expr))))
152  
153  
154  
155  ($let ((a ($lambda ...))
156         (b ...))
157    ($let (('(a b c) ...))
158      (get-current-environment)))
159  =>
160  
161  [env symbols: ((a . ,A) (b . ,B))
162       terms:
163       (([val ,A] . (([val ,B] . ((c . ([end () ,VAL]))))
164                     ...))
165        ...)
166       ]