mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
unify variant types and records; also make-foo instead of <foo>
* module/system/base/syntax.scm (define-record): Rework to separate the type and its constructor. Now (define-record (<foo> bar)) will create `make-foo' as the constructor, not `<foo>'. Also the constructor now takes either keyword or positional arguments, so that it can be used as the implementation of variant types as well. (|): Map directly to define-record instead of rolling our own thing. * module/language/scheme/translate.scm: * module/system/base/language.scm: * module/system/il/compile.scm: * module/system/il/ghil.scm: * module/system/il/glil.scm: * module/system/repl/common.scm: * module/system/vm/assemble.scm: * module/system/vm/debug.scm: Change instances of record creation to use the make-foo procedures instead of <foo>. Adjust module exports as necessary.
This commit is contained in:
Andy Wingo
parent
1aa0dd2b45
commit
849cefacf1
9 changed files with 151 additions and 151 deletions
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(define ,(symbol-append 'make- stem)
|
||||
(let ((slots (list ,@(map (lambda (slot)
|
||||
(if (pair? slot)
|
||||
`(cons ',(car slot) ,(cadr slot))
|
||||
`',slot))
|
||||
slots)))))
|
||||
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)
|
||||
(define (finish-bindings out)
|
||||
(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))))
|
||||
(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))
|
||||
|
||||
(define (get-key klist key def)
|
||||
(do ((ls klist (cddr ls)))
|
||||
((or (null? ls) (eq? (car ls) key))
|
||||
(if (null? ls) def (cadr ls)))))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(let ((vars (make-glil-vars :nargs (length args)
|
||||
:nrest (if rest 1 0)
|
||||
:nlocs (length locs)
|
||||
:nexts (length exts))))
|
||||
(<glil-asm> vars (reverse! stack))))))))
|
||||
(make-glil-asm vars (reverse! stack))))))))
|
||||
|
||||
(define (finalize-index! list)
|
||||
(do ((n 0 (1+ n))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -35,11 +35,12 @@
|
|||
(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
|
||||
(%make-repl :env cenv
|
||||
:options repl-default-options
|
||||
:tm-stats (times)
|
||||
:gc-stats (gc-stats)
|
||||
|
|
|
|||
|
|
@ -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,7 +175,7 @@
|
|||
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
|
||||
(if toplevel
|
||||
(bytecode->objcode bytes vars.nlocs vars.nexts)
|
||||
(<bytespec> :vars vars :bytes bytes
|
||||
(make-bytespec :vars vars :bytes bytes
|
||||
:meta (if (and (null? binding-alist)
|
||||
(null? source-alist))
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue