summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-05-03 18:32:46 +0200
committerAndy Wingo <wingo@pobox.com>2008-05-03 18:32:46 +0200
commit849cefacf15c265a091aa7d582d14b84f82ddcda (patch)
tree1a2b4dd95e4ac851cad8906db3dc72755dacd6e8 /module/system
parent1aa0dd2b4529d19b78f344c921fb71e38fbbee19 (diff)
downloadguile-849cefacf15c265a091aa7d582d14b84f82ddcda.tar.gz
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.
Diffstat (limited to 'module/system')
-rw-r--r--module/system/base/language.scm2
-rw-r--r--module/system/base/syntax.scm79
-rw-r--r--module/system/il/compile.scm64
-rw-r--r--module/system/il/ghil.scm47
-rw-r--r--module/system/il/glil.scm28
-rw-r--r--module/system/repl/common.scm11
-rw-r--r--module/system/vm/assemble.scm24
-rw-r--r--module/system/vm/debug.scm3
8 files changed, 129 insertions, 129 deletions
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 ()