* added (rnrs records procedural) and (rnrs records inspection)

libraries

src/ikarus.compiler.ss

@@ -887,7 +887,7 @@
                   [(p) (mk-seq (mk-seq a0 a1) (make-constant #t))]
                   [else (giveup)])))
          (giveup))]
-    [($record-ref $record/rtd? $struct-ref $struct/rtd?)
+    [($struct-ref $struct/rtd?)
      (or (and (fx= (length rand*) 2)
               (let ([a0 (car rand*)] [a1 (cadr rand*)])
                 (case ctxt

src/ikarus.records.procedural.ss

@@ -1,22 +1,21 @@
 
-(library (ikarus.r6rs.records.procedural)
+(library (ikarus records procedural)
   (export 
-    make-record-type-descriptor
+    make-record-type-descriptor record-type-descriptor?
-    make-record-constructor-descriptor
+    make-record-constructor-descriptor record-accessor
-    record-accessor record-mutator
+    record-mutator record-constructor record-predicate record?
-    record-constructor record-predicate
+    record-rtd record-type-name record-type-parent record-type-uid
-    record? record-rtd record-type-name
+    record-type-generative?  record-type-sealed? record-type-opaque?
-    record-type-parent record-type-uid record-type-generative?
+    record-type-field-names record-field-mutable?)
-    record-type-sealed? record-type-opaque? record-type-field-names)
   (import 
-    (except (ikarus) record-constructor record-predicate set-rtd-printer!
+    (except (ikarus)
-            record? record-type-name record-type-parent
+      record-constructor record-predicate record?  record-type-name
-            record-type-field-names)
+      record-type-parent record-type-descriptor?
-    (prefix (only (ikarus) set-rtd-printer!) core:)
+      record-type-field-names record-field-mutable?)
-    (ikarus system $records))
+    (ikarus system $structs))
 
-  (define-record rtd 
+  (define-struct rtd 
-    (name size old-fields printer symbol parent sealed? opaque? uid fields))
+    (name size old-fields printer-proc symbol parent sealed? opaque? uid fields))
 
   (define rtd-alist '())
   (define (intern-rtd! uid rtd)
@@ -26,20 +25,19 @@
       [(assq uid rtd-alist) => cdr]
       [else #f]))
 
-
   (define (record-type-descriptor? x) (rtd? x))
 
   (define (record? x)
-    (and ($record? x) 
+    (and ($struct? x) 
-         (let ([rtd ($record-rtd x)])
+         (let ([rtd ($struct-rtd x)])
            (and (rtd? rtd) 
                 (not (rtd-opaque? rtd))))))
 
   (define (record-rtd x)
     (define (err x)
       (error 'record-rtd "~s is not a record" x))
-    (if ($record? x)
+    (if ($struct? x)
-        (let ([rtd ($record-rtd x)])
+        (let ([rtd ($struct-rtd x)])
           (if (rtd? rtd)
               (if (not (rtd-opaque? rtd))
                   rtd
@@ -187,7 +185,7 @@
            (generate-rtd name parent uid sealed? opaque? fields)]
           [else (error who "~s is not a valid uid" uid)]))))
 
-  (define-record rcd (rtd prcd proc))
+  (define-struct rcd (rtd prcd proc))
   (define (is-parent-of? prtd rtd)
     (let ([p (rtd-parent rtd)])
       (cond
@@ -229,11 +227,11 @@
           (unless (= (length args) n) 
             (error 'record-constructor 
               "incorrect number of arguments to constructor"))
-          (let f ([r ($make-record rtd n)] [i 0] [args args])
+          (let f ([r ($make-struct rtd n)] [i 0] [args args])
             (cond
               [(null? args) r]
               [else
-               ($record-set! r i (car args))
+               ($struct-set! r i (car args))
                (f r (add1 i) (cdr args))]))))))
 
   (define base-constructors 
@@ -247,10 +245,10 @@
              (let ([proc 
                     (eval `(lambda (rtd) 
                              (lambda ,vars 
-                               ($record rtd . ,vars)))
+                               ($struct rtd . ,vars)))
                           (environment
                             '(ikarus) 
-                            '(ikarus system $records)))])
+                            '(ikarus system $structs)))])
                (vector-set! base-constructors n proc)
                proc)))]
       [else (general-base-constructor n)]))
@@ -331,14 +329,14 @@
           (error who "~s is not a valid index" k))
         (lambda (x) 
           (cond
-            [($record/rtd? x rtd) ($record-ref x i)]
+            [($struct/rtd? x rtd) ($struct-ref x i)]
-            [($record? x)
+            [($struct? x)
-             (let ([xrtd ($record-rtd x)])
+             (let ([xrtd ($struct-rtd x)])
                (unless (rtd? xrtd) 
                  (error who "~s is not of type ~s" x rtd))
                (let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i])
                  (cond
-                   [(eq? prtd rtd) ($record-ref x i)]
+                   [(eq? prtd rtd) ($struct-ref x i)]
                    [(not prtd) 
                     (error who "~s is not of type ~s" x rtd)]
                    [else (f (rtd-parent prtd) rtd x i)])))]
@@ -359,14 +357,14 @@
           (error who "field ~s of ~s is not mutable" k rtd))
         (lambda (x v) 
           (cond
-            [($record/rtd? x rtd) ($record-set! x i v)]
+            [($struct/rtd? x rtd) ($struct-set! x i v)]
-            [($record? x)
+            [($struct? x)
-             (let ([xrtd ($record-rtd x)])
+             (let ([xrtd ($struct-rtd x)])
                (unless (rtd? xrtd) 
                  (error who "~s is not of type ~s" x rtd))
                (let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i] [v v])
                  (cond
-                   [(eq? prtd rtd) ($record-set! x i v)]
+                   [(eq? prtd rtd) ($struct-set! x i v)]
                    [(not prtd) 
                     (error who "~s is not of type ~s" x rtd)]
                    [else (f (rtd-parent prtd) rtd x i v)])))]
@@ -380,9 +378,9 @@
           [p (rtd-parent rtd)])
        (lambda (x) 
          (cond
-           [($record/rtd? x rtd) #t]
+           [($struct/rtd? x rtd) #t]
-           [($record? x)
+           [($struct x)
-            (let ([xrtd ($record-rtd x)])
+            (let ([xrtd ($struct-rtd x)])
               (and (rtd? xrtd) 
                    (let f ([prtd (rtd-parent xrtd)] [rtd rtd])
                      (cond
@@ -391,15 +389,27 @@
                        [else (f (rtd-parent prtd) rtd)]))))]
            [else #f]))))
 
-  (core:set-rtd-printer! (type-descriptor rtd)
+
+  (define (record-field-mutable? rtd k) 
+    (define who 'record-field-mutable?)
+    (unless (rtd? rtd)
+      (error who "~s is not an rtd" rtd))
+    (unless (and (fixnum? k) (fx>= k 0)) 
+      (error who "~s is not a valid index" k))
+    (let ([sz (rtd-size rtd)]
+          [p (rtd-parent rtd)])
+      (let ([i (if p (+ k (rtd-size p)) k)])
+        (unless (fx< i sz) 
+          (error who "~s is not a valid index" k))
+        (car (vector-ref (rtd-fields rtd) k)))))
+
+  (set-rtd-printer! (type-descriptor rtd)
     (lambda (x p) 
       (display (format "#<record-type-descriptor ~s>" (rtd-name x)) p)))
 
-  (core:set-rtd-printer! (type-descriptor rcd)
+  (set-rtd-printer! (type-descriptor rcd)
     (lambda (x p) 
       (display (format "#<record-constructor-descriptor ~s>"
                        (rtd-name (rcd-rtd x))) p)))
                   
-
-
 )

src/makefile.ss

@@ -38,6 +38,7 @@
     "ikarus.fixnums.ss"
     "ikarus.chars.ss"
     "ikarus.structs.ss"
+    "ikarus.records.procedural.ss"
     "ikarus.strings.ss"
     "ikarus.transcoders.ss"
     "ikarus.date-string.ss"

src/tests/r6rs-records-procedural.ss

@@ -0,0 +1,215 @@
+#!/usr/bin/env ikarus --r6rs-script
+
+(import 
+  (ikarus)
+  (rnrs records inspection)
+  (rnrs records procedural))
+
+
+
+(define rtd0 
+  (make-record-type-descriptor 'rtd0
+    #f #f #f #f
+    '#((immutable x0))))
+
+(define rcd0-default
+  (make-record-constructor-descriptor rtd0 #f #f))
+
+(define make-t0-default (record-constructor rcd0-default))
+(define t0? (record-predicate rtd0))
+(define t0-x0 (record-accessor rtd0 0))
+
+(define (test0)
+  (let ([x (make-t0-default 5)])
+    (printf "x=~s\n" x)
+    (assert (not (record-field-mutable? rtd0 0)))
+    (assert (record? x))
+    (assert (t0? x))
+    (assert (= (t0-x0 x) 5))))
+
+(define rtd1 
+  (make-record-type-descriptor 'rtd1
+    rtd0 #f #f #f
+    '#((immutable y0) (mutable y1))))
+
+(define rcd1-default
+  (make-record-constructor-descriptor rtd1 #f #f))
+(define make-t1-default (record-constructor rcd1-default))
+(define t1? (record-predicate rtd1))
+(define t1-y0 (record-accessor rtd1 0))
+(define t1-y1 (record-accessor rtd1 1))
+
+(define (test1)
+  (let ([x (make-t1-default 5 1 2)])
+    (assert (record-field-mutable? rtd1 1))
+    (assert (record? x))
+    (assert (t1? x))
+    (assert (t0? x))
+    (assert (= (t0-x0 x) 5))
+    (assert (= (t1-y0 x) 1))
+    (assert (= (t1-y1 x) 2))))
+
+(define rcd0-17
+  (make-record-constructor-descriptor rtd0 #f
+    (lambda (p)
+      (lambda ()
+        (p 17)))))
+
+(define make-rcd0-17 (record-constructor rcd0-17))
+
+(define (test2)
+  (let ([x (make-rcd0-17)])
+    (assert (record? x))
+    (assert (t0? x))
+    (assert (not (t1? x)))
+    (assert (= (t0-x0 x) 17))))
+
+(define rcd1-17-rev
+  (make-record-constructor-descriptor rtd1 rcd0-17
+    (lambda (p) 
+      (lambda (y0 y1)
+        ((p) y1 y0)))))
+
+(define make-rcd1-17-rev (record-constructor rcd1-17-rev))
+
+(define (test3)
+  (let ([x (make-rcd1-17-rev 1 2)])
+    (assert (record? x))
+    (assert (t1? x))
+    (assert (t0? x))
+    (assert (= (t0-x0 x) 17))
+    (assert (= (t1-y0 x) 2))
+    (assert (= (t1-y1 x) 1))))
+
+(define rcd1-17-default
+  (make-record-constructor-descriptor rtd1 rcd0-17 
+    (lambda (p) (p))))
+
+(define make-rcd1-17-default (record-constructor rcd1-17-default))
+
+(define (test4)
+  (let ([x (make-rcd1-17-default 1 2)])
+    (assert (record? x))
+    (assert (t1? x))
+    (assert (t0? x))
+    (assert (= (t0-x0 x) 17))
+    (assert (= (t1-y0 x) 1))
+    (assert (= (t1-y1 x) 2))))
+
+(define (test5)
+  (define :point 
+    (make-record-type-descriptor 'point
+      #f #f #f #f
+      '#((mutable x) (mutable y))))
+  
+  (define :point-cd 
+    (make-record-constructor-descriptor :point #f #f))
+  
+  (define make-point (record-constructor :point-cd))
+  (define point? (record-predicate :point))
+  (define point-x (record-accessor :point 0))
+  (define point-y (record-accessor :point 1))
+  (define set-point-x! (record-mutator :point 0))
+  (define set-point-y! (record-mutator :point 1))
+  
+  (define :point2 
+    (make-record-type-descriptor 'point2 
+      :point #f #f #f
+      '#((mutable x) (mutable y))))
+  (define make-point2
+    (record-constructor
+      (make-record-constructor-descriptor :point2 #f #f)))
+  (define point2? (record-predicate :point2))
+  (define point2-xx (record-accessor :point2 0))
+  (define point2-yy (record-accessor :point2 1))
+  
+  
+  
+  (define :point-cd/abs
+    (make-record-constructor-descriptor :point #f
+      (lambda (new)
+        (lambda (x y) 
+          (printf "point/abs constr ~s ~s\n" x y)
+          (let ([r (new (abs x) (abs y))])
+            (printf "point/abs r=~s\n" r)
+            r)))))
+  
+  (define make-point/abs (record-constructor :point-cd/abs))
+  
+  (define :cpoint 
+    (make-record-type-descriptor 'cpoint :point #f #f #f
+      '#((mutable rgb))))
+  
+  (define :cpoint-cd
+    (make-record-constructor-descriptor :cpoint :point-cd
+      (lambda (p) 
+        (lambda (x y c) 
+          (printf "cpoint constr ~s ~s ~s\n" x y c)
+          (let ([r ((p x y) (color->rgb c))])
+            (printf "cpoint r=~s\n" r)
+            r)))))
+  
+  (define make-cpoint
+    (record-constructor :cpoint-cd))
+  
+  (define (color->rgb c) (cons 'rgb c))
+  
+  (define cpoint-rgb (record-accessor :cpoint 0))
+  
+  (define cpoint/abs-cd
+    (make-record-constructor-descriptor :cpoint :point-cd/abs
+      (lambda (p)
+        (lambda (x y c) 
+          (printf "cpoint/abs constr ~s ~s ~s\n" x y c)
+          (let ([r ((p x y) (color->rgb c))])
+            (printf "cpointabs r=~s\n" r)
+            r)))))
+  
+  (define make-cpoint/abs
+    (record-constructor cpoint/abs-cd))
+  
+  (printf "cpoint/abs-cd=~s\n" cpoint/abs-cd)
+  
+  (let ()
+    (define p1 (make-point 1 2))
+    (assert (point? p1))
+    (assert (= (point-x p1) 1))
+    (assert (= (point-y p1) 2))
+    (set-point-x! p1 5)
+    (assert (= (point-x p1) 5))
+    (assert (= (point-y p1) 2)))
+  
+  (let ()
+    (define p2 (make-point2 1 2 3 4))
+    (assert (point? p2))
+    (assert (= (point-x p2) 1))
+    (assert (= (point-y p2) 2))
+    (assert (= (point2-xx p2) 3))
+    (assert (= (point2-yy p2) 4)))
+  
+  
+  (let ()
+    (assert (= (point-x (make-point/abs -1 -2)) 1))
+    (assert (= (point-y (make-point/abs -1 -2)) 2)))
+  
+  (let ()
+    (assert (equal? (cpoint-rgb (make-cpoint -1 -3 'red)) '(rgb . red)))
+    (assert (equal? (cpoint-rgb (make-cpoint/abs -1 -3 'red)) '(rgb . red)))
+    (assert (= (point-x (make-cpoint -1 -3 'red)) -1))
+    (assert (= (point-x (make-cpoint/abs -1 -3 'red)) 1))
+    )
+  )
+
+
+(test0)
+(test1)
+(test2)
+(test3)
+(test4)
+(test5)
+(printf "rtd0=~s\n" rtd0)
+(printf "rcd0=~s\n" rcd0-default)
+(printf "fields of ~s are ~s\n" rtd1 (record-type-field-names rtd1))
+(printf "happy happy joy joy\n")
+
+

src/todo-r6rs.ss

@@ -695,7 +695,7 @@
     [file-exists?                               C fi]
     [delete-file                                C fi]
     ;;;
-    [define-record-type                         X rs]
+    [define-record-type                         S rs]
     [fields                                     C rs]
     [immutable                                  C rs]
     [mutable                                    C rs]
@@ -703,29 +703,29 @@
     [parent                                     C rs]
     [parent-rtd                                 C rs]
     [protocol                                   C rs]
-    [record-constructor-descriptor              X rs]
+    [record-constructor-descriptor              S rs]
-    [record-type-descriptor                     X rs]
+    [record-type-descriptor                     S rs]
     [sealed                                     C rs]
     [nongenerative                              C rs]
     ;;;
-    [record-field-mutable?                      X ri]
+    [record-field-mutable?                      C ri]
-    [record-rtd                                 X ri]
+    [record-rtd                                 C ri]
-    [record-type-field-names                    X ri]
+    [record-type-field-names                    C ri]
-    [record-type-generative?                    X ri]
+    [record-type-generative?                    C ri]
-    [record-type-name                           X ri]
+    [record-type-name                           C ri]
-    [record-type-opaque?                        X ri]
+    [record-type-opaque?                        C ri]
-    [record-type-parent                         X ri]
+    [record-type-parent                         C ri]
-    [record-type-sealed?                        X ri]
+    [record-type-sealed?                        C ri]
-    [record-type-uid                            X ri]
+    [record-type-uid                            C ri]
-    [record?                                    X ri]
+    [record?                                    C ri]
     ;;;
-    [make-record-constructor-descriptor         X rp]
+    [make-record-constructor-descriptor         C rp]
-    [make-record-type-descriptor                X rp]
+    [make-record-type-descriptor                C rp]
-    [record-accessor                            X rp]
+    [record-accessor                            C rp]
-    [record-constructor                         X rp]
+    [record-constructor                         C rp]
-    [record-mutator                             X rp]
+    [record-mutator                             C rp]
-    [record-predicate                           X rp]
+    [record-predicate                           C rp]
-    [record-type-descriptor?                    X rp]
+    [record-type-descriptor?                    C rp]
     ;;;
     [bound-identifier=?                         C sc]
     [datum->syntax                              C sc]