conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

library record now contains original file name for libraries loaded 

from files.
This commit is contained in:
Abdulaziz Ghuloum 2008-02-18 20:39:42 -05:00
parent c430a91bb8
commit e751c15bc4
5 changed files with 69 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

2
scheme/last-revision
View File

@ -1 +1 @@
1393 1394

2
scheme/makefile.ss
View File

@ -1543,7 +1543,7 @@
'()))]) '()))])
`(install-library `(install-library
',id ',name ',version ',import-libs ',visit-libs ',invoke-libs ',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) (let ([code `(library (ikarus primlocs)
(export) ;;; must be empty (export) ;;; must be empty
(import (import

74
scheme/psyntax.expander.ss
View File

@ -3523,41 +3523,45 @@
;;; Given a (library . _) s-expression, library-expander expands ;;; Given a (library . _) s-expression, library-expander expands
;;; it to core-form, registers it with the library manager, and ;;; it to core-form, registers it with the library manager, and
;;; returns its invoke-code, visit-code, subst and env. ;;; returns its invoke-code, visit-code, subst and env.
(define (library-expander x) (define library-expander
(define (build-visit-code macro*) (case-lambda
(if (null? macro*) [(x filename)
(build-void) (define (build-visit-code macro*)
(build-sequence no-source (if (null? macro*)
(map (lambda (x) (build-void)
(let ((loc (car x)) (src (cddr x))) (build-sequence no-source
(build-global-assignment no-source loc src))) (map (lambda (x)
macro*)))) (let ((loc (car x)) (src (cddr x)))
(define (visit! macro*) (build-global-assignment no-source loc src)))
(for-each (lambda (x) macro*))))
(let ((loc (car x)) (proc (cadr x))) (define (visit! macro*)
(set-symbol-value! loc proc))) (for-each (lambda (x)
macro*)) (let ((loc (car x)) (proc (cadr x)))
(let-values (((name ver imp* inv* vis* (set-symbol-value! loc proc)))
invoke-code macro* export-subst export-env) macro*))
(core-library-expander x))) (let-values (((name ver imp* inv* vis*
(let ((id (gensym)) invoke-code macro* export-subst export-env)
(name name) (core-library-expander x)))
(ver ver) (let ((id (gensym))
(imp* (map library-spec imp*)) (name name)
(vis* (map library-spec vis*)) (ver ver)
(inv* (map library-spec inv*)) (imp* (map library-spec imp*))
(visit-proc (lambda () (visit! macro*))) (vis* (map library-spec vis*))
(invoke-proc (lambda () (eval-core (expanded->core invoke-code)))) (inv* (map library-spec inv*))
(visit-code (build-visit-code macro*)) (visit-proc (lambda () (visit! macro*)))
(invoke-code invoke-code)) (invoke-proc
(install-library id name ver (lambda () (eval-core (expanded->core invoke-code))))
imp* vis* inv* export-subst export-env (visit-code (build-visit-code macro*))
visit-proc invoke-proc (invoke-code invoke-code))
visit-code invoke-code (install-library id name ver
#t) imp* vis* inv* export-subst export-env
(values id name ver imp* vis* inv* visit-proc invoke-proc
invoke-code visit-code visit-code invoke-code
export-subst export-env)))) #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 ;;; when bootstrapping the system, visit-code is not (and cannot
;;; be) be used in the "next" system. So, we drop it. ;;; be) be used in the "next" system. So, we drop it.

46
scheme/psyntax.library-manager.ss
View File

@ -50,7 +50,8 @@
(define-record library (define-record library
(id name version imp* vis* inv* subst env visit-state (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) (lambda (x p)
(unless (library? x) (unless (library? x)
(assertion-violation 'record-type-printer "not a library")) (assertion-violation 'record-type-printer "not a library"))
@ -199,7 +200,8 @@
[(try-load-from-file file-name)] [(try-load-from-file file-name)]
[else [else
((current-library-expander) ((current-library-expander)
(with-input-from-file file-name read-annotated))]))) (with-input-from-file file-name read-annotated)
file-name)])))
(lambda (f) (lambda (f)
(if (procedure? f) (if (procedure? f)
f f
@ -269,22 +271,30 @@
exp-env)) exp-env))
((current-library-collection) lib)) ((current-library-collection) lib))
(define (install-library id name ver imp* vis* inv* (define install-library
exp-subst exp-env visit-proc invoke-proc (case-lambda
visit-code invoke-code visible?) [(id name ver imp* vis* inv* exp-subst exp-env
(let ((imp-lib* (map find-library-by-spec/die imp*)) visit-proc invoke-proc visit-code invoke-code
(vis-lib* (map find-library-by-spec/die vis*)) visible? source-file-name)
(inv-lib* (map find-library-by-spec/die inv*))) (let ((imp-lib* (map find-library-by-spec/die imp*))
(unless (and (symbol? id) (list? name) (list? ver)) (vis-lib* (map find-library-by-spec/die vis*))
(assertion-violation 'install-library (inv-lib* (map find-library-by-spec/die inv*)))
"invalid spec with id/name/ver" id name ver)) (unless (and (symbol? id) (list? name) (list? ver))
(when (library-exists? name) (assertion-violation 'install-library
(assertion-violation 'install-library "invalid spec with id/name/ver" id name ver))
"library is already installed" name)) (when (library-exists? name)
(let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib* (assertion-violation 'install-library
exp-subst exp-env visit-proc invoke-proc "library is already installed" name))
visit-code invoke-code visible?))) (let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib*
(install-library-record 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! (define extend-library-subst!
(lambda (lib sym label) (lambda (lib sym label)