diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-13 00:01:47 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-13 00:01:47 +0100 |
commit | d9d671f76e0a77dfc643e487fa8d7db6be139366 (patch) | |
tree | e2528ed3331678c61aaa4ad1893eb539b2dace26 /module/system/base/syntax.scm | |
parent | df8cd091f9ffd31a7f77337d2e804d6801ca61ee (diff) | |
download | guile-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.scm | 36 |
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) |