mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 04:15:36 +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
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue