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

101
direct-style-interpreter.scm
View File

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