extra/smalltalk/compiler/lexenv/lexenv.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs kernel accessors quotations slots words
   4 sequences namespaces combinators combinators.short-circuit
   5 summary smalltalk.classes ;
   6 IN: smalltalk.compiler.lexenv
   7
   8 ! local-readers: assoc string => word
   9 ! local-writers: assoc string => word
  10 ! self: word or f for top-level forms
  11 ! class: class word or f for top-level forms
  12 ! method: generic word or f for top-level forms
  13 TUPLE: lexenv local-readers local-writers self return class method ;
  14
  15 : <lexenv> ( -- lexenv ) lexenv new ; inline
  16
  17 CONSTANT: empty-lexenv T{ lexenv }
  18
  19 : lexenv-union ( lexenv1 lexenv2 -- lexenv )
  20     [ <lexenv> ] 2dip {
  21         [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
  22         [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
  23         [ [ self>> ] either? >>self ]
  24         [ [ return>> ] either? >>return ]
  25         [ [ class>> ] either? >>class ]
  26         [ [ method>> ] either? >>method ]
  27     } 2cleave ;
  28
  29 : local-reader ( name lexenv -- local )
  30     local-readers>> at dup [ 1quotation ] when ;
  31
  32 : ivar-reader ( name lexenv -- quot/f )
  33     dup class>> [
  34         [ class>> "slots" word-prop slot-named ] [ self>> ] bi
  35         swap [ name>> reader-word [ ] 2sequence ] [ drop f ] if*
  36     ] [ 2drop f ] if ;
  37
  38 : class-name ( name -- quot/f )
  39     classes get at dup [ [ ] curry ] when ;
  40
  41 ERROR: bad-identifier name ;
  42
  43 M: bad-identifier summary drop "Unknown identifier" ;
  44
  45 : lookup-reader ( name lexenv -- reader-quot )
  46     {
  47         [ local-reader ]
  48         [ ivar-reader ]
  49         [ drop class-name ]
  50         [ drop bad-identifier ]
  51     } 2|| ;
  52
  53 : local-writer ( name lexenv -- local )
  54     local-writers>> at dup [ 1quotation ] when ;
  55
  56 : ivar-writer ( name lexenv -- quot/f )
  57     dup class>> [
  58         [ class>> "slots" word-prop slot-named ] [ self>> ] bi
  59         swap [ name>> writer-word [ ] 2sequence ] [ drop f ] if*
  60     ] [ 2drop f ] if ;
  61
  62 : lookup-writer ( name lexenv -- writer-quot )
  63     {
  64         [ local-writer ]
  65         [ ivar-writer ]
  66         [ drop bad-identifier ]
  67     } 2|| ;