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