extra/infix/infix.factor

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