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 | |
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')
-rw-r--r-- | module/system/base/language.scm | 2 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 36 | ||||
-rw-r--r-- | module/system/repl/common.scm | 2 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 2 |
4 files changed, 38 insertions, 4 deletions
diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 2dac2091b..70000c551 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -34,7 +34,7 @@ ;;; Language class ;;; -(define-record <language> +(define-record/keywords <language> name title version 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) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 03c63bd74..bc3242375 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -35,7 +35,7 @@ ;;; Repl type ;;; -(define-record <repl> vm language options tm-stats gc-stats vm-stats) +(define-record/keywords <repl> vm language options tm-stats gc-stats vm-stats) (define repl-default-options '((trace . #f) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 03eb2ecaa..3c5cfa201 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -31,7 +31,7 @@ ;;; Debugger ;;; -(define-record <debugger> vm chain index) +(define-record/keywords <debugger> vm chain index) (define (vm-debugger vm) (let ((chain (vm-last-frame-chain vm))) |