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

some cleanup, fix sequences

Browse Source
This commit is contained in:
Dane Johnson
2026-01-05 11:44:13 -06:00
parent 4a98a45a8f
commit e379db4e0c
1 changed files with 20 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files

51
bytecode-compiler.scm
View File

@@ -1,7 +1,6 @@
(use-modules (ice-9 match) (use-modules (ice-9 match)
(ice-9 format) (ice-9 format)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-2)
(srfi srfi-9) (srfi srfi-9)
(oop goops) (oop goops)
((rnrs base) #:version (6) #:select (assert))) ((rnrs base) #:version (6) #:select (assert)))
@@ -17,12 +16,6 @@
(define atom? (negate pair?)) (define atom? (negate pair?))
(define finish-pc 0)
(define (conjoin . preds)
(lambda (x)
(any (lambda (pred) (pred x)) preds)))
;; Activation frames ;; Activation frames
(define-class <frame> () (define-class <frame> ()
(next #:init-value #f #:accessor frame-next) (next #:init-value #f #:accessor frame-next)
@@ -32,7 +25,8 @@
(format out "#<<frame> (next=~s) (args=~s)>" (frame-next f) (frame-values f))) (format out "#<<frame> (next=~s) (args=~s)>" (frame-next f) (frame-values f)))
(define (frame? x) (define (frame? x)
(is-a? x <frame>)) (or (eq? #f x)
(is-a? x <frame>)))
(define (allocate-frame size+1) (define (allocate-frame size+1)
(make <frame> #:values (make-vector size+1))) (make <frame> #:values (make-vector size+1)))
@@ -84,29 +78,24 @@
;; Virtual machine registers and functions ;; Virtual machine registers and functions
(define-syntax define-registers (define-syntax define-registers
(syntax-rules (null false) (syntax-rules ()
[(_ name null more ...) [(_ name default more ...)
(begin (define name (make-parameter '())) (begin (define name (make-parameter default))
(define-registers more ...))]
[(_ name false more ...)
(begin (define name (make-parameter #f))
(define-registers more ...))] (define-registers more ...))]
[(_) '()])) [(_) '()]))
(define-registers (define-registers
*globals* null *globals* '()
*primitives* null *primitives* '()
*stack* null *stack* '()
*constants* null *constants* '()
*code* null *code* '()
*env* false *env* #f
*val* false *val* #f
*pc* false *pc* #f
*finish-pc* false *finish-pc* #f
*fun* false *fun* #f
*arg1* false *exit* #f)
*arg2* false
*exit* false)
(define (stack-push v) (define (stack-push v)
(*stack* (cons v (*stack*)))) (*stack* (cons v (*stack*))))
@@ -150,7 +139,7 @@
(pair? pair? 1) (pair? pair? 1)
(symbol? symbol? 1) (symbol? symbol? 1)
(eq? eq? 2) (eq? eq? 2)
;; These are not direct instructions, but we act like they are? I'm a little confused ;; These are not direct instructions, they can be invoked by an argument
(+ + 2) (+ + 2)
(- - 2) (- - 2)
(* * 2) (* * 2)
@@ -176,7 +165,7 @@
(if (null? (cdr e*)) (if (null? (cdr e*))
(meaning (car e*) r tail?) (meaning (car e*) r tail?)
(+sequence+ (meaning (car e*) r #f) (+sequence+ (meaning (car e*) r #f)
(meaning-sequence (car e*) r tail?)))) (meaning-sequence (cdr e*) r tail?))))
(define (meaning-alternative e1 e2 e3 r tail?) (define (meaning-alternative e1 e2 e3 r tail?)
(+alternative+ (meaning e1 r #f) (+alternative+ (meaning e1 r #f)
@@ -505,12 +494,12 @@
(stack-push (*val*))) (stack-push (*val*)))
(define-inst (preserve-env 37) (define-inst (preserve-env 37)
(assert ((conjoin frame? boolean?) (*env*))) (assert (frame? (*env*)))
(stack-push (*env*))) (stack-push (*env*)))
(define-inst (restore-env 38) (define-inst (restore-env 38)
(*env* (stack-pop)) (*env* (stack-pop))
(assert ((conjoin frame? boolean?) (*env*)))) (assert (frame? (*env*))))
(define-inst (pop-function 39) (define-inst (pop-function 39)
(*fun* (stack-pop))) (*fun* (stack-pop)))