summaryrefslogtreecommitdiff
path: root/module/system/base/syntax.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-13 00:01:47 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-13 00:01:47 +0100
commitd9d671f76e0a77dfc643e487fa8d7db6be139366 (patch)
treee2528ed3331678c61aaa4ad1893eb539b2dace26 /module/system/base/syntax.scm
parentdf8cd091f9ffd31a7f77337d2e804d6801ca61ee (diff)
downloadguile-d9d671f76e0a77dfc643e487fa8d7db6be139366.tar.gz
no keyword arguments in GHIL / GLIL, just optional args -- faster compiles
* module/system/base/syntax.scm (define-record): So, in the generated constructors, allow optional arguments, but not keyword arguments. Conses much less in the constructors. (define-record/keywords): And the old define-record is here. * module/language/ghil.scm (parse-ghil): * module/language/ghil/compile-glil.scm (codegen): * module/language/scheme/compile-ghil.scm (translate-1, quote) (quasiquote): Don't use keywords in this compiler hotpath. * module/system/base/language.scm (<language>): * module/system/repl/common.scm (<repl>): * module/system/vm/debug.scm (<debugger>): Use define-record/keywords.
Diffstat (limited to 'module/system/base/syntax.scm')
-rw-r--r--module/system/base/syntax.scm36
1 files changed, 35 insertions, 1 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index e4d3efeff..67bcdb61b 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -21,7 +21,8 @@
(define-module (system base syntax)
#:export (%compute-initargs)
- #:export-syntax (define-type define-record record-case))
+ #:export-syntax (define-type define-record define-record/keywords
+ record-case))
;;;
@@ -56,6 +57,39 @@
`(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names
,@(if printer (list printer) '())))
+ ,(let* ((reqs (let lp ((slots slots))
+ (if (or (null? slots) (not (symbol? (car slots))))
+ '()
+ (cons (car slots) (lp (cdr slots))))))
+ (opts (list-tail slots (length reqs)))
+ (tail (gensym)))
+ `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
+ (let ,(map (lambda (o)
+ `(,(car o) (cond ((null? ,tail) ,(cadr o))
+ (else (let ((_x (car ,tail)))
+ (set! ,tail (cdr ,tail))
+ _x)))))
+ opts)
+ (make-struct ,name 0 ,@slot-names))))
+ (define ,(symbol-append stem '?) (record-predicate ,name))
+ ,@(map (lambda (sname)
+ `(define ,(symbol-append stem '- sname)
+ (make-procedure-with-setter
+ (record-accessor ,name ',sname)
+ (record-modifier ,name ',sname))))
+ slot-names))))
+
+;; like the former, but accepting keyword arguments in addition to
+;; optional arguments
+(define-macro (define-record/keywords name-form . slots)
+ (let* ((name (if (pair? name-form) (car name-form) name-form))
+ (printer (and (pair? name-form) (cadr name-form)))
+ (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+ slots))
+ (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
+ `(begin
+ (define ,name (make-record-type ,(symbol->string name) ',slot-names
+ ,@(if printer (list printer) '())))
(define ,(symbol-append 'make- stem)
(let ((slots (list ,@(map (lambda (slot)
(if (pair? slot)