init commit

denotational-interpreter.scm

@@ -0,0 +1,518 @@
+(use-modules (ice-9 match)
+             (srfi srfi-1) 
+             (srfi srfi-9) ;; Record types
+             (srfi srfi-64) ;; Testing framework
+             )
+;; Globals
+(define undefined-value (make-symbol "undefined"))
+(define g.init (make-parameter '()))
+(define sg.init (make-vector 100))
+(define g.current (make-parameter '()))
+(define sg.current (make-vector 100))
+(define desc.init (make-parameter '()))
+
+;; Macros
+(define-syntax with-fresh-globals
+  (syntax-rules ()
+    [(_ expr ...)
+     (parameterize ([g.current '()]
+                    [g.init '()]
+                    [desc.init '()])
+       expr ...)]))
+(define-syntax define-initial
+  (syntax-rules ()
+    [(_ name value)
+     (vector-set! sg.init (g.init-extend! 'name) value)]))
+(define-syntax define-primitive
+  (syntax-rules ()
+    [(_ name value 0) (define-primitive0 name value)]
+    [(_ name value 1) (define-primitive1 name value)]
+    [(_ name value 2) (define-primitive2 name value)]
+    [(_ name value 3) (define-primitive3 name value)]))
+(define-syntax-rule (define-primitive0 name value)
+  (define-initial name
+    (letrec ([arity+1 (+ 0 1)]
+             [behavior
+              (lambda (v* k)
+                (if (= (activation-rec-length v*) arity+1)
+                    (k (value))
+                    (error "Incorrect arity" 'name)))])
+      (description-extend! 'name `(function ,value))
+      behavior)))
+(define-syntax-rule (define-primitive1 name value)
+  (define-initial name
+    (letrec ([arity+1 (+ 1 1)]
+             [behavior
+              (lambda (v* k)
+                (if (= (activation-rec-length v*) arity+1)
+                    (k (value (activation-rec-ref v* 0)))
+                    (error "Incorrect arity" 'name)))])
+      (description-extend! 'name `(function ,value a))
+      behavior)))
+(define-syntax-rule (define-primitive2 name value)
+  (define-initial name
+    (letrec ([arity+1 (+ 2 1)]
+             [behavior
+              (lambda (v* k)
+                (if (= (activation-rec-length v*) arity+1)
+                    (k (value (activation-rec-ref v* 0)
+                              (activation-rec-ref v* 1)))
+                    (error "Incorrect arity" 'name)))])
+      (description-extend! 'name `(function ,value a b))
+      behavior)))
+(define-syntax-rule (define-primitive3 name value)
+  (define-initial name
+    (letrec ([arity+1 (+ 3 1)]
+             [behavior
+              (lambda (v* k)
+                (if (= (activation-rec-length v*) arity+1)
+                    (k (value (activation-rec-ref v* 0)
+                              (activation-rec-ref v* 1)
+                              (activation-rec-ref v* 2)))
+                    (error "Incorrect arity" 'name)))])
+      (description-extend! 'name `(function ,value a b c))
+      behavior)))
+
+
+;; Record types
+(define-record-type <activation-record>
+  (make-activation-record next vals)
+  activation-record?
+  (next activation-record-next activation-record-next-set!)
+  (vals activation-record-vals))
+
+;; Helpers
+(define (find-indexed pred lst)
+  (find (lambda (kons) (pred (car kons)))
+        (zip lst (iota (length lst)))))
+
+(define (local-variable env ref)
+  (let scan-env ([env env] [i 0])
+    (if (null? env)
+        #f
+        (let ([the-match (find-indexed (lambda (name) (eq? name ref)) (car env))])
+          (if the-match
+              `(local ,i . ,(cadr the-match))
+              (scan-env (cdr env) (+ i 1)))))))
+
+(define (global-variable env ref)
+  (assq-ref env ref))
+
+(define (compute-kind ref r)
+  (or (local-variable r ref)
+      (global-variable (g.current) ref)
+      (global-variable (g.init) ref)))
+
+(define (g.current-extend! ref)
+  (let ([level (length (g.current))])
+    (g.current (cons (cons ref (cons 'global level)) (g.current)))
+    level))
+
+(define (g.init-extend! ref)
+  (let ([level (length (g.init))])
+    (g.init (cons (cons ref (cons 'predefined level)) (g.init)))
+    level))
+
+(define (static-error . args)
+  (apply error "Static Error:" args))
+;; activation records
+(define (make-activation-rec size)
+  (make-activation-record #f (make-vector size)))
+
+(define activation-rec-set!
+  (case-lambda
+    [(r k v) (vector-set! (activation-record-vals r) k v)]
+    [(r j k v) (if (zero? j)
+                   (activation-rec-set! r k v)
+                   (activation-rec-set! (activation-record-next r) (1- j) k v))]))
+
+(define activation-rec-ref
+  (case-lambda
+    [(r i)
+     (vector-ref (activation-record-vals r) i)]
+    [(r i j)
+     (if (zero? i)
+         (activation-rec-ref r j)
+         (activation-rec-ref (activation-record-next r) (1- i) j))]))
+(define (activation-rec-length r)
+  (vector-length (activation-record-vals r)))
+;; function descriptions
+(define (description-extend! name description)
+  (desc.init (cons (cons name description) (desc.init))))
+
+(define (get-description name)
+  (let ([p (assq name (desc.init))])
+    (and (pair? p) (cdr p))))
+
+(define desc-args cddr)
+
+(define desc-address cadr)
+
+;; This maybe works maybe
+(define (thread m* sr k)
+  (if (null? m*)
+      k
+      (lambda _ ((car m*) sr (thread (cdr m*) sr k)))))
+;; for easy testing
+(define (list->activation-rec lst)
+  (let lp ([lst lst]
+           [next #f])
+    (if (null? lst)
+        next
+        (lp (cdr lst)
+            (make-activation-record next (list->vector (append (car lst) (list undefined-value))))))))
+
+;; environments
+(define (predefined-fetch i)
+  (vector-ref sg.init i))
+
+(define (global-fetch i)
+  (vector-ref sg.current i))
+
+(define (r-extend* r n*)
+  (cons n* r))
+
+(define (sr-extend* sr v*)
+  (activation-record-next-set! v* sr)
+  v*)
+
+;; Initial definitions
+(define-initial t #t)
+(define-initial f #f)
+(define-initial nil '())
+(define-primitive cons cons 2)
+(define-primitive car car 1)
+(define-primitive cdr cdr 1)
+(define-primitive + + 2)
+(define-primitive = = 2)
+(define-initial call/cc
+  (let* ([arity 1]
+         [arity+1 (1+ arity)])
+    (lambda (v* k)
+      (if (= arity+1 (activation-rec-length v*))
+          ((activation-rec-ref v* 0)
+           (let ([rec (make-activation-rec (+ 1 1))])
+             (activation-rec-set!
+              rec 0
+              (lambda (values kk)
+                (if (= arity+1 (activation-rec-length values))
+                    (k (activation-rec-ref values 0))
+                    (error "incorrect arity" 'continuation))))
+             rec)
+           k)
+          (error "incorrect arity" 'call/cc)))))
+
+
+;; Denotations
+(define (meaning e r)
+  "Core of the denotation
+Returns a function taking sr and k, the store of activation records and continuation
+that invokes the continuation when called"
+  (match e
+    [(? (negate pair?))
+     (if (symbol? e)      (meaning-reference e r)
+         (meaning-quotation e))]
+    [('quote e* ...)      (meaning-quotation e*)]
+    [('lambda v* e* ...)  (meaning-abstraction v* e* r)]
+    [('if e1 e2 e3)       (meaning-alternative e1 e2 e3 r)]
+    [('begin e* ...)      (meaning-sequence e* r)]
+    [('set! var val)      (meaning-assignment var val r)]
+    [(f v* ...)           (meaning-application f v* r)]))
+
+(define (meaning-r r)
+  (lambda (e)
+    (meaning e r)))
+
+(define (meaning* e* r)
+  "Go through e* defining meanings, thread the expressions and insert
+their results into the activation frame"
+  (let ([m* (map (meaning-r r) e*)]
+        [activation-rec-size (1+ (length e*))])
+    (lambda (sr k)
+      (let lp ([m* m*]
+               [rank 0]
+               [k k])
+        (if (null? m*)
+            (k (make-activation-rec activation-rec-size))
+            ((car m*) sr (lambda (v)
+                           (lp (cdr m*)
+                               (1+ rank)
+                               (lambda (v*)
+                                 (activation-rec-set! v* rank v)
+                                 (k v*))))))))))
+;;(meaning*-dotted e* r (length e*) (length n*))
+(define (meaning*-dotted e* r fixed-size)
+  "Same as `meaning' but put only put `fixed-size' arguments in the 
+activation frame, the rest are made into a list and put at the end"
+  (let ([m* (map (meaning-r r) e*)]
+        [activation-rec-size (1+ fixed-size)])
+    (lambda (sr k)
+      (let lp ([m* m*]
+               [rank 0]
+               [k k])
+        (cond
+         [(null? m*)
+          (let ([v* (make-activation-rec activation-rec-size)])
+            (activation-rec-set! v* fixed-size '())
+            (k v*))]
+         [(< rank fixed-size)
+          ((car m*) sr (lambda (v)
+                         (lp (cdr m*)
+                             (1+ rank)
+                             (lambda (v*)
+                               (activation-rec-set! v* rank v)
+                               (k v*)))))]
+         [else
+          ((car m*) sr (lambda (v)
+                         (lp (cdr m*)
+                             (1+ rank)
+                             (lambda (v*)
+                               (activation-rec-set! v* fixed-size
+                                                    (cons v (activation-rec-ref v* 0 fixed-size)))
+                               (k v*)))))])))))
+
+(define (meaning-quotation e*)
+  (lambda (sr k)
+    (k e*)))
+
+(define (meaning-alternative e1 e2 e3 r)
+  (let ([m1 (meaning e1 r)]
+        [m2 (meaning e2 r)]
+        [m3 (meaning e3 r)])
+    (lambda (sr k)
+      (m1 sr (lambda (v)
+               ((if v m2 m3) sr k))))))
+
+(define (meaning-sequence e* r)
+  (if (null? e*)
+      (static-error "Illegal syntax (begin)")
+      (let ([m* (map (lambda (e) (meaning e r)) e*)])
+        (lambda (sr k)
+          ((thread m* sr (lambda (v) (k v))))))))
+
+(define (meaning-reference ref r)
+  (match (compute-kind ref r)
+    [('local . (i . j))
+     (lambda (sr k)
+      (k (activation-rec-ref sr i j)))]
+    [('global . i)
+     (if (eq? (global-fetch i) undefined-value)
+         (lambda (sr k)
+           (let ([v (global-fetch i)])
+             (if (eq? v undefined-value)
+                 (error "Uninitialized variable" ref)
+                 (k v))))
+         (lambda (sr k)
+           (k (global-fetch i))))]
+    [('predefined . i)
+     (let ([value (predefined-fetch i)])
+       (lambda (sr k)
+         (k value)))]
+    [_ (static-error "No such variable" ref)]))
+
+(define (meaning-application f e* r)
+  (cond
+   [(and (symbol? f)
+         (get-description f)
+         (compute-kind f r)) =>
+    (lambda (kind)
+      (if (eq? (car kind) 'predefined)
+          (meaning-primitive-application f e* r)
+          (meaning-regular-application f e* r)))]
+   [(and (pair? f) (eq? (car f) 'lambda))
+    (meaning-closed-application f e* r)]
+   [else (meaning-regular-application f e* r)]))
+
+(define (meaning-regular-application f e* r)
+  (let [(mf (meaning f r))
+        (m* (meaning* e* r))]
+    (lambda (sr k)
+      (mf sr (lambda (f)
+               (if (procedure? f)
+                   (m* sr (lambda (v*)
+                            (f v* k)))
+                   (error "Not a function" f)))))))
+
+(define (meaning-primitive-application f e* r)
+  (let* ([desc (get-description f)]
+         [address (desc-address desc)]
+         [arity (length e*)])
+    (if (= (length (desc-args desc)) arity)
+        (case arity
+          [(0) (lambda (sr k)
+                 (k (address)))]
+          [(1)
+           (let ([m1 (meaning (first e*) r)])
+             (lambda (sr k)
+               (m1 sr (lambda (v1)
+                        (k (address v1))))))]
+          [(2) (let ([m1 (meaning (first e*) r)]
+                     [m2 (meaning (second e*) r)])
+                 (lambda (sr k)
+                   (m1 sr (lambda (v1)
+                            (m2 sr (lambda (v2)
+                                     (k (address v1 v2))))))))]
+          [(3) (let ([m1 (meaning (first e*) r)]
+                     [m2 (meaning (second e*) r)]
+                     [m3 (meaning (third e*) r)])
+                 (lambda (sr k)
+                   (m1 sr (lambda (v1)
+                            (m2 sr (lambda (v2)
+                                     (m3 sr (lambda (v3)
+                                              (k (address v1 v2 v3))))))))))])
+        (static-error "Wrong arity for" f arity))))
+
+(define (meaning-closed-application e ee* r)
+  (let lp ([n* (second e)]
+           [e* ee*]
+           [fixargs '()])
+    (cond
+     [(pair? n*)
+      (if (pair? e*)
+          (lp (cdr n*) (cdr e*) (cons (car n*) fixargs))
+          (static-error "Not enough arguments" e ee*))]
+     [(null? n*)
+      (if (pair? e*)
+          (static-error "Too many arguments" e ee*)
+          (meaning-fixed-closed-application (second e) (drop e 2) ee* r))]
+     [else
+      (meaning-dotted-closed-application (reverse fixargs) n* (drop e 2) ee* r)])))
+
+(define (meaning-fixed-closed-application n* body e* r)
+  (let* [(m* (meaning* e* r))
+         (r2 (r-extend* r n*))
+         (m+ (meaning-sequence body r2))]
+    (lambda (sr k)
+      (m* sr (lambda (v*)
+               (m+ (sr-extend* sr v*) k))))))
+
+(define (meaning-dotted-closed-application n* n body e* r)
+  (let* ([m* (meaning*-dotted e* r (length n*))]
+         [r2 (r-extend* r (append n* (list n)))]
+         [m+ (meaning-sequence body r2)])
+    (lambda (sr k)
+      (m* sr (lambda (v*)
+               (m+ (sr-extend* sr v*) k))))))
+
+(define (meaning-assignment n e r)
+  (let ([m (meaning e r)]
+        [kind (compute-kind n r)])
+    (if kind
+        (case (car kind)
+          [(local)
+           (let ([i (cadr kind)]
+                 [j (cddr kind)])
+             (lambda (sr k)
+               (m sr (lambda (v)
+                       (activation-rec-set! sr i j v)
+                       (k undefined-value)))))]
+          [else (static-error "Cannot set! undefined variable" n)]))))
+
+(define (meaning-abstraction nn* body r)
+  (let lp ([n* nn*]
+           [fixargs '()])
+    (cond
+     [(pair? n*) (lp (cdr n*) (cons (car n*) fixargs))]
+     [(null? n*) (meaning-fixed-abstraction nn* body r)]
+     [else (meaning-dotted-abstraction (reverse fixargs) n* body r)])))
+
+(define (meaning-fixed-abstraction n* body r)
+  (let* ([arity (length n*)]
+         [arity+1 (1+ arity)]
+         [r2 (r-extend* r n*)]
+         [m+ (meaning-sequence body r2)])
+    (lambda (sr k)
+      (k (lambda (v* k1)
+           (if (= arity+1 (activation-rec-length v*))
+               (m+ (sr-extend* sr v*) k1)
+               (error "Incorrect arity")))))))
+
+(define (meaning-dotted-abstraction n* n body r)
+  (let* ([arity (length n*)]
+         [arity+1 (1+ arity)]
+         [r2 (r-extend* r (append n* (list n)))]
+         [m+ (meaning-sequence body r2)])
+    (lambda (sr k)
+      (k (lambda (v* k1)
+           (if (<= arity+1 (activation-rec-length v*))
+               (begin (listify! v* arity)
+                      (m+ (sr-extend* sr v*) k1))
+               (error "Incorrect arity")))))))
+
+(define (listify! v* arity)
+  (let lp ([index (1- (activation-rec-length v*))]
+           [result '()])
+    (if (= arity index)
+        (activation-rec-set! v* arity result)
+        (lp (1- index) (cons (activation-rec-ref v* (1- index))
+                             result)))))
+
+;; Tests
+(test-begin "denotational-interpreter")
+;; quotation
+(test-group "meaning-quotation"
+  (test-eq 'apple
+    ((meaning-quotation 'apple) #f identity))
+  (test-eq '(apple pear)
+    ((meaning-quotation '(apple pear)) #f identity)))
+;; alternatives
+(test-group "meaning-alternative"
+ (test-eq 'apple
+   ((meaning-alternative 'p 't 'f '((p t f))) (list->activation-rec '((hello apple pear))) identity))
+ (test-eq 'pear
+   ((meaning-alternative 'p 't 'f '((p t f))) (list->activation-rec '((#f apple pear))) identity)))
+;; sequences
+(test-group "meaning-sequence"
+  (test-eq 'b
+    ((meaning-sequence '(a b) '((a b))) (list->activation-rec '((a b))) identity)))
+;; references
+(test-group "meaning-reference"
+  (with-fresh-globals
+   (g.current-extend! 'a)
+   (vector-set! sg.current 0 10)
+   (g.init-extend! 'b)
+   (vector-set! sg.init 0 20)
+   (test-eq 1
+     ((meaning-reference 'b '((a b))) (list->activation-rec '((0 1))) identity))
+   (test-eq 0
+     ((meaning-reference 'b '((a) (b c))) (list->activation-rec '((0 1) (1))) identity))
+   (test-equal 10
+     ((meaning-reference 'a '()) (list->activation-rec '()) identity))
+   (test-equal 20
+     ((meaning-reference 'b '()) (list->activation-rec '()) identity))))
+;; applications
+(test-group "meaning-application"
+  (with-fresh-globals
+   (desc.init `((+ function ,+ . (x y))))
+   (define (+-abstraction sr k)
+     (k (+ (activation-rec-ref sr 0 0)
+           (activation-rec-ref sr 0 1))))
+   (test-eq 2
+     ((meaning-regular-application '+ '(1 1) '((+))) (list->activation-rec `((,+-abstraction))) identity))
+   (test-eq 2
+     ((meaning-primitive-application '+ '(1 1) '(())) (list->activation-rec '()) identity))
+   (test-eq 2 ((meaning-closed-application '(lambda (x) x) '(2) '(())) (list->activation-rec '(())) identity))
+   (test-equal '(2 3) ((meaning-closed-application '(lambda (x . y) y) '(1 2 3) '(())) (list->activation-rec '()) identity))))
+;; assignment
+(test-group "meaning-assignment"
+  (let ([rec (list->activation-rec '((1)))])
+    ((meaning-assignment 'apples 2 '((apples))) rec identity)
+    (test-eq 2                                
+      (activation-rec-ref rec 0 0))))
+;; abstraction
+(test-group "meaning-abstraction"
+  (test-assert (procedure? ((meaning-abstraction '(x) '(x) '(())) #f identity)))
+  (test-eq 2
+    ((meaning-abstraction '(x y) '(y) '(())) #f (lambda (f) (f (make-activation-record #f (vector 1 2 undefined-value)) identity))))
+  (test-equal '(2)
+    ((meaning-abstraction '(x . y) '(y) '(())) #f (lambda (f) (f (list->activation-rec '((1 2))) identity)))))
+(test-group "call/cc"
+  (test-eq 3 ((meaning '(+ 2 (call/cc (lambda (cc) (cc 1) 2))) '(())) #f identity))
+  (test-eq 5 ((meaning '((lambda (cont v)
+                           (set! v (+ 2 (call/cc (lambda (cc) (set! cont cc) 1))))
+                           (if (= v 3)
+                               (cont v)
+                               v)) #f 0)
+                       '(()))
+              #f identity)))
+(test-end "denotational-interpreter")

denotational-lambda.scm

@@ -0,0 +1,38 @@
+(use-modules (ice-9 match)
+             (srfi srfi-64))
+
+(define (meaning expr)
+  (match expr
+    [`(lambda (,var) ,expr)
+     (lambda (env)
+       (lambda (e)
+         ((meaning expr) (rename env e var))))]
+    [(exp0 exp1)
+     (lambda (env)
+       (((meaning exp0) env) ((meaning exp1) env)))]
+    [var (lambda (env) (env var))]))
+
+(define (rename env var e)
+  (let ([v (env var)])
+    (lambda (var)
+      (if (eq? e var)
+          v
+          (env var)))))
+
+;; Okay this isn't really that useful
+(define (echo-env)
+  (lambda (x) x))
+(test-begin "echo-env")
+(test-eq 'x ((meaning 'x) (echo-env)))
+(test-eq 'y ((meaning '((lambda (x) x) y)) (echo-env)))
+(test-end "echo-env")
+
+(define (successor-env)
+  (lambda (x)
+    (cond
+     [(number? x) x]
+     [else (lambda (x) (+ x 1))])))
+(test-begin "successor-env")
+(test-eqv 1 ((meaning '(((lambda (f) (lambda (x) (f x))) succ) 0)) (successor-env)))
+(test-eqv 2 ((meaning '(((lambda (f) (lambda (x) (f (f x)))) succ) 0)) (successor-env)))
+(test-end "successor-env")