extra/infix/infix.factor

   1 ! Copyright (C) 2009 Philipp Brüschweiler
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 effects fry infix.parser infix.ast kernel locals.parser
   5 locals.types math multiline namespaces parser quotations
   6 sequences summary words vocabs.parser ;
   7 IN: infix
   8
   9 <PRIVATE
  10 : prepare-operand ( term -- quot )
  11     dup callable? [ 1quotation ] unless ;
  12
  13 ERROR: local-not-defined name ;
  14 M: local-not-defined summary
  15     drop "local is not defined" ;
  16
  17 : >local-word ( string -- word )
  18     locals get ?at [ local-not-defined ] unless ;
  19
  20 : select-op ( string -- word )
  21     {
  22         { "+" [ [ + ] ] }
  23         { "-" [ [ - ] ] }
  24         { "*" [ [ * ] ] }
  25         { "/" [ [ / ] ] }
  26         [ drop [ mod ] ]
  27     } case ;
  28
  29 GENERIC: infix-codegen ( ast -- quot/number )
  30
  31 M: ast-number infix-codegen value>> ;
  32
  33 M: ast-local infix-codegen
  34     name>> >local-word ;
  35
  36 M: ast-array infix-codegen
  37     [ index>> infix-codegen prepare-operand ]
  38     [ name>> >local-word ] bi '[ @ _ nth ] ;
  39
  40 M: ast-op infix-codegen
  41     [ left>> infix-codegen ] [ right>> infix-codegen ]
  42     [ op>> select-op ] tri
  43     2over [ number? ] both? [ call( a b -- c ) ] [
  44         [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
  45     ] if ;
  46
  47 M: ast-negation infix-codegen
  48     term>> infix-codegen
  49     {
  50         { [ dup number? ] [ neg ] }
  51         { [ dup callable? ] [ '[ @ neg ] ] }
  52         [ '[ _ neg ] ] ! local word
  53     } cond ;
  54
  55 ERROR: bad-stack-effect word ;
  56 M: bad-stack-effect summary
  57     drop "Words used in infix must declare a stack effect and return exactly one value" ;
  58
  59 : check-word ( argcount word -- ? )
  60     dup stack-effect [ ] [ bad-stack-effect ] ?if
  61     [ in>> length ] [ out>> length ] bi
  62     [ = ] dip 1 = and ;
  63
  64 : find-and-check ( args argcount string -- quot )
  65     dup search [ ] [ no-word ] ?if
  66     [ nip ] [ check-word ] 2bi
  67     [ 1quotation compose ] [ bad-stack-effect ] if ;
  68
  69 : arguments-codegen ( seq -- quot )
  70     dup empty? [ drop [ ] ] [
  71         [ infix-codegen prepare-operand ]
  72         [ compose ] map-reduce
  73     ] if ;
  74
  75 M: ast-function infix-codegen
  76     [ arguments>> [ arguments-codegen ] [ length ] bi ]
  77     [ name>> ] bi find-and-check ;
  78
  79 : [infix-parse ( end -- result/quot )
  80     parse-multiline-string build-infix-ast
  81     infix-codegen prepare-operand ;
  82 PRIVATE>
  83
  84 SYNTAX: [infix
  85     "infix]" [infix-parse suffix! \ call suffix! ;