diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/language/scheme/translate.scm | 44 | ||||
-rw-r--r-- | module/system/base/language.scm | 2 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 79 | ||||
-rw-r--r-- | module/system/il/compile.scm | 64 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 47 | ||||
-rw-r--r-- | module/system/il/glil.scm | 28 | ||||
-rw-r--r-- | module/system/repl/common.scm | 11 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 24 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 3 |
9 files changed, 151 insertions, 151 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 843a8472a..9757c08f0 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -52,7 +52,7 @@ (call-with-ghil-environment (make-ghil-mod e) '() (lambda (env vars) - (<ghil-lambda> env #f vars #f (trans env #f x)))))) + (make-ghil-lambda env #f vars #f (trans env #f x)))))) ;;; @@ -139,9 +139,9 @@ ((symbol? x) (let ((y (symbol-expand x))) (if (symbol? y) - (<ghil-ref> e l (ghil-lookup e y)) + (make-ghil-ref e l (ghil-lookup e y)) (trans e l y)))) - (else (<ghil-quote> e l x)))) + (else (make-ghil-quote e l x)))) (define (symbol-expand x) (let loop ((s (symbol->string x))) @@ -155,7 +155,7 @@ (define (trans:x x) (trans e l x)) (define (trans:pair x) (trans-pair e l (car x) (cdr x))) (define (trans:body body) (trans-body e l body)) - (define (make:void) (<ghil-void> e l)) + (define (make:void) (make-ghil-void e l)) (define (bad-syntax) (syntax-error l (format #f "bad ~A" head) (cons head tail))) (case head @@ -168,26 +168,26 @@ ;; (quote OBJ) ((quote) (match tail - ((obj) (<ghil-quote> e l obj)) + ((obj) (make-ghil-quote e l obj)) (else (bad-syntax)))) ;; (quasiquote OBJ) ((quasiquote) (match tail - ((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj))) + ((obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj))) (else (bad-syntax)))) ((define define-private) (match tail ;; (define NAME VAL) (((? symbol? name) val) - (<ghil-define> e l (ghil-lookup e name) (trans:x val))) + (make-ghil-define e l (ghil-lookup e name) (trans:x val))) ;; (define (NAME FORMALS...) BODY...) ((((? symbol? name) . formals) . body) ;; -> (define NAME (lambda FORMALS BODY...)) (let ((val (trans:x `(lambda ,formals ,@body)))) - (<ghil-define> e l (ghil-lookup e name) val))) + (make-ghil-define e l (ghil-lookup e name) val))) (else (bad-syntax)))) @@ -203,7 +203,7 @@ (match tail ;; (set! NAME VAL) (((? symbol? name) val) - (<ghil-set> e l (ghil-lookup e name) (trans:x val))) + (make-ghil-set e l (ghil-lookup e name) (trans:x val))) ;; (set! (NAME ARGS...) VAL) ((((? symbol? name) . args) val) @@ -216,22 +216,22 @@ ((if) (match tail ((test then) - (<ghil-if> e l (trans:x test) (trans:x then) (make:void))) + (make-ghil-if e l (trans:x test) (trans:x then) (make:void))) ((test then else) - (<ghil-if> e l (trans:x test) (trans:x then) (trans:x else))) + (make-ghil-if e l (trans:x test) (trans:x then) (trans:x else))) (else (bad-syntax)))) ;; (and EXPS...) ((and) - (<ghil-and> e l (map trans:x tail))) + (make-ghil-and e l (map trans:x tail))) ;; (or EXPS...) ((or) - (<ghil-or> e l (map trans:x tail))) + (make-ghil-or e l (map trans:x tail))) ;; (begin EXPS...) ((begin) - (<ghil-begin> e l (map trans:x tail))) + (make-ghil-begin e l (map trans:x tail))) ((let) (match tail @@ -243,14 +243,14 @@ ;; (let () BODY...) ((() body ...) ;; NOTE: This differs from `begin' - (<ghil-begin> e l (list (trans:body body)))) + (make-ghil-begin e l (list (trans:body body)))) ;; (let ((SYM VAL) ...) BODY...) (((((? symbol? sym) val) ...) body ...) (let ((vals (map trans:x val))) (call-with-ghil-bindings e sym (lambda (vars) - (<ghil-bind> e l vars vals (trans:body body)))))) + (make-ghil-bind e l vars vals (trans:body body)))))) (else (bad-syntax)))) @@ -270,7 +270,7 @@ (call-with-ghil-bindings e sym (lambda (vars) (let ((vals (map trans:x val))) - (<ghil-bind> e l vars vals (trans:body body)))))) + (make-ghil-bind e l vars vals (trans:body body)))))) (else (bad-syntax)))) ;; (cond (CLAUSE BODY...) ...) @@ -321,7 +321,7 @@ (receive (syms rest) (parse-formals formals) (call-with-ghil-environment e syms (lambda (env vars) - (<ghil-lambda> env l vars rest (trans-body env l body)))))) + (make-ghil-lambda env l vars rest (trans-body env l body)))))) (else (bad-syntax)))) ((eval-case) @@ -339,11 +339,11 @@ (else (if (memq head %scheme-primitives) - (<ghil-inline> e l head (map trans:x tail)) + (make-ghil-inline e l head (map trans:x tail)) (if (memq head %forbidden-primitives) (syntax-error l (format #f "`~a' is forbidden" head) (cons head tail)) - (<ghil-call> e l (trans:x head) (map trans:x tail))))))) + (make-ghil-call e l (trans:x head) (map trans:x tail))))))) (define (trans-quasiquote e l x) (cond ((not (pair? x)) x) @@ -352,8 +352,8 @@ (match (cdr x) ((obj) (if (eq? (car x) 'unquote) - (<ghil-unquote> e l (trans e l obj)) - (<ghil-unquote-splicing> e l (trans e l obj)))) + (make-ghil-unquote e l (trans e l obj)) + (make-ghil-unquote-splicing e l (trans e l obj)))) (else (syntax-error l (format #f "bad ~A" (car x)) x))))) (else (cons (trans-quasiquote e l (car x)) (trans-quasiquote e l (cdr x)))))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 44dda1f64..57396e340 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -36,7 +36,7 @@ )) (define-macro (define-language name . spec) - `(define ,name (,<language> :name ',name ,@spec))) + `(define ,name (,make-language :name ',name ,@spec))) (define (lookup-language name) (let ((m (resolve-module `(language ,name spec)))) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 3a61ea6f6..8599d99fc 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -73,17 +73,22 @@ ;;; Record ;;; +(define (symbol-trim-both sym pred) + (string->symbol (string-trim-both (symbol->string sym) pred))) + + (define-macro (define-record def) - (let ((name (car def)) (slots (cdr def))) + (let* ((name (car def)) (slots (cdr def)) + (stem (symbol-trim-both name (list->char-set '(#\< #\>))))) `(begin - (define (,name . args) - (vector ',name (%make-struct - args - (list ,@(map (lambda (slot) - (if (pair? slot) - `(cons ',(car slot) ,(cadr slot)) - `',slot)) - slots))))) + (define ,(symbol-append 'make- stem) + (let ((slots (list ,@(map (lambda (slot) + (if (pair? slot) + `(cons ',(car slot) ,(cadr slot)) + `',slot)) + slots)))) + (lambda args + (vector ',name (%make-struct args slots))))) (define (,(symbol-append name '?) x) (and (vector? x) (eq? (vector-ref x 0) ',name))) ,@(do ((n 1 (1+ n)) @@ -96,22 +101,32 @@ ls))) ((null? slots) (reverse! ls)))))) -(define *unbound* "#<unbound>") - (define (%make-struct args slots) - (map (lambda (slot) - (let* ((key (if (pair? slot) (car slot) slot)) - (def (if (pair? slot) (cdr slot) *unbound*)) - (val (get-key args (symbol->keyword key) def))) - (if (eq? val *unbound*) - (error "slot unbound" key) - (cons key val)))) - slots)) - -(define (get-key klist key def) - (do ((ls klist (cddr ls))) - ((or (null? ls) (eq? (car ls) key)) - (if (null? ls) def (cadr ls))))) + (define (finish-bindings out) + (map (lambda (slot) + (let ((name (if (pair? slot) (car slot) slot))) + (or (assq name out) + (if (pair? slot) + (cons name (cdr slot)) + (error "unbound slot" args slots name))))) + slots)) + (let lp ((in args) (positional slots) (out '())) + (cond + ((null? in) + (finish-bindings out)) + ((keyword? (car in)) + (let ((sym (keyword->symbol (car in)))) + (cond + ((and (not (memq sym slots)) + (not (assq sym (filter pair? slots)))) + (error "unknown slot" sym)) + ((assq sym out) (error "slot already set" sym out)) + (else (lp (cddr in) '() (acons sym (cadr in) out)))))) + ((null? positional) + (error "too many initargs" args slots)) + (else + (lp (cdr in) (cdr positional) + (acons (car positional) (car in) out)))))) (define (get-slot struct name . names) (let ((data (assq name (vector-ref struct 1)))) @@ -134,21 +149,7 @@ ;;; (define-macro (| . rest) - `(begin ,@(map %make-variant-type rest))) - -(define (%make-variant-type def) - (let ((name (car def)) (slots (cdr def))) - `(begin - (define ,def (vector ',name ,@slots)) - (define (,(symbol-append name '?) x) - (and (vector? x) (eq? (vector-ref x 0) ',name))) - ,@(do ((n 1 (1+ n)) - (slots slots (cdr slots)) - (ls '() (cons `(define ,(string->symbol - (format #f "~A-~A" name n)) - ,(string->symbol (format #f "%slot-~A" n))) - ls))) - ((null? slots) (reverse! ls)))))) + `(begin ,@(map (lambda (def) `(define-record ,def)) rest))) (define (%slot-1 x) (vector-ref x 1)) (define (%slot-2 x) (vector-ref x 2)) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index eab25d600..549dd2e80 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -39,23 +39,23 @@ (define (optimize x) (match x (($ <ghil-set> env var val) - (<ghil-set> env var (optimize val))) + (make-ghil-set env var (optimize val))) (($ <ghil-if> test then else) - (<ghil-if> (optimize test) (optimize then) (optimize else))) + (make-ghil-if (optimize test) (optimize then) (optimize else))) (($ <ghil-begin> exps) - (<ghil-begin> (map optimize exps))) + (make-ghil-begin (map optimize exps))) (($ <ghil-bind> env vars vals body) - (<ghil-bind> env vars (map optimize vals) (optimize body))) + (make-ghil-bind env vars (map optimize vals) (optimize body))) (($ <ghil-lambda> env vars rest body) - (<ghil-lambda> env vars rest (optimize body))) + (make-ghil-lambda env vars rest (optimize body))) ;; FIXME: <ghil-inst> does not exist. -- Ludo'. ; (($ <ghil-inst> inst args) -; (<ghil-inst> inst (map optimize args))) +; (make-ghil-inst inst (map optimize args))) (($ <ghil-call> env proc args) (match proc @@ -67,9 +67,9 @@ (set! v.env env) (ghil-env-add! env v)) lambda-env.variables) - (optimize (<ghil-bind> env vars args body))) + (optimize (make-ghil-bind env vars args body))) (else - (<ghil-call> env (optimize proc) (map optimize args))))) + (make-ghil-call env (optimize proc) (map optimize args))))) (else x))) @@ -77,25 +77,25 @@ ;;; Stage 3: Code generation ;;; -(define *ia-void* (<glil-void>)) -(define *ia-drop* (<glil-call> 'drop 0)) -(define *ia-return* (<glil-call> 'return 0)) +(define *ia-void* (make-glil-void)) +(define *ia-drop* (make-glil-call 'drop 0)) +(define *ia-return* (make-glil-call 'return 0)) (define (make-label) (gensym ":L")) (define (make-glil-var op env var) (case var.kind ((argument) - (<glil-argument> op var.index)) + (make-glil-argument op var.index)) ((local) - (<glil-local> op var.index)) + (make-glil-local op var.index)) ((external) (do ((depth 0 (1+ depth)) (e env e.parent)) ((eq? e var.env) - (<glil-external> op depth var.index)))) + (make-glil-external op depth var.index)))) ((module) - (<glil-module> op var.env var.name)) + (make-glil-module op var.env var.name)) (else (error "Unknown kind of variable:" var)))) (define (codegen ghil) @@ -104,13 +104,13 @@ (set! stack (cons code stack))) (define (comp tree tail drop) (define (push-label! label) - (push-code! (<glil-label> label))) + (push-code! (make-glil-label label))) (define (push-branch! inst label) - (push-code! (<glil-branch> inst label))) + (push-code! (make-glil-branch inst label))) (define (push-call! loc inst args) (for-each comp-push args) - (push-code! (<glil-call> inst (length args))) - (push-code! (<glil-source> loc))) + (push-code! (make-glil-call inst (length args))) + (push-code! (make-glil-source loc))) ;; possible tail position (define (comp-tail tree) (comp tree tail drop)) ;; push the result @@ -132,7 +132,7 @@ (return-code! *ia-void*)) ;; return object if necessary (define (return-object! obj) - (return-code! (<glil-const> obj))) + (return-code! (make-glil-const obj))) ;; ;; dispatch (match tree @@ -152,14 +152,14 @@ ((? pair? pp) (loop (car pp)) (loop (cdr pp)) - (push-code! (<glil-call> 'cons 2))) + (push-code! (make-glil-call 'cons 2))) (($ <ghil-unquote> env loc exp) (comp-push exp)) (($ <ghil-unquote-splicing> env loc exp) (comp-push exp) (push-call! #f 'list-break '())) (else - (push-code! (<glil-const> x))))) + (push-code! (make-glil-const x))))) (maybe-drop) (maybe-return)) @@ -253,11 +253,11 @@ ;; BODY (for-each comp-push vals) (let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars))) - (if (not (null? vars)) (push-code! (<glil-bind> vars)))) + (if (not (null? vars)) (push-code! (make-glil-bind vars)))) (for-each (lambda (var) (push-code! (make-glil-var 'set env var))) (reverse vars)) (comp-tail body) - (push-code! (<glil-unbind>))) + (push-code! (make-glil-unbind))) (($ <ghil-lambda> env loc vars rest body) (return-code! (codegen tree))) @@ -289,23 +289,23 @@ (finalize-index! exts) ;; meta bindings (let ((vars (map (lambda (v) (list v.name v.kind v.index)) args))) - (if (not (null? vars)) (push-code! (<glil-bind> vars)))) + (if (not (null? vars)) (push-code! (make-glil-bind vars)))) ;; export arguments (do ((n 0 (1+ n)) (l args (cdr l))) ((null? l)) (let ((v (car l))) (cond ((eq? v.kind 'external) - (push-code! (<glil-argument> 'ref n)) - (push-code! (<glil-external> 'set 0 v.index)))))) + (push-code! (make-glil-argument 'ref n)) + (push-code! (make-glil-external 'set 0 v.index)))))) ;; compile body (comp body #t #f) ;; create GLIL - (let ((vars (<glil-vars> :nargs (length args) - :nrest (if rest 1 0) - :nlocs (length locs) - :nexts (length exts)))) - (<glil-asm> vars (reverse! stack)))))))) + (let ((vars (make-glil-vars :nargs (length args) + :nrest (if rest 1 0) + :nlocs (length locs) + :nexts (length exts)))) + (make-glil-asm vars (reverse! stack)))))))) (define (finalize-index! list) (do ((n 0 (1+ n)) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index ea3d66e4e..84814bd13 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -25,33 +25,33 @@ :use-module (ice-9 regex) :export ( - <ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2 - <ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3 - <ghil-quasiquote> <ghil-quasiquote>? + <ghil-void> make-ghil-void <ghil-void>? <ghil-void>-1 <ghil-void>-2 + <ghil-quote> make-ghil-quote <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3 + <ghil-quasiquote> make-ghil-quasiquote <ghil-quasiquote>? <ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3 - <ghil-unquote> <ghil-unquote>? + <ghil-unquote> make-ghil-unquote <ghil-unquote>? <ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3 - <ghil-unquote-splicing> <ghil-unquote-splicing>? + <ghil-unquote-splicing> make-ghil-unquote-splicing <ghil-unquote-splicing>? <ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2 <ghil-unquote-splicing>-3 - <ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3 - <ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4 - <ghil-define> <ghil-define>? + <ghil-ref> make-ghil-ref <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3 + <ghil-set> make-ghil-set <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4 + <ghil-define> make-ghil-define <ghil-define>? <ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4 - <ghil-if> <ghil-if>? + <ghil-if> make-ghil-if <ghil-if>? <ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5 - <ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3 - <ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3 - <ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3 - <ghil-bind> <ghil-bind>? + <ghil-and> make-ghil-and <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3 + <ghil-or> make-ghil-or <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3 + <ghil-begin> make-ghil-begin <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3 + <ghil-bind> make-ghil-bind <ghil-bind>? <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5 - <ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2 + <ghil-lambda> make-ghil-lambda <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5 - <ghil-inline> <ghil-inline>? + <ghil-inline> make-ghil-inline <ghil-inline>? <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4 - <ghil-call> <ghil-call>? + <ghil-call> make-ghil-call <ghil-call>? <ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4 )) @@ -112,9 +112,7 @@ ;;; (define-record (<ghil-var> env name kind (type #f) (value #f) (index #f))) - -(define-public (make-ghil-var env name kind) - (<ghil-var> :env env :name name :kind kind)) +(export make-ghil-var) ;;; @@ -122,9 +120,7 @@ ;;; (define-record (<ghil-mod> module (table '()) (imports '()))) - -(define-public (make-ghil-mod module) - (<ghil-mod> :module module)) +(export make-ghil-mod) ;;; @@ -133,10 +129,11 @@ (define-record (<ghil-env> mod parent (table '()) (variables '()))) +(define %make-ghil-env make-ghil-env) (define-public (make-ghil-env e) - (match e - (($ <ghil-mod>) (<ghil-env> :mod e :parent e)) - (($ <ghil-env> m) (<ghil-env> :mod m :parent e)))) + (record-case e + ((<ghil-mod>) (%make-ghil-env :mod e :parent e)) + ((<ghil-env> m) (%make-ghil-env :mod m :parent e)))) (define (ghil-env-toplevel? e) (eq? e.mod e.parent)) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index f4a5c560d..8b10c4b4b 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -24,26 +24,26 @@ :use-module (ice-9 match) :export (pprint-glil - <glil-vars> - <glil-asm> <glil-asm>? + <glil-vars> make-glil-vars + <glil-asm> make-glil-asm <glil-asm>? <glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5 - <glil-bind> <glil-bind>? <glil-bind>-1 - <glil-unbind> <glil-unbind>? - <glil-source> <glil-source>? <glil-source>-1 <glil-source>-2 + <glil-bind> make-glil-bind <glil-bind>? <glil-bind>-1 + <glil-unbind> make-glil-unbind <glil-unbind>? + <glil-source> make-glil-source <glil-source>? <glil-source>-1 <glil-source>-2 - <glil-void> <glil-void>? - <glil-const> <glil-const>? <glil-const>-1 + <glil-void> make-glil-void <glil-void>? + <glil-const> make-glil-const <glil-const>? <glil-const>-1 - <glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2 - <glil-local> <glil-local>? <glil-local>-1 <glil-local>-2 - <glil-external> <glil-external>? + <glil-argument> make-glil-argument <glil-argument>? <glil-argument>-1 <glil-argument>-2 + <glil-local> make-glil-local <glil-local>? <glil-local>-1 <glil-local>-2 + <glil-external> make-glil-external <glil-external>? <glil-external>-1 <glil-external>-2 <glil-external>-3 - <glil-module> <glil-module>? + <glil-module> make-glil-module <glil-module>? <glil-module>-1 <glil-module>-2 <glil-module>-3 - <glil-label> <glil-label>? <glil-label>-1 - <glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2 - <glil-call> <glil-call>? <glil-call>-1 <glil-call>-2 + <glil-label> make-glil-label <glil-label>? <glil-label>-1 + <glil-branch> make-glil-branch <glil-branch>? <glil-branch>-1 <glil-branch>-2 + <glil-call> make-glil-call <glil-call>? <glil-call>-1 <glil-call>-2 )) (define-record (<glil-vars> nargs nrest nlocs nexts)) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index ba3fe5aa5..eb2ad601c 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -35,15 +35,16 @@ (define repl-default-options '((trace . #f))) +(define %make-repl make-repl) (define-public (make-repl lang) (let ((cenv (make-cenv :vm (the-vm) :language (lookup-language lang) :module (current-module)))) - (<repl> :env cenv - :options repl-default-options - :tm-stats (times) - :gc-stats (gc-stats) - :vm-stats (vm-stats cenv.vm)))) + (%make-repl :env cenv + :options repl-default-options + :tm-stats (times) + :gc-stats (gc-stats) + :vm-stats (vm-stats cenv.vm)))) (define-public (repl-welcome repl) (format #t "~A interpreter ~A on Guile ~A\n" diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 47e7b8a69..a885e571e 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -55,9 +55,9 @@ (define (preprocess x e) (record-case x ((<glil-asm> vars body) - (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f)) + (let* ((venv (make-venv :parent e :nexts (slot vars 'nexts) :closure? #f)) (body (map (lambda (x) (preprocess x venv)) body))) - (<vm-asm> :venv venv :glil x :body body))) + (make-vm-asm :venv venv :glil x :body body))) ((<glil-external> op depth index) (do ((d depth (- d 1)) (e e (slot e 'parent))) @@ -147,7 +147,7 @@ (push-code! `(external-set ,(+ n index))))))) ((<glil-module> op module name) - (push-object! (<vlink> :module #f :name name)) + (push-object! (make-vlink :module #f :name name)) (if (eq? op 'ref) (push-code! '(variable-ref)) (push-code! '(variable-set)))) @@ -175,15 +175,15 @@ (let ((bytes (stack->bytes (reverse! stack) label-alist))) (if toplevel (bytecode->objcode bytes vars.nlocs vars.nexts) - (<bytespec> :vars vars :bytes bytes - :meta (if (and (null? binding-alist) - (null? source-alist)) - #f - (cons (reverse! binding-alist) - (reverse! source-alist))) - :objs (let ((objs (map car (reverse! object-alist)))) - (if (null? objs) #f (list->vector objs))) - :closure? venv.closure?))))))))) + (make-bytespec :vars vars :bytes bytes + :meta (if (and (null? binding-alist) + (null? source-alist)) + #f + (cons (reverse! binding-alist) + (reverse! source-alist))) + :objs (let ((objs (map car (reverse! object-alist)))) + (if (null? objs) #f (list->vector objs))) + :closure? venv.closure?))))))))) (define (object-assoc x alist) (record-case x diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index c78f28aa4..686d89714 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -38,7 +38,8 @@ (let ((chain (vm-last-frame-chain vm))) (if (null? chain) (display "Nothing to debug\n") - (debugger-repl (<debugger> :vm vm :chain chain :index (length chain)))))) + (debugger-repl (make-debugger + :vm vm :chain chain :index (length chain)))))) (define (debugger-repl db) (let loop () |