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