diff --git a/src/ikarus.boot b/src/ikarus.boot index 4210544..9c073da 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.library-manager.ss b/src/ikarus.library-manager.ss index 51ededc..f3e4775 100644 --- a/src/ikarus.library-manager.ss +++ b/src/ikarus.library-manager.ss @@ -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")) diff --git a/src/ikarus.records.ss b/src/ikarus.records.ss index 1cb7fda..c456e62 100644 --- a/src/ikarus.records.ss +++ b/src/ikarus.records.ss @@ -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")) diff --git a/src/makefile.ss b/src/makefile.ss index 7b0740c..baa0977 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -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]