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