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

fix bug with sequence

Browse Source
This commit is contained in:
Dane Johnson
2025-11-22 20:11:35 -06:00
parent 2c98b750ca
commit 0d721bde8b
1 changed files with 14 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

35
direct-style-interpreter.scm
View File

@@ -8,7 +8,7 @@
;; the procedures that create them as combinators ;; the procedures that create them as combinators
;; (note: is this true? don't they still use free variables in their definitions?) ;; (note: is this true? don't they still use free variables in their definitions?)
;; ((yes, because they are of dynamic scope, therefore not captured)) ;; ((yes, because they are of dynamic scope, therefore not captured))
;; Globals ;; Globals
(define undefined-value (make-symbol "undefined")) (define undefined-value (make-symbol "undefined"))
(define g.init (make-parameter '())) (define g.init (make-parameter '()))
@@ -18,7 +18,6 @@
(define sg.init (make-vector 100)) (define sg.init (make-vector 100))
(define sg.current (make-vector 100)) (define sg.current (make-vector 100))
;; Macros ;; Macros
(define-syntax with-fresh-globals (define-syntax with-fresh-globals
@@ -82,7 +81,6 @@
(error "Incorrect arity" 'name)))]) (error "Incorrect arity" 'name)))])
(description-extend! 'name `(function ,value a b c)) (description-extend! 'name `(function ,value a b c))
(make-closure behavior (*env*))))) (make-closure behavior (*env*)))))
;; Record types ;; Record types
(define-record-type <activation-record> (define-record-type <activation-record>
@@ -256,7 +254,6 @@
(invoke proc rec)) (invoke proc rec))
(error "Wrong arity" 'apply))) (error "Wrong arity" 'apply)))
(*env*))) (*env*)))
;; Denotations ;; Denotations
(define (meaning e r tail?) (define (meaning e r tail?)
@@ -275,8 +272,8 @@
(define (meaning-quotation e*) (define (meaning-quotation e*)
(CONSTANT e*)) (CONSTANT e*))
(define (CONSTANT value) (define (CONSTANT v)
(lambda () value)) (lambda () v))
(define (meaning-alternative e1 e2 e3 r tail?) (define (meaning-alternative e1 e2 e3 r tail?)
(let ([m1 (meaning e1 r #f)] (let ([m1 (meaning e1 r #f)]
@@ -288,19 +285,16 @@
(lambda () (lambda ()
(if (m1) (m2) (m3)))) (if (m1) (m2) (m3))))
(define (meaning-sequence e* r tail?) (define (meaning-sequence e+ r tail?)
(if (null? e*) (cond
(static-error "Illegal syntax (begin)") [(null? e+) (static-error "Illegal syntax (begin)")]
(SEQUENCE (meaning-list e* r tail?)))) [(null? (cdr e+)) (meaning (car e+) r tail?)]
[else (SEQUENCE (meaning (car e+) r #f)
(meaning-sequence (cdr e+) r tail?))]))
(define (SEQUENCE m+) (define (SEQUENCE m m+)
(lambda () (lambda ()
(let lp ([m* m+]) (m) (m+)))
(if (null? (cdr m*))
((car m*))
(begin
((car m*))
(lp (cdr m*)))))))
(define (meaning-reference n r) (define (meaning-reference n r)
(match (compute-kind n r) (match (compute-kind n r)
@@ -554,7 +548,6 @@
(m+)) (m+))
(error "Incorrect arity"))) (error "Incorrect arity")))
(make-closure the-function (*env*)))) (make-closure the-function (*env*))))
;; Tests ;; Tests
(test-begin "direct-style-interpreter") (test-begin "direct-style-interpreter")
@@ -576,8 +569,8 @@
;; sequences ;; sequences
(test-group "meaning-sequence" (test-group "meaning-sequence"
(with-fresh-globals (with-fresh-globals
(env-set! '((a b))) (env-set! '((1 2)))
(test-eq 'b (test-eq 2
((meaning-sequence '(a b) '((a b)) #t))))) ((meaning-sequence '(a b) '((a b)) #t)))))
;; references ;; references
(test-group "meaning-reference" (test-group "meaning-reference"
@@ -639,7 +632,7 @@
(cont v) (cont v)
v)) #f 0) v)) #f 0)
'(()) #t)))) '(()) #t))))
#;(test-group "apply" (test-group "apply"
(test-eq 3 ((meaning '(apply + 1 2 '()) '(()) #t))) (test-eq 3 ((meaning '(apply + 1 2 '()) '(()) #t)))
(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")