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