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 ;
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 locals get ?at [ local-not-defined ] unless ;
20 : select-op ( string -- word )
29 GENERIC: infix-codegen ( ast -- quot/number )
31 M: ast-number infix-codegen value>> ;
33 M: ast-local infix-codegen
36 M: ast-array infix-codegen
37 [ index>> infix-codegen prepare-operand ]
38 [ name>> >local-word ] bi '[ @ _ nth ] ;
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 '[ @ @ @ ]
47 M: ast-negation infix-codegen
50 { [ dup number? ] [ neg ] }
51 { [ dup callable? ] [ '[ @ neg ] ] }
52 [ '[ _ neg ] ] ! local word
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" ;
59 : check-word ( argcount word -- ? )
60 dup stack-effect [ ] [ bad-stack-effect ] ?if
61 [ in>> length ] [ out>> length ] bi
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 ;
69 : arguments-codegen ( seq -- quot )
70 dup empty? [ drop [ ] ] [
71 [ infix-codegen prepare-operand ]
72 [ compose ] map-reduce
75 M: ast-function infix-codegen
76 [ arguments>> [ arguments-codegen ] [ length ] bi ]
77 [ name>> ] bi find-and-check ;
79 : [infix-parse ( end -- result/quot )
80 parse-multiline-string build-infix-ast
81 infix-codegen prepare-operand ;
85 "infix]" [infix-parse parsed \ call parsed ;