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 infix.ast infix.parser kernel locals.parser
5 locals.types math math.functions math.order multiline parser
6 quotations ranges sequences summary vocabs.parser words
11 : prepare-operand ( term -- quot )
12 dup callable? [ 1quotation ] unless ;
14 ERROR: local-not-defined name ;
15 M: local-not-defined summary
16 drop "local is not defined" ;
18 : >local-word ( string -- word )
22 [ stack-effect ( -- x ) effect= ]
23 } 1|| [ nip ] [ drop local-not-defined ] if ;
25 ERROR: invalid-op string ;
27 : select-op ( string -- word )
38 GENERIC: infix-codegen ( ast -- quot/number )
40 M: ast-value infix-codegen value>> ;
42 M: ast-local infix-codegen
45 :: infix-nth ( n seq -- elt )
46 n dup 0 < [ seq length + ] when seq nth ;
48 M: ast-array infix-codegen
49 [ index>> infix-codegen prepare-operand ]
50 [ name>> >local-word ] bi '[ @ _ infix-nth ] ;
52 : infix-subseq-step ( subseq step -- subseq' )
54 { 0 [ "slice step cannot be zero" throw ] }
58 [ dup length 1 [-] 0 ] dip
59 [ 0 > [ swap ] when ] keep
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*
69 from 0 or dup 0 < [ len + ] when
70 to [ dup 0 < [ len + ] when ] [ len ] if*
71 ] if [ 0 len clamp ] bi@ dupd max ;
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* ;
77 M: ast-slice infix-codegen
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 ] ;
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 '[ @ @ @ ]
92 M: ast-negation infix-codegen
95 { [ dup number? ] [ neg ] }
96 { [ dup callable? ] [ '[ @ neg ] ] }
97 [ '[ _ neg ] ] ! local word
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" ;
104 : check-word ( argcount word -- ? )
105 dup stack-effect [ ] [ bad-stack-effect ] ?if
106 [ in>> length ] [ out>> length ] bi
109 : find-and-check ( args argcount string -- quot )
110 parse-word [ nip ] [ check-word ] 2bi
111 [ 1quotation compose ] [ bad-stack-effect ] if ;
113 : arguments-codegen ( seq -- quot )
115 [ infix-codegen prepare-operand ]
116 [ compose ] map-reduce
119 M: ast-function infix-codegen
120 [ arguments>> [ arguments-codegen ] [ length ] bi ]
121 [ name>> ] bi find-and-check ;
123 : parse-infix-quotation ( end -- result/quot )
124 parse-multiline-string build-infix-ast
125 infix-codegen prepare-operand ;
130 "infix]" parse-infix-quotation suffix! \ call suffix! ;
134 : (INFIX::) ( -- word def effect )
137 [ ";" parse-infix-quotation ] parse-locals-definition
142 SYNTAX: INFIX:: (INFIX::) define-declared ;