extra/smalltalk/compiler/compiler.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators.short-circuit
   4 continuations fry kernel namespaces quotations sequences sets
   5 generalizations slots locals.types generalizations smalltalk.ast
   6 smalltalk.compiler.lexenv smalltalk.selectors ;
   7 IN: smalltalk.compiler
   8
   9 SYMBOL: return-continuation
  10
  11 GENERIC: need-return-continuation? ( ast -- ? )
  12
  13 M: ast-return need-return-continuation? drop t ;
  14
  15 M: ast-block need-return-continuation? body>> need-return-continuation? ;
  16
  17 M: ast-message-send need-return-continuation?
  18     {
  19         [ receiver>> need-return-continuation? ]
  20         [ arguments>> need-return-continuation? ]
  21     } 1&& ;
  22
  23 M: ast-assignment need-return-continuation?
  24     value>> need-return-continuation? ;
  25
  26 M: array need-return-continuation? [ need-return-continuation? ] any? ;
  27
  28 M: object need-return-continuation? drop f ;
  29
  30 GENERIC: assigned-locals ( ast -- seq )
  31
  32 M: ast-return assigned-locals value>> assigned-locals ;
  33
  34 M: ast-block assigned-locals
  35     [ body>> assigned-locals ] [ arguments>> ] bi diff ;
  36
  37 M: ast-message-send assigned-locals
  38     [ arguments>> assigned-locals ]
  39     [ receiver>> assigned-locals ]
  40     bi append ;
  41
  42 M: ast-assignment assigned-locals
  43     [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
  44     [ value>> assigned-locals ] bi append ;
  45
  46 M: array assigned-locals
  47     [ assigned-locals ] map concat ;
  48
  49 M: object assigned-locals drop f ;
  50
  51 GENERIC: compile-ast ( lexenv ast -- quot )
  52
  53 M: object compile-ast nip 1quotation ;
  54
  55 ERROR: unbound-local name ;
  56
  57 M: ast-name compile-ast
  58     name>> swap local-readers>> at 1quotation ;
  59
  60 M: ast-message-send compile-ast
  61     [ arguments>> [ compile-ast ] with map [ ] join ]
  62     [ receiver>> compile-ast ]
  63     [ nip selector>> selector>generic ]
  64     2tri [ append ] dip suffix ;
  65
  66 M: ast-return compile-ast
  67     value>> compile-ast
  68     [ return-continuation get continue-with ] append ;
  69
  70 GENERIC: contains-blocks? ( obj -- ? )
  71
  72 M: ast-block contains-blocks? drop t ;
  73
  74 M: object contains-blocks? drop f ;
  75
  76 M: array contains-blocks? [ contains-blocks? ] any? ;
  77
  78 M: array compile-ast
  79     dup contains-blocks? [
  80         [ [ compile-ast ] with map [ ] join ] [ length ] bi
  81         '[ @ _ narray ]
  82     ] [
  83         call-next-method
  84     ] if ;
  85
  86 GENERIC: compile-assignment ( lexenv name -- quot )
  87
  88 M: ast-name compile-assignment
  89     name>> swap local-writers>> at 1quotation ;
  90
  91 M: ast-assignment compile-ast
  92     [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
  93
  94 : block-lexenv ( block -- lexenv )
  95     [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
  96     '[
  97         dup dup _ key?
  98         [ <local-reader> ]
  99         [ <local> ]
 100         if
 101     ] { } map>assoc
 102     dup
 103     [ nip local-reader? ] assoc-filter
 104     [ <local-writer> ] assoc-map
 105     <lexenv> ;
 106
 107 M: ast-block compile-ast
 108     [
 109         block-lexenv
 110         [ nip local-readers>> values ]
 111         [ lexenv-union ] 2bi
 112     ] [ body>> ] bi
 113     [ drop [ nil ] ] [
 114         unclip-last
 115         [ [ compile-ast [ drop ] append ] with map [ ] join ]
 116         [ compile-ast ]
 117         bi-curry* bi
 118         append
 119     ] if-empty
 120     <lambda> '[ _ ] ;
 121
 122 : compile-method ( block -- quot )
 123     [ [ empty-lexenv ] dip compile-ast [ call ] compose ]
 124     [ arguments>> length ]
 125     [ need-return-continuation? ]
 126     tri
 127     [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
 128
 129 : compile-statement ( statement -- quot )
 130     [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
 131     [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;