mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

SRFI-9: Reimplement in terms of structs, using `syntax-case'.

Browse source 
* module/srfi/srfi-9.scm (define-record-type): Rewrite to use raw
  structs instead of records.  Use `syntax-case' instead of
  `define-macro'.
This commit is contained in:
Ludovic Courtès 2009-12-06 01:00:04 +01:00
parent f680bdd762
commit 09a8dc97db
1 changed files with 98 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

124
module/srfi/srfi-9.scm
View file

@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2002, 2006, 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@ -59,33 +59,105 @@
;;; Code:
(define-module (srfi srfi-9)
:export-syntax (define-record-type))
#:use-module (srfi srfi-1)
#:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
(define-macro (define-record-type type-name constructor/field-tag
predicate-name . field-specs)
`(begin
(define ,type-name
(make-record-type ',type-name ',(map car field-specs)))
(define ,(car constructor/field-tag)
(record-constructor ,type-name ',(cdr constructor/field-tag)))
(define ,predicate-name
(record-predicate ,type-name))
,@(map
(lambda (spec)
(cond
((= (length spec) 2)
`(define ,(cadr spec)
(record-accessor ,type-name ',(car spec))))
((= (length spec) 3)
`(begin
(define ,(cadr spec)
(record-accessor ,type-name ',(car spec)))
(define ,(caddr spec)
(record-modifier ,type-name ',(car spec)))))
(else
(error "invalid field spec " spec))))
field-specs)))
(define-syntax define-record-type
(lambda (x)
(define (field-identifiers field-specs)
(syntax-case field-specs ()
((field-spec)
(syntax-case #'field-spec ()
((name accessor) #'(name))
((name accessor modifier) #'(name))))
((field-spec rest ...)
(append (field-identifiers #'(field-spec))
(field-identifiers #'(rest ...))))))
(define (field-indices fields)
(fold (lambda (field result)
(let ((i (if (null? result)
0
(+ 1 (cdar result)))))
(alist-cons field i result)))
'()
fields))
(define (constructor type-name constructor-spec indices)
(syntax-case constructor-spec ()
((ctor field ...)
(let ((field-count (length indices))
(ctor-args (map (lambda (field)
(cons (syntax->datum field) field))
#'(field ...))))
#`(define #,constructor-spec
(make-struct #,type-name 0
#,@(unfold
(lambda (field-num)
(>= field-num field-count))
(lambda (field-num)
(let* ((name
(car (find (lambda (f+i)
(= (cdr f+i) field-num))
indices)))
(arg (assq name ctor-args)))
(if (pair? arg)
(cdr arg)
#'#f)))
1+
0)))))))
(define (accessors type-name field-specs indices)
(syntax-case field-specs ()
((field-spec)
(syntax-case #'field-spec ()
((name accessor)
(with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
#`((define (accessor s)
(if (eq? (struct-vtable s) #,type-name)
(struct-ref s index)
(throw 'wrong-type-arg 'accessor
"Wrong type argument: ~S" (list s)
(list s)))))))
((name accessor modifier)
(with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
#`(#,@(accessors type-name #'((name accessor)) indices)
(define (modifier s val)
(if (eq? (struct-vtable s) #,type-name)
(struct-set! s index val)
(throw 'wrong-type-arg 'modifier
"Wrong type argument: ~S" (list s)
(list s)))))))))
((field-spec rest ...)
#`(#,@(accessors type-name #'(field-spec) indices)
#,@(accessors type-name #'(rest ...) indices)))))
(syntax-case x ()
((_ type-name constructor-spec predicate-name field-spec ...)
(let* ((fields (field-identifiers #'(field-spec ...)))
(field-count (length fields))
(layout (string-concatenate (make-list field-count "pw")))
(indices (field-indices (map syntax->datum fields))))
#`(begin
(define type-name
(make-vtable #,layout
(lambda (obj port)
(format port "#<~A" 'type-name)
#,@(map (lambda (field)
(let* ((f (syntax->datum field))
(i (assoc-ref indices f)))
#`(format port " ~A: ~S" '#,field
(struct-ref obj #,i))))
fields)
(format port ">"))))
(define (predicate-name obj)
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
#,(constructor #'type-name #'constructor-spec indices)
#,@(accessors #'type-name #'(field-spec ...) indices)))))))
;;; srfi-9.scm ends here