519 lines
18 KiB
Scheme
519 lines
18 KiB
Scheme
(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")
|