Changeset 27291 in project

Timestamp:

08/24/12 16:28:36 (9 years ago)

Author:

felix winkelmann

Message:

typed-records 0.3: appled fix for #899 (by megane)

Location:

release/4/typed-records

Files:

• tags/0.3 (copied) (copied from release/4/typed-records/trunk)
• tags/0.3/tests/t.scm (modified) (1 diff)
• tags/0.3/typed-records.scm (modified) (1 diff)
• tags/0.3/typed-records.setup (modified) (1 diff)
• trunk/tests/t.scm (modified) (1 diff)
• trunk/typed-records.scm (modified) (1 diff)
• trunk/typed-records.setup (modified) (1 diff)

release/4/typed-records/tags/0.3/tests/t.scm

@@ -53 +53 @@
 
   )
+
+;;; test by megane (#899):
+
+(define-record-type foo
+  (make-foo bar)
+  foo?
+  (bar foo-bar foo-bar-set!))
+
+(display (make-foo 1))
+(newline)

release/4/typed-records/tags/0.3/typed-records.scm

@@ -136 +136 @@
                          (cdr ctor))
                    (##sys#make-structure
-                    ',name 
-                    ,@(map (lambda (a/m/t)
-                             (cond ((memq (first a/m/t) (cdr ctor)) (first a/m/t))
+                    ',name
+                    ,@(let lp [(names (map first accs/mods/types))
+                               (l '())]
+                        (if (null? names)
+                            (begin
+                              (reverse l))
+                            (cond ((list-index (cute eq? <> (first names)) (cdr ctor)) =>
+                                   (lambda (ctor-idx) (lp (cdr names) (cons (vector (add1 ctor-idx)) l))))
+                                  (else
                                    ;; XXX this indicates a problem: the initial value
                                    ;;     of the slot is not necessarily of type
                                    ;;     undefined - should be make this an error?
-                                   (else '(##core#undefined))))
-                           accs/mods/types))))
+                                   (lp (cdr names) (cons '(##core#undefined) l)))))))))
          (,%colon ,pred (* -> boolean : (struct ,name)))
          ,@(append-map

release/4/typed-records/tags/0.3/typed-records.setup

@@ -1 +1 @@
 ;;;; typed-records.setup
 
-(standard-extension 'typed-records 0.2)
+(standard-extension 'typed-records 0.3)

release/4/typed-records/trunk/tests/t.scm

@@ -53 +53 @@
 
   )
+
+;;; test by megane (#899):
+
+(define-record-type foo
+  (make-foo bar)
+  foo?
+  (bar foo-bar foo-bar-set!))
+
+(display (make-foo 1))
+(newline)

release/4/typed-records/trunk/typed-records.scm

@@ -136 +136 @@
                          (cdr ctor))
                    (##sys#make-structure
-                    ',name 
-                    ,@(map (lambda (a/m/t)
-                             (cond ((memq (first a/m/t) (cdr ctor)) (first a/m/t))
+                    ',name
+                    ,@(let lp [(names (map first accs/mods/types))
+                               (l '())]
+                        (if (null? names)
+                            (begin
+                              (reverse l))
+                            (cond ((list-index (cute eq? <> (first names)) (cdr ctor)) =>
+                                   (lambda (ctor-idx) (lp (cdr names) (cons (vector (add1 ctor-idx)) l))))
+                                  (else
                                    ;; XXX this indicates a problem: the initial value
                                    ;;     of the slot is not necessarily of type
                                    ;;     undefined - should be make this an error?
-                                   (else '(##core#undefined))))
-                           accs/mods/types))))
+                                   (lp (cdr names) (cons '(##core#undefined) l)))))))))
          (,%colon ,pred (* -> boolean : (struct ,name)))
          ,@(append-map

release/4/typed-records/trunk/typed-records.setup

@@ -1 +1 @@
 ;;;; typed-records.setup
 
-(standard-extension 'typed-records 0.2)
+(standard-extension 'typed-records 0.3)