Better error messages for when new or boa are applied to the wrong type

core/classes/tuple/tuple-tests.factor

@@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting inspector
-columns math.order classes.private ;
+columns math.order classes.private slots.private ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
 
 [ t ] [
     T{ size-test } tuple-size
-    size-test tuple-size =
+    size-test tuple-layout layout-size =
 ] unit-test
 
 GENERIC: <yo-momma>
@@ -220,7 +220,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 [
     "IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ error>> no-tuple-class? ] must-fail-with
+] [ error>> not-a-tuple-class? ] must-fail-with
 
 ! Inheritance
 TUPLE: computer cpu ram ;
@@ -252,7 +252,7 @@ C: <laptop> laptop
 test-laptop-slot-values
 
 [ laptop ] [
-    "laptop" get tuple-layout
+    "laptop" get 1 slot
     dup layout-echelon swap
     layout-superclasses nth
 ] unit-test
@@ -490,7 +490,7 @@ USE: vocabs
     ] with-compilation-unit
 ] unit-test
 
-[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
+[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with
 
 ! Accessors not being forgotten...
 [ [ ] ] [
@@ -595,3 +595,6 @@ GENERIC: break-me ( obj -- )
 [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
 
 [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
+
+! Insufficient type checking
+[ \ vocab tuple>array drop ] must-fail

core/classes/tuple/tuple.factor

@@ -9,32 +9,32 @@ IN: classes.tuple
 
 M: tuple class 1 slot 2 slot { word } declare ;
 
-ERROR: no-tuple-class class ;
+ERROR: not-a-tuple object ;
+
+: check-tuple ( object -- tuple )
+    dup tuple? [ not-a-tuple ] unless ; inline
+
+ERROR: not-a-tuple-class class ;
+
+: check-tuple-class ( class -- class )
+    dup tuple-class? [ not-a-tuple-class ] unless ; inline
 
 <PRIVATE
 
-GENERIC: tuple-layout ( object -- layout )
+: tuple-layout ( class -- layout )
+    check-tuple-class "layout" word-prop ;
 
-M: tuple-class tuple-layout "layout" word-prop ;
-
-M: tuple tuple-layout 1 slot ;
-
-M: tuple-layout tuple-layout ;
-
-: tuple-size tuple-layout layout-size ; inline
+: tuple-size ( tuple -- size )
+    1 slot layout-size ; inline
 
 : prepare-tuple>array ( tuple -- n tuple layout )
-    [ tuple-size ] [ ] [ tuple-layout ] tri ;
+    check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
 
 : copy-tuple-slots ( n tuple -- array )
     [ array-nth ] curry map ;
 
 PRIVATE>
 
-: check-tuple ( class -- )
-    dup tuple-class?
-    [ drop ] [ no-tuple-class ] if ;
-
 : tuple>array ( tuple -- array )
     prepare-tuple>array
     >r copy-tuple-slots r>
@@ -63,7 +63,7 @@ ERROR: bad-superclass class ;
 <PRIVATE
 
 : tuple= ( tuple1 tuple2 -- ? )
-    2dup [ tuple-layout ] bi@ eq? [
+    2dup [ 1 slot ] bi@ eq? [
         [ drop tuple-size ]
         [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
         2bi all-integers?

core/debugger/debugger.factor

@@ -209,8 +209,11 @@ M: inconsistent-next-method summary
 M: check-method summary
     drop "Invalid parameters for create-method" ;
 
-M: no-tuple-class summary
-    drop "BOA constructors can only be defined for tuple classes" ;
+M: not-a-tuple summary
+    drop "Not a tuple" ;
+
+M: not-a-tuple-class summary
+    drop "Not a tuple class" ;
 
 M: bad-superclass summary
     drop "Tuple classes can only inherit from other tuple classes" ;

core/effects/effects.factor

@@ -42,14 +42,14 @@ M: integer (stack-picture) drop "object" ;
 
 GENERIC: stack-effect ( word -- effect/f )
 
-M: symbol stack-effect drop 0 1 <effect> ;
+M: symbol stack-effect drop (( -- symbol )) ;
 
 M: word stack-effect
     { "declared-effect" "inferred-effect" }
     swap word-props [ at ] curry map [ ] find nip ;
 
 M: effect clone
-    [ in>> clone ] keep effect-out clone <effect> ;
+    [ in>> clone ] [ out>> clone ] bi <effect> ;
 
 : split-shuffle ( stack shuffle -- stack1 stack2 )
     in>> length cut* ;

core/inference/backend/backend.factor

@@ -228,7 +228,7 @@ M: object constructor drop f ;
         1 infer->r
         peek-d reify-curry
         1 infer-r>
-        2 1 <effect> swap #call consume/produce
+        (( obj quot -- curry )) swap #call consume/produce
     ] when* ;
 
 : reify-curries ( n -- )

core/inference/transforms/transforms-tests.factor

@@ -1,7 +1,7 @@
 IN: inference.transforms.tests
 USING: sequences inference.transforms tools.test math kernel
 quotations inference accessors combinators words arrays
-classes ;
+classes classes.tuple ;
 
 : compose-n-quot ( word -- quot' ) <repetition> >quotation ;
 : compose-n ( quot -- ) compose-n-quot call ;
@@ -46,3 +46,9 @@ C: <color> color
 [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
 
 [ fixnum instance? ] must-infer
+
+: bad-new-test ( -- obj ) V{ } new ;
+
+[ bad-new-test ] must-infer
+
+[ bad-new-test ] [ T{ not-a-tuple-class f V{ } } = ] must-fail-with

core/inference/transforms/transforms.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel words sequences generic math namespaces
 quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic sets definitions ;
+inference.dataflow inference.state classes.tuple
+classes.tuple.private effects inspector hashtables classes
+generic sets definitions ;
 IN: inference.transforms
 
 : pop-literals ( n -- rstate seq )
@@ -83,19 +84,26 @@ M: duplicated-slots-error summary
 ] 1 define-transform
 
 \ boa [
-    dup +inlined+ depends-on
-    tuple-layout [ <tuple-boa> ] curry
+    dup tuple-class? [
+        dup +inlined+ depends-on
+        tuple-layout [ <tuple-boa> ] curry
+    ] [
+        [ not-a-tuple-class ] curry time-bomb
+    ] if
 ] 1 define-transform
 
 \ new [
     1 ensure-values
     peek-d value? [
-        pop-literal
-        dup +inlined+ depends-on
-        tuple-layout [ <tuple> ] curry
-        swap infer-quot
+        pop-literal dup tuple-class? [
+            dup +inlined+ depends-on
+            tuple-layout [ <tuple> ] curry
+            swap infer-quot
+        ] [
+            \ not-a-tuple-class boa time-bomb drop
+        ] if
     ] [
-        \ new 1 1 <effect> make-call-node
+        \ new (( class -- tuple )) make-call-node
     ] if
 ] "infer" set-word-prop
 

core/optimizer/math/partial/partial.factor

@@ -59,7 +59,7 @@ PREDICATE: math-partial < word
 : define-integer-op-word ( word fix-word big-word -- )
     [
         [ integer-op-word ] [ integer-op-quot ] 3bi
-        2 1 <effect> define-declared
+        (( x y -- z )) define-declared
     ]
     [
         [ integer-op-word ] [ 2drop ] 3bi

core/syntax/syntax.factor

@@ -168,7 +168,7 @@ IN: bootstrap.syntax
 
     "C:" [
         CREATE-WORD
-        scan-word dup check-tuple
+        scan-word check-tuple-class
         [ boa ] curry define-inline
     ] define-syntax