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 effects effects.parser fry
   4 infix.ast infix.parser kernel locals locals.parser math
   5 math.functions math.order math.ranges multiline namespaces
   6 parser quotations sequences summary vocabs.parser words ;
   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     qualified-vocabs last words>> ?at
  19     [ local-not-defined ] unless ;
  20
  21 ERROR: invalid-op string ;
  22
  23 : select-op ( string -- word )
  24     {
  25         { "+" [ [ + ] ] }
  26         { "-" [ [ - ] ] }
  27         { "*" [ [ * ] ] }
  28         { "/" [ [ / ] ] }
  29         { "%" [ [ mod ] ] }
  30         { "**" [ [ ^ ] ] }
  31         [ invalid-op ]
  32     } case ;
  33
  34 GENERIC: infix-codegen ( ast -- quot/number )
  35
  36 M: ast-number infix-codegen value>> ;
  37
  38 M: ast-local infix-codegen
  39     name>> >local-word ;
  40
  41 :: infix-nth ( n seq -- elt )
  42     n dup 0 < [ seq length + ] when seq nth ;
  43
  44 M: ast-array infix-codegen
  45     [ index>> infix-codegen prepare-operand ]
  46     [ name>> >local-word ] bi '[ @ _ infix-nth ] ;
  47
  48 : infix-subseq-step ( subseq step -- subseq' )
  49     dup 0 < [ [ reverse! ] dip ] when
  50     abs dup 1 = [ drop ] [
  51         [ dup length 1 [-] 0 swap ] dip
  52         <range> swap nths
  53     ] if ;
  54
  55 :: infix-subseq-range ( from to step len -- from to )
  56     step [ 0 < ] [ f ] if* [
  57         to [ dup 0 < [ len + ] when 1 + ] [ 0 ] if*
  58         from [ dup 0 < [ len + ] when 1 + ] [ len ] if*
  59     ] [
  60         from 0 or dup 0 < [ len + ] when
  61         to [ dup 0 < [ len + ] when ] [ len ] if*
  62     ] if [ 0 len clamp ] bi@ dupd max ;
  63
  64 :: infix-subseq ( from to step seq -- subseq )
  65     from to step seq length infix-subseq-range
  66     seq subseq step [ infix-subseq-step ] when* ;
  67
  68 M: ast-slice infix-codegen
  69     {
  70         [ from>> [ infix-codegen prepare-operand ] [ [ f ] ] if* ]
  71         [ to>>   [ infix-codegen prepare-operand ] [ [ f ] ] if* ]
  72         [ step>> [ infix-codegen prepare-operand ] [ [ f ] ] if* ]
  73         [ name>> >local-word ]
  74     } cleave '[ @ @ @ _ infix-subseq ] ;
  75
  76 M: ast-op infix-codegen
  77     [ left>> infix-codegen ] [ right>> infix-codegen ]
  78     [ op>> select-op ] tri
  79     2over [ number? ] both? [ call( a b -- c ) ] [
  80         [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
  81     ] if ;
  82
  83 M: ast-negation infix-codegen
  84     term>> infix-codegen
  85     {
  86         { [ dup number? ] [ neg ] }
  87         { [ dup callable? ] [ '[ @ neg ] ] }
  88         [ '[ _ neg ] ] ! local word
  89     } cond ;
  90
  91 ERROR: bad-stack-effect word ;
  92 M: bad-stack-effect summary
  93     drop "Words used in infix must declare a stack effect and return exactly one value" ;
  94
  95 : check-word ( argcount word -- ? )
  96     dup stack-effect [ ] [ bad-stack-effect ] ?if
  97     [ in>> length ] [ out>> length ] bi
  98     [ = ] dip 1 = and ;
  99
 100 : find-and-check ( args argcount string -- quot )
 101     parse-word [ nip ] [ check-word ] 2bi
 102     [ 1quotation compose ] [ bad-stack-effect ] if ;
 103
 104 : arguments-codegen ( seq -- quot )
 105     [ [ ] ] [
 106         [ infix-codegen prepare-operand ]
 107         [ compose ] map-reduce
 108     ] if-empty ;
 109
 110 M: ast-function infix-codegen
 111     [ arguments>> [ arguments-codegen ] [ length ] bi ]
 112     [ name>> ] bi find-and-check ;
 113
 114 : parse-infix-quotation ( end -- result/quot )
 115     parse-multiline-string build-infix-ast
 116     infix-codegen prepare-operand ;
 117
 118 PRIVATE>
 119
 120 SYNTAX: [infix
 121     "infix]" parse-infix-quotation suffix! \ call suffix! ;
 122
 123 <PRIVATE
 124
 125 : (INFIX::) ( -- word def effect )
 126     [
 127         scan-new-word
 128         [ ";" parse-infix-quotation ] parse-locals-definition
 129     ] with-definition ;
 130
 131 PRIVATE>
 132
 133 SYNTAX: INFIX:: (INFIX::) define-declared ;