refactor state parser
parent
72fcd2b133
commit
b6d8521c8c
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io io.streams.string kernel math namespaces sequences
|
USING: io io.streams.string kernel math namespaces sequences
|
||||||
strings circular prettyprint debugger ascii ;
|
strings circular prettyprint debugger ascii sbufs fry inspector
|
||||||
|
accessors sequences.lib ;
|
||||||
IN: state-parser
|
IN: state-parser
|
||||||
|
|
||||||
! * Basic underlying words
|
! * Basic underlying words
|
||||||
|
@ -11,50 +12,56 @@ TUPLE: spot char line column next ;
|
||||||
|
|
||||||
C: <spot> spot
|
C: <spot> spot
|
||||||
|
|
||||||
: get-char ( -- char ) spot get spot-char ;
|
: get-char ( -- char ) spot get char>> ;
|
||||||
: set-char ( char -- ) spot get set-spot-char ;
|
: set-char ( char -- ) spot get swap >>char drop ;
|
||||||
: get-line ( -- line ) spot get spot-line ;
|
: get-line ( -- line ) spot get line>> ;
|
||||||
: set-line ( line -- ) spot get set-spot-line ;
|
: set-line ( line -- ) spot get swap >>line drop ;
|
||||||
: get-column ( -- column ) spot get spot-column ;
|
: get-column ( -- column ) spot get column>> ;
|
||||||
: set-column ( column -- ) spot get set-spot-column ;
|
: set-column ( column -- ) spot get swap >>column drop ;
|
||||||
: get-next ( -- char ) spot get spot-next ;
|
: get-next ( -- char ) spot get next>> ;
|
||||||
: set-next ( char -- ) spot get set-spot-next ;
|
: set-next ( char -- ) spot get swap >>next drop ;
|
||||||
|
|
||||||
! * Errors
|
! * Errors
|
||||||
TUPLE: parsing-error line column ;
|
TUPLE: parsing-error line column ;
|
||||||
: <parsing-error> ( -- parsing-error )
|
|
||||||
get-line get-column parsing-error boa ;
|
|
||||||
|
|
||||||
: construct-parsing-error ( ... slots class -- error )
|
: parsing-error ( class -- obj )
|
||||||
construct <parsing-error> over set-delegate ; inline
|
new
|
||||||
|
get-line >>line
|
||||||
|
get-column >>column ;
|
||||||
|
M: parsing-error summary ( obj -- str )
|
||||||
|
[
|
||||||
|
"Parsing error" print
|
||||||
|
"Line: " write dup line>> .
|
||||||
|
"Column: " write column>> .
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
: parsing-error. ( parsing-error -- )
|
TUPLE: expected < parsing-error should-be was ;
|
||||||
"Parsing error" print
|
: expected ( should-be was -- * )
|
||||||
"Line: " write dup parsing-error-line .
|
\ expected parsing-error
|
||||||
"Column: " write parsing-error-column . ;
|
swap >>was
|
||||||
|
swap >>should-be throw ;
|
||||||
|
M: expected summary ( obj -- str )
|
||||||
|
[
|
||||||
|
dup call-next-method write
|
||||||
|
"Token expected: " write dup should-be>> print
|
||||||
|
"Token present: " write was>> print
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: expected should-be was ;
|
TUPLE: unexpected-end < parsing-error ;
|
||||||
: <expected> ( should-be was -- error )
|
: unexpected-end \ unexpected-end parsing-error throw ;
|
||||||
{ set-expected-should-be set-expected-was }
|
M: unexpected-end summary ( obj -- str )
|
||||||
expected construct-parsing-error ;
|
[
|
||||||
M: expected error.
|
call-next-method write
|
||||||
dup parsing-error.
|
"File unexpectedly ended." print
|
||||||
"Token expected: " write dup expected-should-be print
|
] with-string-writer ;
|
||||||
"Token present: " write expected-was print ;
|
|
||||||
|
|
||||||
TUPLE: unexpected-end ;
|
TUPLE: missing-close < parsing-error ;
|
||||||
: <unexpected-end> ( -- unexpected-end )
|
: missing-close \ missing-close parsing-error throw ;
|
||||||
{ } unexpected-end construct-parsing-error ;
|
M: missing-close summary ( obj -- str )
|
||||||
M: unexpected-end error.
|
[
|
||||||
parsing-error.
|
call-next-method write
|
||||||
"File unexpectedly ended." print ;
|
"Missing closing token." print
|
||||||
|
] with-string-writer ;
|
||||||
TUPLE: missing-close ;
|
|
||||||
: <missing-close> ( -- missing-close )
|
|
||||||
{ } missing-close construct-parsing-error ;
|
|
||||||
M: missing-close error.
|
|
||||||
parsing-error.
|
|
||||||
"Missing closing token." print ;
|
|
||||||
|
|
||||||
SYMBOL: prolog-data
|
SYMBOL: prolog-data
|
||||||
|
|
||||||
|
@ -65,7 +72,8 @@ SYMBOL: prolog-data
|
||||||
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if
|
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if
|
||||||
set-column ;
|
set-column ;
|
||||||
|
|
||||||
: (next) ( -- char ) ! this normalizes \r\n and \r
|
! (next) normalizes \r\n and \r
|
||||||
|
: (next) ( -- char )
|
||||||
get-next read1
|
get-next read1
|
||||||
2dup swap CHAR: \r = [
|
2dup swap CHAR: \r = [
|
||||||
CHAR: \n =
|
CHAR: \n =
|
||||||
|
@ -75,10 +83,7 @@ SYMBOL: prolog-data
|
||||||
|
|
||||||
: next ( -- )
|
: next ( -- )
|
||||||
#! Increment spot.
|
#! Increment spot.
|
||||||
get-char [
|
get-char [ unexpected-end ] unless (next) record ;
|
||||||
<unexpected-end> throw
|
|
||||||
] unless
|
|
||||||
(next) record ;
|
|
||||||
|
|
||||||
: next* ( -- )
|
: next* ( -- )
|
||||||
get-char [ (next) record ] when ;
|
get-char [ (next) record ] when ;
|
||||||
|
@ -95,9 +100,9 @@ SYMBOL: prolog-data
|
||||||
#! Take the substring of a string starting at spot
|
#! Take the substring of a string starting at spot
|
||||||
#! from code until the quotation given is true and
|
#! from code until the quotation given is true and
|
||||||
#! advance spot to after the substring.
|
#! advance spot to after the substring.
|
||||||
[ [
|
10 <sbuf> [
|
||||||
dup slip swap dup [ get-char , ] unless
|
'[ @ [ t ] [ get-char , push f ] if ] skip-until
|
||||||
] skip-until ] "" make nip ; inline
|
] keep >string ; inline
|
||||||
|
|
||||||
: take-rest ( -- string )
|
: take-rest ( -- string )
|
||||||
[ f ] take-until ;
|
[ f ] take-until ;
|
||||||
|
@ -105,6 +110,20 @@ SYMBOL: prolog-data
|
||||||
: take-char ( ch -- string )
|
: take-char ( ch -- string )
|
||||||
[ dup get-char = ] take-until nip ;
|
[ dup get-char = ] take-until nip ;
|
||||||
|
|
||||||
|
TUPLE: not-enough-characters < parsing-error ;
|
||||||
|
: not-enough-characters
|
||||||
|
\ not-enough-characters parsing-error throw ;
|
||||||
|
M: not-enough-characters summary ( obj -- str )
|
||||||
|
[
|
||||||
|
call-next-method write
|
||||||
|
"Not enough characters" print
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
|
: take ( n -- string )
|
||||||
|
[ 1- ] [ <sbuf> ] bi [
|
||||||
|
'[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop
|
||||||
|
] keep get-char [ over push ] when* >string ;
|
||||||
|
|
||||||
: pass-blank ( -- )
|
: pass-blank ( -- )
|
||||||
#! Advance code past any whitespace, including newlines
|
#! Advance code past any whitespace, including newlines
|
||||||
[ get-char blank? not ] skip-until ;
|
[ get-char blank? not ] skip-until ;
|
||||||
|
@ -117,16 +136,16 @@ SYMBOL: prolog-data
|
||||||
dup length <circular-string>
|
dup length <circular-string>
|
||||||
[ 2dup string-matches? ] take-until nip
|
[ 2dup string-matches? ] take-until nip
|
||||||
dup length rot length 1- - head
|
dup length rot length 1- - head
|
||||||
get-char [ <missing-close> throw ] unless next ;
|
get-char [ missing-close ] unless next ;
|
||||||
|
|
||||||
: expect ( ch -- )
|
: expect ( ch -- )
|
||||||
get-char 2dup = [ 2drop ] [
|
get-char 2dup = [ 2drop ] [
|
||||||
>r 1string r> 1string <expected> throw
|
>r 1string r> 1string expected
|
||||||
] if next ;
|
] if next ;
|
||||||
|
|
||||||
: expect-string ( string -- )
|
: expect-string ( string -- )
|
||||||
dup [ drop get-char next ] map 2dup =
|
dup [ drop get-char next ] map 2dup =
|
||||||
[ 2drop ] [ <expected> throw ] if ;
|
[ 2drop ] [ expected ] if ;
|
||||||
|
|
||||||
: init-parser ( -- )
|
: init-parser ( -- )
|
||||||
0 1 0 f <spot> spot set
|
0 1 0 f <spot> spot set
|
||||||
|
|
Loading…
Reference in New Issue