From 871831fdae1364b58d87fc5b56f703250accc646 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 20:07:30 -0500 Subject: [PATCH] Fixing hook stack effects --- core/generic/generic-tests.factor | 11 ---- core/generic/generic.factor | 5 +- core/generic/standard/engines/engines.factor | 2 + .../standard/engines/tuple/tuple.factor | 4 +- core/generic/standard/standard-tests.factor | 39 ++++++++++++- core/generic/standard/standard.factor | 55 ++++++++++--------- core/inference/backend/backend.factor | 4 +- 7 files changed, 79 insertions(+), 41 deletions(-) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 524835f461..bbd7186a11 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -123,17 +123,6 @@ M: integer wii drop 6 ; [ 3 ] [ T{ first-one } wii ] unit-test -! Hooks -SYMBOL: my-var -HOOK: my-hook my-var ( -- x ) - -M: integer my-hook "an integer" ; -M: string my-hook "a string" ; - -[ "an integer" ] [ 3 my-var set my-hook ] unit-test -[ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with - GENERIC: tag-and-f ( x -- x x ) M: fixnum tag-and-f 1 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index f41f3ebcd0..cd08e80512 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -38,7 +38,10 @@ GENERIC: effective-method ( ... generic -- method ) : next-method ( class generic -- class/f ) [ next-method-class ] keep method ; -GENERIC: next-method-quot ( class generic -- quot ) +GENERIC: next-method-quot* ( class generic -- quot ) + +: next-method-quot ( class generic -- quot ) + dup "combination" word-prop next-method-quot* ; : (call-next-method) ( class generic -- ) next-method-quot call ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index bf8d4fb67a..ccd64d1291 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -47,3 +47,5 @@ SYMBOL: (dispatch#) } case ; : picker ( -- quot ) \ (dispatch#) get (picker) ; + +GENERIC: extra-values ( method generic -- n ) diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 40e749f473..69d73aa872 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -66,7 +66,9 @@ PREDICATE: tuple-dispatch-engine-word < word "tuple-dispatch-engine" word-prop ; M: tuple-dispatch-engine-word stack-effect - "tuple-dispatch-generic" word-prop stack-effect ; + "tuple-dispatch-generic" word-prop + [ extra-values ] [ stack-effect clone ] bi + [ length + ] change-in ; M: tuple-dispatch-engine-word crossref? drop t ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 2f58770b1a..a906acd324 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,7 +1,8 @@ IN: generic.standard.tests USING: tools.test math math.functions math.constants generic.standard strings sequences arrays kernel accessors -words float-arrays byte-arrays bit-arrays parser namespaces ; +words float-arrays byte-arrays bit-arrays parser namespaces +quotations inference vectors growable ; GENERIC: lo-tag-test @@ -194,7 +195,7 @@ M: ceo salary [ 102000 ] [ executive construct-boa salary ] unit-test [ ceo construct-boa salary ] -[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with +[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with [ intern construct-boa salary ] [ T{ no-next-method f intern salary } = ] must-fail-with @@ -233,3 +234,37 @@ M: c funky* "c" , call-next-method ; T{ a } funky { { "a" "x" "z" } { "a" "y" "z" } } member? ] unit-test + +! Hooks +SYMBOL: my-var +HOOK: my-hook my-var ( -- x ) + +M: integer my-hook "an integer" ; +M: string my-hook "a string" ; + +[ "an integer" ] [ 3 my-var set my-hook ] unit-test +[ "a string" ] [ my-hook my-var set my-hook ] unit-test +[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with + +HOOK: my-tuple-hook my-var ( -- x ) + +M: sequence my-tuple-hook my-hook ; + +[ f ] [ + \ my-tuple-hook [ "engines" word-prop ] keep prefix + [ 1quotation infer ] map all-equal? +] unit-test + +HOOK: call-next-hooker my-var ( -- x ) + +M: sequence call-next-hooker "sequence" ; + +M: array call-next-hooker call-next-method "array " prepend ; + +M: vector call-next-hooker call-next-method "vector " prepend ; + +M: growable call-next-hooker call-next-method "growable " prepend ; + +[ "vector growable sequence" ] [ + V{ } my-var [ call-next-hooker ] with-variable +] unit-test diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 9f9a892fd4..ed5134a624 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -67,7 +67,9 @@ ERROR: no-method object generic ; drop generic get "default-method" word-prop 1quotation ] unless ; -GENERIC: mangle-method ( method generic -- quot ) +: mangle-method ( method generic -- quot ) + [ 1quotation ] [ extra-values \ drop ] bi* + prepend [ ] like ; : single-combination ( word -- quot ) [ @@ -91,6 +93,23 @@ GENERIC: mangle-method ( method generic -- quot ) } cleave ] with-scope ; +ERROR: inconsistent-next-method class generic ; + +ERROR: no-next-method class generic ; + +: single-next-method-quot ( class generic -- quot ) + [ + [ drop [ instance? ] curry % ] + [ + 2dup next-method + [ 2nip 1quotation ] + [ [ no-next-method ] 2curry ] if* , + ] + [ [ inconsistent-next-method ] 2curry , ] + 2tri + \ if , + ] [ ] make ; + TUPLE: standard-combination # ; C: standard-combination @@ -107,8 +126,7 @@ PREDICATE: simple-generic < standard-generic : with-standard ( combination quot -- quot' ) >r #>> (dispatch#) r> with-variable ; inline -M: standard-generic mangle-method - drop 1quotation ; +M: standard-generic extra-values drop 0 ; M: standard-combination make-default-method [ empty-method ] with-standard ; @@ -118,30 +136,15 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-combination next-method-quot* + [ + single-next-method-quot picker prepend + ] with-standard ; + M: standard-generic effective-method [ dispatch# (picker) call ] keep [ order [ instance? ] with find-last nip ] keep method ; -ERROR: inconsistent-next-method object class generic ; - -ERROR: no-next-method class generic ; - -M: standard-generic next-method-quot - [ - [ - [ [ instance? ] curry ] - [ dispatch# (picker) ] bi* prepend % - ] - [ - 2dup next-method - [ 2nip 1quotation ] - [ [ no-next-method ] 2curry ] if* , - ] - [ [ inconsistent-next-method ] 2curry , ] - 2tri - \ if , - ] [ ] make ; - TUPLE: hook-combination var ; C: hook-combination @@ -156,8 +159,7 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; -M: hook-generic mangle-method - drop 1quotation [ drop ] prepend ; +M: hook-generic extra-values drop 1 ; M: hook-combination make-default-method [ error-method ] with-hook ; @@ -165,6 +167,9 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ drop ] [ [ single-combination ] with-hook ] 2bi define ; +M: hook-combination next-method-quot* + [ single-next-method-quot ] with-hook ; + M: simple-generic definer drop \ GENERIC: f ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index c0de217bd1..3dcb1d2360 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -36,6 +36,8 @@ TUPLE: inference-error error type rstate ; M: inference-error compiler-error-type type>> ; +M: inference-error error-help error>> error-help ; + : (inference-error) ( ... class type -- * ) >r construct-boa r> recursive-state get @@ -359,7 +361,7 @@ TUPLE: effect-error word effect ; \ effect-error inference-error ; : check-effect ( word effect -- ) - dup pick "declared-effect" word-prop effect<= + dup pick stack-effect effect<= [ 2drop ] [ effect-error ] if ; : finish-word ( word -- )