extra/fjsc/fjsc.factor

   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 sequences math math.parser
   4 namespaces make words quotations arrays hashtables io
   5 io.streams.string assocs ascii peg.parsers accessors ;
   6 IN: fjsc
   7
   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 ;
  16 TUPLE: ast-comment ;
  17 TUPLE: ast-stack-effect in out ;
  18 TUPLE: ast-use name ;
  19 TUPLE: ast-using names ;
  20 TUPLE: ast-in name ;
  21 TUPLE: ast-hashtable elements ;
  22
  23 : identifier-middle? ( ch -- bool )
  24   [ blank? not ] keep
  25   [ "}];\"" member? not ] keep
  26   digit? not
  27   and and ;
  28
  29 : 'identifier-ends' ( -- parser )
  30   [
  31     [ blank? not ] keep
  32     [ CHAR: " = not ] keep
  33     [ CHAR: ; = not ] keep
  34     [ LETTER? not ] keep
  35     [ letter? not ] keep
  36     identifier-middle? not
  37     and and and and and
  38   ] satisfy repeat0 ;
  39
  40 : 'identifier-middle' ( -- parser )
  41   [ identifier-middle? ] satisfy repeat1 ;
  42
  43 : 'identifier' ( -- parser )
  44   [
  45     'identifier-ends' ,
  46     'identifier-middle' ,
  47     'identifier-ends' ,
  48   ] seq* [
  49     concat >string f ast-identifier boa
  50   ] action ;
  51
  52
  53 DEFER: 'expression'
  54
  55 : 'effect-name' ( -- parser )
  56   [
  57     [ blank? not ] keep
  58     [ CHAR: ) = not ] keep
  59     CHAR: - = not
  60     and and
  61   ] satisfy repeat1 [ >string ] action ;
  62
  63 : 'stack-effect' ( -- parser )
  64   [
  65     "(" token hide ,
  66     'effect-name' sp repeat0 ,
  67     "--" token sp hide ,
  68     'effect-name' sp repeat0 ,
  69     ")" token sp hide ,
  70   ] seq* [
  71     first2 ast-stack-effect boa
  72   ] action ;
  73
  74 : 'define' ( -- parser )
  75   [
  76     ":" token sp hide ,
  77     'identifier' sp [ value>> ] action ,
  78     'stack-effect' sp optional ,
  79     'expression' ,
  80     ";" token sp hide ,
  81   ] seq* [ first3 ast-define boa ] action ;
  82
  83 : 'quotation' ( -- parser )
  84   [
  85     "[" token sp hide ,
  86     'expression' [ values>> ] action ,
  87     "]" token sp hide ,
  88   ] seq* [ first ast-quotation boa ] action ;
  89
  90 : 'array' ( -- parser )
  91   [
  92     "{" token sp hide ,
  93     'expression' [ values>> ] action ,
  94     "}" token sp hide ,
  95   ] seq* [ first ast-array boa ] action ;
  96
  97 : 'word' ( -- parser )
  98   [
  99     "\\" token sp hide ,
 100     'identifier' sp ,
 101   ] seq* [ first value>> f ast-word boa ] action ;
 102
 103 : 'atom' ( -- parser )
 104   [
 105     'identifier' ,
 106     'integer' [ ast-number boa ] action ,
 107     'string' [ ast-string boa ] action ,
 108   ] choice* ;
 109
 110 : 'comment' ( -- parser )
 111   [
 112     [
 113       "#!" token sp ,
 114       "!" token sp ,
 115     ] choice* hide ,
 116     [
 117       dup CHAR: \n = swap CHAR: \r = or not
 118     ] satisfy repeat0 ,
 119   ] seq* [ drop ast-comment boa ] action ;
 120
 121 : 'USE:' ( -- parser )
 122   [
 123     "USE:" token sp hide ,
 124     'identifier' sp ,
 125   ] seq* [ first value>> ast-use boa ] action ;
 126
 127 : 'IN:' ( -- parser )
 128   [
 129     "IN:" token sp hide ,
 130     'identifier' sp ,
 131   ] seq* [ first value>> ast-in boa ] action ;
 132
 133 : 'USING:' ( -- parser )
 134   [
 135     "USING:" token sp hide ,
 136     'identifier' sp [ value>> ] action repeat1 ,
 137     ";" token sp hide ,
 138   ] seq* [ first ast-using boa ] action ;
 139
 140 : 'hashtable' ( -- parser )
 141   [
 142     "H{" token sp hide ,
 143     'expression' [ values>> ] action ,
 144     "}" token sp hide ,
 145   ] seq* [ first ast-hashtable boa ] action ;
 146
 147 : 'parsing-word' ( -- parser )
 148   [
 149     'USE:' ,
 150     'USING:' ,
 151     'IN:' ,
 152   ] choice* ;
 153
 154 : 'expression' ( -- parser )
 155   [
 156     [
 157       'comment' ,
 158       'parsing-word' sp ,
 159       'quotation' sp ,
 160       'define' sp ,
 161       'array' sp ,
 162       'hashtable' sp ,
 163       'word' sp ,
 164       'atom' sp ,
 165     ] choice* repeat0 [ ast-expression boa ] action
 166   ] delay ;
 167
 168 : 'statement' ( -- parser )
 169   'expression' ;
 170
 171 GENERIC: (compile) ( ast -- )
 172 GENERIC: (literal) ( ast -- )
 173
 174 M: ast-number (literal)
 175   value>> number>string , ;
 176
 177 M: ast-number (compile)
 178   "factor.push_data(" ,
 179   (literal)
 180   "," , ;
 181
 182 M: ast-string (literal)
 183   "\"" ,
 184   value>> ,
 185   "\"" , ;
 186
 187 M: ast-string (compile)
 188   "factor.push_data(" ,
 189   (literal)
 190   "," , ;
 191
 192 M: ast-identifier (literal)
 193   dup vocab>> [
 194    "factor.get_word(\"" ,
 195    dup vocab>> ,
 196    "\",\"" ,
 197    value>> ,
 198    "\")" ,
 199   ] [
 200    "factor.find_word(\"" , value>> , "\")" ,
 201   ] if ;
 202
 203 M: ast-identifier (compile)
 204   (literal) ".execute(" ,  ;
 205
 206 M: ast-define (compile)
 207   "factor.define_word(\"" ,
 208   dup name>> ,
 209   "\",\"source\"," ,
 210   expression>> (compile)
 211   "," , ;
 212
 213 : do-expressions ( seq -- )
 214   dup empty? not [
 215     unclip
 216     dup ast-comment? not [
 217       "function() {" ,
 218       (compile)
 219       do-expressions
 220       ")}" ,
 221     ] [
 222       drop do-expressions
 223     ] if
 224   ] [
 225     drop "factor.cont.next" ,
 226   ] if  ;
 227
 228 M: ast-quotation (literal)
 229   "factor.make_quotation(\"source\"," ,
 230   values>> do-expressions
 231   ")" , ;
 232
 233 M: ast-quotation (compile)
 234   "factor.push_data(factor.make_quotation(\"source\"," ,
 235   values>> do-expressions
 236   ")," , ;
 237
 238 M: ast-array (literal)
 239   "[" ,
 240   elements>> [ "," , ] [ (literal) ] interleave
 241   "]" , ;
 242
 243 M: ast-array (compile)
 244   "factor.push_data(" , (literal) "," , ;
 245
 246 M: ast-hashtable (literal)
 247   "new Hashtable().fromAlist([" ,
 248   elements>> [ "," , ] [ (literal) ] interleave
 249   "])" , ;
 250
 251 M: ast-hashtable (compile)
 252   "factor.push_data(" , (literal) "," , ;
 253
 254
 255 M: ast-expression (literal)
 256   values>> [
 257     (literal)
 258   ] each ;
 259
 260 M: ast-expression (compile)
 261   values>> do-expressions ;
 262
 263 M: ast-word (literal)
 264   dup vocab>> [
 265    "factor.get_word(\"" ,
 266    dup vocab>> ,
 267    "\",\"" ,
 268    value>> ,
 269    "\")" ,
 270   ] [
 271    "factor.find_word(\"" , value>> , "\")" ,
 272   ] if ;
 273
 274 M: ast-word (compile)
 275   "factor.push_data(" ,
 276   (literal)
 277   "," , ;
 278
 279 M: ast-comment (compile)
 280   drop ;
 281
 282 M: ast-stack-effect (compile)
 283   drop ;
 284
 285 M: ast-use (compile)
 286   "factor.use(\"" ,
 287   name>> ,
 288   "\"," , ;
 289
 290 M: ast-in (compile)
 291   "factor.set_in(\"" ,
 292   name>> ,
 293   "\"," , ;
 294
 295 M: ast-using (compile)
 296   "factor.using([" ,
 297   names>> [
 298     "," ,
 299   ] [
 300     "\"" , , "\"" ,
 301   ] interleave
 302   "]," , ;
 303
 304 GENERIC: (parse-factor-quotation) ( object -- ast )
 305
 306 M: number (parse-factor-quotation) ( object -- ast )
 307   ast-number boa ;
 308
 309 M: symbol (parse-factor-quotation) ( object -- ast )
 310   dup >string swap vocabulary>> ast-identifier boa ;
 311
 312 M: word (parse-factor-quotation) ( object -- ast )
 313   dup name>> swap vocabulary>> ast-identifier boa ;
 314
 315 M: string (parse-factor-quotation) ( object -- ast )
 316   ast-string boa ;
 317
 318 M: quotation (parse-factor-quotation) ( object -- ast )
 319   [
 320     [ (parse-factor-quotation) , ] each
 321   ] { } make ast-quotation boa ;
 322
 323 M: array (parse-factor-quotation) ( object -- ast )
 324   [
 325     [ (parse-factor-quotation) , ] each
 326   ] { } make ast-array boa ;
 327
 328 M: hashtable (parse-factor-quotation) ( object -- ast )
 329   >alist [
 330     [ (parse-factor-quotation) , ] each
 331   ] { } make ast-hashtable boa ;
 332
 333 M: wrapper (parse-factor-quotation) ( object -- ast )
 334   wrapped>> dup name>> swap vocabulary>> ast-word boa ;
 335
 336 GENERIC: fjsc-parse ( object -- ast )
 337
 338 M: string fjsc-parse ( object -- ast )
 339   'expression' parse ast>> ;
 340
 341 M: quotation fjsc-parse ( object -- ast )
 342   [
 343     [ (parse-factor-quotation) , ] each
 344   ] { } make ast-expression boa ;
 345
 346 : fjsc-compile ( ast -- string )
 347   [
 348     [
 349       "(" ,
 350       (compile)
 351       ")" ,
 352     ] { } make [ write ] each
 353   ] with-string-writer ;
 354
 355 : fjsc-compile* ( string -- string )
 356   'statement' parse ast>> fjsc-compile ;
 357
 358 : fc* ( string -- string )
 359   [
 360   'statement' parse ast>> values>> do-expressions
 361   ] { } make [ write ] each ;
 362
 363
 364 : fjsc-literal ( ast -- string )
 365   [
 366     [ (literal) ] { } make [ write ] each
 367   ] with-string-writer ;
 368