From a6302bc57df8e44de93e85fcb0f969d1c8402793 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Wed, 27 Jun 2007 13:15:51 +0300
Subject: [PATCH] added:   src/lab/   src/lab/ikarus.r6rs.records.procedural.ss
   src/lab/ikarus.r6rs.records.syntactic.ss

These are nonworking versions of r6rs records facility
---
 benchmarks.larceny/results.Larceny-r6rs   |  20 ++
 src/lab/ikarus.r6rs.records.procedural.ss | 257 ++++++++++++++++++++++
 src/lab/ikarus.r6rs.records.syntactic.ss  | 231 +++++++++++++++++++
 src/pass-specify-rep-primops.ss           |   9 -
 4 files changed, 508 insertions(+), 9 deletions(-)
 create mode 100644 src/lab/ikarus.r6rs.records.procedural.ss
 create mode 100644 src/lab/ikarus.r6rs.records.syntactic.ss

diff --git a/benchmarks.larceny/results.Larceny-r6rs b/benchmarks.larceny/results.Larceny-r6rs
index 1cc174c..19d1516 100644
--- a/benchmarks.larceny/results.Larceny-r6rs
+++ b/benchmarks.larceny/results.Larceny-r6rs
@@ -8110,3 +8110,23 @@ Words allocated: 2754231001
 Words reclaimed: 0
 Elapsed time...: 25078 ms (User: 20914 ms; System: 4118 ms)
 Elapsed GC time: 13457 ms (CPU: 13523 in 10508 collections.)
+
+****************************
+Benchmarking Larceny-r6rs on Mon Jun 18 18:05:57 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
+
+Testing sum1 under Larceny-r6rs
+Compiling...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+> 
+Running...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+Words allocated: 6553342
+Words reclaimed: 0
+Elapsed time...: 3454 ms (User: 2052 ms; System: 1399 ms)
+Elapsed GC time: 8 ms (CPU: 9 in 25 collections.)
diff --git a/src/lab/ikarus.r6rs.records.procedural.ss b/src/lab/ikarus.r6rs.records.procedural.ss
new file mode 100644
index 0000000..4e2c07a
--- /dev/null
+++ b/src/lab/ikarus.r6rs.records.procedural.ss
@@ -0,0 +1,257 @@
+
+(library (ikarus.r6rs.records.procedural)
+  (export 
+    make-record-type-descriptor
+    make-record-constructor-descriptor
+    record-accessor record-mutator
+    record-constructor record-predicate)
+  (import 
+    (except (ikarus) record-constructor record-predicate)
+    (ikarus system $records))
+
+  (define-record rtd (name size parent sealed? opaque? uid fields))
+  (define rtd-alist '())
+  (define (intern-rtd! uid rtd)
+    (set! rtd-alist (cons (cons uid rtd) rtd-alist)))
+  (define (lookup-rtd uid)
+    (cond
+      [(assq uid rtd-alist) => cdr]
+      [else #f]))
+
+
+  (define (record-type-descriptor? x) (rtd? x))
+
+  (module (make-record-type-descriptor)
+    (define who 'make-record-type-descriptor)
+    (define (make-rtd-aux name parent uid sealed? opaque? fields)
+      (make-rtd name (vector-length fields) parent sealed? opaque? uid fields))
+    (define (convert-fields pfv sv)
+      (unless (vector? sv) 
+        (error who "invalid fields argument ~s" sv))
+      (let ([n1 (vector-length pfv)]
+            [n2 (vector-length sv)])
+        (let ([v (make-vector (+ n1 n2))])
+          (let f ([i 0])
+            (unless (= i n1) 
+              (vector-set! v i (vector-ref pfv i))
+              (f (add1 i))))
+          (let f ([i 0])
+            (unless (= i n2)
+              (let ([x (vector-ref sv i)])
+                (if (pair? x) 
+                    (let ([m/u (car x)] [x (cdr x)])
+                      (if (pair? x) 
+                          (let ([name (car x)])
+                            (unless (and (null? (cdr x)) (symbol? name))
+                              (error who "invalid fields argument ~s" sv))
+                            (vector-set! v (+ i n1) 
+                              (cons (case m/u
+                                      [(mutable)   #t]
+                                      [(immutable) #f]
+                                      [else 
+                                       (error who "invalid fields argument ~s" sv)]) 
+                                    name)))
+                          (error who "invalid fields argument ~s" sv)))
+                    (error who "invalid fields argument ~s" sv)))
+              (f (add1 i))))
+          v)))
+    (define generate-rtd
+      (lambda (name parent uid sealed? opaque? fields)
+        (cond
+          [(rtd? parent)
+           (when (rtd-sealed? parent) 
+             (error who "cannot extend sealed parent ~s" parent))
+           (make-rtd-aux name parent uid sealed? 
+             (or opaque? (rtd-opaque? parent))
+             (convert-fields (rtd-fields parent) fields))]
+          [(eqv? parent #f) 
+           (make-rtd-aux name parent uid sealed? opaque?
+             (convert-fields '#() fields))]
+          [else (error who "~s is not a valid parent" parent)])))
+    (define (same-fields-as-rtd? fields rtd)
+      (let* ([fv (rtd-fields rtd)]
+             [n (vector-length fv)])
+        (and (vector? fields)
+             (= (vector-length fields) n)
+             (let f ([i 0])
+               (or (= i n) 
+                   (let ([a (vector-ref fields i)]
+                         [b (vector-ref fv i)])
+                     (and
+                       (pair? a)
+                       (case (car a) 
+                         [(mutable) (eqv? (car b) #t)]
+                         [(immutable) (eqv? (car b) #f)]
+                         [else #f])
+                       (let ([a (cdr a)])
+                         (and (pair? a)
+                              (null? (cdr a))
+                              (eq? (car a) (cdr b))))
+                       (f (+ i 1)))))))))
+    (define make-nongenerative-rtd 
+      (lambda (name parent uid sealed? opaque? fields)
+        (cond
+          [(lookup-rtd uid) =>
+           (lambda (rtd) 
+             (unless
+               (and (eqv? name (rtd-name rtd))
+                    (eqv? parent (rtd-parent rtd))
+                    (eqv? sealed? (rtd-sealed? rtd))
+                    (eqv? opaque? (rtd-opaque? rtd))
+                    (same-fields-as-rtd? fields rtd))
+               (error who "invalid arguments"))
+             rtd)]
+          [else
+           (let ([rtd (generate-rtd name parent uid sealed? opaque? fields)])
+             (intern-rtd! uid rtd)
+             rtd)])))
+    (define make-record-type-descriptor
+      (lambda (name parent uid sealed? opaque? fields)
+        (unless (symbol? name)
+          (error who "~s is not a valid record type name" name))
+        (unless (boolean? sealed?)
+          (error who "~s is not a valid sealed? argument" sealed?))
+        (unless (boolean? opaque?)
+          (error who "~s is not a valid opaque? argument" opaque?))
+        (cond
+          [(symbol? uid) 
+           (make-nongenerative-rtd name parent uid sealed? opaque? fields)]
+          [(eqv? uid #f) 
+           (generate-rtd name parent uid sealed? opaque? fields)]
+          [else (error who "~s is not a valid uid" uid)]))))
+
+  (define-record rcd (rtd pproc proc))
+  (define make-record-constructor-descriptor
+    (lambda (rtd parent protocol)
+      (define who 'make-record-constructor-descriptor)
+      (define (make-rcd/default-proto&prcd rtd) 
+        (make-rcd rtd #f #f))
+      (define (make-rcd/default-proto rtd parent)
+        (cond
+          [(not parent) 
+           (make-rcd/default-proto&prcd rtd)]
+          [(rcd? parent) 
+           (error who "BUG1")]
+          [else (error who "~s is not a valid record constructor descriptor"
+                       parent)]))
+      (define (make-rcd/procedure-proto rtd parent protocol) 
+        (error who "BUG2"))
+      (unless (rtd? rtd)
+        (error who "~s is not an rtd" rtd))
+      (cond
+        [(not protocol) 
+         (make-rcd/default-proto rtd parent)]
+        [(procedure? protocol) 
+         (make-rcd/procedure-proto rtd parent protocol)]
+        [else (error who "~s is not a valid protocol" protocol)])))
+
+  (define (iota i n)
+    (if (= i n)
+        '()
+        (cons i (iota (+ i 1) n))))
+  (define (sym n)
+    (string->symbol (format "v~s" n)))
+
+  (define (default-constructor-maker n) 
+    ;;; FIXME: should cache compiled procedures
+    (let ([vars (map sym (iota 0 n))])
+      (eval `(lambda (rtd) 
+               (lambda ,vars 
+                 ($record rtd . ,vars)))
+            (environment '(ikarus) '(ikarus system $records)))))
+
+
+
+  (define (record-constructor rcd)
+    (define who 'record-constructor)
+    (unless (rcd? rcd)
+      (error who "~s is not a record constructor descriptor" rcd))
+    (let ([rtd (rcd-rtd rcd)]
+          [pproc (rcd-pproc rcd)]
+          [proc (rcd-proc rcd)])
+      (cond
+        [(not pproc)
+         (cond
+           [(not proc) 
+            ((default-constructor-maker (rtd-size rtd)) rtd)]
+           [else (error who "BUG")])]
+        [else (error who "BUG")])))
+
+  (define (record-accessor rtd k) 
+    (define who 'record-accessor)
+    (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))
+        (lambda (x) 
+          (cond
+            [($record/rtd? x rtd) ($record-ref x i)]
+            [($record? x)
+             (let ([xrtd ($record-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)]
+                   [(not prtd) 
+                    (error who "~s is not of type ~s" x rtd)]
+                   [else (f (rtd-parent prtd) rtd x i)])))]
+            [else (error who "~s is not of type ~s" x rtd)])))))
+
+  (define (record-mutator rtd k) 
+    (define who 'record-mutator)
+    (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))
+        (unless (car (vector-ref (rtd-fields rtd) k))
+          (error who "field ~s of ~s is not mutable" k rtd))
+        (lambda (x v) 
+          (cond
+            [($record/rtd? x rtd) ($record-set! x i v)]
+            [($record? x)
+             (let ([xrtd ($record-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)]
+                   [(not prtd) 
+                    (error who "~s is not of type ~s" x rtd)]
+                   [else (f (rtd-parent prtd) rtd x i v)])))]
+            [else (error who "~s is not of type ~s" x rtd)])))))
+
+  (define (record-predicate rtd) 
+    (define who 'record-predicate)
+    (unless (rtd? rtd)
+      (error who "~s is not an rtd" rtd))
+    (let ([sz (rtd-size rtd)]
+          [p (rtd-parent rtd)])
+       (lambda (x) 
+         (cond
+           [($record/rtd? x rtd) #t]
+           [($record? x)
+            (let ([xrtd ($record-rtd x)])
+              (and (rtd? xrtd) 
+                   (let f ([prtd (rtd-parent xrtd)] [rtd rtd])
+                     (cond
+                       [(eq? prtd rtd) #t]
+                       [(not prtd)     #f]
+                       [else (f (rtd-parent prtd) rtd)]))))]
+           [else #f]))))
+
+
+                  
+
+
+)
diff --git a/src/lab/ikarus.r6rs.records.syntactic.ss b/src/lab/ikarus.r6rs.records.syntactic.ss
new file mode 100644
index 0000000..851f996
--- /dev/null
+++ b/src/lab/ikarus.r6rs.records.syntactic.ss
@@ -0,0 +1,231 @@
+
+
+
+;;; (define-record-type <namespec> <clause> ...)
+;;; <namespec> ::= (<record-name> <constructor-name> <predicate-name>)
+;;;              | <record-name>
+;;; <clause> ::= (fields <fieldspec> ...)
+;;;            | (protocol <expr>)
+;;;            | (parent <parent-name>)
+;;;            | (sealed <bool>)  ; defaults to #f
+;;;            | (opaque <bool>)  ; defaults to #f
+;;;            | (nongenerative <uid>) ; use uid
+;;;            | (nongenerative) ; compile-time generative
+;;;
+;;; <fieldspec> ::= (immutable <fieldname> <accessorname>)
+;;;               | (mutable <fieldname> <accessorname> <mutattorname>)
+;;;               | (immutable <fieldname>)
+;;;               | (mutable <fieldname>)
+;;;               | <fieldname>  ; defaults to immutable
+;;;
+;;; (record-type-descriptor <record-name>) => rtd
+;;; (record-constructor-descriptor <record-name>) => rcd
+
+
+(library (ikarus r6rs records syntactic)
+  (export ---)
+  (import ---)
+  (define-syntax define-record-type
+    (lambda (x)
+      (define (id ctxt . str*)
+        (datum->syntax ctxt 
+          (string->symbol 
+            (apply string-append 
+              (map (lambda (x) 
+                     (cond
+                       [(symbol? x) (symbol->string x)]
+                       [(string? x) x]
+                       [else (error 'define-record-type "BUG")]))
+                   str*)))))
+      (define (get-record-name spec)
+        (syntax-case spec ()
+          [(foo make-foo foo?) #'foo]
+          [foo #'foo]))
+      (define (get-record-constructor-name spec ctxt)
+        (syntax-case spec ()
+          [(foo make-foo foo?) #'make-foo]
+          [foo (id ctxt "make-" (syntax->datum #'foo))]))
+      (define (get-record-predicate-name spec ctxt)
+        (syntax-case spec ()
+          [(foo make-foo foo?) #'foo?]
+          [foo (id ctxt (syntax->datum #'foo) "?")]))
+      (define (get-clause id ls)
+        (syntax-case ls ()
+          [() #f]
+          [((x . rest) . ls)
+           (if (free-identifier=? id #'x) 
+               #'(x . rest)
+               (get-clause id #'ls))]))
+      (define (foo-rtd-code ctxt name clause*) 
+        (define (convert-field-spec* ls)
+          (list #'quote
+            (list->vector
+              (map (lambda (x) 
+                     (syntax-case x (mutable immutable)
+                       [(mutable name . rest) #'(mutable name)]
+                       [(immutable name . rest) #'(immutable name)]
+                       [name #'(immutable name)]))
+                   ls))))
+        (with-syntax ([name name]
+                      [parent-rtd-code 
+                       (syntax-case (get-clause #'parent clause*) ()
+                         [(_ name) #'(record-type-descriptor name)]
+                         [_ #'#f])]
+                      [uid-code 
+                       (syntax-case (get-clause #'nongenerative clause*) ()
+                         [(_) (datum->syntax ctxt (gensym))]
+                         [(_ uid) #''uid]
+                         [_ #'#f])]
+                      [sealed?
+                       (syntax-case (get-clause #'sealed? clause*) ()
+                         [(_ #t) #'#t]
+                         [_      #'#f])]
+                      [opaque?
+                       (syntax-case (get-clause #'opaque? clause*) ()
+                         [(_ #t) #'#t]
+                         [_      #'#f])]
+                      [fields 
+                       (syntax-case (get-clause #'fields clause*) ()
+                         [(_ field-spec* ...) 
+                          (convert-field-spec* #'(field-spec* ...))]
+                         [_ #''#()])])
+          #'(make-record-type-descriptor 'name
+               parent-rtd-code 
+               uid-code sealed? opaque? fields)))
+      (define (foo-rcd-code clause*) 
+        (with-syntax ([parent-rcd-code 
+                       (syntax-case (get-clause #'parent clause*) ()
+                         [(_ name) #'(record-constructor-descriptor name)]
+                         [_ #'#f])])
+          #'(make-record-constructor-descriptor foo-rtd
+               parent-rcd-code protocol)))
+      (define (get-protocol-code clause*)
+        (syntax-case (get-clause #'protocol clause*) ()
+          [(_ expr) #'expr]
+          [_        #'#f]))
+      (define (do-define-record ctxt namespec clause*)
+        (let ([foo (get-record-name namespec)])
+        (with-syntax ([foo foo]
+                      [make-foo (get-record-constructor-name namespec ctxt)] 
+                      [foo? (get-record-predicate-name namespec ctxt)]
+                      [foo-rtd-code (foo-rtd-code ctxt name clause*)]
+                      [protocol-code (get-protocol-code clause*)])
+          #'(begin
+              (define foo-rtd foo-rtd-code)
+              (define protocol protocol-code)
+              (define foo-rcd foo-rcd-code)
+              (define-syntax foo (list '$rtd #'foo-rtd #'foo-rcd))
+              (define foo? (record-predicate foo-rtd))
+              (define make-foo (record-constructor foo-rcd))
+              (define foo-x* (record-accessor foo-rtd idx*))
+              ...
+              (define set-foo-x!* (record-mutator foo-rtd mutable-idx*))
+              ...)
+      (syntax-case x ()
+        [(ctxt namespec clause* ...)
+         (do-define-record #'ctxt #'namespec #'(clause* ...))])))
+           
+
+)
+
+
+
+
+
+  (define-record foo (bar baz)) 
+==
+  (define-record-type foo 
+    (fields bar baz)
+    (nongenerative))
+
+  (define-record-type foo (fields x y) (nongenerative))
+==
+  (begin
+    (define-syntax foo `($rtd <foo-rtd> <foo-rcd>))
+       ;;; <foo-rcd> = #[rcd <foo-rtd> #f #f]
+       ;;; <foo-rtd> = #[rtd foo <gensym> #(x y) ---]
+    (define (make-foo x y) 
+      ($record '<foo-rtd> x y))
+    (define (foo? x)
+      ($record/rtd? x '<foo-rtd>))
+    (define (foo-x x)
+      (if ($record/rtd? x '<foo-rtd>) ($record-ref x 0) (error ---)))
+    (define (foo-y x)
+      (if ($record/rtd? x '<foo-rtd>) ($record-ref x 1) (error ---))))
+
+  (record-type-descriptor foo) 
+== 
+  '<foo-rtd>
+
+  (record-constructor-descriptor foo) 
+== 
+  '<foo-rcd>
+
+  (record-constructor '<foo-rcd>)
+=>
+  (default-rtd-constructor '<foo-rtd>)
+=>
+  (lambda (x y) 
+    ($record '<foo-rtd> x y))
+
+
+
+  (define-record-type foo (fields x y) (generative))
+==
+  (begin
+    (define foo-rtd (make-rtd --- ---))
+    (define foo-rcd (make-rcd foo-rtd #f #f))
+    (define-syntax foo `($rtd #'foo-rtd #'foo-rcd))
+    (define (make-foo x y) 
+      ($record foo-rtd x y))
+    (define (foo? x)
+      ($record/rtd? x foo-rtd))
+    (define (foo-x x)
+      (if ($record/rtd? x foo-rtd) ($record-ref x 0) (error ---)))
+    (define (foo-y x)
+      (if ($record/rtd? x foo-rtd) ($record-ref x 1) (error ---))))
+
+
+  (define-record-type foo 
+    (fields x y) 
+    (parent pfoo) ;;; pfoo = `($rtd <pfoo-rtd> <pfoo-rcd>)
+    (nongenerative))
+==
+  (begin
+    (define-syntax foo `($rtd <foo-rtd> <foo-rcd>))
+       ;;; <pfoo-rcd> = #[rcd <foo-rtd> #f #f]
+       ;;; <foo-rcd> = #[rcd <foo-rtd> #f #f]
+       ;;; <foo-rtd> = #[rtd foo <gensym> #(x y) ---]
+    (define (make-foo x y) 
+      ($record '<foo-rtd> x y))
+    (define (foo? x)
+      ($record/rtd? x '<foo-rtd>))
+    (define (foo-x x)
+      (if ($record/rtd? x '<foo-rtd>) ($record-ref x 2) (error ---)))
+    (define (foo-y x)
+      (if ($record/rtd? x '<foo-rtd>) ($record-ref x 3) (error ---))))
+
+
+
+
+(define-record-type bar 
+   (fields c)
+   (parent foo)
+   (protocol 
+     (lambda (p) 
+       (lambda (a b c) 
+         ((p a b) c))))
+   (sealed #f)
+   (opaque #t)
+==
+(begin
+  (define protocol-0
+    (lambda (p)
+      (lambda (a b c) 
+        ((p a b) c))))
+  (define bars-rtd '<some-rtd>)
+  (define-syntax bar `($rtd <some rtd> <some rcd>))
+
+
+
+
diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss
index fb0c5d1..94fe93b 100644
--- a/src/pass-specify-rep-primops.ss
+++ b/src/pass-specify-rep-primops.ss
@@ -460,13 +460,6 @@
   [(P str) (K #t)]
   [(E str) (nop)])
 
-;(define-primop primitive-set! unsafe
-;  [(E x v) (mem-assign v (T x) (- disp-symbol-system-value symbol-tag))])
-;
-;(define-primop primitive-ref unsafe
-;  [(V x) (prm 'mref (T x) (K (- disp-symbol-system-value symbol-tag)))]
-;  [(E x) (nop)])
-
 (define-primop $symbol-string unsafe
   [(V x) (prm 'mref (T x) (K (- disp-symbol-record-string symbol-ptag)))]
   [(E x) (nop)])
@@ -496,8 +489,6 @@
   [(E x v)
    (with-tmp ([x (T x)])
      (prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (T v))
-     ;(prm 'mset x (K (- disp-symbol-function symbol-tag))
-     ;     (prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
      (dirty-vector-set x))])