factor/core/parser/parser.factor

282 lines
6.6 KiB
Factor

! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
sequences strings vectors words words.symbol quotations io
combinators sorting splitting math.parser effects continuations
io.files io.streams.string vocabs io.encodings.utf8 source-files
classes hashtables compiler.errors compiler.units accessors sets
lexer vocabs.parser ;
IN: parser
: location ( -- loc )
file get lexer get line>> 2dup and
[ [ path>> ] dip 2array ] [ 2drop f ] if ;
: save-location ( definition -- )
location remember-definition ;
SYMBOL: parser-notes
t parser-notes set-global
: parser-notes? ( -- ? )
parser-notes get "quiet" get not and ;
: note. ( str -- )
parser-notes? [
file get [ path>> write ":" write ] when*
lexer get [ line>> number>string write ": " write ] when*
"Note: " write dup print
] when drop ;
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
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* ;
: create-in ( str -- word )
current-vocab create dup set-word dup save-location ;
: CREATE ( -- word ) scan create-in ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
SYMBOL: amended-use
SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word? [
dup vocabulary>>
[ (use+) ]
[ amended-use get dup [ push ] [ 2drop ] if ]
[ "Added ``" "'' vocabulary to search path" surround note. ]
tri
] [ create-in ] if ;
: no-word ( name -- newword )
dup words-named [ forward-reference? not ] filter
dup length 1 = auto-use? get and
[ nip first no-word-restarted ]
[ <no-word-error> throw-restarts no-word-restarted ]
if ;
: check-forward ( str word -- word/f )
dup forward-reference? [
drop
use get
[ at ] with map sift
[ forward-reference? not ] find nip
] [
nip
] if ;
: search ( str -- word/f )
dup use get assoc-stack check-forward ;
: scan-word ( -- word/number/f )
scan dup [
dup search [ ] [
dup string>number [ ] [ no-word ] ?if
] ?if
] when ;
ERROR: staging-violation word ;
: execute-parsing ( word -- )
dup changed-definitions get key? [ staging-violation ] when
execute ;
: scan-object ( -- object )
scan-word dup parsing-word?
[ V{ } clone swap execute-parsing first ] when ;
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing-word? ] [ nip execute-parsing t ] }
[ pick push drop t ]
} cond ;
: (parse-until) ( accum end -- accum )
[ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
: parse-until ( end -- vec )
100 <vector> swap (parse-until) ;
: parsed ( accum obj -- accum ) over push ;
: (parse-lines) ( lexer -- quot )
[
f parse-until >quotation
] with-lexer ;
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
: parse-literal ( accum end quot -- accum )
[ parse-until ] dip call parsed ; inline
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
: (:) ( -- word def ) CREATE-WORD parse-definition ;
ERROR: bad-number ;
: parse-base ( parsed base -- parsed )
scan swap base> [ bad-number ] unless* parsed ;
SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
[
f in set { "syntax" } set-use
bootstrap-syntax get [ use get push ] when*
call
] with-scope ; inline
SYMBOL: interactive-vocabs
{
"accessors"
"arrays"
"assocs"
"combinators"
"compiler"
"compiler.errors"
"compiler.units"
"continuations"
"debugger"
"definitions"
"editors"
"help"
"inspector"
"io"
"io.files"
"kernel"
"listener"
"math"
"math.order"
"memory"
"namespaces"
"prettyprint"
"sequences"
"slicing"
"sorting"
"stack-checker"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.threads"
"tools.time"
"tools.vocabs"
"vocabs"
"vocabs.loader"
"words"
"scratchpad"
} interactive-vocabs set-global
: with-interactive-vocabs ( quot -- )
[
"scratchpad" in set
interactive-vocabs get set-use
call
] with-scope ; inline
SYMBOL: print-use-hook
print-use-hook global [ [ ] or ] change-at
!
: parse-fresh ( lines -- quot )
[
V{ } clone amended-use set
parse-lines
amended-use get empty? [ print-use-hook get call ] unless
] with-file-vocabs ;
: parsing-file ( file -- )
"quiet" get [ drop ] [ "Loading " write print flush ] if ;
: filter-moved ( assoc1 assoc2 -- seq )
swap assoc-diff [
drop where dup [ first ] when
file get path>> =
] assoc-filter keys ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
[ get first2 assoc-union ] bi@ ;
: removed-classes ( -- assoc1 assoc2 )
new-definitions old-definitions
[ get second ] bi@ ;
: forget-removed-definitions ( -- )
removed-definitions filter-moved forget-all ;
: reset-removed-classes ( -- )
removed-classes
filter-moved [ class? ] filter [ forget-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2
filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
: forget-smudged ( -- )
forget-removed-definitions
reset-removed-classes
fix-class-words ;
: finish-parsing ( lines quot -- )
file get
[ record-form ]
[ record-definitions ]
[ record-checksum ]
tri ;
: parse-stream ( stream name -- quot )
[
[
lines dup parse-fresh
tuck finish-parsing
forget-smudged
] with-source-file
] with-compilation-unit ;
: parse-file-restarts ( file -- restarts )
"Load " " again" surround t 2array 1array ;
: parse-file ( file -- quot )
[
[
[ parsing-file ] keep
[ utf8 <file-reader> ] keep
parse-stream
] with-compiler-errors
] [
over parse-file-restarts rethrow-restarts
drop parse-file
] recover ;
: run-file ( file -- )
[ parse-file call ] curry assert-depth ;
: ?run-file ( path -- )
dup exists? [ run-file ] [ drop ] if ;