Deploy tool: if debugger is not stripped out, actually use it to report errors; print an error if vocab has no MAIN: word
parent
1f273a852a
commit
20053c7f5c
|
@ -70,7 +70,7 @@ M: string error. print ;
|
||||||
"Type :help for debugging help." print flush ;
|
"Type :help for debugging help." print flush ;
|
||||||
|
|
||||||
: try ( quot -- )
|
: try ( quot -- )
|
||||||
[ print-error-and-restarts ] recover ;
|
[ print-error-and-restarts ] recover ; inline
|
||||||
|
|
||||||
: expired-error. ( obj -- )
|
: expired-error. ( obj -- )
|
||||||
"Object did not survive image save/load: " write third . ;
|
"Object did not survive image save/load: " write third . ;
|
||||||
|
|
|
@ -58,25 +58,17 @@ DEFER: ?make-staging-image
|
||||||
: staging-command-line ( profile -- flags )
|
: staging-command-line ( profile -- flags )
|
||||||
[
|
[
|
||||||
"-staging" ,
|
"-staging" ,
|
||||||
|
|
||||||
dup empty? [
|
dup empty? [
|
||||||
"-i=" my-boot-image-name append ,
|
"-i=" my-boot-image-name append ,
|
||||||
] [
|
] [
|
||||||
dup but-last ?make-staging-image
|
dup but-last ?make-staging-image
|
||||||
|
|
||||||
"-resource-path=" "" resource-path append ,
|
"-resource-path=" "" resource-path append ,
|
||||||
|
|
||||||
"-i=" over but-last staging-image-name append ,
|
"-i=" over but-last staging-image-name append ,
|
||||||
|
|
||||||
"-run=tools.deploy.restage" ,
|
"-run=tools.deploy.restage" ,
|
||||||
] if
|
] if
|
||||||
|
|
||||||
"-output-image=" over staging-image-name append ,
|
"-output-image=" over staging-image-name append ,
|
||||||
|
|
||||||
"-include=" swap " " join append ,
|
"-include=" swap " " join append ,
|
||||||
|
|
||||||
strip-word-names? [ "-no-stack-traces" , ] when
|
strip-word-names? [ "-no-stack-traces" , ] when
|
||||||
|
|
||||||
"-no-user-init" ,
|
"-no-user-init" ,
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
|
@ -101,16 +93,11 @@ DEFER: ?make-staging-image
|
||||||
|
|
||||||
[
|
[
|
||||||
"-i=" bootstrap-profile staging-image-name append ,
|
"-i=" bootstrap-profile staging-image-name append ,
|
||||||
|
|
||||||
"-resource-path=" "" resource-path append ,
|
"-resource-path=" "" resource-path append ,
|
||||||
|
|
||||||
"-run=tools.deploy.shaker" ,
|
"-run=tools.deploy.shaker" ,
|
||||||
|
|
||||||
[ "-deploy-vocab=" prepend , ]
|
[ "-deploy-vocab=" prepend , ]
|
||||||
[ make-deploy-config "-deploy-config=" prepend , ] bi
|
[ make-deploy-config "-deploy-config=" prepend , ] bi
|
||||||
|
|
||||||
"-output-image=" prepend ,
|
"-output-image=" prepend ,
|
||||||
|
|
||||||
strip-word-names? [ "-no-stack-traces" , ] when
|
strip-word-names? [ "-no-stack-traces" , ] when
|
||||||
] { } make
|
] { } make
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
|
@ -104,3 +104,8 @@ M: quit-responder call-responder*
|
||||||
"tools.deploy.test.10" shake-and-bake
|
"tools.deploy.test.10" shake-and-bake
|
||||||
run-temp-image
|
run-temp-image
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
"tools.deploy.test.11" shake-and-bake
|
||||||
|
run-temp-image
|
||||||
|
] unit-test
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors io.backend io.streams.c init fry
|
USING: accessors io.backend io.streams.c init fry
|
||||||
namespaces make assocs kernel parser lexer strings.parser vocabs
|
namespaces make assocs kernel parser lexer strings.parser vocabs
|
||||||
|
@ -232,7 +232,6 @@ IN: tools.deploy.shaker
|
||||||
"tools"
|
"tools"
|
||||||
"io.launcher"
|
"io.launcher"
|
||||||
"random"
|
"random"
|
||||||
"compiler"
|
|
||||||
"stack-checker"
|
"stack-checker"
|
||||||
"bootstrap"
|
"bootstrap"
|
||||||
"listener"
|
"listener"
|
||||||
|
@ -241,7 +240,7 @@ IN: tools.deploy.shaker
|
||||||
strip-dictionary? [
|
strip-dictionary? [
|
||||||
"libraries" "alien" lookup ,
|
"libraries" "alien" lookup ,
|
||||||
|
|
||||||
{ } { "cpu" } strip-vocab-globals %
|
{ } { "cpu" "compiler" } strip-vocab-globals %
|
||||||
|
|
||||||
{
|
{
|
||||||
gensym
|
gensym
|
||||||
|
@ -359,12 +358,26 @@ IN: tools.deploy.shaker
|
||||||
|
|
||||||
SYMBOL: deploy-vocab
|
SYMBOL: deploy-vocab
|
||||||
|
|
||||||
: set-boot-quot* ( word -- )
|
: [:c] ( -- word ) ":c" "debugger" lookup ;
|
||||||
|
|
||||||
|
: [print-error] ( -- word ) "print-error" "debugger" lookup ;
|
||||||
|
|
||||||
|
: deploy-boot-quot ( word -- )
|
||||||
[
|
[
|
||||||
\ boot ,
|
[ boot ] %
|
||||||
init-hooks get values concat %
|
init-hooks get values concat %
|
||||||
,
|
strip-debugger? [ , ] [
|
||||||
strip-io? [ \ flush , ] unless
|
! Don't reference try directly
|
||||||
|
[:c]
|
||||||
|
[print-error]
|
||||||
|
'[
|
||||||
|
[ _ execute ] [
|
||||||
|
_ execute nl
|
||||||
|
_ execute
|
||||||
|
] recover
|
||||||
|
] %
|
||||||
|
] if
|
||||||
|
strip-io? [ [ flush ] % ] unless
|
||||||
[ 0 exit ] %
|
[ 0 exit ] %
|
||||||
] [ ] make
|
] [ ] make
|
||||||
set-boot-quot ;
|
set-boot-quot ;
|
||||||
|
@ -392,7 +405,7 @@ SYMBOL: deploy-vocab
|
||||||
strip-init-hooks
|
strip-init-hooks
|
||||||
strip-c-io
|
strip-c-io
|
||||||
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
|
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
|
||||||
deploy-vocab get vocab-main set-boot-quot*
|
deploy-vocab get vocab-main deploy-boot-quot
|
||||||
stripped-word-props
|
stripped-word-props
|
||||||
stripped-globals strip-globals
|
stripped-globals strip-globals
|
||||||
compress-byte-arrays
|
compress-byte-arrays
|
||||||
|
@ -401,16 +414,33 @@ SYMBOL: deploy-vocab
|
||||||
compress-wrappers
|
compress-wrappers
|
||||||
strip-words ;
|
strip-words ;
|
||||||
|
|
||||||
|
: deploy-error-handler ( quot -- )
|
||||||
|
[
|
||||||
|
strip-debugger?
|
||||||
|
[ error-continuation get call>> callstack>array die ]
|
||||||
|
! Don't reference these words literally, if we're stripping the
|
||||||
|
! debugger out we don't want to load the prettyprinter at all
|
||||||
|
[ [:c] nl [print-error] ] if
|
||||||
|
1 exit
|
||||||
|
] recover ; inline
|
||||||
|
|
||||||
: (deploy) ( final-image vocab config -- )
|
: (deploy) ( final-image vocab config -- )
|
||||||
#! Does the actual work of a deployment in the slave
|
#! Does the actual work of a deployment in the slave
|
||||||
#! stage2 image
|
#! stage2 image
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
|
strip-debugger? [
|
||||||
|
"debugger" require
|
||||||
|
"inspector" require
|
||||||
|
] unless
|
||||||
deploy-vocab set
|
deploy-vocab set
|
||||||
deploy-vocab get require
|
deploy-vocab get require
|
||||||
|
deploy-vocab get vocab-main [
|
||||||
|
"Vocabulary has no MAIN: word." print flush 1 exit
|
||||||
|
] unless
|
||||||
strip
|
strip
|
||||||
finish-deploy
|
finish-deploy
|
||||||
] [ error-continuation get call>> callstack>array die 1 exit ] recover
|
] deploy-error-handler
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
||||||
: do-deploy ( -- )
|
: do-deploy ( -- )
|
||||||
|
|
Loading…
Reference in New Issue