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