diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 485f0f5fa7..44291a96cc 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,13 +1,15 @@ ! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays alien.libraries accessors io.backend io.encodings.utf8 io.files -io.streams.c init fry namespaces math make assocs kernel parser -parser.notes lexer strings.parser vocabs sequences sequences.deep -sequences.private words memory kernel.private continuations io -vocabs.loader system strings sets vectors quotations byte-arrays -sorting compiler.units definitions generic generic.standard -generic.single tools.deploy.config combinators classes vocabs.loader.private -classes.builtin slots.private grouping command-line io.pathnames ; +USING: arrays alien.libraries accessors io.backend +io.encodings.utf8 io.files io.streams.c init fry namespaces math +make assocs kernel parser parser.notes lexer strings.parser +vocabs sequences sequences.deep sequences.private words memory +kernel.private continuations io vocabs.loader system strings +sets vectors quotations byte-arrays sorting compiler.units +definitions generic generic.standard generic.single +tools.deploy.config combinators combinators.private classes +vocabs.loader.private classes.builtin slots.private grouping +command-line io.pathnames ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes.private QUALIFIED: compiler.crossref @@ -548,10 +550,18 @@ SYMBOL: deploy-vocab strip-words clear-megamorphic-caches ; +: die-with ( error original-error -- * ) + #! We don't want DCE to drop the error before the die call! + [ die 1 exit ] (( a -- * )) call-effect-unsafe ; + +: die-with2 ( error original-error -- * ) + #! We don't want DCE to drop the error before the die call! + [ die 1 exit ] (( a b -- * )) call-effect-unsafe ; + : deploy-error-handler ( quot -- ) [ strip-debugger? - [ error-continuation get call>> callstack>array die 1 exit ] + [ original-error get die-with2 ] ! Don't reference these words literally, if we're stripping the ! debugger out we don't want to load the prettyprinter at all [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index b7565e7d9e..5faeab0e2d 100644 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/basis/tools/deploy/shaker/strip-debugger.factor @@ -1,17 +1,13 @@ USING: compiler.units words vocabs kernel threads.private ; IN: debugger -: consume ( error -- ) - #! We don't want DCE to drop the error before the die call! - drop ; +: error. ( error -- ) original-error get die-with2 ; -: print-error ( error -- ) die consume ; - -: error. ( error -- ) die consume ; +: print-error ( error -- ) error. ; "threads" vocab [ [ "error-in-thread" "threads" lookup - [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi + [ [ drop error. ] define ] [ f "combination" set-word-prop ] bi ] with-compilation-unit ] when