Parser now prints an IN:/USING: form if restarts were invoked; add more restarts for certain errors

db4
Slava Pestov 2008-11-19 16:03:05 -06:00
parent 84d1a91966
commit 6085557116
2 changed files with 55 additions and 11 deletions

View File

@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton classes.intersection classes.predicate classes.singleton
combinators quotations sets accessors colors ; combinators quotations sets accessors colors parser ;
IN: prettyprint IN: prettyprint
: make-pprint ( obj quot -- block in use ) : make-pprint ( obj quot -- block in use )
@ -48,6 +48,22 @@ IN: prettyprint
dupd remove [ { "syntax" "scratchpad" } member? not ] filter dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ; 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 -- ) : with-use ( obj quot -- )
make-pprint vocabs. do-pprint ; inline make-pprint vocabs. do-pprint ; inline

View File

@ -52,7 +52,12 @@ SYMBOL: in
M: parsing-word stack-effect drop (( parsed -- parsed )) ; 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 ) : current-vocab ( -- str )
in get [ no-current-vocab ] unless* ; in get [ no-current-vocab ] unless* ;
@ -64,20 +69,31 @@ ERROR: no-current-vocab ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ; : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
: word-restarts ( possibilities -- restarts ) : word-restarts ( possibilities name -- restarts )
natural-sort [ [
natural-sort
[ [
"Use the " swap vocabulary>> " vocabulary" 3append [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep
] keep ] { } map>assoc
] { } map>assoc ; ]
[ "Defer word in current vocabulary" swap 2array ] bi*
suffix ;
ERROR: no-word-error name ; 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 ) : no-word ( name -- newword )
dup \ no-word-error boa dup \ no-word-error boa
swap words-named [ forward-reference? not ] filter swap [ words-named [ forward-reference? not ] filter ] keep
word-restarts throw-restarts word-restarts throw-restarts
dup vocabulary>> (use+) ; no-word-restarted ;
: check-forward ( str word -- word/f ) : check-forward ( str word -- word/f )
dup forward-reference? [ dup forward-reference? [
@ -127,7 +143,9 @@ ERROR: staging-violation word ;
: parsed ( accum obj -- accum ) over push ; : parsed ( accum obj -- accum ) over push ;
: (parse-lines) ( lexer -- quot ) : (parse-lines) ( lexer -- quot )
[ f parse-until >quotation ] with-lexer ; [
f parse-until >quotation
] with-lexer ;
: parse-lines ( lines -- quot ) : parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ; lexer-factory get call (parse-lines) ;
@ -206,8 +224,18 @@ SYMBOL: interactive-vocabs
call call
] with-scope ; inline ] with-scope ; inline
SYMBOL: print-use-hook
[ ] print-use-hook set-global
: parse-fresh ( lines -- quot ) : 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 -- ) : parsing-file ( file -- )
"quiet" get [ "quiet" get [