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

* module/srfi/srfi-9.scm (define-record-type): Rewrite to use raw
  structs instead of records.  Use `syntax-case' instead of
  `define-macro'.

1 files changed, 98 insertions, 26 deletions

diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index c64be5e51..4a5fa6a95 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -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