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
parent
30934965f3
commit
052e48e9e8
12
LOG
12
LOG
|
|
@ -905,3 +905,15 @@
|
|||
field names in define-record-type field specs.
|
||||
syntax.ss,
|
||||
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
249
mats/8.ms
|
|
@ -8730,6 +8730,255 @@
|
|||
"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
|
||||
(begin
|
||||
(with-output-to-file "testfile-clo-1a.ss"
|
||||
|
|
|
|||
|
|
@ -1566,13 +1566,24 @@ in fasl files does not generally make sense.
|
|||
%-----------------------------------------------------------------------------
|
||||
\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
|
||||
standalone \scheme{export} form to \scheme{(import \var{import-spec})} has been
|
||||
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
|
||||
directory in a state where a subsequent create operation fails with
|
||||
|
|
|
|||
14
s/compile.ss
14
s/compile.ss
|
|
@ -461,8 +461,8 @@
|
|||
(Inner : Inner (ir) -> Inner ()
|
||||
[,lsrc lsrc] ; NB: workaround for nanopass tag snafu
|
||||
[(program ,uid ,body) ($build-invoke-program uid body)]
|
||||
[(library/ct ,uid ,import-code ,visit-code)
|
||||
($build-install-library/ct-code uid import-code visit-code)]
|
||||
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
||||
($build-install-library/ct-code uid export-id* import-code visit-code)]
|
||||
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
||||
($build-install-library/rt-code uid dl* db* dv* de* body)]
|
||||
[else ir]))
|
||||
|
|
@ -916,7 +916,7 @@
|
|||
(program-node-ir-set! maybe-program ir)
|
||||
(values)])
|
||||
(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))
|
||||
(record-ct-lib-ir! uid ir)
|
||||
(values)])
|
||||
|
|
@ -1042,8 +1042,8 @@
|
|||
(define build-install-library/ct-code
|
||||
(lambda (node)
|
||||
(nanopass-case (Lexpand ctLibrary) (library-node-ctir node)
|
||||
[(library/ct ,uid ,import-code ,visit-code)
|
||||
($build-install-library/ct-code uid
|
||||
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
||||
($build-install-library/ct-code uid export-id*
|
||||
(if (library-node-visible? node) import-code void-pr)
|
||||
(if (library-node-visible? node) visit-code void-pr))])))
|
||||
|
||||
|
|
@ -1449,8 +1449,8 @@
|
|||
(Inner : Inner (ir) -> Expr ()
|
||||
[,lsrc lsrc]
|
||||
[(program ,uid ,body) ($build-invoke-program uid body)]
|
||||
[(library/ct ,uid ,import-code ,visit-code)
|
||||
($build-install-library/ct-code uid import-code visit-code)]
|
||||
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
||||
($build-install-library/ct-code uid export-id* import-code visit-code)]
|
||||
[(library/rt ,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)])
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@
|
|||
(Inner : Inner (ir) -> * (val)
|
||||
[,lsrc (go lsrc)]
|
||||
[(program ,uid ,body) (go ($build-invoke-program uid body))]
|
||||
[(library/ct ,uid ,import-code ,visit-code)
|
||||
(go ($build-install-library/ct-code uid import-code visit-code))]
|
||||
[(library/ct ,uid (,export-id* ...) ,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)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -80,10 +80,10 @@
|
|||
(define maybe-label? (lambda (x) (or (not x) (gensym? x))))
|
||||
|
||||
(define-language Lexpand
|
||||
(nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-1})
|
||||
(nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-2})
|
||||
(terminals
|
||||
(maybe-label (dl))
|
||||
(gensym (uid))
|
||||
(gensym (uid export-id))
|
||||
(library-path (path))
|
||||
(library-version (version))
|
||||
(maybe-optimization-loc (db))
|
||||
|
|
@ -110,7 +110,7 @@
|
|||
prog
|
||||
lsrc)
|
||||
(ctLibrary (ctlib)
|
||||
(library/ct uid import-code visit-code))
|
||||
(library/ct uid (export-id* ...) import-code visit-code))
|
||||
(rtLibrary (rtlib)
|
||||
(library/rt uid
|
||||
(dl* ...)
|
||||
|
|
|
|||
|
|
@ -666,8 +666,8 @@
|
|||
[,lsrc (ibeval lsrc)]
|
||||
[(program ,uid ,body)
|
||||
(ibeval ($build-invoke-program uid body))]
|
||||
[(library/ct ,uid ,import-code ,visit-code)
|
||||
(ibeval ($build-install-library/ct-code uid import-code visit-code))]
|
||||
[(library/ct ,uid (,export-id* ...) ,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)
|
||||
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
|
||||
[,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)]
|
||||
|
|
|
|||
60
s/syntax.ss
60
s/syntax.ss
|
|
@ -828,9 +828,10 @@
|
|||
,(build-sequence no-source init*)))))
|
||||
|
||||
(define build-top-library/ct
|
||||
(lambda (uid import-code* visit-code*)
|
||||
(lambda (uid export-id* import-code* visit-code*)
|
||||
(with-output-language (Lexpand ctLibrary)
|
||||
`(library/ct ,uid
|
||||
(,export-id* ...)
|
||||
,(build-lambda no-source '()
|
||||
(build-sequence no-source import-code*))
|
||||
,(if (null? visit-code*)
|
||||
|
|
@ -2357,9 +2358,10 @@
|
|||
(mutable clo*) ; cross-library optimization information
|
||||
(mutable loaded-import-reqs)
|
||||
(mutable loaded-visit-reqs)
|
||||
(mutable export-id*) ; ids that need to be reset when visit-code raises an exception
|
||||
(mutable import-code)
|
||||
(mutable visit-code))
|
||||
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-1})
|
||||
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-2})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type rtdesc
|
||||
|
|
@ -2375,6 +2377,7 @@
|
|||
libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set!
|
||||
libdesc-import-code libdesc-import-code-set!
|
||||
libdesc-visit-code libdesc-visit-code-set!
|
||||
libdesc-visit-id* libdesc-visit-id*-set!
|
||||
libdesc-clo* libdesc-clo*-set!)
|
||||
(define get-ctdesc
|
||||
(lambda (desc)
|
||||
|
|
@ -2416,6 +2419,12 @@
|
|||
(define libdesc-visit-code-set!
|
||||
(lambda (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*
|
||||
(lambda (desc)
|
||||
(ctdesc-clo* (get-ctdesc desc))))
|
||||
|
|
@ -2460,10 +2469,15 @@
|
|||
(when (eq? p 'pending)
|
||||
($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc)))
|
||||
(libdesc-visit-code-set! desc 'pending)
|
||||
(on-reset
|
||||
(begin
|
||||
(for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc))
|
||||
(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))]))]
|
||||
(p))
|
||||
(libdesc-visit-code-set! desc #f)
|
||||
(libdesc-visit-id*-set! desc '()))]))]
|
||||
[else ($oops #f "library ~:s is not defined" uid)])))
|
||||
|
||||
(define invoke-library
|
||||
|
|
@ -2480,8 +2494,9 @@
|
|||
(when (eq? p 'pending)
|
||||
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
|
||||
(libdesc-invoke-code-set! desc 'pending)
|
||||
(on-reset (libdesc-invoke-code-set! desc p)
|
||||
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
|
||||
(p)
|
||||
(p))
|
||||
(libdesc-invoke-code-set! desc #f))]))]
|
||||
[else ($oops #f "library ~:s is not defined" uid)])))
|
||||
|
||||
|
|
@ -2525,8 +2540,9 @@
|
|||
(when (eq? p 'pending)
|
||||
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
|
||||
(libdesc-invoke-code-set! desc 'pending)
|
||||
(on-reset (libdesc-invoke-code-set! desc p)
|
||||
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
|
||||
(p)
|
||||
(p))
|
||||
(libdesc-invoke-code-set! desc #f))]))
|
||||
(unless (memp (lambda (x) (eq? (libreq-uid x) 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
|
||||
; 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-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
|
||||
(top-level-eval-hook
|
||||
(build-lambda no-source '()
|
||||
|
|
@ -2666,6 +2682,13 @@
|
|||
build-void
|
||||
(lambda ()
|
||||
(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
|
||||
`(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*)
|
||||
,@(if (null? env*)
|
||||
|
|
@ -4632,11 +4655,12 @@
|
|||
(when desc (put-library-descriptor uid desc)))))
|
||||
|
||||
(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)])
|
||||
(unless desc (sorry! who "unable to install visit code for non-existent library ~s" uid))
|
||||
(let ([ctdesc (libdesc-ctdesc desc)])
|
||||
(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-visit-code-set! ctdesc visit-code)))))
|
||||
|
||||
|
|
@ -5077,7 +5101,8 @@
|
|||
[(#t) (void)]
|
||||
[(#f)
|
||||
(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)]
|
||||
[(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))]))))))
|
||||
(define load-visit-library
|
||||
|
|
@ -5091,8 +5116,9 @@
|
|||
[(#t) (void)]
|
||||
[(#f)
|
||||
(libdesc-loaded-visit-reqs-set! desc 'pending)
|
||||
(on-reset (libdesc-loaded-visit-reqs-set! desc #f)
|
||||
(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))
|
||||
(for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc)))
|
||||
(libdesc-loaded-visit-reqs-set! desc #t)]
|
||||
[(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))]))))))
|
||||
(define load-import-library
|
||||
|
|
@ -5106,7 +5132,8 @@
|
|||
[(#t) (void)]
|
||||
[(#f)
|
||||
(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)]
|
||||
[(pending) ($oops #f "cyclic dependency involving import of library ~s" (libdesc-path desc))]))))))
|
||||
(define import-library
|
||||
|
|
@ -5261,9 +5288,10 @@
|
|||
(build-lambda no-source '() body))))
|
||||
|
||||
(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-data no-source uid)
|
||||
(build-data no-source export-id*)
|
||||
import-code
|
||||
visit-code)))
|
||||
|
||||
|
|
@ -5393,7 +5421,7 @@
|
|||
(library/ct-info-visit-visit-req* linfo/ct)
|
||||
(library/ct-info-visit-req* linfo/ct)
|
||||
(library/ct-info-clo* linfo/ct)
|
||||
#f #f 'loading 'loading)))))
|
||||
#f #f '() 'loading 'loading)))))
|
||||
|
||||
(set! $install-library/rt-desc
|
||||
(lambda (linfo/rt for-import? ofn)
|
||||
|
|
@ -5405,8 +5433,8 @@
|
|||
uid ofn (make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading)))))
|
||||
|
||||
(set! $install-library/ct-code
|
||||
(lambda (uid import-code visit-code)
|
||||
(install-library/ct-code uid import-code visit-code)))
|
||||
(lambda (uid export-id* import-code visit-code)
|
||||
(install-library/ct-code uid export-id* import-code visit-code)))
|
||||
|
||||
(set! $install-library/rt-code
|
||||
(lambda (uid invoke-code)
|
||||
|
|
@ -5482,7 +5510,7 @@
|
|||
(lambda (path uid)
|
||||
(install-library path uid
|
||||
(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)))))
|
||||
(set! $make-base-modules
|
||||
(lambda ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user