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 IN: stack-checker.transforms
  13
  14 : call-transformer ( stack quot -- newquot )
  15     '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ]
  16     [ error-continuation get current-word get transform-expansion-error ]
  17     recover ;
  18
  19 :: ((apply-transform)) ( quot values stack rstate -- )
  20     rstate recursive-state [ stack quot call-transformer ] with-variable
  21     values [ length meta-d shorten-by ] [ #drop, ] bi
  22     rstate infer-quot ;
  23
  24 : literal-values? ( values -- ? ) [ literal-value? ] all? ;
  25
  26 : input-values? ( values -- ? )
  27     [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ;
  28
  29 : (apply-transform) ( quot n -- )
  30     ensure-d {
  31         { [ dup literal-values? ] [
  32             dup empty? [ dup recursive-state get ] [
  33                 [ ]
  34                 [ [ literal value>> ] map ]
  35                 [ first literal recursion>> ] tri
  36             ] if
  37             ((apply-transform))
  38         ] }
  39         { [ dup input-values? ] [ drop current-word get unknown-macro-input ] }
  40         [ drop current-word get bad-macro-input ]
  41     } cond ;
  42
  43 : apply-transform ( word -- )
  44     [ current-word set ]
  45     [ "transform-quot" word-prop ]
  46     [ "transform-n" word-prop ] tri
  47     (apply-transform) ;
  48
  49 : apply-macro ( word -- )
  50     [ current-word set ]
  51     [ "macro" word-prop ]
  52     [ "declared-effect" word-prop in>> length ] tri
  53     (apply-transform) ;
  54
  55 : define-transform ( word quot n -- )
  56     [ drop "transform-quot" set-word-prop ]
  57     [ nip "transform-n" set-word-prop ]
  58     3bi ;
  59
  60 ! Combinators
  61 \ cond [ cond>quot ] 1 define-transform
  62
  63 \ cond t "no-compile" set-word-prop
  64
  65 \ case [
  66     [
  67         [ no-case ]
  68     ] [
  69         dup last callable? [
  70             dup last swap but-last
  71         ] [
  72             [ no-case ] swap
  73         ] if case>quot
  74     ] if-empty
  75 ] 1 define-transform
  76
  77 \ case t "no-compile" set-word-prop
  78
  79 \ cleave [ cleave>quot ] 1 define-transform
  80
  81 \ cleave t "no-compile" set-word-prop
  82
  83 \ 2cleave [ 2cleave>quot ] 1 define-transform
  84
  85 \ 2cleave t "no-compile" set-word-prop
  86
  87 \ 3cleave [ 3cleave>quot ] 1 define-transform
  88
  89 \ 3cleave t "no-compile" set-word-prop
  90
  91 \ spread [ 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 \ (call-next-method) [
 128     [
 129         [ "method-class" word-prop ]
 130         [ "method-generic" word-prop ] bi
 131         [ inlined-dependency depends-on ] bi@
 132     ] [
 133         [ next-method-quot ]
 134         [ '[ _ no-next-method ] ] bi or
 135     ] 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 inlined-dependency depends-on
 144         [ "boa-check" word-prop [ ] or ]
 145         [ tuple-layout '[ _ <tuple-boa> ] ]
 146         bi append
 147     ] [ drop f ] if
 148 ] 1 define-transform
 149
 150 \ boa t "no-compile" set-word-prop