summaryrefslogtreecommitdiff
path: root/module/system/base/syntax.scm
diff options
context:
space:
mode:
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)