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