update compiliation steps to use the letrecs (fix combinators)

scmvm/language/scheme.scm

@@ -52,7 +52,7 @@
   (next environment-next)
   (values environment-values))
 
-(define (make-environment)
+(define (null-environment)
   (make-environment* #f '()))
 
 (define (environment-extend env values)
@@ -62,9 +62,9 @@
   (let loop ([r r]
              [j 0])
     (cond
-     [(not r) #f]
+     [(not r) (values #f #f)]
      [(list-index (lambda (n0) (eq? n n0)) (environment-values r)) => (lambda (i) (values i j))]
-     [else (loop (+ j 1) (environment-next r))])))
+     [else (loop (environment-next r) (+ j 1))])))
 
 (define (environment-assq r n)
   (let loop ([r r])
@@ -275,7 +275,7 @@
                              (lambda (t*) (k (cons t t*))) r)) r)))
 
 (define (cps-convert-prgm prgm tail)
-  (T-c prgm tail (make-environment)))
+  (T-c prgm tail (null-environment)))
 
 (define* (ir-convert prgm #:optional (tail 'ktail))
   (cps-convert-prgm (desugar-top prgm) tail))
@@ -307,8 +307,8 @@
      (meaning-assignment v e r k)]
     [('if e k1 k2)
      (meaning-alternative e r k1 k2)]
-    [('letrec ([v e]) k)
-     (meaning-definition v e r k)]
+    [('letrec ([v* e*] ...) k)
+     (meaning-definition v* e* r k)]
     [(f e* ... k)
      (meaning-application f e* r k)]
     [_ (signal-exception "Unrecognized cps" e)]))
@@ -373,37 +373,34 @@
   (let* ([m (meaning e r)]
          [r0 (r-extend r v)]
          [mk (meaning k r0)])
-    (meaning-append
-     m mk)))
-
-(define (meaning-definition v e r k)
-  (let* ([r0 (r-extend r v)]
-         [m (meaning e r0)]
-         [mk (meaning k r0)])
     (meaning-append m mk)))
 
+(define (meaning-definition v* e* r k)
+  (let* ([r0 (r-extend* r v*)]
+         [m* (meaning* e* r0)]
+         [mk (meaning k r0)])
+    (meaning-append m* mk)))
+
 (define (meaning* e* r)
-  (map (lambda (e) (meaning e r)) e*))
+  (apply append (map (lambda (e) (meaning e r)) e*)))
 
 (define meaning-append append)
 
 (define signal-exception error)
 
 (define (r-extend r v)
-  (cons (list v) r))
+  (environment-extend r (list v)))
 
 (define (r-extend* r v*)
-  (cons v* r))
+  (environment-extend r v*))
 
-(define (locate-local-reference n j r)
-  (cond
-   [(null? r) #f]
-   [(list-index (lambda (n0) (eq? n n0)) (car r)) => (lambda (i) `(local ,j ,i))]
-   [else (locate-local-reference n (+ j 1) (cdr r))]))
+(define (locate-local-reference n r)
+  (let-values ([(i j) (environment-lookup r n)])
+    (and i j `(local ,j ,i))))
 
 (define (locate-reference n r)
   (cond
-   [(locate-local-reference n 0 r) => identity]))
+   [(locate-local-reference n r) => identity]))
 
 (define-syntax define-combinator
   (syntax-rules ()