basis/stack-checker/transforms/transforms.factor

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