guile-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: Functional record "setters", a different approach


From: Mark H Weaver
Subject: Re: Functional record "setters", a different approach
Date: Wed, 11 Apr 2012 04:20:54 -0400
User-agent: Gnus/5.13 (Gnus v5.13) Emacs/24.0.92 (gnu/linux)

I wrote:
> I rushed out my last email because I didn't want anyone else to waste
> time working on the same functionality.

More importantly, I just realized that the patch I sent out included
only part of my changes.  It was missing my initial work to clean up the
srfi-9 code before I started adding the new functionality.  Here's the
complete patch.  Apologies for the wasted bandwidth :-(

    Mark


diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index da71d1e..866d28b 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -29,8 +29,8 @@
 ;;         <predicate name>
 ;;         <field spec> ...)
 ;;
-;;  <field spec> -> (<field tag> <accessor name>)
-;;               -> (<field tag> <accessor name> <modifier name>)
+;;  <field spec> -> (<field tag> <getter name>)
+;;               -> (<field tag> <getter name> <setter name>)
 ;;
 ;;  <field tag> -> <identifier>
 ;;  <... name>  -> <identifier>
@@ -60,7 +60,7 @@
 
 (define-module (srfi srfi-9)
   #:use-module (srfi srfi-1)
-  #:export (define-record-type))
+  #:export-syntax (define-record-type))
 
 (cond-expand-provide (current-module) '(srfi-9))
 
@@ -68,8 +68,26 @@
 ;; because the public one has a different `make-procedure-name', so
 ;; using it would require users to recompile code that uses SRFI-9.  See
 ;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+  (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time.  This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define %%type #f)   ; a private syntax literal
+(define-syntax-rule (getter-type getter) (getter () %%type))
 
-(define-syntax define-inlinable
+(define %%index #f)  ; a private syntax literal
+(define-syntax-rule (getter-index getter) (getter () %%index))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax-rule (getter-copier getter) (getter () %%copier))
+
+(define-syntax define-tagged-inlinable
   (lambda (x)
     (define (make-procedure-name name)
       (datum->syntax name
@@ -77,7 +95,7 @@
                                     '-procedure)))
 
     (syntax-case x ()
-      ((_ (name formals ...) body ...)
+      ((_ ((key value) ...) (name formals ...) body ...)
        (identifier? #'name)
        (with-syntax ((proc-name  (make-procedure-name #'name))
                      ((args ...) (generate-temporaries #'(formals ...))))
@@ -86,7 +104,8 @@
                body ...)
              (define-syntax name
                (lambda (x)
-                 (syntax-case x ()
+                 (syntax-case x (key ...)
+                   ((_ () key) #'value) ...
                    ((_ args ...)
                     #'((lambda (formals ...)
                          body ...)
@@ -109,90 +128,139 @@
       (loop (cdr fields) (+ 1 off)))))
   (display ">" p))
 
+(define (throw-bad-struct s who)
+  (throw 'wrong-type-arg who
+         "Wrong type argument: ~S" (list s)
+         (list s)))
+
+(define (make-copier-id type-name)
+  (datum->syntax type-name
+                 (symbol-append '%% (syntax->datum type-name)
+                                '-modified-copy)))
+
+(define-syntax %%modified-copy
+  (lambda (x)
+    (syntax-case x ()
+      ((_ type-name (getter-id ...) check? s (getter expr) ...)
+       (every identifier? #'(getter ...))
+       (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+             (getter+exprs #'((getter expr) ...)))
+         (define (lookup id default-expr)
+           (let ((results
+                  (filter (lambda (g+e)
+                            (free-identifier=? id (car g+e)))
+                          getter+exprs)))
+             (case (length results)
+               ((0) default-expr)
+               ((1) (cadar results))
+               (else (syntax-violation
+                      copier-name "duplicate getter" x id)))))
+         (for-each (lambda (id)
+                     (or (find (lambda (getter-id)
+                                 (free-identifier=? id getter-id))
+                               #'(getter-id ...))
+                         (syntax-violation
+                          copier-name "unknown getter" x id)))
+                   #'(getter ...))
+         (with-syntax ((unsafe-expr
+                        #`(make-struct
+                           type-name 0
+                           #,@(map (lambda (getter index)
+                                     (lookup getter #`(struct-ref s #,index)))
+                                   #'(getter-id ...)
+                                   (iota (length #'(getter-id ...)))))))
+           (if (syntax->datum #'check?)
+               #`(if (eq? (struct-vtable s) type-name)
+                     unsafe-expr
+                     (throw-bad-struct
+                      s '#,(datum->syntax #'here copier-name)))
+               #'unsafe-expr)))))))
+
 (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)
+      (map (lambda (field-spec)
+             (syntax-case field-spec ()
+               ((name getter) #'name)
+               ((name getter setter) #'name)))
+           field-specs))
+
+    (define (getter-identifiers field-specs)
+      (map (lambda (field-spec)
+             (syntax-case field-spec ()
+               ((name getter) #'getter)
+               ((name getter setter) #'getter)))
+           field-specs))
+
+    (define (constructor form type-name constructor-spec field-names)
       (syntax-case constructor-spec ()
         ((ctor field ...)
-         (let ((field-count (length indices))
-               (ctor-args   (map (lambda (field)
-                                   (cons (syntax->datum field) field))
-                                 #'(field ...))))
+         (every identifier? #'(field ...))
+         (let ((ctor-args (map (lambda (field)
+                                 (let ((name (syntax->datum field)))
+                                   (or (memq name field-names)
+                                       (syntax-violation
+                                        'define-record-type
+                                        "unknown field in constructor-spec"
+                                        form field))
+                                   (cons name field)))
+                               #'(field ...))))
            #`(define-inlinable #,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-inlinable (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-inlinable (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)))))
+                            #,@(map (lambda (name)
+                                      (assq-ref ctor-args name))
+                                    field-names)))))))
+
+    (define (copier type-name getter-ids copier-id)
+      (with-syntax ((type-name type-name)
+                    (getter-ids getter-ids)
+                    ;; FIXME: Using 'copier-id' here (without stripping
+                    ;; its wrap) fails when 'define-record-type' is used
+                    ;; at non-top-level.  Why?
+                    (copier-id (datum->syntax
+                                #'here (syntax->datum copier-id))))
+        #'(define-syntax-rule
+            (copier-id check? s (getter expr) (... ...))
+            (%%modified-copy type-name getter-ids
+                             check? s (getter expr) (... ...)))))
+
+    (define (getters type-name getter-ids copier-id)
+      (map (lambda (getter index)
+             #`(define-tagged-inlinable
+                 ((%%type   #,type-name)
+                  (%%index  #,index)
+                  (%%copier #,copier-id))
+                 (#,getter s)
+                 (if (eq? (struct-vtable s) #,type-name)
+                     (struct-ref s #,index)
+                     (throw-bad-struct s '#,getter))))
+           getter-ids
+           (iota (length getter-ids))))
+
+    (define (setters type-name field-specs)
+      (filter-map (lambda (field-spec index)
+                    (syntax-case field-spec ()
+                      ((name getter) #f)
+                      ((name getter setter)
+                       #`(define-inlinable (setter s val)
+                           (if (eq? (struct-vtable s) #,type-name)
+                               (struct-set! s #,index val)
+                               (throw-bad-struct s 'setter))))))
+                  field-specs
+                  (iota (length field-specs))))
 
     (syntax-case x ()
       ((_ type-name constructor-spec predicate-name field-spec ...)
-       (let* ((fields      (field-identifiers #'(field-spec ...)))
-              (field-count (length fields))
+       (let* ((field-ids   (field-identifiers  #'(field-spec ...)))
+              (getter-ids  (getter-identifiers #'(field-spec ...)))
+              (field-count (length field-ids))
               (layout      (string-concatenate (make-list field-count "pw")))
-              (indices     (field-indices (map syntax->datum fields)))
+              (field-names (map syntax->datum field-ids))
               (ctor-name   (syntax-case #'constructor-spec ()
-                             ((ctor args ...) #'ctor))))
+                             ((ctor args ...) #'ctor)))
+              (copier-id   (make-copier-id #'type-name)))
          #`(begin
-             #,(constructor #'type-name #'constructor-spec indices)
+             #,(constructor x #'type-name #'constructor-spec field-names)
 
              (define type-name
                (let ((rtd (make-struct/no-tail
@@ -200,7 +268,7 @@
                            '#,(datum->syntax #'here (make-struct-layout 
layout))
                            default-record-printer
                            'type-name
-                           '#,fields)))
+                           '#,field-ids)))
                  (set-struct-vtable-name! rtd 'type-name)
                  (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
                  rtd))
@@ -209,6 +277,9 @@
                (and (struct? obj)
                     (eq? (struct-vtable obj) type-name)))
 
-             #,@(accessors #'type-name #'(field-spec ...) indices)))))))
+             #,@(getters #'type-name getter-ids copier-id)
+             #,@(setters #'type-name #'(field-spec ...))
+             #,(copier #'type-name getter-ids copier-id)
+             ))))))
 
 ;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 30c101b..d9c24a1 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -1,6 +1,6 @@
 ;;; Extensions to SRFI-9
 
-;;     Copyright (C) 2010 Free Software Foundation, Inc.
+;;     Copyright (C) 2010, 2012 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
@@ -23,8 +23,63 @@
 ;;; Code:
 
 (define-module (srfi srfi-9 gnu)
-  #:export (set-record-type-printer!))
+  #:use-module (srfi srfi-1)
+  #:export (set-record-type-printer!)
+  #:export-syntax (modified-copy modified-copy-nocheck))
 
 (define (set-record-type-printer! type thunk)
   "Set a custom printer THUNK for TYPE."
   (struct-set! type vtable-index-printer thunk))
+
+(define-syntax-rule (modified-copy s . rest)
+  (%modified-copy #t s . rest))
+
+(define-syntax-rule (modified-copy-nocheck s . rest)
+  (%modified-copy #f s . rest))
+
+(define-syntax %modified-copy
+  (lambda (x)
+    (with-syntax ((getter-type   #'(@@ (srfi srfi-9) getter-type))
+                  (getter-index  #'(@@ (srfi srfi-9) getter-index))
+                  (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+      (syntax-case x ()
+        ((_ check? s)
+         #'s)
+        ((_ check? s (() e))
+         #'e)
+        ((_ check? struct-expr ((getter . rest) expr) ...)
+         ;;
+         ;; FIXME: Improve compile-time error reporting:
+         ;;   1. report an error if any getter-path is a
+         ;;      prefix of any other getter-path.
+         ;;   2. report an error if the initial getters
+         ;;      do not all belong to the same record type.
+         ;;
+         ;; forest : (tree ...)
+         ;;   tree : (getter (rest . expr) ...)
+         (let ((forest
+                (fold (lambda (g r e forest)
+                        (cond ((find (lambda (tree)
+                                       (free-identifier=? g (car tree)))
+                                     forest)
+                               => (lambda (tree)
+                                    (cons (cons g (cons (cons r e)
+                                                        (cdr tree)))
+                                          (delq tree forest))))
+                              (else (cons (list g (cons r e))
+                                          forest))))
+                      '()
+                      #'(getter ...)
+                      #'(rest ...)
+                      #'(expr ...))))
+           #`(let ((s struct-expr))
+               ((getter-copier #,(caar forest))
+                check?
+                s
+                #,@(map (lambda (tree)
+                          (with-syntax (((getter (rest . expr) ...) tree))
+                            #'(getter (%modified-copy
+                                       check?
+                                       (struct-ref s (getter-index getter))
+                                       (rest expr) ...))))
+                        forest)))))))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 321fe16..d0668db 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -29,7 +29,7 @@
   (x get-x) (y get-y set-y!))
 
 (define-record-type :bar (make-bar i j) bar? 
-  (i get-i) (i get-j set-j!))
+  (i get-i) (j get-j set-j!))
 
 (define f (make-foo 1))
 (set-y! f 2)

reply via email to

[Prev in Thread] Current Thread [Next in Thread]