basis/typed/typed.factor

   1 ! Copyright (C) 2009, 2010, 2011 Joe Groff, Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes classes.algebra classes.tuple
   4 classes.struct combinators combinators.short-circuit definitions
   5 effects effects.parser fry generalizations kernel kernel.private
   6 locals locals.parser macros quotations sequences slots
   7 stack-checker.dependencies words ;
   8 FROM: classes.tuple.private => tuple-layout ;
   9 IN: typed
  10
  11 ERROR: type-mismatch-error value expected-type word expected-types ;
  12 ERROR: input-mismatch-error < type-mismatch-error ;
  13 ERROR: output-mismatch-error < type-mismatch-error ;
  14 ERROR: no-types-specified word effect ;
  15
  16 PREDICATE: typed-gensym < word "typed-gensym" word-prop >boolean ;
  17 PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
  18
  19 <PRIVATE
  20
  21 : unboxable-tuple-class? ( type -- ? )
  22     {
  23         [ only-classoid? not ]
  24         [ all-slots empty? not ]
  25         [ immutable-tuple-class? ]
  26         [ final-class? ]
  27         [ struct-class? not ] ! for struct boa change
  28     } 1&& ;
  29
  30 ! typed inputs
  31
  32 : typed-stack-effect? ( effect -- ? )
  33     [ object = ] all? not ;
  34
  35 : add-depends-on-unboxing ( class -- )
  36     [ dup tuple-layout add-depends-on-tuple-layout ]
  37     [ add-depends-on-final ]
  38     bi ;
  39
  40 : (unboxer) ( type -- quot )
  41     dup unboxable-tuple-class? [
  42         dup add-depends-on-unboxing
  43         all-slots [
  44             [ name>> reader-word 1quotation ]
  45             [ class>> (unboxer) ] bi compose
  46         ] map [ cleave ] curry
  47     ] [ drop [ ] ] if ;
  48
  49 :: unboxer ( error-quot word types type -- quot )
  50     type word? [ type "coercer" word-prop ] [ f ] if [ ] or
  51     type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
  52     type (unboxer)
  53     compose compose ;
  54
  55 : make-unboxer ( error-quot word types -- quot )
  56     dup [ unboxer ] 3 nwith
  57     [ swap \ dip [ ] 2sequence prepend ] map-reduce ;
  58
  59 : (unboxed-types) ( type -- types )
  60     dup unboxable-tuple-class?
  61     [
  62         dup add-depends-on-unboxing
  63         all-slots [ class>> (unboxed-types) ] map concat
  64     ]
  65     [ 1array ] if ;
  66
  67 : unboxed-types ( types -- types' )
  68     [ (unboxed-types) ] map concat ;
  69
  70 :: typed-inputs ( quot word types -- quot' )
  71     types unboxed-types :> unboxed-types
  72
  73     [ input-mismatch-error ] word types make-unboxer
  74     unboxed-types quot '[ _ declare @ ]
  75     compose ;
  76
  77 ! typed outputs
  78
  79 :: typed-outputs ( quot word types -- quot' )
  80     [ output-mismatch-error ] word types make-unboxer
  81     quot prepose ;
  82
  83 DEFER: make-boxer
  84
  85 : boxer ( type -- quot )
  86     dup unboxable-tuple-class?
  87     [
  88         dup add-depends-on-unboxing
  89         [ all-slots [ class>> ] map make-boxer ]
  90         [ [ boa ] curry ]
  91         bi compose
  92     ]
  93     [ drop [ ] ] if ;
  94
  95 : make-boxer ( types -- quot )
  96     [ [ ] ]
  97     [ [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ] if-empty ;
  98
  99 ! defining typed words
 100
 101 MACRO: (typed) ( word def effect -- quot )
 102     swapd
 103     [
 104         nip effect-in-types swap
 105         [ [ unboxed-types ] [ make-boxer ] bi ] dip
 106         '[ _ declare @ @ ]
 107     ]
 108     [
 109         effect-out-types
 110         dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
 111     ] 2bi ;
 112
 113 : <typed-gensym> ( parent-word -- word )
 114     [ name>> "( typed " " )" surround f <word> dup ]
 115     [ "typed-gensym" set-word-prop ] bi ;
 116
 117 : unboxed-effect ( effect -- effect' )
 118     [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
 119     [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
 120
 121 M: typed-gensym stack-effect call-next-method unboxed-effect ;
 122 M: typed-gensym parent-word "typed-gensym" word-prop ;
 123 M: typed-gensym crossref? parent-word crossref? ;
 124 M: typed-gensym where parent-word where ;
 125
 126 : define-typed-gensym ( word def effect -- gensym )
 127     [ 2drop <typed-gensym> dup ]
 128     [ [ (typed) ] 3curry ]
 129     [ 2nip ] 3tri define-declared ;
 130
 131 MACRO: typed ( quot word effect -- quot' )
 132     [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
 133     [
 134         nip effect-out-types dup typed-stack-effect?
 135         [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
 136     ] 2bi ;
 137
 138 : (typed-def) ( word def effect -- quot )
 139     [ define-typed-gensym ] 3keep
 140     [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
 141     [ typed ] 3curry ;
 142
 143 : typed-def? ( effect -- quot )
 144     {
 145         [ effect-in-types typed-stack-effect? ]
 146         [ effect-out-types typed-stack-effect? ]
 147     } 1|| ;
 148
 149 : typed-def ( word def effect -- quot )
 150     dup typed-def?
 151     [ (typed-def) ] [ nip no-types-specified ] if ;
 152
 153 M: typed-word subwords
 154     [ call-next-method ]
 155     [ "typed-word" word-prop ] bi suffix ;
 156
 157 PRIVATE>
 158
 159 : define-typed ( word def effect -- )
 160     [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
 161     [ drop "typed-def" set-word-prop ]
 162     [ 2drop "typed-word" word-prop set-last-word ] 3tri ;
 163
 164 SYNTAX: TYPED:
 165     (:) define-typed ;
 166 SYNTAX: TYPED::
 167     (::) define-typed ;
 168
 169 USE: vocabs.loader
 170
 171 { "typed" "prettyprint" } "typed.prettyprint" require-when
 172 { "typed" "compiler.cfg.debugger" } "typed.debugger" require-when