summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-05-03 13:46:56 +0200
committerAndy Wingo <wingo@pobox.com>2008-05-03 13:46:56 +0200
commitbe4efc52d29f7d26db01da846121bd648be99567 (patch)
tree3fd9616f953d7deba1a247e88052097a10438eba
parent063fd30bbe68c67475dc46ba5d4cf49bac321305 (diff)
downloadguile-be4efc52d29f7d26db01da846121bd648be99567.tar.gz
pull in srfi-9, implement record-case
* module/system/base/syntax.scm: Pull in srfi-9. Define a record-case macro that will replace (match foo (($ <type> slot ...) body...)).
-rw-r--r--module/system/base/syntax.scm20
1 files changed, 19 insertions, 1 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 7f23df601..a1d9181d3 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -20,11 +20,14 @@
;;; Code:
(define-module (system base syntax)
+ :use-modules (srfi srfi-9)
:export (%make-struct slot
%slot-1 %slot-2 %slot-3 %slot-4 %slot-5
%slot-6 %slot-7 %slot-8 %slot-9
list-fold)
- :export-syntax (syntax define-type define-record |))
+ :export-syntax (syntax define-type define-record record-case)
+ :re-export-syntax (define-record-type))
+(export-syntax |) ;; emacs doesn't like the |
;;;
@@ -157,6 +160,21 @@
(define (%slot-8 x) (vector-ref x 8))
(define (%slot-9 x) (vector-ref x 9))
+(define-macro (record-case record . clauses)
+ (let ((r (gensym)))
+ (define (process-clause clause)
+ (let ((record-type (caar clause))
+ (slots (cdar clause))
+ (body (cdr clause)))
+ `(((record-predicate ,record-type) ,r)
+ (let ,(map (lambda (slot)
+ `(,slot ((record-accessor ,record-type ',slot) ,r)))
+ slots)
+ ,@body))))
+ `(let ((,r ,record))
+ (cond ,@(map process-clause clauses)
+ (else (error "unhandled record" ,r))))))
+
;;;
;;; Utilities