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 ;
10 : prepare-operand ( term -- quot )
11 dup callable? [ 1quotation ] unless ;
13 ERROR: local-not-defined name ;
14 M: local-not-defined summary
15 drop "local is not defined" ;
17 : >local-word ( string -- word )
18 qualified-vocabs last words>> ?at
19 [ throw-local-not-defined ] unless ;
21 ERROR: invalid-op string ;
23 : select-op ( string -- word )
34 GENERIC: infix-codegen ( ast -- quot/number )
36 M: ast-number infix-codegen value>> ;
38 M: ast-local infix-codegen
41 :: infix-nth ( n seq -- elt )
42 n dup 0 < [ seq length + ] when seq nth ;
44 M: ast-array infix-codegen
45 [ index>> infix-codegen prepare-operand ]
46 [ name>> >local-word ] bi '[ @ _ infix-nth ] ;
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
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*
60 from 0 or dup 0 < [ len + ] when
61 to [ dup 0 < [ len + ] when ] [ len ] if*
62 ] if [ 0 len clamp ] bi@ dupd max ;
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* ;
68 M: ast-slice infix-codegen
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 ] ;
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 '[ @ @ @ ]
83 M: ast-negation infix-codegen
86 { [ dup number? ] [ neg ] }
87 { [ dup callable? ] [ '[ @ neg ] ] }
88 [ '[ _ neg ] ] ! local word
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" ;
95 : check-word ( argcount word -- ? )
96 dup stack-effect [ ] [ bad-stack-effect ] ?if
97 [ in>> length ] [ out>> length ] bi
100 : find-and-check ( args argcount string -- quot )
101 parse-word [ nip ] [ check-word ] 2bi
102 [ 1quotation compose ] [ bad-stack-effect ] if ;
104 : arguments-codegen ( seq -- quot )
106 [ infix-codegen prepare-operand ]
107 [ compose ] map-reduce
110 M: ast-function infix-codegen
111 [ arguments>> [ arguments-codegen ] [ length ] bi ]
112 [ name>> ] bi find-and-check ;
114 : parse-infix-quotation ( end -- result/quot )
115 parse-multiline-string build-infix-ast
116 infix-codegen prepare-operand ;
121 "infix]" parse-infix-quotation suffix! \ call suffix! ;
125 : (INFIX::) ( -- word def effect )
128 [ ";" parse-infix-quotation ] parse-locals-definition
133 SYNTAX: INFIX:: (INFIX::) define-declared ;