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))])