removed macro from lazy interpreter and some other clean-ups. added a "lazy SKI" combinator compiler.

Author: yinwang0

interp-call-by-need.ss

@@ -5,23 +5,8 @@
 ;; author: Yin Wang ([email protected])
 
 
-
 (load "pmatch.scm")
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; a compositional version:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-syntax memo
-  (syntax-rules ()
-    [(_ body)
-     (let ([val? #f] [e (lambda () body)])
-       (lambda ()
-         (if val?
-             e
-             (begin
-               (set! val? #t)
-               (set! e (e))
-               e))))]))
 
 (define interp1
   (lambda (exp env)
@@ -31,23 +16,44 @@
       [(lambda (,x) ,e)
        (lambda (v)
          (interp1 e (lambda (x^)
-                     (if (eq? x^ x) v (env x^)))))]
+                      (if (eq? x^ x) v (env x^)))))]
       [(,op ,e1 ,e2) (guard (memq op '(+ - * /)))
        (let ([v1 (interp1 e1 env)]
              [v2 (interp1 e2 env)])
-         (if (and (number? v1) (number? v2))
-             ((eval op) v1 v2)
-             `(,op ,v1 ,v2)))]
-      [(,f . ,x*) (guard (procedure? f))
-       (apply f (map (lambda (x) (interp1 x env)) x*))]
+         (cond
+          [(and (number? v1) (number? v2))
+           ((eval op) v1 v2)]
+          [else
+           `(,op ,v1 ,v2)]))]
+      [(,f ,x) (guard (procedure? f))
+       (f (interp1 x env))]
       [(,e1 ,e2)
        (let ([v1 (interp1 e1 env)])
-         (if (procedure? v1)
-             (v1 (memo (interp1 e2 env)))
-             `(,v1 ,(interp1 e2 env))))]
+         (cond
+          [(procedure? v1)
+           (v1 (let ([val? #f]
+                     [e (lambda () (interp1 e2 env))])
+                 (lambda ()
+                   (cond
+                    [val? e]
+                    [else
+                     (begin
+                       (set! val? #t)
+                       (set! e (e))
+                       e)]))))]
+          [else
+           `(,v1 ,(interp1 e2 env))]))]
       [,exp (eval exp)])))
 
+
 (define interp
   (lambda (exp)
     (interp1 exp (lambda (x) (lambda () x)))))
 
+
+
+;; ------------------------ tests -------------------------
+(interp
+ '((lambda (x) 42)
+   ((lambda (x) (x x))
+    (lambda (x) (x x)))))

lazy-ski.ss

@@ -0,0 +1,124 @@
+(load "pmatch.scm")
+
+(define occur-free?
+  (lambda (y exp)
+    (pmatch exp
+      [,x (guard (symbol? x)) (eq? y x)]
+      [(lambda (,x) ,e) (and (not (eq? y x)) (occur-free? y e))]
+      [(,rator ,rand) (or (occur-free? y rator) (occur-free? y rand))])))
+
+(define value?
+  (lambda (exp)
+    (pmatch exp
+      [,x (guard (symbol? x)) #t]
+      [(lambda (,x) ,e) #t]
+      [(,rator ,rand) #f])))
+
+(define app? (lambda (x) (not (value? x))))
+
+(define term-length
+  (lambda (exp)
+    (pmatch exp
+      [,x (guard (symbol? x)) 0]
+      [(lambda (,x) ,e) (+ 1 (term-length e))]
+      [(,rator ,rand) (+ 1 (term-length rator) (term-length rand))])))
+
+; call-by-name compiler to S, K, I
+(define compile
+  (lambda (exp)
+    (pmatch exp
+      [,x (guard (symbol? x)) x]
+      [(,M ,N) `(,(compile M) ,(compile N))]
+      [(lambda (,x) (,M ,y))
+       (guard (eq? x y) (not (occur-free? x M))) (compile M)]
+      [(lambda (,x) ,y) (guard (eq? x y)) `I]
+      [(lambda (,x) (,M ,N)) (guard (or (occur-free? x M) (occur-free? x N)))
+       `((S ,(compile `(lambda (,x) ,M))) ,(compile `(lambda (,x) ,N)))]
+      [(lambda (,x) ,M) (guard (not (occur-free? x M))) `(K ,(compile M))]
+      [(lambda (,x) ,M) (guard (occur-free? x M))
+       (compile `(lambda (,x) ,(compile M)))])))
+
+; call-by-name compiler to S, K, I, B, C
+(define compile-bc
+  (lambda (exp)
+    (pmatch exp
+      [,x (guard (symbol? x)) x]
+      [(,M ,N) `(,(compile-bc M) ,(compile-bc N))]
+      [(lambda (,x) ,y) (guard (eq? x y)) `I]
+      [(lambda (,x) (,M ,y))
+       (guard (eq? x y) (not (occur-free? x M))) (compile-bc M)]
+      [(lambda (,x) (,M ,N)) (guard (and (not (occur-free? x M)) (occur-free? x N)))
+       `((B ,(compile-bc M)) ,(compile-bc `(lambda (,x) ,N)))]
+      [(lambda (,x) (,M ,N)) (guard (and (occur-free? x M) (not (occur-free? x N))))
+       `((C ,(compile-bc `(lambda (,x) ,M))) ,(compile-bc N))]
+      [(lambda (,x) (,M ,N)) (guard (or (occur-free? x M) (occur-free? x N)))
+       `((S ,(compile-bc `(lambda (,x) ,M))) ,(compile-bc `(lambda (,x) ,N)))]
+      [(lambda (,x) ,M) (guard (not (occur-free? x M))) `(K ,(compile-bc M))]
+      [(lambda (,x) ,M) (guard (occur-free? x M))
+       (compile-bc `(lambda (,x) ,(compile-bc M)))])))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ski->lanbda converter
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; create gensyms
+(define fv
+  (let ((n -1))
+    (lambda (x)
+      (set! n (+ 1 n))
+      (string->symbol
+       (string-append (symbol->string x) "." (number->string n))))))
+
+;; substitution with free variable capturing avoiding
+(define subst
+  (lambda (x y exp)
+    (pmatch exp
+      [,u (guard (symbol? u)) (if (eq? u x) y u)]
+      [(lambda (,u) ,e)
+       (cond
+        [(eq? u x) exp]
+        [(occur-free? u y)              ; possible capture, switch names
+         (let* ([u* (fv u)]
+                [e* (subst u u* e)])
+           `(lambda (,u*) ,(subst x y e*)))]
+        [else
+         `(lambda (,u) ,(subst x y e))])]
+      [(,e1 ,e2) `(,(subst x y e1) ,(subst x y e2))]
+      [,exp exp])))
+
+
+; combinator definitions
+(define com-table
+  '((S . (lambda (f) (lambda (g) (lambda (x) ((f x) (g x))))))
+    (K . (lambda (x) (lambda (y) x)))
+    (I . (lambda (x) x))
+    (B . (lambda (f) (lambda (g) (lambda (x) (f (g x))))))
+    (C . (lambda (a) (lambda (b) (lambda (c) ((a c) b)))))))
+
+; substitute combinator with their lambda term definitions
+(define sub-com
+  (lambda (exp defs)
+    (cond
+     [(null? defs) exp]
+     [else (sub-com (subst (caar defs) (cdar defs) exp) (cdr defs))])))
+
+(define ski->lambda
+  (lambda (exp)
+    (sub-com exp com-table)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define to-number `(lambda (n) ((n (lambda (x) (,add1 x))) 0)))
+
+(interp `(,to-number ,(ski->lambda (compile-bc `(,!-n ,lfive)))))
+; => 120
+(term-length `(,! ,lfive))
+; => 93
+(term-length (compile `(,! ,lfive)))
+; => 144
+(term-length (compile-bc `(,! ,lfive)))
+; => 73
+