committing @akeep library change with rebuilt boot files:

- fixed an issue with the library system where an exception that occurs
  during visit or revisit left the library in an inconsistent state that
  caused it to appear that it was still in the process of running.  This
  manifested in it raising a cyclic dependency exception, even though
  there really is not a cyclic dependency.  The various library
  management functions involved will now reset the part of the library
  when an exception occurs.  This also means that if the library visit
  or revisit failed for a transient reason (such as a missing or
  incorrect library version that can be fixed by updating the
  library-directories) it is now possible to recover from these errors.
    expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss,
    8.ms

original commit: 6dbd72496fb4eaf5fb65453d0ae0a75f0ef2ad80
This commit is contained in:
dyb 2018-04-05 21:28:33 -07:00
parent 30934965f3
commit 052e48e9e8
8 changed files with 337 additions and 37 deletions

12
LOG
View File

@ -905,3 +905,15 @@
field names in define-record-type field specs. field names in define-record-type field specs.
syntax.ss, syntax.ss,
record.ms, root-experr* record.ms, root-experr*
- fixed an issue with the library system where an exception that occurs
during visit or revisit left the library in an inconsistent state that
caused it to appear that it was still in the process of running. This
manifested in it raising a cyclic dependency exception, even though
there really is not a cyclic dependency. The various library
management functions involved will now reset the part of the library
when an exception occurs. This also means that if the library visit
or revisit failed for a transient reason (such as a missing or
incorrect library version that can be fixed by updating the
library-directories) it is now possible to recover from these errors.
expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss,
8.ms

249
mats/8.ms
View File

@ -8730,6 +8730,255 @@
"revisiting testfile-l6-prog1\n#((10 . 12))\n") "revisiting testfile-l6-prog1\n#((10 . 12))\n")
) )
(mat library-regression
; test that failing invoke code does not result in cyclic dependency problem on re-run
(equal?
(separate-eval
'(begin
(library (invoke-fail)
(export x)
(import (chezscheme))
(define x #f)
(error #f "failed to load library (invoke-fail)"))
(guard (e [else
(guard (e2 [else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'x (environment '(chezscheme) '(invoke-fail))))])
(eval 'x (environment '(chezscheme) '(invoke-fail))))))
"Exception: failed to load library (invoke-fail)\nException: failed to load library (invoke-fail)\n")
; test that true cyclic dependency will always report the same thing
(equal?
(separate-eval
'(begin
(library (invoke-cyclic)
(export x y)
(import (chezscheme))
(define x #f)
(define y (eval '(if x 5 10) (environment '(chezscheme) '(invoke-cyclic)))))
(guard (e [else
(guard (e2 [else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'x (environment '(chezscheme) '(invoke-cyclic))))])
(eval 'x (environment '(chezscheme) '(invoke-cyclic))))))
"Exception: cyclic dependency involving invocation of library (invoke-cyclic)\nException: cyclic dependency involving invocation of library (invoke-cyclic)\n")
(begin
; library to help make it easier to cause a failure in the visit-code that
; does not lead to failure during compilation of the file.
(with-output-to-file "testfile-lr-l1.ss"
(lambda ()
(pretty-print
'(library (testfile-lr-l1)
(export make-it-fail)
(import (chezscheme))
(define make-it-fail (make-parameter #f (lambda (x) (and x #t)))))))
'replace)
; simple test to define one macro and potentially to raise an error when
; defining the second one.
(with-output-to-file "testfile-lr-l2.ss"
(lambda ()
(pretty-print
'(library (testfile-lr-l2)
(export M1 M2)
(import (chezscheme) (testfile-lr-l1))
(define-syntax M1
(identifier-syntax #f))
(define-syntax M2
(if (make-it-fail)
(error 'M2 "user requested failure with (make-it-fail) parameter")
(lambda (x)
(syntax-case x ()
[(_ expr) #'expr])))))))
'replace)
; more complete test that attempts to create the various types of things
; that can be defined in visit code so that we can verify things are being
; properly reset.
(with-output-to-file "testfile-lr-l3.ss"
(lambda ()
(pretty-print
'(library (testfile-lr-l3)
(export a b c d e f g h)
(import (chezscheme) (testfile-lr-l1))
(module a (x) (define x 5))
(alias b cons)
(define-syntax c (make-compile-time-value 5))
(define d 5)
(meta define e 5)
(define-syntax f (identifier-syntax #f))
(define $g (make-parameter #f))
(define-syntax g
(make-variable-transformer
(lambda (x)
(syntax-case x ()
[(set! _ v) #'($g v)]
[_ #'($g)]
[(_ e* ...) #'(($g) e* ...)]))))
(define-property f g 10)
(define-syntax h
(if (make-it-fail)
(error 'h "user requested failure with (make-it-fail) parameter")
(lambda (x)
(syntax-case x ()
[(_ expr) #'expr])))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t])
(for-each compile-library x)))
'(list "testfile-lr-l1" "testfile-lr-l2" "testfile-lr-l3"))
#t)
(equal?
(separate-eval
'(begin
(import (testfile-lr-l2) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'M1 (environment '(testfile-lr-l2))))])
(eval 'M1 (environment '(testfile-lr-l2))))))
"Exception in M2: user requested failure with (make-it-fail) parameter\nException in M2: user requested failure with (make-it-fail) parameter\n")
; module is defined as part of import code, run time bindings are setup as part of invoke code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(import a)
x))
"5\n")
; alias is part of module binding ribcage, set up by import code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(b 'a 'b)))
"(a . b)\n")
; compile-time-value is set in visit code, should show same error each time it is referenced
(equal?
(separate-eval
'(begin
(library (lookup)
(export lookup)
(import (chezscheme))
(define-syntax lookup
(lambda (x)
(syntax-case x ()
[(_ id) (lambda (rho) #`'#,(rho #'id))]
[(_ id key) (lambda (rho) #`'#,(rho #'id #'key))]))))
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))])
(eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; defines are set up as part of invoke code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
d))
"5\n")
; meta defines are set up as part of visit code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval '(let ()
(define-syntax get-e
(lambda (x)
(syntax-case x ()
[(_) #`'#,e])))
(get-e))
(environment '(chezscheme) '(testfile-lr-l3))))])
(eval '(let ()
(define-syntax get-e
(lambda (x)
(syntax-case x ()
[(_) #`'#,e])))
(get-e))
(environment '(chezscheme) '(testfile-lr-l3))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; macros are set up as part of visit code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'f (environment '(testfile-lr-l3))))])
(eval 'f (environment '(testfile-lr-l3))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; variable transformer macros are set up as part of visit code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'g (environment '(testfile-lr-l3))))])
(eval 'g (environment '(testfile-lr-l3))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; properties are setup as part of visit code.
(equal?
(separate-eval
'(begin
(library (lookup)
(export lookup)
(import (chezscheme))
(define-syntax lookup
(lambda (x)
(syntax-case x ()
[(_ id) (lambda (rho) #`'#,(rho #'id))]
[(_ id key) (lambda (rho) #`'#,(rho #'id #'key))]))))
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))])
(eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
)
(mat cross-library-optimization (mat cross-library-optimization
(begin (begin
(with-output-to-file "testfile-clo-1a.ss" (with-output-to-file "testfile-clo-1a.ss"

View File

@ -1566,13 +1566,24 @@ in fasl files does not generally make sense.
%----------------------------------------------------------------------------- %-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes} \section{Bug Fixes}\label{section:bugfixes}
\subsection{Incomplete handling of import specs within standalone export forms} \subsection{Misleading cyclic dependency error (9.5)}
The library system no longer reports a cyclic dependency error
during the second and subsequent attempts to visit or invoke a
library after the first attempt fails for some reason other than
an actual cyclic dependency.
The fix also allows a library to be visited or invoked successfully
on the second or subsequent attempt if the visit or invoke failed
for a transient reason, such as a missing or incorrect version in
an imported library.
\subsection{Incomplete handling of import specs within standalone export forms (9.5)}
A bug that limited the \scheme{(import \var{import-spec} \dots)} form within a A bug that limited the \scheme{(import \var{import-spec} \dots)} form within a
standalone \scheme{export} form to \scheme{(import \var{import-spec})} has been standalone \scheme{export} form to \scheme{(import \var{import-spec})} has been
fixed. fixed.
\subsection{Permission denied after deleting files or directories in Windows} \subsection{Permission denied after deleting files or directories in Windows (9.5)}
In Windows, deleting a file or directory briefly leaves the file or In Windows, deleting a file or directory briefly leaves the file or
directory in a state where a subsequent create operation fails with directory in a state where a subsequent create operation fails with

View File

@ -461,8 +461,8 @@
(Inner : Inner (ir) -> Inner () (Inner : Inner (ir) -> Inner ()
[,lsrc lsrc] ; NB: workaround for nanopass tag snafu [,lsrc lsrc] ; NB: workaround for nanopass tag snafu
[(program ,uid ,body) ($build-invoke-program uid body)] [(program ,uid ,body) ($build-invoke-program uid body)]
[(library/ct ,uid ,import-code ,visit-code) [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
($build-install-library/ct-code uid import-code visit-code)] ($build-install-library/ct-code uid export-id* import-code visit-code)]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
($build-install-library/rt-code uid dl* db* dv* de* body)] ($build-install-library/rt-code uid dl* db* dv* de* body)]
[else ir])) [else ir]))
@ -916,7 +916,7 @@
(program-node-ir-set! maybe-program ir) (program-node-ir-set! maybe-program ir)
(values)]) (values)])
(ctLibrary : ctLibrary (ir situation) -> * () (ctLibrary : ctLibrary (ir situation) -> * ()
[(library/ct ,uid ,import-code ,visit-code) [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(when (eq? situation 'revisit) ($oops who "encountered revisit-only compile-time library ~s while processing wpo file ~s" (lookup-path uid) ifn)) (when (eq? situation 'revisit) ($oops who "encountered revisit-only compile-time library ~s while processing wpo file ~s" (lookup-path uid) ifn))
(record-ct-lib-ir! uid ir) (record-ct-lib-ir! uid ir)
(values)]) (values)])
@ -1042,8 +1042,8 @@
(define build-install-library/ct-code (define build-install-library/ct-code
(lambda (node) (lambda (node)
(nanopass-case (Lexpand ctLibrary) (library-node-ctir node) (nanopass-case (Lexpand ctLibrary) (library-node-ctir node)
[(library/ct ,uid ,import-code ,visit-code) [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
($build-install-library/ct-code uid ($build-install-library/ct-code uid export-id*
(if (library-node-visible? node) import-code void-pr) (if (library-node-visible? node) import-code void-pr)
(if (library-node-visible? node) visit-code void-pr))]))) (if (library-node-visible? node) visit-code void-pr))])))
@ -1449,8 +1449,8 @@
(Inner : Inner (ir) -> Expr () (Inner : Inner (ir) -> Expr ()
[,lsrc lsrc] [,lsrc lsrc]
[(program ,uid ,body) ($build-invoke-program uid body)] [(program ,uid ,body) ($build-invoke-program uid body)]
[(library/ct ,uid ,import-code ,visit-code) [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
($build-install-library/ct-code uid import-code visit-code)] ($build-install-library/ct-code uid export-id* import-code visit-code)]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
($build-install-library/rt-code uid dl* db* dv* de* body)] ($build-install-library/rt-code uid dl* db* dv* de* body)]
[else (sorry! who "unexpected Lexpand record ~s" ir)]) [else (sorry! who "unexpected Lexpand record ~s" ir)])

View File

@ -26,8 +26,8 @@
(Inner : Inner (ir) -> * (val) (Inner : Inner (ir) -> * (val)
[,lsrc (go lsrc)] [,lsrc (go lsrc)]
[(program ,uid ,body) (go ($build-invoke-program uid body))] [(program ,uid ,body) (go ($build-invoke-program uid body))]
[(library/ct ,uid ,import-code ,visit-code) [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(go ($build-install-library/ct-code uid import-code visit-code))] (go ($build-install-library/ct-code uid export-id* import-code visit-code))]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(go ($build-install-library/rt-code uid dl* db* dv* de* body))] (go ($build-install-library/rt-code uid dl* db* dv* de* body))]
[,linfo/ct `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct) [,linfo/ct `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct)

View File

@ -80,10 +80,10 @@
(define maybe-label? (lambda (x) (or (not x) (gensym? x)))) (define maybe-label? (lambda (x) (or (not x) (gensym? x))))
(define-language Lexpand (define-language Lexpand
(nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-1}) (nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-2})
(terminals (terminals
(maybe-label (dl)) (maybe-label (dl))
(gensym (uid)) (gensym (uid export-id))
(library-path (path)) (library-path (path))
(library-version (version)) (library-version (version))
(maybe-optimization-loc (db)) (maybe-optimization-loc (db))
@ -110,7 +110,7 @@
prog prog
lsrc) lsrc)
(ctLibrary (ctlib) (ctLibrary (ctlib)
(library/ct uid import-code visit-code)) (library/ct uid (export-id* ...) import-code visit-code))
(rtLibrary (rtlib) (rtLibrary (rtlib)
(library/rt uid (library/rt uid
(dl* ...) (dl* ...)

View File

@ -666,8 +666,8 @@
[,lsrc (ibeval lsrc)] [,lsrc (ibeval lsrc)]
[(program ,uid ,body) [(program ,uid ,body)
(ibeval ($build-invoke-program uid body))] (ibeval ($build-invoke-program uid body))]
[(library/ct ,uid ,import-code ,visit-code) [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(ibeval ($build-install-library/ct-code uid import-code visit-code))] (ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))] (ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
[,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)] [,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)]

View File

@ -828,9 +828,10 @@
,(build-sequence no-source init*))))) ,(build-sequence no-source init*)))))
(define build-top-library/ct (define build-top-library/ct
(lambda (uid import-code* visit-code*) (lambda (uid export-id* import-code* visit-code*)
(with-output-language (Lexpand ctLibrary) (with-output-language (Lexpand ctLibrary)
`(library/ct ,uid `(library/ct ,uid
(,export-id* ...)
,(build-lambda no-source '() ,(build-lambda no-source '()
(build-sequence no-source import-code*)) (build-sequence no-source import-code*))
,(if (null? visit-code*) ,(if (null? visit-code*)
@ -2357,9 +2358,10 @@
(mutable clo*) ; cross-library optimization information (mutable clo*) ; cross-library optimization information
(mutable loaded-import-reqs) (mutable loaded-import-reqs)
(mutable loaded-visit-reqs) (mutable loaded-visit-reqs)
(mutable export-id*) ; ids that need to be reset when visit-code raises an exception
(mutable import-code) (mutable import-code)
(mutable visit-code)) (mutable visit-code))
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-1}) (nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-2})
(sealed #t)) (sealed #t))
(define-record-type rtdesc (define-record-type rtdesc
@ -2375,6 +2377,7 @@
libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set! libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set!
libdesc-import-code libdesc-import-code-set! libdesc-import-code libdesc-import-code-set!
libdesc-visit-code libdesc-visit-code-set! libdesc-visit-code libdesc-visit-code-set!
libdesc-visit-id* libdesc-visit-id*-set!
libdesc-clo* libdesc-clo*-set!) libdesc-clo* libdesc-clo*-set!)
(define get-ctdesc (define get-ctdesc
(lambda (desc) (lambda (desc)
@ -2416,6 +2419,12 @@
(define libdesc-visit-code-set! (define libdesc-visit-code-set!
(lambda (desc x) (lambda (desc x)
(ctdesc-visit-code-set! (get-ctdesc desc) x))) (ctdesc-visit-code-set! (get-ctdesc desc) x)))
(define libdesc-visit-id*
(lambda (desc)
(ctdesc-export-id* (get-ctdesc desc))))
(define libdesc-visit-id*-set!
(lambda (desc x)
(ctdesc-export-id*-set! (get-ctdesc desc) x)))
(define libdesc-clo* (define libdesc-clo*
(lambda (desc) (lambda (desc)
(ctdesc-clo* (get-ctdesc desc)))) (ctdesc-clo* (get-ctdesc desc))))
@ -2460,10 +2469,15 @@
(when (eq? p 'pending) (when (eq? p 'pending)
($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc)))
(libdesc-visit-code-set! desc 'pending) (libdesc-visit-code-set! desc 'pending)
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc)) (on-reset
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc)) (begin
(p) (for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc))
(libdesc-visit-code-set! desc #f))]))] (libdesc-visit-code-set! desc p))
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc))
(p))
(libdesc-visit-code-set! desc #f)
(libdesc-visit-id*-set! desc '()))]))]
[else ($oops #f "library ~:s is not defined" uid)]))) [else ($oops #f "library ~:s is not defined" uid)])))
(define invoke-library (define invoke-library
@ -2480,8 +2494,9 @@
(when (eq? p 'pending) (when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending) (libdesc-invoke-code-set! desc 'pending)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc)) (on-reset (libdesc-invoke-code-set! desc p)
(p) (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))] (libdesc-invoke-code-set! desc #f))]))]
[else ($oops #f "library ~:s is not defined" uid)]))) [else ($oops #f "library ~:s is not defined" uid)])))
@ -2525,8 +2540,9 @@
(when (eq? p 'pending) (when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending) (libdesc-invoke-code-set! desc 'pending)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc)) (on-reset (libdesc-invoke-code-set! desc p)
(p) (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))])) (libdesc-invoke-code-set! desc #f))]))
(unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*) (unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*)
(set! req* (cons (make-libreq (libdesc-path desc) (libdesc-version desc) uid) req*))))] (set! req* (cons (make-libreq (libdesc-path desc) (libdesc-version desc) uid) req*))))]
@ -2626,7 +2642,7 @@
(install-library library-path library-uid (install-library library-path library-uid
; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment ; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment
(make-libdesc library-path library-version outfn #f (make-libdesc library-path library-version outfn #f
(make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t #f #f) (make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-rtdesc invoke-req* #t (make-rtdesc invoke-req* #t
(top-level-eval-hook (top-level-eval-hook
(build-lambda no-source '() (build-lambda no-source '()
@ -2666,6 +2682,13 @@
build-void build-void
(lambda () (lambda ()
(build-top-library/ct library-uid (build-top-library/ct library-uid
; visit-time exports (making them available for reset on visit-code failure)
(fold-left (lambda (ls x)
(let ([label (car x)] [exp (cdr x)])
(if (and (pair? exp) (eq? (car exp) 'visit))
(cons label ls)
ls)))
'() env*)
; setup code ; setup code
`(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*) `(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*)
,@(if (null? env*) ,@(if (null? env*)
@ -4632,11 +4655,12 @@
(when desc (put-library-descriptor uid desc))))) (when desc (put-library-descriptor uid desc)))))
(define-who install-library/ct-code (define-who install-library/ct-code
(lambda (uid import-code visit-code) (lambda (uid export-id* import-code visit-code)
(let ([desc (get-library-descriptor uid)]) (let ([desc (get-library-descriptor uid)])
(unless desc (sorry! who "unable to install visit code for non-existent library ~s" uid)) (unless desc (sorry! who "unable to install visit code for non-existent library ~s" uid))
(let ([ctdesc (libdesc-ctdesc desc)]) (let ([ctdesc (libdesc-ctdesc desc)])
(unless ctdesc (sorry! who "unable to install visit code for revisit-only library ~s" uid)) (unless ctdesc (sorry! who "unable to install visit code for revisit-only library ~s" uid))
(ctdesc-export-id*-set! ctdesc export-id*)
(ctdesc-import-code-set! ctdesc import-code) (ctdesc-import-code-set! ctdesc import-code)
(ctdesc-visit-code-set! ctdesc visit-code))))) (ctdesc-visit-code-set! ctdesc visit-code)))))
@ -5077,7 +5101,8 @@
[(#t) (void)] [(#t) (void)]
[(#f) [(#f)
(libdesc-loaded-invoke-reqs-set! desc 'pending) (libdesc-loaded-invoke-reqs-set! desc 'pending)
(for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc)) (on-reset (libdesc-loaded-invoke-reqs-set! desc #f)
(for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc)))
(libdesc-loaded-invoke-reqs-set! desc #t)] (libdesc-loaded-invoke-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))])))))) [(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))]))))))
(define load-visit-library (define load-visit-library
@ -5091,8 +5116,9 @@
[(#t) (void)] [(#t) (void)]
[(#f) [(#f)
(libdesc-loaded-visit-reqs-set! desc 'pending) (libdesc-loaded-visit-reqs-set! desc 'pending)
(for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc)) (on-reset (libdesc-loaded-visit-reqs-set! desc #f)
(for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc)) (for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc))
(for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc)))
(libdesc-loaded-visit-reqs-set! desc #t)] (libdesc-loaded-visit-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))])))))) [(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))]))))))
(define load-import-library (define load-import-library
@ -5106,7 +5132,8 @@
[(#t) (void)] [(#t) (void)]
[(#f) [(#f)
(libdesc-loaded-import-reqs-set! desc 'pending) (libdesc-loaded-import-reqs-set! desc 'pending)
(for-each (make-load-req load-import-library path) (libdesc-import-req* desc)) (on-reset (libdesc-loaded-import-reqs-set! desc #f)
(for-each (make-load-req load-import-library path) (libdesc-import-req* desc)))
(libdesc-loaded-import-reqs-set! desc #t)] (libdesc-loaded-import-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving import of library ~s" (libdesc-path desc))])))))) [(pending) ($oops #f "cyclic dependency involving import of library ~s" (libdesc-path desc))]))))))
(define import-library (define import-library
@ -5261,9 +5288,10 @@
(build-lambda no-source '() body)))) (build-lambda no-source '() body))))
(set-who! $build-install-library/ct-code (set-who! $build-install-library/ct-code
(lambda (uid import-code visit-code) (lambda (uid export-id* import-code visit-code)
(build-primcall no-source 3 '$install-library/ct-code (build-primcall no-source 3 '$install-library/ct-code
(build-data no-source uid) (build-data no-source uid)
(build-data no-source export-id*)
import-code import-code
visit-code))) visit-code)))
@ -5393,7 +5421,7 @@
(library/ct-info-visit-visit-req* linfo/ct) (library/ct-info-visit-visit-req* linfo/ct)
(library/ct-info-visit-req* linfo/ct) (library/ct-info-visit-req* linfo/ct)
(library/ct-info-clo* linfo/ct) (library/ct-info-clo* linfo/ct)
#f #f 'loading 'loading))))) #f #f '() 'loading 'loading)))))
(set! $install-library/rt-desc (set! $install-library/rt-desc
(lambda (linfo/rt for-import? ofn) (lambda (linfo/rt for-import? ofn)
@ -5405,8 +5433,8 @@
uid ofn (make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading))))) uid ofn (make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading)))))
(set! $install-library/ct-code (set! $install-library/ct-code
(lambda (uid import-code visit-code) (lambda (uid export-id* import-code visit-code)
(install-library/ct-code uid import-code visit-code))) (install-library/ct-code uid export-id* import-code visit-code)))
(set! $install-library/rt-code (set! $install-library/rt-code
(lambda (uid invoke-code) (lambda (uid invoke-code)
@ -5482,7 +5510,7 @@
(lambda (path uid) (lambda (path uid)
(install-library path uid (install-library path uid
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t (make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t
(make-ctdesc '() '() '() '() '() #t #t #f #f) (make-ctdesc '() '() '() '() '() #t #t '() #f #f)
(make-rtdesc '() #t #f))))) (make-rtdesc '() #t #f)))))
(set! $make-base-modules (set! $make-base-modules
(lambda () (lambda ()