Parser now prints an IN:/USING: form if restarts were invoked; add more restarts for certain errors
parent
84d1a91966
commit
6085557116
|
|
@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs
|
|||
definitions effects classes.builtin classes.tuple io.files
|
||||
classes continuations hashtables classes.mixin classes.union
|
||||
classes.intersection classes.predicate classes.singleton
|
||||
combinators quotations sets accessors colors ;
|
||||
combinators quotations sets accessors colors parser ;
|
||||
IN: prettyprint
|
||||
|
||||
: make-pprint ( obj quot -- block in use )
|
||||
|
|
@ -48,6 +48,22 @@ IN: prettyprint
|
|||
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
|
||||
use. in. ;
|
||||
|
||||
: vocab-names ( words -- vocabs )
|
||||
dictionary get
|
||||
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
|
||||
|
||||
: prelude. ( -- )
|
||||
in get use get vocab-names vocabs. ;
|
||||
|
||||
[
|
||||
nl
|
||||
"Restarts were invoked adding vocabularies to the search path." print
|
||||
"To avoid doing this in the future, add the following USING:" print
|
||||
"and IN: forms at the top of the source file:" print nl
|
||||
prelude.
|
||||
nl
|
||||
] print-use-hook set-global
|
||||
|
||||
: with-use ( obj quot -- )
|
||||
make-pprint vocabs. do-pprint ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,12 @@ SYMBOL: in
|
|||
|
||||
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
|
||||
|
||||
ERROR: no-current-vocab ;
|
||||
TUPLE: no-current-vocab ;
|
||||
|
||||
: no-current-vocab ( -- vocab )
|
||||
\ no-current-vocab boa
|
||||
{ { "Define words in scratchpad vocabulary" "scratchpad" } }
|
||||
throw-restarts dup set-in ;
|
||||
|
||||
: current-vocab ( -- str )
|
||||
in get [ no-current-vocab ] unless* ;
|
||||
|
|
@ -64,20 +69,31 @@ ERROR: no-current-vocab ;
|
|||
|
||||
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
|
||||
|
||||
: word-restarts ( possibilities -- restarts )
|
||||
natural-sort [
|
||||
: word-restarts ( possibilities name -- restarts )
|
||||
[
|
||||
natural-sort
|
||||
[
|
||||
"Use the " swap vocabulary>> " vocabulary" 3append
|
||||
] keep
|
||||
] { } map>assoc ;
|
||||
[ "Use the " swap vocabulary>> " vocabulary" 3append ] keep
|
||||
] { } map>assoc
|
||||
]
|
||||
[ "Defer word in current vocabulary" swap 2array ] bi*
|
||||
suffix ;
|
||||
|
||||
ERROR: no-word-error name ;
|
||||
|
||||
SYMBOL: amended-use?
|
||||
|
||||
: no-word-restarted ( restart-value -- word )
|
||||
dup word?
|
||||
[ amended-use? on dup vocabulary>> (use+) ]
|
||||
[ create-in ]
|
||||
if ;
|
||||
|
||||
: no-word ( name -- newword )
|
||||
dup \ no-word-error boa
|
||||
swap words-named [ forward-reference? not ] filter
|
||||
swap [ words-named [ forward-reference? not ] filter ] keep
|
||||
word-restarts throw-restarts
|
||||
dup vocabulary>> (use+) ;
|
||||
no-word-restarted ;
|
||||
|
||||
: check-forward ( str word -- word/f )
|
||||
dup forward-reference? [
|
||||
|
|
@ -127,7 +143,9 @@ ERROR: staging-violation word ;
|
|||
: parsed ( accum obj -- accum ) over push ;
|
||||
|
||||
: (parse-lines) ( lexer -- quot )
|
||||
[ f parse-until >quotation ] with-lexer ;
|
||||
[
|
||||
f parse-until >quotation
|
||||
] with-lexer ;
|
||||
|
||||
: parse-lines ( lines -- quot )
|
||||
lexer-factory get call (parse-lines) ;
|
||||
|
|
@ -206,8 +224,18 @@ SYMBOL: interactive-vocabs
|
|||
call
|
||||
] with-scope ; inline
|
||||
|
||||
SYMBOL: print-use-hook
|
||||
|
||||
[ ] print-use-hook set-global
|
||||
|
||||
: parse-fresh ( lines -- quot )
|
||||
[ parse-lines ] with-file-vocabs ;
|
||||
[
|
||||
amended-use? off
|
||||
parse-lines
|
||||
amended-use? get [
|
||||
print-use-hook get call
|
||||
] when
|
||||
] with-file-vocabs ;
|
||||
|
||||
: parsing-file ( file -- )
|
||||
"quiet" get [
|
||||
|
|
|
|||
Loading…
Reference in New Issue