Fixing inference after cleanup

core/generic/math/math.factor

@@ -25,16 +25,12 @@ PREDICATE: class math-class ( object -- ? )
     [ [ math-precedence ] compare 0 > ] most ;
 
 : (math-upgrade) ( max class -- quot )
-    dupd = [
+    dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
-        drop [ ]
-    ] [
-        "coercer" word-prop [ ] or
-    ] if ;
 
 : math-upgrade ( class1 class2 -- quot )
     [ math-class-max ] 2keep
-    >r over r> (math-upgrade)
+    >r over r> (math-upgrade) >r (math-upgrade)
-    >r (math-upgrade) dup empty? [ [ dip ] curry ] unless
+    dup empty? [ [ dip ] curry [ ] like ] unless
     r> append ;
 
 TUPLE: no-math-method left right generic ;

core/inference/backend/backend.factor

@@ -89,7 +89,7 @@ M: wrapper apply-object wrapped apply-literal ;
     r> recursive-state set ;
 
 : infer-quot-recursive ( quot word label -- )
-    2array add* infer-quot ;
+    recursive-state get -rot 2array add* infer-quot ;
 
 : time-bomb ( error -- )
     [ throw ] curry recursive-state get infer-quot ;
@@ -106,7 +106,7 @@ TUPLE: recursive-quotation-error quot ;
         dup value-literal callable? [
             dup value-literal
             over value-recursion
-            rot f infer-quot-recursive
+            rot f 2array add* infer-quot
         ] [
             drop bad-call
         ] if
@@ -364,11 +364,12 @@ TUPLE: effect-error word effect ;
     over recorded get push
     "inferred-effect" set-word-prop ;
 
-: infer-compound ( word -- )
+: infer-compound ( word -- effect )
     [
         init-inference
         dup word-def over dup infer-quot-recursive
         finish-word
+        current-effect
     ] with-scope ;
 
 M: compound infer-word
@@ -413,7 +414,7 @@ TUPLE: recursive-declare-error word ;
     [
         copy-inference nest-node
         dup word-def swap gensym
-        recursive-state get pick pick infer-quot-recursive
+        [ infer-quot-recursive ] 2keep
         #label unnest-node
     ] H{ } make-assoc ;
 

core/inference/transforms/transforms.factor

@@ -8,7 +8,7 @@ IN: inference.transforms
 : pop-literals ( n -- rstate seq )
     dup zero? [ drop f ] [
         [ ensure-values ] keep [ d-tail ] keep (consume-values)
-        dup value-recursion swap [ value-literal ] map
+        dup first value-recursion swap [ value-literal ] map
     ] if ;
 
 : transform-quot ( quot n -- newquot )
@@ -19,6 +19,7 @@ IN: inference.transforms
 : define-transform ( word quot n -- )
     transform-quot "infer" set-word-prop ;
 
+! Combinators
 \ cond [
     cond>quot
 ] 1 define-transform
@@ -35,6 +36,7 @@ IN: inference.transforms
     ] if
 ] 1 define-transform
 
+! Bitfields
 GENERIC: (bitfield-quot) ( spec -- quot )
 
 M: integer (bitfield-quot) ( spec -- quot )
@@ -58,5 +60,5 @@ M: pair (bitfield-quot) ( spec -- quot )
 \ set-slots [ <reversed> [get-slots] ] 1 define-transform
 
 \ construct-boa [
-    [ dup literalize , tuple-size , \ <tuple-boa> , ] [ ] make
+    dup tuple-size [ <tuple-boa> ] 2curry
 ] 1 define-transform

core/quotations/quotations.factor

@@ -43,6 +43,6 @@ M: curry nth
         >r 1- r> curry-quot nth
     ] if ;
 
-M: curry like drop [ ] like ;
+M: curry like drop dup callable? [ >quotation ] unless ;
 
 INSTANCE: curry immutable-sequence