From b6d8521c8ceec6d2dec2906435823100399d853e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 May 2008 17:11:51 -0500 Subject: [PATCH] refactor state parser --- extra/state-parser/state-parser.factor | 117 ++++++++++++++----------- 1 file changed, 68 insertions(+), 49 deletions(-) diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 96ad4ca0b4..17d5377259 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. 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 ! * Basic underlying words @@ -11,50 +12,56 @@ TUPLE: spot char line column next ; C: spot -: get-char ( -- char ) spot get spot-char ; -: set-char ( char -- ) spot get set-spot-char ; -: get-line ( -- line ) spot get spot-line ; -: set-line ( line -- ) spot get set-spot-line ; -: get-column ( -- column ) spot get spot-column ; -: set-column ( column -- ) spot get set-spot-column ; -: get-next ( -- char ) spot get spot-next ; -: set-next ( char -- ) spot get set-spot-next ; +: get-char ( -- char ) spot get char>> ; +: set-char ( char -- ) spot get swap >>char drop ; +: get-line ( -- line ) spot get line>> ; +: set-line ( line -- ) spot get swap >>line drop ; +: get-column ( -- column ) spot get column>> ; +: set-column ( column -- ) spot get swap >>column drop ; +: get-next ( -- char ) spot get next>> ; +: set-next ( char -- ) spot get swap >>next drop ; ! * Errors TUPLE: parsing-error line column ; -: ( -- parsing-error ) - get-line get-column parsing-error boa ; -: construct-parsing-error ( ... slots class -- error ) - construct over set-delegate ; inline +: parsing-error ( class -- obj ) + 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 -- ) - "Parsing error" print - "Line: " write dup parsing-error-line . - "Column: " write parsing-error-column . ; +TUPLE: expected < parsing-error should-be was ; +: expected ( should-be was -- * ) + \ expected parsing-error + 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 ; -: ( should-be was -- error ) - { set-expected-should-be set-expected-was } - expected construct-parsing-error ; -M: expected error. - dup parsing-error. - "Token expected: " write dup expected-should-be print - "Token present: " write expected-was print ; +TUPLE: unexpected-end < parsing-error ; +: unexpected-end \ unexpected-end parsing-error throw ; +M: unexpected-end summary ( obj -- str ) + [ + call-next-method write + "File unexpectedly ended." print + ] with-string-writer ; -TUPLE: unexpected-end ; -: ( -- unexpected-end ) - { } unexpected-end construct-parsing-error ; -M: unexpected-end error. - parsing-error. - "File unexpectedly ended." print ; - -TUPLE: missing-close ; -: ( -- missing-close ) - { } missing-close construct-parsing-error ; -M: missing-close error. - parsing-error. - "Missing closing token." print ; +TUPLE: missing-close < parsing-error ; +: missing-close \ missing-close parsing-error throw ; +M: missing-close summary ( obj -- str ) + [ + call-next-method write + "Missing closing token." print + ] with-string-writer ; SYMBOL: prolog-data @@ -65,7 +72,8 @@ SYMBOL: prolog-data [ 0 get-line 1+ set-line ] [ get-column 1+ ] if set-column ; -: (next) ( -- char ) ! this normalizes \r\n and \r +! (next) normalizes \r\n and \r +: (next) ( -- char ) get-next read1 2dup swap CHAR: \r = [ CHAR: \n = @@ -75,10 +83,7 @@ SYMBOL: prolog-data : next ( -- ) #! Increment spot. - get-char [ - throw - ] unless - (next) record ; + get-char [ unexpected-end ] unless (next) record ; : next* ( -- ) get-char [ (next) record ] when ; @@ -95,9 +100,9 @@ SYMBOL: prolog-data #! Take the substring of a string starting at spot #! from code until the quotation given is true and #! advance spot to after the substring. - [ [ - dup slip swap dup [ get-char , ] unless - ] skip-until ] "" make nip ; inline + 10 [ + '[ @ [ t ] [ get-char , push f ] if ] skip-until + ] keep >string ; inline : take-rest ( -- string ) [ f ] take-until ; @@ -105,6 +110,20 @@ SYMBOL: prolog-data : take-char ( ch -- string ) [ 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- ] [ ] bi [ + '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + ] keep get-char [ over push ] when* >string ; + : pass-blank ( -- ) #! Advance code past any whitespace, including newlines [ get-char blank? not ] skip-until ; @@ -117,16 +136,16 @@ SYMBOL: prolog-data dup length [ 2dup string-matches? ] take-until nip dup length rot length 1- - head - get-char [ throw ] unless next ; + get-char [ missing-close ] unless next ; : expect ( ch -- ) get-char 2dup = [ 2drop ] [ - >r 1string r> 1string throw + >r 1string r> 1string expected ] if next ; : expect-string ( string -- ) dup [ drop get-char next ] map 2dup = - [ 2drop ] [ throw ] if ; + [ 2drop ] [ expected ] if ; : init-parser ( -- ) 0 1 0 f spot set