listener: move pprint error catching to stack.

db4
John Benediktsson 2012-06-01 17:54:58 -07:00
parent a2d2bfc9d1
commit d9e1f20286
2 changed files with 15 additions and 14 deletions

View File

@ -93,13 +93,6 @@ t error-summary? set-global
] tabular-output nl ] tabular-output nl
] unless-empty ; ] unless-empty ;
: print-stack ( seq -- )
[
[ short. ]
[ drop "~pprint error~" swap write-object nl ]
recover
] each ;
: trimmed-stack. ( seq -- ) : trimmed-stack. ( seq -- )
dup length max-stack-items get > [ dup length max-stack-items get > [
max-stack-items get cut* max-stack-items get cut*
@ -107,7 +100,7 @@ t error-summary? set-global
[ length number>string "(" " more items)" surround ] keep [ length number>string "(" " more items)" surround ] keep
write-object nl write-object nl
] dip ] dip
] when print-stack ; ] when stack. ;
: datastack. ( datastack -- ) : datastack. ( datastack -- )
display-stacks? get [ display-stacks? get [

View File

@ -1,10 +1,11 @@
! Copyright (C) 2003, 2010 Slava Pestov. ! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors assocs colors combinators grouping io USING: arrays accessors assocs classes colors combinators
io.streams.string io.styles kernel make math math.parser namespaces continuations grouping io io.streams.string io.styles kernel
parser prettyprint.backend prettyprint.config prettyprint.custom make math math.parser namespaces parser prettyprint.backend
prettyprint.sections quotations sequences sorting strings vocabs prettyprint.config prettyprint.custom prettyprint.sections
vocabs.prettyprint words sets generic ; quotations sequences sorting strings vocabs vocabs.prettyprint
words sets generic ;
FROM: namespaces => set ; FROM: namespaces => set ;
IN: prettyprint IN: prettyprint
@ -38,7 +39,14 @@ IN: prettyprint
: .o ( n -- ) >oct print ; : .o ( n -- ) >oct print ;
: .h ( n -- ) >hex print ; : .h ( n -- ) >hex print ;
: stack. ( seq -- ) [ short. ] each ; : stack. ( seq -- )
[
[ short. ] [
drop
[ class-of name>> "~pprint error: " "~" surround ]
keep write-object nl
] recover
] each ;
: .s ( -- ) datastack stack. ; : .s ( -- ) datastack stack. ;
: .r ( -- ) retainstack stack. ; : .r ( -- ) retainstack stack. ;