diff options
Diffstat (limited to 'record.scm')
| -rw-r--r-- | record.scm | 27 |
1 files changed, 22 insertions, 5 deletions
@@ -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) |