1 ! Copyright (C) 2006 Chris Double. All Rights Reserved.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel peg strings promises sequences math
4 math.parser namespaces words quotations arrays hashtables io
5 io.streams.string assocs memoize ascii peg.parsers ;
8 TUPLE: ast-number value ;
9 TUPLE: ast-identifier value vocab ;
10 TUPLE: ast-string value ;
11 TUPLE: ast-quotation values ;
12 TUPLE: ast-array elements ;
13 TUPLE: ast-define name stack-effect expression ;
14 TUPLE: ast-expression values ;
15 TUPLE: ast-word value vocab ;
17 TUPLE: ast-stack-effect in out ;
19 TUPLE: ast-using names ;
21 TUPLE: ast-hashtable elements ;
23 C: <ast-number> ast-number
24 C: <ast-identifier> ast-identifier
25 C: <ast-string> ast-string
26 C: <ast-quotation> ast-quotation
27 C: <ast-array> ast-array
28 C: <ast-define> ast-define
29 C: <ast-expression> ast-expression
30 C: <ast-word> ast-word
31 C: <ast-comment> ast-comment
32 C: <ast-stack-effect> ast-stack-effect
34 C: <ast-using> ast-using
36 C: <ast-hashtable> ast-hashtable
38 : identifier-middle? ( ch -- bool )
40 [ "}];\"" member? not ] keep
44 MEMO: 'identifier-ends' ( -- parser )
47 [ CHAR: " = not ] keep
48 [ CHAR: ; = not ] keep
51 identifier-middle? not
55 MEMO: 'identifier-middle' ( -- parser )
56 [ identifier-middle? ] satisfy repeat1 ;
58 MEMO: 'identifier' ( -- parser )
64 concat >string f <ast-identifier>
70 MEMO: 'effect-name' ( -- parser )
73 [ CHAR: ) = not ] keep
76 ] satisfy repeat1 [ >string ] action ;
78 MEMO: 'stack-effect' ( -- parser )
81 'effect-name' sp repeat0 ,
83 'effect-name' sp repeat0 ,
86 first2 <ast-stack-effect>
89 MEMO: 'define' ( -- parser )
92 'identifier' sp [ ast-identifier-value ] action ,
93 'stack-effect' sp optional ,
96 ] { } make seq [ first3 <ast-define> ] action ;
98 MEMO: 'quotation' ( -- parser )
101 'expression' [ ast-expression-values ] action ,
103 ] { } make seq [ first <ast-quotation> ] action ;
105 MEMO: 'array' ( -- parser )
108 'expression' [ ast-expression-values ] action ,
110 ] { } make seq [ first <ast-array> ] action ;
112 MEMO: 'word' ( -- parser )
116 ] { } make seq [ first ast-identifier-value f <ast-word> ] action ;
118 MEMO: 'atom' ( -- parser )
121 'integer' [ <ast-number> ] action ,
122 'string' [ <ast-string> ] action ,
125 MEMO: 'comment' ( -- parser )
130 ] { } make choice hide ,
132 dup CHAR: \n = swap CHAR: \r = or not
134 ] { } make seq [ drop <ast-comment> ] action ;
136 MEMO: 'USE:' ( -- parser )
138 "USE:" token sp hide ,
140 ] { } make seq [ first ast-identifier-value <ast-use> ] action ;
142 MEMO: 'IN:' ( -- parser )
144 "IN:" token sp hide ,
146 ] { } make seq [ first ast-identifier-value <ast-in> ] action ;
148 MEMO: 'USING:' ( -- parser )
150 "USING:" token sp hide ,
151 'identifier' sp [ ast-identifier-value ] action repeat1 ,
153 ] { } make seq [ first <ast-using> ] action ;
155 MEMO: 'hashtable' ( -- parser )
158 'expression' [ ast-expression-values ] action ,
160 ] { } make seq [ first <ast-hashtable> ] action ;
162 MEMO: 'parsing-word' ( -- parser )
169 MEMO: 'expression' ( -- parser )
180 ] { } make choice repeat0 [ <ast-expression> ] action
183 MEMO: 'statement' ( -- parser )
186 GENERIC: (compile) ( ast -- )
187 GENERIC: (literal) ( ast -- )
189 M: ast-number (literal)
190 ast-number-value number>string , ;
192 M: ast-number (compile)
193 "factor.push_data(" ,
197 M: ast-string (literal)
202 M: ast-string (compile)
203 "factor.push_data(" ,
207 M: ast-identifier (literal)
208 dup ast-identifier-vocab [
209 "factor.get_word(\"" ,
210 dup ast-identifier-vocab ,
212 ast-identifier-value ,
215 "factor.find_word(\"" , ast-identifier-value , "\")" ,
218 M: ast-identifier (compile)
219 (literal) ".execute(" , ;
221 M: ast-define (compile)
222 "factor.define_word(\"" ,
223 dup ast-define-name ,
225 ast-define-expression (compile)
228 : do-expressions ( seq -- )
231 dup ast-comment? not [
240 drop "factor.cont.next" ,
243 M: ast-quotation (literal)
244 "factor.make_quotation(\"source\"," ,
245 ast-quotation-values do-expressions
248 M: ast-quotation (compile)
249 "factor.push_data(factor.make_quotation(\"source\"," ,
250 ast-quotation-values do-expressions
253 M: ast-array (literal)
255 ast-array-elements [ "," , ] [ (literal) ] interleave
258 M: ast-array (compile)
259 "factor.push_data(" , (literal) "," , ;
261 M: ast-hashtable (literal)
262 "new Hashtable().fromAlist([" ,
263 ast-hashtable-elements [ "," , ] [ (literal) ] interleave
266 M: ast-hashtable (compile)
267 "factor.push_data(" , (literal) "," , ;
270 M: ast-expression (literal)
271 ast-expression-values [
275 M: ast-expression (compile)
276 ast-expression-values do-expressions ;
278 M: ast-word (literal)
280 "factor.get_word(\"" ,
286 "factor.find_word(\"" , ast-word-value , "\")" ,
289 M: ast-word (compile)
290 "factor.push_data(" ,
294 M: ast-comment (compile)
297 M: ast-stack-effect (compile)
310 M: ast-using (compile)
319 GENERIC: (parse-factor-quotation) ( object -- ast )
321 M: number (parse-factor-quotation) ( object -- ast )
324 M: symbol (parse-factor-quotation) ( object -- ast )
325 dup >string swap vocabulary>> <ast-identifier> ;
327 M: word (parse-factor-quotation) ( object -- ast )
328 dup name>> swap vocabulary>> <ast-identifier> ;
330 M: string (parse-factor-quotation) ( object -- ast )
333 M: quotation (parse-factor-quotation) ( object -- ast )
335 [ (parse-factor-quotation) , ] each
336 ] { } make <ast-quotation> ;
338 M: array (parse-factor-quotation) ( object -- ast )
340 [ (parse-factor-quotation) , ] each
341 ] { } make <ast-array> ;
343 M: hashtable (parse-factor-quotation) ( object -- ast )
345 [ (parse-factor-quotation) , ] each
346 ] { } make <ast-hashtable> ;
348 M: wrapper (parse-factor-quotation) ( object -- ast )
349 wrapped>> dup name>> swap vocabulary>> <ast-word> ;
351 GENERIC: fjsc-parse ( object -- ast )
353 M: string fjsc-parse ( object -- ast )
354 'expression' parse parse-result-ast ;
356 M: quotation fjsc-parse ( object -- ast )
358 [ (parse-factor-quotation) , ] each
359 ] { } make <ast-expression> ;
361 : fjsc-compile ( ast -- string )
367 ] { } make [ write ] each
368 ] with-string-writer ;
370 : fjsc-compile* ( string -- string )
371 'statement' parse parse-result-ast fjsc-compile ;
373 : fc* ( string -- string )
375 'statement' parse parse-result-ast ast-expression-values do-expressions
376 ] { } make [ write ] each ;
379 : fjsc-literal ( ast -- string )
381 [ (literal) ] { } make [ write ] each
382 ] with-string-writer ;