aboutsummaryrefslogtreecommitdiffstats
path: root/record.scm
diff options
context:
space:
mode:
Diffstat (limited to 'record.scm')
-rw-r--r--record.scm27
1 files changed, 22 insertions, 5 deletions
diff --git a/record.scm b/record.scm
index 555d3ea..b0cc755 100644
--- a/record.scm
+++ b/record.scm
@@ -1,6 +1,6 @@
; "record.scm" record data types
; Written by David Carlton, carlton@husc.harvard.edu.
-; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu
+; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu, 1996, 1997
;
; This code is in the public domain.
@@ -17,6 +17,8 @@
(define vector-set! vector-set!)
(define vector-fill! vector-fill!)
(define vector->list vector->list)
+(define display display)
+(define write write)
(define record-modifier #f)
(define record-accessor #f)
@@ -32,6 +34,8 @@
(vect? vector?)
(vect-ref vector-ref)
(vect->list vector->list)
+ (disp display)
+ (wri write)
;; Need to wrap these to protect record data from being corrupted.
(vect-set! vector-set!)
@@ -71,10 +75,15 @@
(rtd-length (lambda (rtd) (vect-ref rtd 4)))
(rec-rtd (lambda (x) (vect-ref x 0)))
+ (rec-disp-str
+ (lambda (x)
+ (let ((name (rtd-name (rec-rtd x))))
+ (string-append
+ "#<" (if (symbol? name) (symbol->string name) name) ">"))))
(make-rec-type
(lambda (type-name field-names)
- (if (not (string? type-name))
+ (if (not (or (symbol? type-name) (string? type-name)))
(slib:error 'make-record-type "non-string type-name argument."
type-name))
(if (or (and (list? field-names) (comlist:has-duplicates? field-names))
@@ -182,17 +191,17 @@
(vect-set! x index y)))))
)
- (set! vector? (lambda (obj) (and (not (rec? obj)) (vector? obj))))
+ (set! vector? (lambda (obj) (and (not (rec? obj)) (vect? obj))))
(set! vector-ref
(lambda (vector k)
(cond ((rec? vector)
(vec:error 'vector-ref nvt vector))
(else (vect-ref vector k)))))
(set! vector->list
- (lambda (vector k)
+ (lambda (vector)
(cond ((rec? vector)
(vec:error 'vector->list nvt vector))
- (else (vect->list vector k)))))
+ (else (vect->list vector)))))
(set! vector-set!
(lambda (vector k obj)
(cond ((rec? vector)
@@ -203,6 +212,14 @@
(cond ((rec? vector)
(vec:error 'vector-fill! nvt vector))
(else (vect-fill! vector fill)))))
+ (set! display
+ (lambda (obj . opt)
+ (apply disp (if (rec? obj) (rec-disp-str obj) obj) opt)))
+ (set! write
+ (lambda (obj . opt)
+ (if (rec? obj)
+ (apply disp (rec-disp-str obj) opt)
+ (apply wri obj opt))))
(set! record-modifier rec-modifier)
(set! record-accessor rec-accessor)
(set! record-constructor rec-constructor)