! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg strings promises sequences math math.parser
- namespaces words quotations arrays hashtables io
- io.streams.string assocs memoize ascii peg.parsers ;
+USING: accessors kernel peg strings sequences math math.parser
+make words quotations arrays hashtables io
+io.streams.string assocs ascii peg.parsers words.symbol
+combinators.short-circuit ;
IN: fjsc
TUPLE: ast-number value ;
TUPLE: ast-in name ;
TUPLE: ast-hashtable elements ;
-C: <ast-number> ast-number
-C: <ast-identifier> ast-identifier
-C: <ast-string> ast-string
-C: <ast-quotation> ast-quotation
-C: <ast-array> ast-array
-C: <ast-define> ast-define
-C: <ast-expression> ast-expression
-C: <ast-word> ast-word
-C: <ast-comment> ast-comment
-C: <ast-stack-effect> ast-stack-effect
-C: <ast-use> ast-use
-C: <ast-using> ast-using
-C: <ast-in> ast-in
-C: <ast-hashtable> ast-hashtable
-
: identifier-middle? ( ch -- bool )
- [ blank? not ] keep
- [ "}];\"" member? not ] keep
- digit? not
- and and ;
-
-MEMO: 'identifier-ends' ( -- parser )
- [
- [ blank? not ] keep
- [ CHAR: " = not ] keep
- [ CHAR: ; = not ] keep
- [ LETTER? not ] keep
- [ letter? not ] keep
- identifier-middle? not
- and and and and and
- ] satisfy repeat0 ;
-
-MEMO: 'identifier-middle' ( -- parser )
- [ identifier-middle? ] satisfy repeat1 ;
-
-MEMO: 'identifier' ( -- parser )
- [
- 'identifier-ends' ,
- 'identifier-middle' ,
- 'identifier-ends' ,
- ] { } make seq [
- concat >string f <ast-identifier>
- ] action ;
-
-
-DEFER: 'expression'
-
-MEMO: 'effect-name' ( -- parser )
- [
- [ blank? not ] keep
- [ CHAR: ) = not ] keep
- CHAR: - = not
- and and
- ] satisfy repeat1 [ >string ] action ;
-
-MEMO: 'stack-effect' ( -- parser )
- [
- "(" token hide ,
- 'effect-name' sp repeat0 ,
- "--" token sp hide ,
- 'effect-name' sp repeat0 ,
- ")" token sp hide ,
- ] { } make seq [
- first2 <ast-stack-effect>
- ] action ;
-
-MEMO: 'define' ( -- parser )
- [
- ":" token sp hide ,
- 'identifier' sp [ ast-identifier-value ] action ,
- 'stack-effect' sp optional ,
- 'expression' ,
- ";" token sp hide ,
- ] { } make seq [ first3 <ast-define> ] action ;
-
-MEMO: 'quotation' ( -- parser )
- [
- "[" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
- "]" token sp hide ,
- ] { } make seq [ first <ast-quotation> ] action ;
-
-MEMO: 'array' ( -- parser )
- [
- "{" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
- "}" token sp hide ,
- ] { } make seq [ first <ast-array> ] action ;
-
-MEMO: 'word' ( -- parser )
- [
- "\\" token sp hide ,
- 'identifier' sp ,
- ] { } make seq [ first ast-identifier-value f <ast-word> ] action ;
-
-MEMO: 'atom' ( -- parser )
- [
- 'identifier' ,
- 'integer' [ <ast-number> ] action ,
- 'string' [ <ast-string> ] action ,
- ] { } make choice ;
-
-MEMO: 'comment' ( -- parser )
- [
+ {
+ [ blank? not ]
+ [ "}];\"" member? not ]
+ [ digit? not ]
+ } 1&& ;
+
+: identifier-ends-parser ( -- parser )
+ [
+ {
+ [ blank? not ]
+ [ CHAR: \" = not ]
+ [ CHAR: ; = not ]
+ [ LETTER? not ]
+ [ letter? not ]
+ [ identifier-middle? not ]
+ } 1&&
+ ] satisfy repeat0 ;
+
+: identifier-middle-parser ( -- parser )
+ [ identifier-middle? ] satisfy repeat1 ;
+
+: identifier-parser ( -- parser )
+ [
+ identifier-ends-parser ,
+ identifier-middle-parser ,
+ identifier-ends-parser ,
+ ] seq* [
+ "" concat-as f ast-identifier boa
+ ] action ;
+
+
+DEFER: expression-parser
+
+: effect-name-parser ( -- parser )
+ [
+ {
+ [ blank? not ]
+ [ CHAR: ) = not ]
+ [ CHAR: - = not ]
+ } 1&&
+ ] satisfy repeat1 [ >string ] action ;
+
+: stack-effect-parser ( -- parser )
+ [
+ "(" token hide ,
+ effect-name-parser sp repeat0 ,
+ "--" token sp hide ,
+ effect-name-parser sp repeat0 ,
+ ")" token sp hide ,
+ ] seq* [
+ first2 ast-stack-effect boa
+ ] action ;
+
+: define-parser ( -- parser )
+ [
+ ":" token sp hide ,
+ identifier-parser sp [ value>> ] action ,
+ stack-effect-parser sp optional ,
+ expression-parser ,
+ ";" token sp hide ,
+ ] seq* [ first3 ast-define boa ] action ;
+
+: quotation-parser ( -- parser )
[
- "#!" token sp ,
- "!" token sp ,
- ] { } make choice hide ,
+ "[" token sp hide ,
+ expression-parser [ values>> ] action ,
+ "]" token sp hide ,
+ ] seq* [ first ast-quotation boa ] action ;
+
+: array-parser ( -- parser )
+ [
+ "{" token sp hide ,
+ expression-parser [ values>> ] action ,
+ "}" token sp hide ,
+ ] seq* [ first ast-array boa ] action ;
+
+: word-parser ( -- parser )
+ [
+ "\\" token sp hide ,
+ identifier-parser sp ,
+ ] seq* [ first value>> f ast-word boa ] action ;
+
+: atom-parser ( -- parser )
[
- dup CHAR: \n = swap CHAR: \r = or not
- ] satisfy repeat0 ,
- ] { } make seq [ drop <ast-comment> ] action ;
-
-MEMO: 'USE:' ( -- parser )
- [
- "USE:" token sp hide ,
- 'identifier' sp ,
- ] { } make seq [ first ast-identifier-value <ast-use> ] action ;
-
-MEMO: 'IN:' ( -- parser )
- [
- "IN:" token sp hide ,
- 'identifier' sp ,
- ] { } make seq [ first ast-identifier-value <ast-in> ] action ;
-
-MEMO: 'USING:' ( -- parser )
- [
- "USING:" token sp hide ,
- 'identifier' sp [ ast-identifier-value ] action repeat1 ,
- ";" token sp hide ,
- ] { } make seq [ first <ast-using> ] action ;
-
-MEMO: 'hashtable' ( -- parser )
- [
- "H{" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
- "}" token sp hide ,
- ] { } make seq [ first <ast-hashtable> ] action ;
-
-MEMO: 'parsing-word' ( -- parser )
- [
- 'USE:' ,
- 'USING:' ,
- 'IN:' ,
- ] { } make choice ;
-
-MEMO: 'expression' ( -- parser )
- [
+ identifier-parser ,
+ integer-parser [ ast-number boa ] action ,
+ string-parser [ ast-string boa ] action ,
+ ] choice* ;
+
+: comment-parser ( -- parser )
+ [
+ "!" token hide ,
+ [
+ dup CHAR: \n = swap CHAR: \r = or not
+ ] satisfy repeat0 ,
+ ] seq* [ drop ast-comment boa ] action ;
+
+: USE-parser ( -- parser )
+ [
+ "USE:" token sp hide ,
+ identifier-parser sp ,
+ ] seq* [ first value>> ast-use boa ] action ;
+
+: IN-parser ( -- parser )
[
- 'comment' ,
- 'parsing-word' sp ,
- 'quotation' sp ,
- 'define' sp ,
- 'array' sp ,
- 'hashtable' sp ,
- 'word' sp ,
- 'atom' sp ,
- ] { } make choice repeat0 [ <ast-expression> ] action
- ] delay ;
-
-MEMO: 'statement' ( -- parser )
- 'expression' ;
+ "IN:" token sp hide ,
+ identifier-parser sp ,
+ ] seq* [ first value>> ast-in boa ] action ;
+
+: USING-parser ( -- parser )
+ [
+ "USING:" token sp hide ,
+ identifier-parser sp [ value>> ] action repeat1 ,
+ ";" token sp hide ,
+ ] seq* [ first ast-using boa ] action ;
+
+: hashtable-parser ( -- parser )
+ [
+ "H{" token sp hide ,
+ expression-parser [ values>> ] action ,
+ "}" token sp hide ,
+ ] seq* [ first ast-hashtable boa ] action ;
+
+: parsing-word-parser ( -- parser )
+ [
+ USE-parser ,
+ USING-parser ,
+ IN-parser ,
+ ] choice* ;
+
+: expression-parser ( -- parser )
+ [
+ [
+ comment-parser ,
+ parsing-word-parser sp ,
+ quotation-parser sp ,
+ define-parser sp ,
+ array-parser sp ,
+ hashtable-parser sp ,
+ word-parser sp ,
+ atom-parser sp ,
+ ] choice* repeat0 [ ast-expression boa ] action
+ ] delay ;
+
+: statement-parser ( -- parser )
+ expression-parser ;
GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- )
M: ast-number (literal)
- ast-number-value number>string , ;
+ value>> number>string , ;
M: ast-number (compile)
- "factor.push_data(" ,
- (literal)
- "," , ;
+ "factor.push_data(" ,
+ (literal)
+ "," , ;
M: ast-string (literal)
- "\"" ,
- ast-string-value ,
- "\"" , ;
+ "\"" ,
+ value>> ,
+ "\"" , ;
M: ast-string (compile)
- "factor.push_data(" ,
- (literal)
- "," , ;
+ "factor.push_data(" ,
+ (literal)
+ "," , ;
M: ast-identifier (literal)
- dup ast-identifier-vocab [
- "factor.get_word(\"" ,
- dup ast-identifier-vocab ,
- "\",\"" ,
- ast-identifier-value ,
- "\")" ,
- ] [
- "factor.find_word(\"" , ast-identifier-value , "\")" ,
- ] if ;
+ dup vocab>> [
+ "factor.get_word(\"" ,
+ dup vocab>> ,
+ "\",\"" ,
+ value>> ,
+ "\")" ,
+ ] [
+ "factor.find_word(\"" , value>> , "\")" ,
+ ] if ;
M: ast-identifier (compile)
- (literal) ".execute(" , ;
+ (literal) ".execute(" , ;
M: ast-define (compile)
- "factor.define_word(\"" ,
- dup ast-define-name ,
- "\",\"source\"," ,
- ast-define-expression (compile)
- "," , ;
+ "factor.define_word(\"" ,
+ dup name>> ,
+ "\",\"source\"," ,
+ expression>> (compile)
+ "," , ;
: do-expressions ( seq -- )
- dup empty? not [
- unclip
- dup ast-comment? not [
- "function() {" ,
- (compile)
- do-expressions
- ")}" ,
+ dup empty? not [
+ unclip
+ dup ast-comment? not [
+ "function() {" ,
+ (compile)
+ do-expressions
+ ")}" ,
+ ] [
+ drop do-expressions
+ ] if
] [
- drop do-expressions
- ] if
- ] [
- drop "factor.cont.next" ,
- ] if ;
+ drop "factor.cont.next" ,
+ ] if ;
M: ast-quotation (literal)
- "factor.make_quotation(\"source\"," ,
- ast-quotation-values do-expressions
- ")" , ;
+ "factor.make_quotation(\"source\"," ,
+ values>> do-expressions
+ ")" , ;
M: ast-quotation (compile)
- "factor.push_data(factor.make_quotation(\"source\"," ,
- ast-quotation-values do-expressions
- ")," , ;
+ "factor.push_data(factor.make_quotation(\"source\"," ,
+ values>> do-expressions
+ ")," , ;
M: ast-array (literal)
- "[" ,
- ast-array-elements [ "," , ] [ (literal) ] interleave
- "]" , ;
+ "[" ,
+ elements>> [ "," , ] [ (literal) ] interleave
+ "]" , ;
M: ast-array (compile)
- "factor.push_data(" , (literal) "," , ;
+ "factor.push_data(" , (literal) "," , ;
M: ast-hashtable (literal)
- "new Hashtable().fromAlist([" ,
- ast-hashtable-elements [ "," , ] [ (literal) ] interleave
- "])" , ;
+ "new Hashtable().fromAlist([" ,
+ elements>> [ "," , ] [ (literal) ] interleave
+ "])" , ;
M: ast-hashtable (compile)
- "factor.push_data(" , (literal) "," , ;
+ "factor.push_data(" , (literal) "," , ;
M: ast-expression (literal)
- ast-expression-values [
- (literal)
- ] each ;
+ values>> [
+ (literal)
+ ] each ;
M: ast-expression (compile)
- ast-expression-values do-expressions ;
+ values>> do-expressions ;
M: ast-word (literal)
- dup ast-word-vocab [
- "factor.get_word(\"" ,
- dup ast-word-vocab ,
- "\",\"" ,
- ast-word-value ,
- "\")" ,
- ] [
- "factor.find_word(\"" , ast-word-value , "\")" ,
- ] if ;
+ dup vocab>> [
+ "factor.get_word(\"" ,
+ dup vocab>> ,
+ "\",\"" ,
+ value>> ,
+ "\")" ,
+ ] [
+ "factor.find_word(\"" , value>> , "\")" ,
+ ] if ;
M: ast-word (compile)
- "factor.push_data(" ,
- (literal)
- "," , ;
+ "factor.push_data(" ,
+ (literal)
+ "," , ;
M: ast-comment (compile)
- drop ;
+ drop ;
M: ast-stack-effect (compile)
- drop ;
+ drop ;
M: ast-use (compile)
- "factor.use(\"" ,
- ast-use-name ,
- "\"," , ;
+ "factor.use(\"" ,
+ name>> ,
+ "\"," , ;
M: ast-in (compile)
- "factor.set_in(\"" ,
- ast-in-name ,
- "\"," , ;
+ "factor.set_in(\"" ,
+ name>> ,
+ "\"," , ;
M: ast-using (compile)
- "factor.using([" ,
- ast-using-names [
- "," ,
- ] [
- "\"" , , "\"" ,
- ] interleave
- "]," , ;
+ "factor.using([" ,
+ names>> [
+ "," ,
+ ] [
+ "\"" , , "\"" ,
+ ] interleave
+ "]," , ;
GENERIC: (parse-factor-quotation) ( object -- ast )
-M: number (parse-factor-quotation) ( object -- ast )
- <ast-number> ;
+M: number (parse-factor-quotation)
+ ast-number boa ;
-M: symbol (parse-factor-quotation) ( object -- ast )
- dup >string swap word-vocabulary <ast-identifier> ;
+M: symbol (parse-factor-quotation)
+ [ >string ] [ vocabulary>> ] bi ast-identifier boa ;
-M: word (parse-factor-quotation) ( object -- ast )
- dup word-name swap word-vocabulary <ast-identifier> ;
+M: word (parse-factor-quotation)
+ [ name>> ] [ vocabulary>> ] bi ast-identifier boa ;
-M: string (parse-factor-quotation) ( object -- ast )
- <ast-string> ;
+M: string (parse-factor-quotation)
+ ast-string boa ;
-M: quotation (parse-factor-quotation) ( object -- ast )
- [
- [ (parse-factor-quotation) , ] each
- ] { } make <ast-quotation> ;
+M: quotation (parse-factor-quotation)
+ [ (parse-factor-quotation) ] { } map-as ast-quotation boa ;
-M: array (parse-factor-quotation) ( object -- ast )
- [
- [ (parse-factor-quotation) , ] each
- ] { } make <ast-array> ;
+M: array (parse-factor-quotation)
+ [ (parse-factor-quotation) ] { } map-as ast-array boa ;
-M: hashtable (parse-factor-quotation) ( object -- ast )
- >alist [
- [ (parse-factor-quotation) , ] each
- ] { } make <ast-hashtable> ;
+M: hashtable (parse-factor-quotation)
+ >alist [ (parse-factor-quotation) ] { } map-as ast-hashtable boa ;
-M: wrapper (parse-factor-quotation) ( object -- ast )
- wrapped dup word-name swap word-vocabulary <ast-word> ;
+M: wrapper (parse-factor-quotation)
+ wrapped>> [ name>> ] [ vocabulary>> ] bi ast-word boa ;
GENERIC: fjsc-parse ( object -- ast )
-M: string fjsc-parse ( object -- ast )
- 'expression' parse parse-result-ast ;
+M: string fjsc-parse
+ expression-parser parse ;
-M: quotation fjsc-parse ( object -- ast )
- [
- [ (parse-factor-quotation) , ] each
- ] { } make <ast-expression> ;
+M: quotation fjsc-parse
+ [ (parse-factor-quotation) ] { } map-as ast-expression boa ;
: fjsc-compile ( ast -- string )
- [
[
- "(" ,
- (compile)
- ")" ,
- ] { } make [ write ] each
- ] with-string-writer ;
+ [
+ "(" ,
+ (compile)
+ ")" ,
+ ] { } make [ write ] each
+ ] with-string-writer ;
: fjsc-compile* ( string -- string )
- 'statement' parse parse-result-ast fjsc-compile ;
-
-: fc* ( string -- string )
- [
- 'statement' parse parse-result-ast ast-expression-values do-expressions
- ] { } make [ write ] each ;
+ statement-parser parse fjsc-compile ;
+: fc* ( string -- )
+ [
+ statement-parser parse values>> do-expressions
+ ] { } make [ write ] each ;
: fjsc-literal ( ast -- string )
- [
- [ (literal) ] { } make [ write ] each
- ] with-string-writer ;
-
+ [
+ [ (literal) ] { } make [ write ] each
+ ] with-string-writer ;
projects / factor.git / blobdiff