basis/stack-checker/backend/backend.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays effects fry kernel locals math
   4 math.order namespaces quotations sequences
   5 stack-checker.dependencies stack-checker.errors
   6 stack-checker.recursive-state stack-checker.state
   7 stack-checker.values stack-checker.visitor words ;
   8 IN: stack-checker.backend
   9
  10 : push-d ( obj -- ) meta-d push ;
  11
  12 : introduce-values ( values -- )
  13     [ [ input-parameter swap set-known ] each ]
  14     [ length input-count +@ ]
  15     [ #introduce, ]
  16     tri ;
  17
  18 : update-inner-d ( new -- )
  19     inner-d-index get min inner-d-index set ;
  20
  21 : pop-d  ( -- obj )
  22     meta-d
  23     [ <value> dup 1array introduce-values ]
  24     [ pop meta-d length update-inner-d ] if-empty ;
  25
  26 : peek-d ( -- obj ) pop-d dup push-d ;
  27
  28 : make-values ( n -- values )
  29     [ <value> ] replicate ;
  30
  31 : ensure-d ( n -- values )
  32     meta-d 2dup length > [
  33         2dup
  34         [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
  35         [ introduce-values ] [ meta-d push-all ] bi
  36         meta-d push-all
  37     ] when
  38     swap from-tail [ tail ] [ update-inner-d ] bi ;
  39
  40 : shorten-by ( n seq -- )
  41     [ length swap - ] keep shorten ; inline
  42
  43 : shorten-d ( n -- )
  44     meta-d shorten-by meta-d length update-inner-d ;
  45
  46 : consume-d ( n -- seq )
  47     [ ensure-d ] [ shorten-d ] bi ;
  48
  49 : output-d ( values -- ) meta-d push-all ;
  50
  51 : produce-d ( n -- values )
  52     make-values dup meta-d push-all ;
  53
  54 : push-r ( obj -- ) meta-r push ;
  55
  56 : pop-r ( -- obj )
  57     meta-r [ too-many-r> ] [ pop ] if-empty ;
  58
  59 : consume-r ( n -- seq )
  60     meta-r 2dup length > [ too-many-r> ] when
  61     [ swap tail* ] [ shorten-by ] 2bi ;
  62
  63 : output-r ( seq -- ) meta-r push-all ;
  64
  65 : push-literal ( obj -- )
  66     literals get push ;
  67
  68 : pop-literal ( -- obj )
  69     literals get [
  70         pop-d [ 1array #drop, ] [ literal value>> ] bi
  71     ] [ pop ] if-empty ;
  72
  73 : literals-available? ( n -- literals ? )
  74     literals get 2dup length <= [
  75         [ swap tail* ] [ shorten-by ] 2bi t
  76     ] [
  77         2drop f f
  78     ] if ;
  79
  80 GENERIC: apply-object ( obj -- )
  81
  82 M: wrapper apply-object
  83     wrapped>> push-literal ;
  84
  85 M: object apply-object push-literal ;
  86
  87 : terminate ( -- )
  88     terminated? on meta-d clone meta-r clone #terminate, ;
  89
  90 : check->r ( -- )
  91     meta-r empty? [ too-many->r ] unless ;
  92
  93 : infer-quot-here ( quot -- )
  94     meta-r [
  95         V{ } clone (meta-r) set
  96         [ apply-object terminated? get not ] all?
  97         [ commit-literals check->r ] [ literals get delete-all ] if
  98     ] dip (meta-r) set ;
  99
 100 : infer-quot ( quot rstate -- )
 101     recursive-state get [
 102         recursive-state set
 103         infer-quot-here
 104     ] dip recursive-state set ;
 105
 106 : time-bomb-quot ( obj generic -- quot )
 107     [ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ;
 108
 109 : time-bomb ( obj generic -- )
 110     time-bomb-quot infer-quot-here ;
 111
 112 : infer-literal-quot ( literal -- )
 113     dup recursive-quotation? [
 114         value>> recursive-quotation-error
 115     ] [
 116         dup value>> callable? [
 117             [ value>> ]
 118             [ [ recursion>> ] keep add-local-quotation ]
 119             bi infer-quot
 120         ] [
 121             value>> \ call time-bomb
 122         ] if
 123     ] if ;
 124
 125 : infer->r ( n -- )
 126     consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
 127
 128 : infer-r> ( n -- )
 129     consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 130
 131 : consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
 132     '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
 133     [ terminated?>> [ terminate ] when ]
 134     bi ; inline
 135
 136 : apply-word/effect ( word effect -- )
 137     swap '[ _ #call, ] consume/produce ;
 138
 139 : end-infer ( -- )
 140     meta-d clone #return, ;
 141
 142 : required-stack-effect ( word -- effect )
 143     dup stack-effect [ ] [ missing-effect ] ?if ;
 144
 145 : with-infer ( quot -- effect visitor )
 146     [
 147         init-inference
 148         H{ } clone known-values set
 149         stack-visitor off
 150         call
 151         end-infer
 152         current-effect
 153         stack-visitor get
 154     ] with-scope ; inline
 155
 156 : ?quotation-effect ( in -- effect/f )
 157     dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
 158
 159 :: declare-effect-d ( word effect variables branches n -- )
 160     meta-d length :> d-length
 161     n d-length < [
 162         d-length 1 - n - :> n'
 163         n' meta-d nth :> value
 164         value known :> known
 165         known word effect variables branches <declared-effect> :> known'
 166         known' value set-known
 167         known' branches push
 168     ] [ word unknown-macro-input ] if ;
 169
 170 :: declare-input-effects ( word -- )
 171     H{ } clone :> variables
 172     V{ } clone :> branches
 173     word stack-effect in>> <reversed> [| in n |
 174         in ?quotation-effect [| effect |
 175             word effect variables branches n declare-effect-d
 176         ] when*
 177     ] each-index ;