Deploy tool: if debugger is not stripped out, actually use it to report errors; print an error if vocab has no MAIN: word

db4
Slava Pestov 2009-02-16 19:00:09 -06:00
parent 1f273a852a
commit 20053c7f5c
4 changed files with 45 additions and 23 deletions

View File

@ -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 . ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ( -- )