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