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..1f0b80e016 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 ( 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 -- ) diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 07038ceadf..ef710ea57d 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -2,10 +2,16 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel words parser io inspector quotations sequences prettyprint continuations effects definitions compiler.units -namespaces assocs tools.walker ; +namespaces assocs tools.walker generic ; IN: tools.annotations -: reset ( word -- ) +GENERIC: reset ( word -- ) + +M: generic reset + [ call-next-method ] + [ subwords [ reset ] each ] bi ; + +M: word reset dup "unannotated-def" word-prop [ [ dup dup "unannotated-def" word-prop define @@ -60,8 +66,16 @@ IN: tools.annotations : watch-vars ( word vars -- ) dupd [ (watch-vars) ] 2curry annotate ; +GENERIC# annotate-methods 1 ( word quot -- ) + +M: generic annotate-methods + >r "methods" word-prop values r> [ annotate ] curry each ; + +M: word annotate-methods + annotate ; + : breakpoint ( word -- ) - [ add-breakpoint ] annotate ; + [ add-breakpoint ] annotate-methods ; : breakpoint-if ( word quot -- ) - [ [ [ break ] when ] rot 3append ] curry annotate ; + [ [ [ break ] when ] rot 3append ] curry annotate-methods ; diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 33ab877ee1..68b106663c 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -31,6 +31,6 @@ M: winnt deploy* [ deploy-name get create-exe-dir ] keep [ deploy-name get image-name ] keep [ namespace make-deploy-image ] keep - open-in-explorer + (normalize-path) open-in-explorer ] bind ] with-directory ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 9445486656..3ad10a6991 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -4,8 +4,9 @@ USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string -io.encodings.utf8 combinators debugger system command-line +io.encodings.utf8 combinators debugger command-line qualified ui.render math.vectors classes.tuple opengl.gl threads ; +QUALIFIED: system IN: ui.x11 SINGLETON: x11-ui-backend @@ -261,5 +262,5 @@ M: x11-ui-backend ui ( -- ) x11-ui-backend ui-backend set-global -[ "DISPLAY" os-env "ui" "listener" ? ] +[ "DISPLAY" system:os-env "ui" "listener" ? ] main-vocab-hook set-global