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