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