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