* now exporting set-rtd-printer!

This commit is contained in:
Abdulaziz Ghuloum 2007-05-07 04:04:54 -04:00
parent 3f4e5ee1a4
commit 37920f52af
4 changed files with 20 additions and 12 deletions

Binary file not shown.

View File

@ -19,11 +19,14 @@
[(x) (set! set (set-cons x set))])))
(define current-library-collection
(make-parameter (make-collection)
;;; this works now because make-collection is a lambda
;;; binding and this turns into a complex binding as far
;;; as letrec is concerned. It will be more ok once we do
;;; letrec*.
(make-parameter (make-collection)
(lambda (x)
(unless (procedure? x)
(error 'current-library-collection
"~s is not a procedure" x))
(error 'current-library-collection "~s is not a procedure" x))
x)))
(define-record library
@ -87,7 +90,6 @@
(define (imported-label->binding lab)
(get-hash-table label->binding-table lab #f))
(define (invoke-library lib)
(let ([invoke (library-invoke-state lib)])
(when (procedure? invoke)
@ -102,7 +104,6 @@
(define (invoke-library-by-spec spec)
(invoke-library (find-library-by-spec/die spec)))
(define installed-libraries
(lambda () ((current-library-collection))))
(define library-spec
@ -112,9 +113,7 @@
(list (library-id x) (library-name x) (library-ver x))))
;;; init
((record-field-mutator (record-type-descriptor (type-descriptor library)) 'printer)
(type-descriptor library)
(set-rtd-printer! (type-descriptor library)
(lambda (x p)
(unless (library? x)
(error 'record-type-printer "not a library"))

View File

@ -4,7 +4,8 @@
(export
make-record-type record-type-name record-type-symbol
record-type-field-names record-constructor record-predicate
record-field-accessor record-field-mutator record? record-rtd
record-field-accessor record-field-mutator record? record-rtd
set-rtd-printer!
(rename (record-rtd record-type-descriptor))
record-name record-printer record-length record-ref record-set!)
@ -17,7 +18,7 @@
record-type-field-names record-constructor record-predicate
record-field-accessor record-field-mutator record? record-rtd
record-type-descriptor record-name record-printer record-length
record-ref record-set!))
record-ref record-set! set-rtd-printer!))
@ -58,7 +59,7 @@
(lambda (rtd fields)
($record-set! rtd 2 fields)))
(define set-rtd-printer!
(define $set-rtd-printer!
(lambda (rtd printer)
($record-set! rtd 3 printer)))
@ -253,9 +254,16 @@
(error 'record-set! "index ~s is out of range for ~s" i x))
($record-set! x i v))))
(define (set-rtd-printer! x p)
(unless (rtd? x)
(error 'set-rtd-printer! "~s is not an rtd" x))
(unless (procedure? p)
(error 'set-rtd-printer! "~s is not a procedure" p))
($set-rtd-printer! x p))
(set-rtd-fields! (base-rtd) '(name fields length printer symbol))
(set-rtd-name! (base-rtd) "base-rtd")
(set-rtd-printer! (base-rtd)
($set-rtd-printer! (base-rtd)
(lambda (x p)
(unless (rtd? x)
(error 'record-type-printer "not an rtd"))

View File

@ -382,6 +382,7 @@
[record-type-field-names i]
[record-type-symbol i]
[record-type-name i]
[set-rtd-printer! i]
[record-name i]
[record-constructor i]
[record-predicate i]