diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 23fd101991..5f7431ecf3 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -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 . ; diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index ff851edce6..7d8f357240 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -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 ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 600b1d8d55..0dea093081 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 0a0aa82c52..7ba5cee507 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -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 ( -- )