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 ( -- 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 ( -- parser )
  44     [ identifier-middle? ] satisfy repeat1 ;
  45
  46 : identifier-parser ( -- parser )
  47     [
  48         identifier-ends-parser ,
  49         identifier-middle-parser ,
  50         identifier-ends-parser ,
  51     ] seq* [
  52         "" concat-as f ast-identifier boa
  53     ] action ;
  54
  55
  56 DEFER: expression-parser
  57
  58 : effect-name-parser ( -- parser )
  59     [
  60         {
  61             [ blank? not ]
  62             [ CHAR: ) = not ]
  63             [ CHAR: - = not ]
  64         } 1&&
  65     ] satisfy repeat1 [ >string ] action ;
  66
  67 : stack-effect-parser ( -- parser )
  68     [
  69         "(" token hide ,
  70         effect-name-parser sp repeat0 ,
  71         "--" token sp hide ,
  72         effect-name-parser sp repeat0 ,
  73         ")" token sp hide ,
  74     ] seq* [
  75         first2 ast-stack-effect boa
  76     ] action ;
  77
  78 : define-parser ( -- parser )
  79     [
  80         ":" token sp hide ,
  81         identifier-parser sp [ value>> ] action ,
  82         stack-effect-parser sp optional ,
  83         expression-parser ,
  84         ";" token sp hide ,
  85     ] seq* [ first3 ast-define boa ] action ;
  86
  87 : quotation-parser ( -- parser )
  88     [
  89         "[" token sp hide ,
  90         expression-parser [ values>> ] action ,
  91         "]" token sp hide ,
  92     ] seq* [ first ast-quotation boa ] action ;
  93
  94 : array-parser ( -- parser )
  95     [
  96         "{" token sp hide ,
  97         expression-parser [ values>> ] action ,
  98         "}" token sp hide ,
  99     ] seq* [ first ast-array boa ] action ;
 100
 101 : word-parser ( -- parser )
 102     [
 103         "\\" token sp hide ,
 104         identifier-parser sp ,
 105     ] seq* [ first value>> f ast-word boa ] action ;
 106
 107 : atom-parser ( -- parser )
 108     [
 109         identifier-parser ,
 110         integer-parser [ ast-number boa ] action ,
 111         string-parser [ ast-string boa ] action ,
 112     ] choice* ;
 113
 114 : comment-parser ( -- parser )
 115     [
 116         "!" token 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 ( -- parser )
 123     [
 124         "USE:" token sp hide ,
 125         identifier-parser sp ,
 126     ] seq* [ first value>> ast-use boa ] action ;
 127
 128 : IN-parser ( -- parser )
 129     [
 130         "IN:" token sp hide ,
 131         identifier-parser sp ,
 132     ] seq* [ first value>> ast-in boa ] action ;
 133
 134 : USING-parser ( -- parser )
 135     [
 136         "USING:" token sp hide ,
 137         identifier-parser sp [ value>> ] action repeat1 ,
 138         ";" token sp hide ,
 139     ] seq* [ first ast-using boa ] action ;
 140
 141 : hashtable-parser ( -- parser )
 142     [
 143         "H{" token sp hide ,
 144         expression-parser [ values>> ] action ,
 145         "}" token sp hide ,
 146     ] seq* [ first ast-hashtable boa ] action ;
 147
 148 : parsing-word-parser ( -- parser )
 149     [
 150         USE-parser ,
 151         USING-parser ,
 152         IN-parser ,
 153     ] choice* ;
 154
 155 : expression-parser ( -- parser )
 156     [
 157         [
 158             comment-parser ,
 159             parsing-word-parser sp ,
 160             quotation-parser sp ,
 161             define-parser sp ,
 162             array-parser sp ,
 163             hashtable-parser sp ,
 164             word-parser sp ,
 165             atom-parser sp ,
 166         ] choice* repeat0 [ ast-expression boa ] action
 167     ] delay ;
 168
 169 : statement-parser ( -- parser )
 170     expression-parser ;
 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     [ >string ] [ vocabulary>> ] bi ast-identifier boa ;
 312
 313 M: word (parse-factor-quotation) ( object -- ast )
 314     [ name>> ] [ vocabulary>> ] bi 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     [ (parse-factor-quotation) ] { } map-as ast-quotation boa ;
 321
 322 M: array (parse-factor-quotation) ( object -- ast )
 323     [ (parse-factor-quotation) ] { } map-as ast-array boa ;
 324
 325 M: hashtable (parse-factor-quotation) ( object -- ast )
 326     >alist [ (parse-factor-quotation) ] { } map-as ast-hashtable boa ;
 327
 328 M: wrapper (parse-factor-quotation) ( object -- ast )
 329     wrapped>> [ name>> ] [ vocabulary>> ] bi ast-word boa ;
 330
 331 GENERIC: fjsc-parse ( object -- ast )
 332
 333 M: string fjsc-parse ( object -- ast )
 334     expression-parser parse ;
 335
 336 M: quotation fjsc-parse ( object -- ast )
 337     [ (parse-factor-quotation) ] { } map-as ast-expression boa ;
 338
 339 : fjsc-compile ( ast -- string )
 340     [
 341         [
 342             "(" ,
 343             (compile)
 344             ")" ,
 345         ] { } make [ write ] each
 346     ] with-string-writer ;
 347
 348 : fjsc-compile* ( string -- string )
 349     statement-parser parse fjsc-compile ;
 350
 351 : fc* ( string -- )
 352     [
 353         statement-parser parse values>> do-expressions
 354     ] { } make [ write ] each ;
 355
 356 : fjsc-literal ( ast -- string )
 357     [
 358         [ (literal) ] { } make [ write ] each
 359     ] with-string-writer ;