Move the combinators together

2025-11-22 20:39:27 -06:00
parent 9df556d2ac
commit 0fa5814710
1 changed files with 123 additions and 135 deletions
--- a/direct-style-interpreter.scm
+++ b/direct-style-interpreter.scm
@@ -255,6 +255,128 @@
         (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"
@@ -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")