summaryrefslogtreecommitdiff
path: root/module/system/base/syntax.scm
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/base/syntax.scm
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/base/syntax.scm')
-rw-r--r--module/system/base/syntax.scm79
1 files changed, 40 insertions, 39 deletions
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))