Paste: Almost XY in factor

Author:	doublec
Mode:	factor
Date:	Sat, 7 Feb 2009 03:57:01

Plain Text |

Delete Paste

! 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   = <foreign tokenize-xy Tok>
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 ; 

Annotation: case instead?

Author:	tylerg
Mode:	factor
Date:	Thu, 12 Feb 2009 04:58:37

Plain Text |

Delete Annotation

! cool! Also I'm stealing these unfold and linrec words for my utility file.
! But couldn't you have written the matching much simpler using "case" instead of "cond" ? 

SYMBOLS: foo
         ->
         <-
         =>
         <=
        xy/
        xy\ ;


: (x@eval) ( xy -- xy )
  y-pop {
    { xy/  [ x-pop y-compose ] }
    { xy\  [ y-pop x-push ] }
    { ->  [ x-pop >>y ] }
    { <-  [ x-pop >>x ] }
    { =>  [ x-pop y-push-tail ] }
    { <=  [ y-pop-tail x-push ] }
    { *  [ x-pop2 * x-push ] }
    { +  [ x-pop2 + x-push ] }
    { foo   [ { 1 + foo } y-compose ] }
    [ x-push ]
  } case ;

:: @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 ] }
    { "=>" [ xy x-pop y-push-tail ] }
    { "<=" [ xy y-pop-tail x-push ] }
    { "->" [ xy x-pop value>> >>y ] }
    { "<-" [ xy x-pop >>x ] }
    { "\\" [ xy y-pop x-push ] }
    { "/" [ xy x-pop value>> y-compose ] }
    { "+" [ xy x-pop2 [ value>> ] bi@ + ast-number boa x-push ] }
    { "-"[ xy x-pop2 [ value>> ] bi@ - ast-number boa x-push ] } 
    { "*" [ xy x-pop2 [ value>> ] bi@ * ast-number boa x-push ] } 
   [ xy env>> at [ xy swap y-compose ] [ xy ast-word x-push ] if* ]
  } case ;

New Annotation

Summary:
Author:
Mode:	textPostgreSQLPowerCenter Parameter Fileactionscriptadaada95ans-forth94antantlrantlr4apacheconfapdlapplescriptaspaspect-jassembly-agcassembly-agsassembly-arm32assembly-m68kassembly-macro32assembly-mcs51assembly-parrotassembly-r2000assembly-x86avroawkbbatchbbjbcelbeanshellbibtexbinsource-agccc#c++cfscriptchillcilclipsclojurecmakecobolcoffeescriptcoldfusioncplex-lpcsscsvcvs-commitddartdjangodockerfiledotdoxygendrawj2ddsssleiffelembperlerlangfactorfhtmlforthfortranfortran90foxprofreemarkergcbasicgettextgherkingnuplotgogradlegroovygsphaskellhaxehexhl7v2hlslhtaccesshtmlhxmli4glicalendariconidlinforminiinno-setupinterlisiojamonjavajava module-infojavaccjavafxjavascriptjcljedit-actionsjflexjhtmljmkjsonjspkotlinlatexlexlilypondlispliterate-haskelllogslogtalklotosluam4macroschedulermailmakefilemaplemarkdownmavenmavscriptmetapostmlmodula3moinmqscmustache-templatemxmlmyghtymysqln3netrexxnqcnsis2objective-cobjectrexxoccamomnimarkopensipsoutlinepascalpatchperlphppikepl-sqlpl-sql9pl1plaintexplantumlpop11postscriptpovraypowerdynamopowershellprogressprologpropertiesprotobufpspptlpurepvwavepyrexpythonqdocrakefilercprdrebolredcoderelax-ng-compactrenderman-ribrestrfcrhtmlroffrpm-specrtfrubyrustrviews#s+sassbtscalaschemesdl/prsgmlshellscriptshtmlsipsippslateslaxsmalltalksmartysmi-mibsparqlsql-loadersqrsquidconfstatasvn-commitswiftswigtcltemplate-toolkittextexinfotldtransact-sqltsptwikityposcripturluscriptvalavbscriptvelocityverilogvhdlvisualbasicvrml2wellknowntextxmlxqxslyabyamlzpt
Body:

Done