! Copyright (C) 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. IN: xy USING: accessors arrays assocs combinators io kernel locals make math math.parser namespaces peg peg.ebnf sequences strings ; :: linrec ( if-quot: ( -- ? ) then-quot: ( -- ) else1-quot: ( -- ) else2-quot: ( -- ) -- ) if-quot call [ then-quot call ] [ else1-quot call if-quot then-quot else1-quot else2-quot linrec else2-quot call ] if ; inline recursive :: unfold ( seed p: ( seed -- ? ) f: ( seed -- o ) g: ( seed -- seed' ) -- ) [ seed [ dup p call ] [ ] [ dup f call , g call ] [ ] linrec ] { } make nip ; inline TUPLE: token-number value ; TUPLE: token-word value ; TUPLE: token-string value ; EBNF: tokenize-xy Digit = [0-9] Digits = Digit+ Number = Digits &(Space | Punctuation | !(.)) => [[ string>number token-number boa ]] Letter = [a-zA-Z] SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]] MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]] Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment Spaces = Space* => [[ ignore ]] Punctuation = "(" | ")" | "[" | "]" | ";" String = '"' (!('"') .) '"' => [[ second >string token-string boa ]] Word = !(String) (!(Space | Punctuation) .)+ => [[ >string token-word boa ]] Tok = Spaces (Number | Word | String | Punctuation ) Toks = Tok* Spaces ;EBNF TUPLE: ast-number value ; TUPLE: ast-word value ; TUPLE: ast-string value ; TUPLE: ast-quot-open ; TUPLE: ast-quot-close ; TUPLE: ast-list-open ; TUPLE: ast-list-close ; TUPLE: ast-list value ; TUPLE: ast-quot value ; TUPLE: ast-define ; TUPLE: ast-define-start ; GENERIC: (@pprint) ( ast -- ) M: ast-number (@pprint) ( ast -- ) value>> # ; M: ast-word (@pprint) ( ast -- ) value>> % ; M: ast-string (@pprint) ( ast -- ) CHAR: " , value>> % CHAR: " , ; M: ast-quot-open (@pprint) ( ast -- ) drop CHAR: [ , ; M: ast-quot-close (@pprint) ( ast -- ) drop CHAR: ] , ; M: ast-list-open (@pprint) ( ast -- ) drop CHAR: ( , ; M: ast-list-close (@pprint) ( ast -- ) drop CHAR: ) , ; M: ast-list (@pprint) ( ast -- ) CHAR: ( , " " % value>> [ (@pprint) " " % ] each CHAR: ) , ; M: ast-quot (@pprint) ( ast -- ) CHAR: [ , " " % value>> [ (@pprint) " " % ] each CHAR: ] , ; M: ast-define (@pprint) ( ast -- ) drop CHAR: ; , ; M: ast-define-start (@pprint) ( ast -- ) drop CHAR: ; , ; : @pprint ( ast -- string ) [ (@pprint) ] "" make ; EBNF: parse-xy tokenizer = Word = . ?[ token-word? ]? => [[ value>> ast-word boa ]] Number = . ?[ token-number? ]? => [[ value>> ast-number boa ]] String = . ?[ token-string? ]? => [[ value>> ast-string boa ]] QuotOpen = "[" => [[ drop ast-quot-open boa ]] QuotClose = "]" => [[ drop ast-quot-close boa ]] ListOpen = "(" => [[ drop ast-list-open boa ]] ListClose = ")" => [[ drop ast-list-close boa ]] Define = ";" => [[ drop ast-define boa ]] Sequence = QuotOpen | QuotClose | ListOpen | ListClose XY = (Word | Number | String | Sequence | Define)+ ;EBNF TUPLE: XY env x y ; :: y-empty? ( xy -- ? ) xy y>> empty? ; :: y-pop ( xy -- xy y ) xy env>> xy x>> xy y>> unclip [ XY boa ] dip ; :: y-push ( xy y -- xy ) xy env>> xy x>> xy y>> y prefix XY boa ; :: y-pop-tail ( xy -- xy y ) xy env>> xy x>> xy y>> 1 cut* first [ XY boa ] dip ; :: y-compose ( xy seq -- xy ) xy env>> xy x>> seq xy y>> append XY boa ; :: x-push ( xy x -- xy ) xy env>> xy x>> x suffix xy y>> XY boa ; :: y-push-tail ( xy y -- xy ) xy env>> xy x>> xy y>> y suffix XY boa ; :: x-pop ( xy -- xy x ) xy env>> xy x>> 1 cut* first [ xy y>> XY boa ] dip ; :: x-pop2 ( xy -- xy x1 x2 ) xy env>> xy x>> 2 cut* first2 [ xy y>> XY boa ] 2dip ; SYMBOL: foo SYMBOL: -> SYMBOL: <- SYMBOL: => SYMBOL: <= SYMBOL: xy/ SYMBOL: xy\ : (x@eval) ( xy -- xy ) y-pop { { [ dup \ xy/ = ] [ drop x-pop y-compose ] } { [ dup \ xy\ = ] [ drop y-pop x-push ] } { [ dup \ -> = ] [ drop x-pop >>y ] } { [ dup \ <- = ] [ drop x-pop >>x ] } { [ dup \ => = ] [ drop x-pop y-push-tail ] } { [ dup \ <= = ] [ drop y-pop-tail x-push ] } { [ dup \ * = ] [ drop x-pop2 * x-push ] } { [ dup \ + = ] [ drop x-pop2 + x-push ] } { [ dup foo = ] [ drop { 1 + foo } y-compose ] } [ x-push ] } cond ; GENERIC: (@eval) ( xy v -- xy ) M: object (@eval) ( xy ast-number -- xy ) x-push ; :: quot-active? ( xy -- ? ) xy x>> [ dup ast-quot-open? swap ast-define-start? or ] find-last nip ; :: @eval-word ( xy ast-word -- xy ) ast-word value>> { { [ dup "`" = ] [ drop xy x-pop dup ast-list? over ast-quot? or [ value>> first ] [ 1array ast-list boa ] if x-push ] } { [ dup "=>" = ] [ drop xy x-pop y-push-tail ] } { [ dup "<=" = ] [ drop xy y-pop-tail x-push ] } { [ dup "->" = ] [ drop xy x-pop value>> >>y ] } { [ dup "<-" = ] [ drop xy x-pop >>x ] } { [ dup "\\" = ] [ drop xy y-pop x-push ] } { [ dup "/" = ] [ drop xy x-pop value>> y-compose ] } { [ dup "+" = ] [ drop xy x-pop2 [ value>> ] bi@ + ast-number boa x-push ] } { [ dup "-" = ] [ drop xy x-pop2 [ value>> ] bi@ - ast-number boa x-push ] } { [ dup "*" = ] [ drop xy x-pop2 [ value>> ] bi@ * ast-number boa x-push ] } [ xy env>> at [ xy swap y-compose ] [ xy ast-word x-push ] if* ] } cond ; M:: ast-word (@eval) ( xy ast-word -- xy ) ast-word value>> { { [ dup "\\" = ] [ drop xy y-pop x-push ] } { [ dup "/" = ] [ drop xy x-pop dup ast-word? [ dup value>> xy env>> at [ nip ] when* ] [ value>> ] if y-compose ] } [ drop xy quot-active? [ xy ast-word x-push ] [ xy ast-word @eval-word ] if ] } cond ; M:: ast-quot-close (@eval) ( xy ast-quot-close -- xy ) xy x>> [ ast-quot-open? ] find-last [ xy env>> xy x>> rot cut 1 tail ast-quot boa xy y>> swap prefix XY boa ] [ drop xy ast-quot-close x-push ] if ; M:: ast-list-close (@eval) ( xy ast-quot-close -- xy ) xy x>> [ ast-list-open? ] find-last [ xy env>> xy x>> rot cut 1 tail ast-list boa xy y>> swap prefix XY boa ] [ "mismatched start/end markers" throw ] if ; :: @eval-ast-define ( index env x y -- xy ) x index cut 1 tail unclip value>> env clone [ set-at ] keep swap y XY boa ; M:: ast-define (@eval) ( xy ast-define -- xy ) xy x>> [ ast-define-start? ] find-last [ xy [ env>> ] [ x>> ] [ y>> ] tri @eval-ast-define ] [ drop xy ast-define-start boa x-push ] if ; : @eval1 ( xy -- xy ) y-pop (@eval) ; : @eval ( xy -- xy ) [ dup y-empty? ] [ ] [ @eval1 ] [ ] linrec ; : default-env ( -- env ) [ ] H{ } make-assoc ; : xy ( string -- xy ) parse-xy [ default-env { } ] dip XY boa ; : @step ( xy -- xy ) @eval1 dup [ x>> ast-list boa @pprint write " -> " write ] [ y>> ast-quot boa @pprint print ] bi ;