(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
- scan {
+ scan-token {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
- scan create-function
+ scan-token create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
- scan {
+ scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
dup search dup lexical? [ nip ] [ drop ] if ;
: scan-string-param ( -- name/param )
- scan >string-param ;
+ scan-token >string-param ;
: scan-c-type-param ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
- scan {
- { [ dup not ] [ unexpected-eof ] }
+ scan-token {
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name-delim ( end-delim string/f -- ? )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
+ ! Check for mistakes of this form:
+ !
+ ! TUPLE: blahblah foo bing
+ !
+ ! : ...
{
- { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
: parse-tuple-slots-delim ( end-delim -- )
- dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+ dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
: parse-slot-name ( string/f -- ? )
";" swap parse-slot-name-delim ;
2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
: parse-slot-value ( class slots -- )
- scan check-slot-name scan-object 2array , scan {
- { f [ \ } unexpected-eof ] }
+ scan check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
2dup parse-slot-value
- scan {
- { f [ 2drop \ } unexpected-eof ] }
+ scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
[ 2nip bad-literal-tuple ]
assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
- scan {
- { f [ unexpected-eof ] }
+ scan-token {
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
: parse-effect-value ( token -- value )
":" ?tail [
- scan {
+ scan-token {
{ [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
[ parse-word dup class? [ bad-effect ] unless ]
} cond 2array
] when ;
HELP: scan
{ $values { "str/f" { $maybe string } } }
-{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word outputs " { $link f } " on end of input. To throw an error on end of input, use " { $link scan-token } " instead." }
+$parsing-note ;
+
+HELP: scan-token
+{ $values { "str" string } }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link scan } " instead." }
$parsing-note ;
HELP: still-parsing?
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
io vectors arrays math.parser combinators continuations
: push-parsing-word ( word -- )
lexer-parsing-word new
- swap >>word
- lexer get [
- [ line>> >>line ]
- [ line-text>> >>line-text ]
- [ column>> >>column ] tri
- ] [ parsing-words>> push ] bi ;
+ swap >>word
+ lexer get [
+ [ line>> >>line ]
+ [ line-text>> >>line-text ]
+ [ column>> >>column ] tri
+ ] [ parsing-words>> push ] bi ;
: pop-parsing-word ( -- )
lexer get parsing-words>> pop drop ;
[ line-text>> ]
} cleave subseq ;
-: parse-token ( lexer -- str/f )
+: parse-token ( lexer -- str/f )
dup still-parsing? [
dup skip-blank
dup still-parsing-line?
: unexpected-eof ( word -- * ) f unexpected ;
+: scan-token ( -- str ) scan [ "token" unexpected-eof ] unless* ;
+
: expect ( token -- )
- scan
- [ 2dup = [ 2drop ] [ unexpected ] if ]
- [ unexpected-eof ]
- if* ;
+ scan-token 2dup = [ 2drop ] [ unexpected ] if ;
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
- [ scan ] 2dip {
- { [ 2over = ] [ 3drop ] }
- { [ pick not ] [ drop unexpected-eof ] }
- [ [ nip call ] [ each-token ] 2bi ]
- } cond ; inline recursive
+ [ scan-token ] 2dip 2over =
+ [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
collector [ each-token ] dip { } like ; inline
: <lexer-error> ( msg -- error )
\ lexer-error new
- lexer get [
- [ line>> >>line ]
- [ column>> >>column ] bi
- ] [
- [ line-text>> >>line-text ]
- [ parsing-words>> clone >>parsing-words ] bi
- ] bi
- swap >>error ;
+ lexer get [
+ [ line>> >>line ]
+ [ column>> >>column ] bi
+ ] [
+ [ line-text>> >>line-text ]
+ [ parsing-words>> clone >>parsing-words ] bi
+ ] bi
+ swap >>error ;
: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
[ (parsing-word-lexer-dump) ] if ;
: lexer-dump ( error -- )
- dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
+ dup parsing-words>>
+ [ simple-lexer-dump ]
+ [ last parsing-word-lexer-dump ] if-empty ;
: with-lexer ( lexer quot -- newquot )
[ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
+{ $subsections
+ scan-token
+ scan-object
+}
+"Lower-level words:"
{ $subsections
scan
scan-word
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ;
+
+HELP: scan-object
+{ $values { "object" object } }
+{ $description "Parses a literal representation of an object." }
+$parsing-note ;
"#!" [ POSTPONE: ! ] define-core-syntax
- "IN:" [ scan set-current-vocab ] define-core-syntax
+ "IN:" [ scan-token set-current-vocab ] define-core-syntax
"<PRIVATE" [ begin-private ] define-core-syntax
"PRIVATE>" [ end-private ] define-core-syntax
- "USE:" [ scan use-vocab ] define-core-syntax
+ "USE:" [ scan-token use-vocab ] define-core-syntax
- "UNUSE:" [ scan unuse-vocab ] define-core-syntax
+ "UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
"USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
- "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
+ "QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
- "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
+ "QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
"FROM:" [
- scan "=>" expect ";" parse-tokens add-words-from
+ scan-token "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
- scan "=>" expect ";" parse-tokens add-words-excluding
+ scan-token "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
- scan scan "=>" expect scan add-renamed-word
+ scan-token scan-token "=>" expect scan-token add-renamed-word
] define-core-syntax
"HEX:" [ 16 parse-base ] define-core-syntax
"t" "syntax" lookup define-singleton-class
"CHAR:" [
- scan {
+ scan-token {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call( name -- char ) ]
] define-core-syntax
"DEFER:" [
- scan current-vocab create
+ scan-token current-vocab create
[ fake-definition ] [ set-word ] [ undefined-def define ] tri
] define-core-syntax
"PREDICATE:" [
CREATE-CLASS
- scan "<" assert=
+ "<" expect
scan-word
parse-definition define-predicate-class
] define-core-syntax
] define-core-syntax
"SLOT:" [
- scan define-protocol-slot
+ scan-token define-protocol-slot
] define-core-syntax
"C:" [