Move the combinators together

direct-style-interpreter.scm

@@ -255,13 +255,135 @@
          (error "Wrong arity" 'apply)))
    (*env*)))
 
+;; Combinators
+(define (CONSTANT v)
+  (lambda () v))
+
+(define (SEQUENCE m m+)
+  (lambda () (m) (m+)))
+
+(define (SHALLOW-ARGUMENT-REF j)
+  (lambda () (activation-rec-ref (*env*) j)))
+
+(define (DEEP-ARGUMENT-REF i j)
+  (lambda () (activation-rec-ref (*env*) i j)))
+
+(define (PREDEFINED i)
+  (lambda () (predefined-fetch i)))
+
+(define (GLOBAL-REF i)
+  (lambda () (global-fetch i)))
+
+(define (CHECKED-GLOBAL-REF i)
+  (lambda ()
+    (let ([v (global-fetch i)])
+      (if (eq? v undefined-value)
+          (error "Uninitialized variable")
+          v))))
+
+(define (ALTERNATIVE m1 m2 m3)
+  (lambda () (if (m1) (m2) (m3))))
+
+(define (STORE-ARGUMENT m m* rank)
+  (lambda ()
+    (let ([v* (m*)]
+          [v (m)])
+      (activation-rec-set! v* rank v)
+      v*)))
+
+(define (CONS-ARGUMENT m m* size)
+  (lambda ()
+    (let* ([v* (m*)]
+           [v (m)]
+           [lst (activation-rec-ref v* size)])
+      (activation-rec-set! v* size (cons v lst))
+      v*)))
+
+(define (ALLOCATE-FRAME size)
+  (lambda () (make-activation-rec (1+ size))))
+
+(define (ALLOCATE-DOTTED-FRAME size)
+  (lambda ()
+    (let ([rec (make-activation-rec (1+ size))])
+      (activation-rec-set! rec size '())
+      rec)))
+
+(define (REGULAR-CALL m m*)
+  (lambda ()
+    (let* ([f (m)]
+           [v* (m*)]
+           [sr (*env*)]
+           [res (invoke f v*)])
+      (*env* sr)
+      res)))
+
+(define (TR-REGULAR-CALL m m*)
+  (lambda () (invoke (m) (m*))))
+
+(define (CALL0 address)
+  (lambda () (address)))
+
+(define (CALL1 address m1)
+  (lambda () (address (m1))))
+
+(define (CALL2 address m1 m2)
+  (lambda ()
+    (let ([v1 (m1)])
+      (address v1 (m2)))))
+
+(define (CALL3 address m1 m2 m3)
+  (lambda ()
+    (let ([v1 (m1)]
+          [v2 (m2)])
+      (address v1 v2 (m3)))))
+
+(define (FIX-LET m* m+)
+  (lambda ()
+    (*env* (sr-extend* (*env*) (m*)))
+    (let ([res (m+)])
+      (*env* (activation-record-next (*env*))) ;; black magic
+      res)))
+
+(define (TR-FIX-LET m* m+)
+  (lambda ()
+    (*env* (sr-extend* (*env*) (m*)))
+    (m+)))
+
+(define (SHALLOW-ARGUMENT-SET! j m)
+  (lambda () (activation-rec-set! (*env*) j (m))))
+
+(define (DEEP-ARGUMENT-SET! i j m)
+  (lambda () (activation-rec-set! (*env*) i j (m))))
+
+(define (GLOBAL-SET! i m)
+  (lambda () (global-update! i (m))))
+
+(define (FIX-CLOSURE m+ arity)
+  (lambda ()
+    (define (the-function v* sr)
+      (if (= (activation-rec-length v*) (1+ arity))
+          (begin (*env* (sr-extend* sr v*))
+                 (m+))
+          (error "Incorrect arity")))
+    (make-closure the-function (*env*))))
+
+(define (NARY-CLOSURE m+ arity)
+  (lambda ()
+    (define (the-function v* sr)
+      (if (>= (activation-rec-length v*) (1+ arity))
+          (begin (listify! v* arity)
+                 (*env* (sr-extend* sr v*))
+                 (m+))
+          (error "Incorrect arity")))
+    (make-closure the-function (*env*))))
+
 ;; Denotations
 (define (meaning e r tail?)
   "Core of the denotation. `tail?' allows us to avoid capturing the local environment if we know we will not return"
   (match e
     [(? (negate pair?))
      (if (symbol? e)      (meaning-reference e r)
-                          (meaning-quotation e))]
+         (meaning-quotation e))]
     [('quote e* ...)      (meaning-quotation (car e*))]
     [('lambda v* e* ...)  (meaning-abstraction v* e* r)]
     [('if e1 e2 e3)       (meaning-alternative e1 e2 e3 r tail?)]
@@ -272,19 +394,12 @@
 (define (meaning-quotation e*)
   (CONSTANT e*))
 
-(define (CONSTANT v)
-  (lambda () v))
-
 (define (meaning-alternative e1 e2 e3 r tail?)
   (let ([m1 (meaning e1 r #f)]
         [m2 (meaning e2 r tail?)]
         [m3 (meaning e3 r tail?)])
     (ALTERNATIVE m1 m2 m3)))
 
-(define (ALTERNATIVE m1 m2 m3)
-  (lambda ()
-    (if (m1) (m2) (m3))))
-
 (define (meaning-sequence e+ r tail?)
   (cond
    [(null? e+) (static-error "Illegal syntax (begin)")]
@@ -292,10 +407,6 @@
    [else (SEQUENCE (meaning (car e+) r #f)
                    (meaning-sequence (cdr e+) r tail?))]))
 
-(define (SEQUENCE m m+)
-  (lambda ()
-    (m) (m+)))
-
 (define (meaning-reference n r)
   (match (compute-kind n r)
     [('local . (i . j))
@@ -308,29 +419,6 @@
      (PREDEFINED i)]
     [_ (static-error "No such variable" n)]))
 
-(define (SHALLOW-ARGUMENT-REF j)
-  (lambda ()
-    (activation-rec-ref (*env*) j)))
-
-(define (DEEP-ARGUMENT-REF i j)
-  (lambda ()
-    (activation-rec-ref (*env*) i j)))
-
-(define (PREDEFINED i)
-  (lambda ()
-    (predefined-fetch i)))
-
-(define (GLOBAL-REF i)
-  (lambda ()
-    (global-fetch i)))
-
-(define (CHECKED-GLOBAL-REF i)
-  (lambda ()
-    (let ([v (global-fetch i)])
-      (if (eq? v undefined-value)
-          (error "Uninitialized variable")
-          v))))
-
 (define (meaning-application f e* r tail?)
   (cond
    [(and (symbol? f)
@@ -365,49 +453,11 @@
      [(> fixed-size rank) (STORE-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) rank)]
      [else (CONS-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) fixed-size)])))
 
-(define (STORE-ARGUMENT m m* rank)
-  (lambda ()
-    (let ([v* (m*)]
-          [v (m)])
-      (activation-rec-set! v* rank v)
-      v*)))
-
-(define (CONS-ARGUMENT m m* size)
-  (lambda ()
-    (let* ([v* (m*)]
-           [v (m)]
-           [lst (activation-rec-ref v* size)])
-      (activation-rec-set! v* size (cons v lst))
-      v*)))
-
-(define (ALLOCATE-FRAME size)
-  (lambda ()
-    (make-activation-rec (1+ size))))
-
-(define (ALLOCATE-DOTTED-FRAME size)
-  (lambda ()
-    (let ([rec (make-activation-rec (1+ size))])
-      (activation-rec-set! rec size '())
-      rec)))
-
 (define (meaning-regular-application f e* r tail?)
   (let [(mf (meaning f r #f))
         (m* (meaning* e* r))]
     ((if tail? TR-REGULAR-CALL REGULAR-CALL) mf m*))) ;; hehe new trick
 
-(define (REGULAR-CALL m m*)
-  (lambda ()
-    (let* ([f (m)]
-           [v* (m*)]
-           [sr (*env*)]
-           [res (invoke f v*)])
-      (*env* sr)
-      res)))
-
-(define (TR-REGULAR-CALL m m*)
-  (lambda ()
-    (invoke (m) (m*))))
-
 (define (meaning-primitive-application f e* r)
   (let* ([desc (get-description f)]
          [address (desc-address desc)]
@@ -426,25 +476,6 @@
                  (CALL3 address m1 m2 m3))])
         (static-error "Wrong arity for" f arity))))
 
-(define (CALL0 address)
-  (lambda ()
-    (address)))
-
-(define (CALL1 address m1)
-  (lambda ()
-    (address (m1))))
-
-(define (CALL2 address m1 m2)
-  (lambda ()
-    (let ([v1 (m1)])
-      (address v1 (m2)))))
-
-(define (CALL3 address m1 m2 m3)
-  (lambda ()
-    (let ([v1 (m1)]
-          [v2 (m2)])
-      (address v1 v2 (m3)))))
-
 (define (meaning-closed-application e ee* r tail?)
   (let lp ([n* (second e)]
            [e* ee*]
@@ -473,18 +504,6 @@
          [m+ (meaning-sequence body r2 tail?)])
     ((if tail? TR-FIX-LET FIX-LET) m* m+)))
 
-(define (FIX-LET m* m+)
-  (lambda ()
-    (*env* (sr-extend* (*env*) (m*)))
-    (let ([res (m+)])
-      (*env* (activation-record-next (*env*))) ;; black magic
-      res)))
-
-(define (TR-FIX-LET m* m+)
-  (lambda ()
-    (*env* (sr-extend* (*env*) (m*)))
-    (m+)))
-
 (define (meaning-assignment n e r)
   (let ([m (meaning e r #f)])
     (match (compute-kind n r)
@@ -498,18 +517,6 @@
        (static-error "Cannot set predefined variable" n)]
       [_ (static-error "Cannot set! undefined variable" n)])))
 
-(define (SHALLOW-ARGUMENT-SET! j m)
-  (lambda ()
-    (activation-rec-set! (*env*) j (m))))
-
-(define (DEEP-ARGUMENT-SET! i j m)
-  (lambda ()
-    (activation-rec-set! (*env*) i j (m))))
-
-(define (GLOBAL-SET! i m)
-  (lambda ()
-    (global-update! i (m))))
-
 (define (meaning-abstraction nn* body r)
   (let lp ([n* nn*]
            [fixargs '()])
@@ -529,25 +536,6 @@
          [r2 (r-extend* r (append n* (list n)))]
          [m+ (meaning-sequence body r2 #t)])
     (NARY-CLOSURE m+ arity)))
-
-(define (FIX-CLOSURE m+ arity)
-  (lambda ()
-    (define (the-function v* sr)
-      (if (= (activation-rec-length v*) (1+ arity))
-          (begin (*env* (sr-extend* sr v*))
-                 (m+))
-          (error "Incorrect arity")))
-    (make-closure the-function (*env*))))
-
-(define (NARY-CLOSURE m+ arity)
-  (lambda ()
-    (define (the-function v* sr)
-      (if (>= (activation-rec-length v*) (1+ arity))
-          (begin (listify! v* arity)
-                 (*env* (sr-extend* sr v*))
-                 (m+))
-          (error "Incorrect arity")))
-    (make-closure the-function (*env*))))
 
 ;; Tests
 (test-begin "direct-style-interpreter")