diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index acab56a..6a91bc7 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/last-revision b/scheme/last-revision index f252370..80b6d67 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1393 +1394 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 7ea74dc..508baf4 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1543,7 +1543,7 @@ '()))]) `(install-library ',id ',name ',version ',import-libs ',visit-libs ',invoke-libs - ',subst ',env void void '#f '#f ',visible?))))) + ',subst ',env void void '#f '#f ',visible? '#f))))) (let ([code `(library (ikarus primlocs) (export) ;;; must be empty (import diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 0911786..d0efa75 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -3523,41 +3523,45 @@ ;;; Given a (library . _) s-expression, library-expander expands ;;; it to core-form, registers it with the library manager, and ;;; returns its invoke-code, visit-code, subst and env. - (define (library-expander x) - (define (build-visit-code macro*) - (if (null? macro*) - (build-void) - (build-sequence no-source - (map (lambda (x) - (let ((loc (car x)) (src (cddr x))) - (build-global-assignment no-source loc src))) - macro*)))) - (define (visit! macro*) - (for-each (lambda (x) - (let ((loc (car x)) (proc (cadr x))) - (set-symbol-value! loc proc))) - macro*)) - (let-values (((name ver imp* inv* vis* - invoke-code macro* export-subst export-env) - (core-library-expander x))) - (let ((id (gensym)) - (name name) - (ver ver) - (imp* (map library-spec imp*)) - (vis* (map library-spec vis*)) - (inv* (map library-spec inv*)) - (visit-proc (lambda () (visit! macro*))) - (invoke-proc (lambda () (eval-core (expanded->core invoke-code)))) - (visit-code (build-visit-code macro*)) - (invoke-code invoke-code)) - (install-library id name ver - imp* vis* inv* export-subst export-env - visit-proc invoke-proc - visit-code invoke-code - #t) - (values id name ver imp* vis* inv* - invoke-code visit-code - export-subst export-env)))) + (define library-expander + (case-lambda + [(x filename) + (define (build-visit-code macro*) + (if (null? macro*) + (build-void) + (build-sequence no-source + (map (lambda (x) + (let ((loc (car x)) (src (cddr x))) + (build-global-assignment no-source loc src))) + macro*)))) + (define (visit! macro*) + (for-each (lambda (x) + (let ((loc (car x)) (proc (cadr x))) + (set-symbol-value! loc proc))) + macro*)) + (let-values (((name ver imp* inv* vis* + invoke-code macro* export-subst export-env) + (core-library-expander x))) + (let ((id (gensym)) + (name name) + (ver ver) + (imp* (map library-spec imp*)) + (vis* (map library-spec vis*)) + (inv* (map library-spec inv*)) + (visit-proc (lambda () (visit! macro*))) + (invoke-proc + (lambda () (eval-core (expanded->core invoke-code)))) + (visit-code (build-visit-code macro*)) + (invoke-code invoke-code)) + (install-library id name ver + imp* vis* inv* export-subst export-env + visit-proc invoke-proc + visit-code invoke-code + #t filename) + (values id name ver imp* vis* inv* + invoke-code visit-code + export-subst export-env)))] + [(x) (library-expander x #f)])) ;;; when bootstrapping the system, visit-code is not (and cannot ;;; be) be used in the "next" system. So, we drop it. diff --git a/scheme/psyntax.library-manager.ss b/scheme/psyntax.library-manager.ss index 44c9acb..6037f89 100644 --- a/scheme/psyntax.library-manager.ss +++ b/scheme/psyntax.library-manager.ss @@ -50,7 +50,8 @@ (define-record library (id name version imp* vis* inv* subst env visit-state - invoke-state visit-code invoke-code visible?) + invoke-state visit-code invoke-code visible? + source-file-name) (lambda (x p) (unless (library? x) (assertion-violation 'record-type-printer "not a library")) @@ -199,7 +200,8 @@ [(try-load-from-file file-name)] [else ((current-library-expander) - (with-input-from-file file-name read-annotated))]))) + (with-input-from-file file-name read-annotated) + file-name)]))) (lambda (f) (if (procedure? f) f @@ -269,22 +271,30 @@ exp-env)) ((current-library-collection) lib)) - (define (install-library id name ver imp* vis* inv* - exp-subst exp-env visit-proc invoke-proc - visit-code invoke-code visible?) - (let ((imp-lib* (map find-library-by-spec/die imp*)) - (vis-lib* (map find-library-by-spec/die vis*)) - (inv-lib* (map find-library-by-spec/die inv*))) - (unless (and (symbol? id) (list? name) (list? ver)) - (assertion-violation 'install-library - "invalid spec with id/name/ver" id name ver)) - (when (library-exists? name) - (assertion-violation 'install-library - "library is already installed" name)) - (let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib* - exp-subst exp-env visit-proc invoke-proc - visit-code invoke-code visible?))) - (install-library-record lib)))) + (define install-library + (case-lambda + [(id name ver imp* vis* inv* exp-subst exp-env + visit-proc invoke-proc visit-code invoke-code + visible? source-file-name) + (let ((imp-lib* (map find-library-by-spec/die imp*)) + (vis-lib* (map find-library-by-spec/die vis*)) + (inv-lib* (map find-library-by-spec/die inv*))) + (unless (and (symbol? id) (list? name) (list? ver)) + (assertion-violation 'install-library + "invalid spec with id/name/ver" id name ver)) + (when (library-exists? name) + (assertion-violation 'install-library + "library is already installed" name)) + (let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib* + exp-subst exp-env visit-proc invoke-proc + visit-code invoke-code visible? source-file-name))) + (install-library-record lib)))] + #;[(id name ver imp* vis* inv* exp-subst exp-env + visit-proc invoke-proc visit-code invoke-code + visible?) + (install-library id name ver imp* vis* inv* exp-subst exp-env + visit-proc invoke-proc visit-code invoke-code + visible? #f)])) (define extend-library-subst! (lambda (lib sym label)