basis/stack-checker/transforms/transforms.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes.tuple classes.tuple.private combinators
   4 combinators.short-circuit continuations fry generic kernel
   5 locals namespaces quotations sequences stack-checker.backend
   6 stack-checker.dependencies stack-checker.errors
   7 stack-checker.recursive-state stack-checker.values
   8 stack-checker.visitor words ;
   9 IN: stack-checker.transforms
  10
  11 : call-transformer ( stack quot -- newquot )
  12     '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ]
  13     [ error-continuation get current-word get transform-expansion-error ]
  14     recover ;
  15
  16 :: apply-literal-values-transform ( quot values stack rstate -- )
  17     rstate recursive-state [ stack quot call-transformer ] with-variable
  18     values [ length shorten-d ] [ #drop, ] bi
  19     rstate infer-quot ;
  20
  21 : literal-values? ( values -- ? ) [ literal-value? ] all? ;
  22
  23 : input-values? ( values -- ? )
  24     [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ;
  25
  26 : (apply-transform) ( quot n -- )
  27     ensure-d {
  28         { [ dup literal-values? ] [
  29             dup empty? [ dup recursive-state get ] [
  30                 [ ]
  31                 [ [ literal value>> ] map ]
  32                 [ first literal recursion>> ] tri
  33             ] if
  34             apply-literal-values-transform
  35         ] }
  36         { [ dup input-values? ] [ drop current-word get unknown-macro-input ] }
  37         [ drop current-word get bad-macro-input ]
  38     } cond ;
  39
  40 : apply-transform ( word -- )
  41     [ current-word set ]
  42     [ "transform-quot" word-prop ]
  43     [ "transform-n" word-prop ] tri
  44     (apply-transform) ;
  45
  46 : apply-macro ( word -- )
  47     [ current-word set ]
  48     [ "macro" word-prop ]
  49     [ "declared-effect" word-prop in>> length ] tri
  50     (apply-transform) ;
  51
  52 : define-transform ( word quot n -- )
  53     [ drop "transform-quot" set-word-prop ]
  54     [ nip "transform-n" set-word-prop ]
  55     3bi ;
  56
  57 ! Combinators
  58 \ cond [ cond>quot ] 1 define-transform
  59
  60 \ cond t "no-compile" set-word-prop
  61
  62 \ case [
  63     [
  64         [ no-case ]
  65     ] [
  66         dup [ callable? ] find dup
  67         [ [ head ] dip ] [ 2drop [ no-case ] ] if
  68         swap case>quot
  69     ] if-empty
  70 ] 1 define-transform
  71
  72 \ case t "no-compile" set-word-prop
  73
  74 \ cleave [ cleave>quot ] 1 define-transform
  75
  76 \ cleave t "no-compile" set-word-prop
  77
  78 \ 2cleave [ 2cleave>quot ] 1 define-transform
  79
  80 \ 2cleave t "no-compile" set-word-prop
  81
  82 \ 3cleave [ 3cleave>quot ] 1 define-transform
  83
  84 \ 3cleave t "no-compile" set-word-prop
  85
  86 \ 4cleave [ 4cleave>quot ] 1 define-transform
  87
  88 \ 4cleave t "no-compile" set-word-prop
  89
  90 \ spread [ deep-spread>quot ] 1 define-transform
  91
  92 \ spread t "no-compile" set-word-prop
  93
  94 \ 0&& [ '[ _ 0 n&& ] ] 1 define-transform
  95
  96 \ 0&& t "no-compile" set-word-prop
  97
  98 \ 1&& [ '[ _ 1 n&& ] ] 1 define-transform
  99
 100 \ 1&& t "no-compile" set-word-prop
 101
 102 \ 2&& [ '[ _ 2 n&& ] ] 1 define-transform
 103
 104 \ 2&& t "no-compile" set-word-prop
 105
 106 \ 3&& [ '[ _ 3 n&& ] ] 1 define-transform
 107
 108 \ 3&& t "no-compile" set-word-prop
 109
 110 \ 0|| [ '[ _ 0 n|| ] ] 1 define-transform
 111
 112 \ 0|| t "no-compile" set-word-prop
 113
 114 \ 1|| [ '[ _ 1 n|| ] ] 1 define-transform
 115
 116 \ 1|| t "no-compile" set-word-prop
 117
 118 \ 2|| [ '[ _ 2 n|| ] ] 1 define-transform
 119
 120 \ 2|| t "no-compile" set-word-prop
 121
 122 \ 3|| [ '[ _ 3 n|| ] ] 1 define-transform
 123
 124 \ 3|| t "no-compile" set-word-prop
 125
 126 : add-next-method-dependency ( method -- )
 127     [ "method-class" word-prop ]
 128     [ "method-generic" word-prop ] bi
 129     2dup next-method
 130     add-depends-on-next-method ;
 131
 132 \ (call-next-method) [
 133     [ add-next-method-dependency ]
 134     [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
 135 ] 1 define-transform
 136
 137 \ (call-next-method) t "no-compile" set-word-prop
 138
 139 ! Constructors
 140 \ boa [
 141     dup tuple-class? [
 142         dup tuple-layout
 143         [ add-depends-on-tuple-layout ]
 144         [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
 145         '[ @ _ <tuple-boa> ]
 146     ] [
 147         \ boa time-bomb
 148     ] if
 149 ] 1 define-transform
 150
 151 \ boa t "no-compile" set-word-prop