basis/stack-checker/values/values.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs fry kernel namespaces quotations
   4 sequences stack-checker.errors stack-checker.recursive-state ;
   5 IN: stack-checker.values
   6
   7 : <value> ( -- value ) \ <value> counter ;
   8
   9 SYMBOL: known-values
  10
  11 : known ( value -- known )
  12     known-values get at ;
  13
  14 : set-known ( known value -- )
  15     '[ _ known-values get set-at ] when* ;
  16
  17 : make-known ( known -- value )
  18     <value> [ set-known ] keep ;
  19
  20 : copy-value ( value -- value' )
  21     known make-known ;
  22
  23 : copy-values ( values -- values' )
  24     [ copy-value ] map ;
  25
  26 GENERIC: (literal-value?) ( value -- ? )
  27
  28 : literal-value? ( value -- ? )
  29     known (literal-value?) ;
  30
  31 GENERIC: (input-value?) ( value -- ? )
  32
  33 : input-value? ( value -- ? )
  34     known (input-value?) ;
  35
  36 GENERIC: (literal) ( known -- literal )
  37
  38 TUPLE: literal-tuple < identity-tuple value recursion ;
  39
  40 : literal ( value -- literal ) known (literal) ;
  41
  42 M: literal-tuple hashcode* nip value>> identity-hashcode ;
  43
  44 : <literal> ( obj -- value )
  45     recursive-state get literal-tuple boa ;
  46
  47 M: literal-tuple (input-value?) drop f ;
  48
  49 M: literal-tuple (literal-value?) drop t ;
  50
  51 M: literal-tuple (literal) ;
  52
  53 : curried/composed-literal ( input1 input2 quot -- literal )
  54     [ [ literal ] bi@ ] dip
  55     [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
  56     literal-tuple boa ; inline
  57
  58 TUPLE: curried-effect obj quot ;
  59
  60 C: <curried-effect> curried-effect
  61
  62 : >curried-effect< ( curried-effect -- obj quot )
  63     [ obj>> ] [ quot>> ] bi ; inline
  64
  65 M: curried-effect (input-value?)
  66     >curried-effect< [ input-value? ] either? ;
  67
  68 M: curried-effect (literal-value?)
  69     >curried-effect< [ literal-value? ] both? ;
  70
  71 M: curried-effect (literal)
  72     >curried-effect< [ curry ] curried/composed-literal ;
  73
  74 TUPLE: composed-effect quot1 quot2 ;
  75
  76 C: <composed-effect> composed-effect
  77
  78 : >composed-effect< ( composed-effect -- quot1 quot2 )
  79     [ quot1>> ] [ quot2>> ] bi ; inline
  80
  81 M: composed-effect (input-value?)
  82     >composed-effect< [ input-value? ] either? ;
  83
  84 M: composed-effect (literal-value?)
  85     >composed-effect< [ literal-value? ] both? ;
  86
  87 M: composed-effect (literal)
  88     >composed-effect< [ compose ] curried/composed-literal ;
  89
  90 SINGLETON: input-parameter
  91
  92 SYMBOL: current-word
  93
  94 M: input-parameter (input-value?) drop t ;
  95
  96 M: input-parameter (literal-value?) drop f ;
  97
  98 M: input-parameter (literal) current-word get unknown-macro-input ;
  99
 100 ! Argument corresponding to polymorphic declared input of inline combinator
 101
 102 TUPLE: declared-effect known word effect variables branches actual ;
 103
 104 C: (declared-effect) declared-effect
 105
 106 : <declared-effect> ( known word effect variables branches -- declared-effect )
 107     f (declared-effect) ; inline
 108
 109 M: declared-effect (input-value?) known>> (input-value?) ;
 110
 111 M: declared-effect (literal-value?) known>> (literal-value?) ;
 112
 113 M: declared-effect (literal) known>> (literal) ;
 114
 115 ! Computed values
 116 M: f (input-value?) drop f ;
 117
 118 M: f (literal-value?) drop f ;
 119
 120 M: f (literal) current-word get bad-macro-input ;
 121
 122 GENERIC: known>callable ( known -- quot )
 123
 124 : ?@ ( x -- y )
 125     dup callable? [ drop \ _ ] unless ;
 126
 127 M: object known>callable drop \ _ ;
 128
 129 M: literal-tuple known>callable value>> ;
 130
 131 M: composed-effect known>callable
 132     >composed-effect< [ known known>callable ?@ ] bi@ append ;
 133
 134 M: curried-effect known>callable
 135     >curried-effect< [ known known>callable ] bi@ swap prefix ;
 136
 137 M: declared-effect known>callable
 138     known>> known>callable ;