steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

refactor state parser

db4
Doug Coleman 2008-05-02 17:11:51 -05:00
parent 72fcd2b133
commit b6d8521c8c
1 changed files with 68 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

117
extra/state-parser/state-parser.factor
View File

@ -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