basis/stack-checker/transforms/transforms.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry accessors arrays kernel words sequences generic math
   4 namespaces make quotations assocs combinators classes.tuple
   5 classes.tuple.private effects summary hashtables classes generic
   6 sets definitions generic.standard slots.private continuations
   7 stack-checker.backend stack-checker.state stack-checker.visitor
   8 stack-checker.errors ;
   9 IN: stack-checker.transforms
  10
  11 : give-up-transform ( word -- )
  12     dup recursive-label
  13     [ call-recursive-word ]
  14     [ dup infer-word apply-word/effect ]
  15     if ;
  16
  17 : ((apply-transform)) ( word quot values stack -- )
  18     rot with-datastack first2
  19     dup [
  20         [
  21             [ drop ] [
  22                 [ length meta-d get '[ _ pop* ] times ]
  23                 [ #drop, ]
  24                 bi
  25             ] bi*
  26         ] 2dip
  27         swap infer-quot
  28     ] [
  29         3drop give-up-transform
  30     ] if ; inline
  31
  32 : (apply-transform) ( word quot n -- )
  33     ensure-d dup [ known literal? ] all? [
  34         dup empty? [
  35             recursive-state get 1array
  36         ] [
  37             [ ]
  38             [ [ literal value>> ] map ]
  39             [ first literal recursion>> ] tri
  40             prefix
  41         ] if
  42         ((apply-transform))
  43     ] [ 2drop give-up-transform ] if ;
  44
  45 : apply-transform ( word -- )
  46     [ inlined-dependency depends-on ] [
  47         [ ]
  48         [ "transform-quot" word-prop ]
  49         [ "transform-n" word-prop ]
  50         tri
  51         (apply-transform)
  52     ] bi ;
  53
  54 : apply-macro ( word -- )
  55     [ inlined-dependency depends-on ] [
  56         [ ]
  57         [ "macro" word-prop ]
  58         [ "declared-effect" word-prop in>> length ]
  59         tri
  60         (apply-transform)
  61     ] bi ;
  62
  63 : define-transform ( word quot n -- )
  64     [ drop "transform-quot" set-word-prop ]
  65     [ nip "transform-n" set-word-prop ]
  66     3bi ;
  67
  68 ! Combinators
  69 \ cond [ cond>quot ] 1 define-transform
  70
  71 \ case [
  72     [
  73         [ no-case ]
  74     ] [
  75         dup peek quotation? [
  76             dup peek swap but-last
  77         ] [
  78             [ no-case ] swap
  79         ] if case>quot
  80     ] if-empty
  81 ] 1 define-transform
  82
  83 \ cleave [ cleave>quot ] 1 define-transform
  84
  85 \ 2cleave [ 2cleave>quot ] 1 define-transform
  86
  87 \ 3cleave [ 3cleave>quot ] 1 define-transform
  88
  89 \ spread [ spread>quot ] 1 define-transform
  90
  91 \ (call-next-method) [
  92     [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
  93 ] 2 define-transform
  94
  95 ! Constructors
  96 \ boa [
  97     dup tuple-class? [
  98         dup inlined-dependency depends-on
  99         [ "boa-check" word-prop [ ] or ]
 100         [ tuple-layout '[ _ <tuple-boa> ] ]
 101         bi append
 102     ] [ drop f ] if
 103 ] 1 define-transform
 104
 105 \ new [
 106     dup tuple-class? [
 107         dup inlined-dependency depends-on
 108         [
 109             [ all-slots [ initial>> literalize , ] each ]
 110             [ literalize , ] bi
 111             \ boa ,
 112         ] [ ] make
 113     ] [ drop f ] if
 114 ] 1 define-transform
 115
 116 ! Membership testing
 117 : bit-member-n 256 ; inline
 118
 119 : bit-member? ( seq -- ? )
 120     #! Can we use a fast byte array test here?
 121     {
 122         { [ dup length 8 < ] [ f ] }
 123         { [ dup [ integer? not ] contains? ] [ f ] }
 124         { [ dup [ 0 < ] contains? ] [ f ] }
 125         { [ dup [ bit-member-n >= ] contains? ] [ f ] }
 126         [ t ]
 127     } cond nip ;
 128
 129 : bit-member-seq ( seq -- flags )
 130     bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
 131
 132 : exact-float? ( f -- ? )
 133     dup float? [ dup >integer >float = ] [ drop f ] if ; inline
 134
 135 : bit-member-quot ( seq -- newquot )
 136     [
 137         bit-member-seq ,
 138         [
 139             {
 140                 { [ over fixnum? ] [ ?nth 1 eq? ] }
 141                 { [ over bignum? ] [ ?nth 1 eq? ] }
 142                 { [ over exact-float? ] [ ?nth 1 eq? ] }
 143                 [ 2drop f ]
 144             } cond
 145         ] %
 146     ] [ ] make ;
 147
 148 : member-quot ( seq -- newquot )
 149     dup bit-member? [
 150         bit-member-quot
 151     ] [
 152         [ literalize [ t ] ] { } map>assoc
 153         [ drop f ] suffix [ case ] curry
 154     ] if ;
 155
 156 \ member? [
 157     dup sequence? [ member-quot ] [ drop f ] if
 158 ] 1 define-transform
 159
 160 : memq-quot ( seq -- newquot )
 161     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 162     [ drop f ] suffix [ cond ] curry ;
 163
 164 \ memq? [
 165     dup sequence? [ memq-quot ] [ drop f ] if
 166 ] 1 define-transform