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.scm75
1 files changed, 72 insertions, 3 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 867720cdb..4cdd6119b 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -22,7 +22,7 @@
(define-module (system base syntax)
#:export (%compute-initargs)
#:export-syntax (define-type define-record define-record/keywords
- record-case))
+ record-case transform-record))
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
@@ -97,7 +97,7 @@
(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 '(#\< #\>)))))
+ (stem (trim-brackets name)))
`(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names
,@(if printer (list printer) '())))
@@ -184,7 +184,7 @@
(let ((record-type (caar clause))
(slots (cdar clause))
(body (cdr clause)))
- (let ((stem (symbol-trim-both record-type (list->char-set '(#\< #\>)))))
+ (let ((stem (trim-brackets record-type)))
`((eq? ,rtd ,record-type)
(let ,(map (lambda (slot)
(if (pair? slot)
@@ -198,3 +198,72 @@
(if (assq 'else clauses)
clauses
(append clauses `((else (error "unhandled record" ,r))))))))))
+
+;; Here we take the terrorism to another level. Nasty, but the client
+;; code looks good.
+
+(define-macro (transform-record type-and-common record . clauses)
+ (let ((r (gensym))
+ (rtd (gensym))
+ (type-stem (trim-brackets (car type-and-common))))
+ (define (make-stem s)
+ (symbol-append type-stem '- s))
+ (define (further-predicates x record-stem slots)
+ (define (access slot)
+ `(,(symbol-append (make-stem record-stem) '- slot) ,x))
+ (let lp ((in slots) (out '()))
+ (cond ((null? in) out)
+ ((pair? (car in))
+ (let ((slot (caar in))
+ (arg (cadar in)))
+ (cond ((symbol? arg)
+ (lp (cdr in) out))
+ ((pair? arg)
+ (lp (cdr in)
+ (append (further-predicates (access slot)
+ (car arg)
+ (cdr arg))
+ out)))
+ (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg)
+ out))))))
+ (else (lp (cdr in) out)))))
+ (define (let-clauses x record-stem slots)
+ (define (access slot)
+ `(,(symbol-append (make-stem record-stem) '- slot) ,x))
+ (let lp ((in slots) (out '()))
+ (cond ((null? in) out)
+ ((pair? (car in))
+ (let ((slot (caar in))
+ (arg (cadar in)))
+ (cond ((symbol? arg)
+ (lp (cdr in)
+ (cons `(,arg ,(access slot)) out)))
+ ((pair? arg)
+ (lp (cdr in)
+ (append (let-clauses (access slot)
+ (car arg)
+ (cdr arg))
+ out)))
+ (else
+ (lp (cdr in) out)))))
+ (else
+ (lp (cdr in)
+ (cons `(,(car in) ,(access (car in))) out))))))
+ (define (process-clause clause)
+ (if (eq? (car clause) 'else)
+ clause
+ (let ((stem (caar clause))
+ (slots (cdar clause))
+ (body (cdr clause)))
+ (let ((record-type (symbol-append '< (make-stem stem) '>)))
+ `((and (eq? ,rtd ,record-type)
+ ,@(reverse (further-predicates r stem slots)))
+ (let ,(reverse (let-clauses r stem (append (cdr type-and-common)
+ slots)))
+ ,@(if (pair? body) body '((if #f #f)))))))))
+ `(let* ((,r ,record)
+ (,rtd (struct-vtable ,r)))
+ (cond ,@(let ((clauses (map process-clause clauses)))
+ (if (assq 'else clauses)
+ clauses
+ (append clauses `((else (error "unhandled record" ,r))))))))))