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