dane/lisp-in-small-pieces
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

correct primitive behavior, call/cc and apply

Browse Source
This commit is contained in:
Dane Johnson
2025-11-21 17:44:06 -06:00
parent d61b5dcbb2
commit 2c98b750ca
1 changed files with 65 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files

87
direct-style-interpreter.scm
View File

@@ -43,12 +43,12 @@
(define-initial name
(letrec ([arity+1 (+ 0 1)]
[behavior
(lambda (v* k)
(lambda (v* sr)
(if (= (activation-rec-length v*) arity+1)
(k (value))
(value)
(error "Incorrect arity" 'name)))])
(description-extend! 'name `(function ,value))
behavior)))
(make-closure behavior (*env*)))))
(define-syntax-rule (define-primitive1 name value)
(define-initial name
(letrec ([arity+1 (+ 1 1)]
@@ -58,30 +58,30 @@
(k (value (activation-rec-ref v* 0)))
(error "Incorrect arity" 'name)))])
(description-extend! 'name `(function ,value a))
behavior)))
(make-closure behavior (*env*)))))
(define-syntax-rule (define-primitive2 name value)
(define-initial name
(letrec ([arity+1 (+ 2 1)]
[behavior
(lambda (v* k)
(lambda (v* sr)
(if (= (activation-rec-length v*) arity+1)
(k (value (activation-rec-ref v* 0)
(activation-rec-ref v* 1)))
(value (activation-rec-ref v* 0)
(activation-rec-ref v* 1))
(error "Incorrect arity" 'name)))])
(description-extend! 'name `(function ,value a b))
behavior)))
(make-closure behavior (*env*)))))
(define-syntax-rule (define-primitive3 name value)
(define-initial name
(letrec ([arity+1 (+ 3 1)]
[behavior
(lambda (v* k)
(lambda (v* sr)
(if (= (activation-rec-length v*) arity+1)
(k (value (activation-rec-ref v* 0)
(value (activation-rec-ref v* 0)
(activation-rec-ref v* 1)
(activation-rec-ref v* 2)))
(activation-rec-ref v* 2))
(error "Incorrect arity" 'name)))])
(description-extend! 'name `(function ,value a b c))
behavior)))
(make-closure behavior (*env*)))))
;; Record types
@@ -217,19 +217,45 @@
(define-initial call/cc
(let* ([arity 1]
[arity+1 (1+ arity)])
(lambda (v* k)
(make-closure
(lambda (v* sr)
(if (= arity+1 (activation-rec-length v*))
((activation-rec-ref v* 0)
(call/cc ;; call/cc is "magic" for our purposes here,
;; there are no reified continuations in the denotation
(lambda (k)
(invoke
(activation-rec-ref v* 0)
(let ([rec (make-activation-rec (+ 1 1))])
(activation-rec-set!
rec 0
(lambda (values kk)
(make-closure
(lambda (values r)
(if (= arity+1 (activation-rec-length values))
(k (activation-rec-ref values 0))
(error "incorrect arity" 'continuation))))
rec)
k)
(error "incorrect arity" 'call/cc)))))
(error "Incorrect arity" 'continuation)))
(*env*)))
rec))))
(error "Incorrect arity" 'call/cc)))
(*env*))))
(define-initial apply
(make-closure
(lambda (v* sr)
(if (>= (activation-rec-length v*) 3)
(let* ([proc (activation-rec-ref v* 0)]
[last-arg-index (- (activation-rec-length v*) 2)]
[last-arg (activation-rec-ref v* last-arg-index)]
[size (+ last-arg-index (length last-arg))]
[rec (make-activation-rec size)])
(do ([i 1 (+ i 1)])
((= i last-arg-index))
(activation-rec-set! rec (- i 1) (activation-rec-ref v* i)))
(do ([i (- last-arg-index 1) (+ i 1)]
[last-arg last-arg (cdr last-arg)])
((null? last-arg))
(activation-rec-set! rec i (car last-arg)))
(invoke proc rec))
(error "Wrong arity" 'apply)))
(*env*)))
;; Denotations
@@ -239,7 +265,7 @@
[(? (negate pair?))
(if (symbol? e) (meaning-reference e r)
(meaning-quotation e))]
[('quote 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?)]
[('begin e* ...) (meaning-sequence e* r tail?)]
@@ -248,6 +274,7 @@
(define (meaning-quotation e*)
(CONSTANT e*))
(define (CONSTANT value)
(lambda () value))
@@ -604,13 +631,15 @@
(call-with-1-2 ((meaning-abstraction '(x y) '(y) '(())))))
(test-equal '(2)
(call-with-1-2 ((meaning-abstraction '(x . y) '(y) '(())))))))
;; (test-group "call/cc"
;; (test-eq 3 ((meaning '(+ 2 (call/cc (lambda (cc) (cc 1) 2))) '(()) #t) 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)
;; '(()) #t)
;; identity)))
(test-group "call/cc"
(test-eq 3 ((meaning '(+ 2 (call/cc (lambda (cc) (cc 1) 2))) '(()) #t)))
(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)
'(()) #t))))
#;(test-group "apply"
(test-eq 3 ((meaning '(apply + 1 2 '()) '(()) #t)))
(test-eq 3 ((meaning '(apply + '(1 2)) '(()) #t))))
(test-end "direct-style-interpreter")