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 sequences.generalizations slots locals.types
   6 splitting math locals.rewrite.closures generic words combinators
   7 locals smalltalk.ast smalltalk.compiler.lexenv
   8 smalltalk.compiler.assignment smalltalk.compiler.return
   9 smalltalk.selectors smalltalk.classes ;
  10 IN: smalltalk.compiler
  11
  12 GENERIC: compile-ast ( lexenv ast -- quot )
  13
  14 M: object compile-ast nip 1quotation ;
  15
  16 M: self compile-ast drop self>> 1quotation ;
  17
  18 ERROR: unbound-local name ;
  19
  20 M: ast-name compile-ast name>> swap lookup-reader ;
  21
  22 : compile-arguments ( lexenv ast -- quot )
  23     arguments>> [ compile-ast ] with map [ ] join ;
  24
  25 : compile-new ( lexenv ast -- quot )
  26     [ receiver>> compile-ast ]
  27     [ compile-arguments ] 2bi
  28     [ new ] 3append ;
  29
  30 : compile-ifTrue:ifFalse: ( lexenv ast -- quot )
  31     [ receiver>> compile-ast ]
  32     [ compile-arguments ] 2bi
  33     [ if ] 3append ;
  34
  35 M: ast-message-send compile-ast
  36     dup selector>> {
  37         { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
  38         { "new" [ compile-new ] }
  39         [
  40             drop
  41             [ compile-arguments ]
  42             [ receiver>> compile-ast ]
  43             [ nip selector>> selector>generic ]
  44             2tri [ append ] dip suffix
  45         ]
  46     } case ;
  47
  48 M: ast-cascade compile-ast
  49     [ receiver>> compile-ast ]
  50     [
  51         messages>> [
  52             [ compile-arguments \ dip ]
  53             [ selector>> selector>generic ] bi
  54             [ ] 3sequence
  55         ] with map
  56         unclip-last [ [ [ drop ] append ] map ] dip suffix
  57         cleave>quot
  58     ] 2bi append ;
  59
  60 M: ast-return compile-ast
  61     [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
  62     [ continue-with ] 3append ;
  63
  64 : (compile-sequence) ( lexenv asts -- quot )
  65     [ drop [ nil ] ] [
  66         [ compile-ast ] with map [ drop ] join
  67     ] if-empty ;
  68
  69 : block-lexenv ( block -- lexenv )
  70     [ [ arguments>> ] [ temporaries>> ] bi append ]
  71     [ body>> [ assigned-locals ] map concat unique ] bi
  72     '[
  73         dup dup _ key?
  74         [ <local-reader> ]
  75         [ <local> ]
  76         if
  77     ] H{ } map>assoc
  78     dup
  79     [ nip local-reader? ] assoc-filter
  80     [ <local-writer> ] assoc-map
  81     <lexenv> swap >>local-writers swap >>local-readers ;
  82
  83 : lookup-block-vars ( vars lexenv -- seq )
  84     local-readers>> '[ _ at ] map ;
  85
  86 : make-temporaries ( block lexenv -- quot )
  87     [ temporaries>> ] dip lookup-block-vars
  88     [ <def> [ f ] swap suffix ] map [ ] join ;
  89
  90 :: compile-sequence ( lexenv block -- vars quot )
  91     lexenv block block-lexenv lexenv-union :> lexenv
  92     block arguments>> lexenv lookup-block-vars
  93     lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
  94
  95 M: ast-sequence compile-ast
  96     compile-sequence nip ;
  97
  98 GENERIC: contains-blocks? ( obj -- ? )
  99
 100 M: ast-block contains-blocks? drop t ;
 101
 102 M: object contains-blocks? drop f ;
 103
 104 M: array contains-blocks? [ contains-blocks? ] any? ;
 105
 106 M: array compile-ast
 107     dup contains-blocks? [
 108         [ [ compile-ast ] with map [ ] join ] [ length ] bi
 109         '[ @ _ narray ]
 110     ] [ call-next-method ] if ;
 111
 112 GENERIC: compile-assignment ( lexenv name -- quot )
 113
 114 M: ast-name compile-assignment name>> swap lookup-writer ;
 115
 116 M: ast-assignment compile-ast
 117     [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
 118
 119 M: ast-block compile-ast
 120     compile-sequence <lambda> '[ _ ] ;
 121
 122 :: (compile-method-body) ( lexenv block -- lambda )
 123     lexenv block compile-sequence
 124     [ lexenv self>> suffix ] dip <lambda> ;
 125
 126 : compile-method-body ( lexenv block -- quot )
 127     [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
 128     make-return ;
 129
 130 : compile-method ( lexenv ast-method -- )
 131     [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
 132     [ body>> compile-method-body ]
 133     2bi define ;
 134
 135 : <class-lexenv> ( class -- lexenv )
 136     <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
 137
 138 M: ast-class compile-ast
 139     nip
 140     [
 141         [ name>> ] [ superclass>> ] [ ivars>> ] tri
 142         define-class <class-lexenv>
 143     ]
 144     [ methods>> ] bi
 145     [ compile-method ] with each
 146     [ nil ] ;
 147
 148 ERROR: no-word name ;
 149
 150 M: ast-foreign compile-ast
 151     nip
 152     [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
 153     [ name>> ] bi define-foreign
 154     [ nil ] ;
 155
 156 : compile-smalltalk ( statement -- quot )
 157     [ empty-lexenv ] dip [ compile-sequence nip 0 ]
 158     2keep make-return ;