mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

pull in srfi-9, implement record-case

Browse source 
* module/system/base/syntax.scm: Pull in srfi-9. Define a record-case
  macro that will replace (match foo (($ <type> slot ...) body...)).
This commit is contained in:
Andy Wingo 2008-05-03 13:46:56 +02:00
parent 063fd30bbe
commit be4efc52d2
1 changed files with 19 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

20
module/system/base/syntax.scm
View file

@ -20,11 +20,14 @@
;;; Code: ;;; Code:
(define-module (system base syntax) (define-module (system base syntax)
:use-modules (srfi srfi-9)
:export (%make-struct slot :export (%make-struct slot
%slot-1 %slot-2 %slot-3 %slot-4 %slot-5 %slot-1 %slot-2 %slot-3 %slot-4 %slot-5
%slot-6 %slot-7 %slot-8 %slot-9 %slot-6 %slot-7 %slot-8 %slot-9
list-fold) 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-8 x) (vector-ref x 8))
(define (%slot-9 x) (vector-ref x 9)) (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 ;;; Utilities