diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 604914bd5c..c93bd11ffe 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/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: @@ -220,7 +220,7 @@ C: erg's-reshape-problem [ "IN: classes.tuple.tests SYMBOL: not-a-class C: 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 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b4a2302a9e..df59f34ff4 100755 --- a/core/classes/tuple/tuple.factor +++ b/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 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 ; ; +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 ; + [ in>> clone ] [ out>> clone ] bi ; : split-shuffle ( stack shuffle -- stack1 stack2 ) in>> length cut* ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index f8b071e803..59fbd289db 100755 --- a/core/inference/backend/backend.factor +++ b/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 swap #call consume/produce + (( obj quot -- curry )) swap #call consume/produce ] when* ; : reify-curries ( n -- ) diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index f90dd2350c..7f5f8035fb 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/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' ) >quotation ; : compose-n ( quot -- ) compose-n-quot call ; @@ -46,3 +46,9 @@ C: 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 5ca10c7545..8fc72b0f09 100755 --- a/core/inference/transforms/transforms.factor +++ b/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 [ ] curry + dup tuple-class? [ + dup +inlined+ depends-on + tuple-layout [ ] 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 [ ] curry - swap infer-quot + pop-literal dup tuple-class? [ + dup +inlined+ depends-on + tuple-layout [ ] curry + swap infer-quot + ] [ + \ not-a-tuple-class boa time-bomb drop + ] if ] [ - \ new 1 1 make-call-node + \ new (( class -- tuple )) make-call-node ] if ] "infer" set-word-prop diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 8b5e25deb1..30a726e022 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/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 define-declared + (( x y -- z )) define-declared ] [ [ integer-op-word ] [ 2drop ] 3bi diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index dfba35f71a..4d4b81d00e 100755 --- a/core/syntax/syntax.factor +++ b/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