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:
parent
30934965f3
commit
052e48e9e8
12
LOG
12
LOG
|
@ -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
249
mats/8.ms
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
14
s/compile.ss
14
s/compile.ss
|
@ -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)])
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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* ...)
|
||||||
|
|
|
@ -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)]
|
||||||
|
|
70
s/syntax.ss
70
s/syntax.ss
|
@ -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 ()
|
||||||
|
|
Loading…
Reference in New Issue
Block a user