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