steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make M\ throw an error upon lookup failure. Change method -> ?lookup-method, lookup-method is the throwing version of ?lookup-method. Fixes #229.

db4
Doug Coleman 2011-10-03 15:49:49 -07:00
parent 8ee9fcc11f
commit 181f11faa8
18 changed files with 49 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/classes/struct/struct-tests.factor
View File

@ -540,6 +540,6 @@ STRUCT: going-to-redefine { a uint } ;
[ ] [
"IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
] unit-test
[ f ] [ \ going-to-redefine \ clone method ] unit-test
[ f ] [ \ going-to-redefine \ struct-slot-values method ] unit-test
[ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test
[ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test

4
basis/classes/struct/struct.factor
View File

@ -196,7 +196,7 @@ M: struct-c-type base-type ;
define-inline-method ;
: forget-struct-slot-values-method ( class -- )
\ struct-slot-values method forget ;
\ struct-slot-values ?lookup-method forget ;
: clone-underlying ( struct -- byte-array )
binary-object memory>byte-array ; inline
@ -207,7 +207,7 @@ M: struct-c-type base-type ;
define-inline-method ;
: forget-clone-method ( class -- )
\ clone method forget ;
\ clone ?lookup-method forget ;
:: c-type-for-class ( class slots size align -- c-type )
struct-c-type new

4
basis/compiler/tests/redefine1.factor
View File

@ -15,7 +15,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 7 ] [ method-redefine-test-1 ] unit-test
[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test
[ ] [ [ fixnum \ method-redefine-generic-1 lookup-method forget ] with-compilation-unit ] unit-test
[ 6 ] [ method-redefine-test-1 ] unit-test
@ -33,6 +33,6 @@ M: integer method-redefine-generic-2 3 + ;
[ ] [
[
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
fixnum string [ \ method-redefine-generic-2 lookup-method forget ] bi@
] with-compilation-unit
] unit-test

12
basis/compiler/tests/redefine3.factor
View File

@ -18,18 +18,18 @@ M: empty-mixin sheeple drop "wake up" ; inline
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ t ] [ object \ sheeple lookup-method \ sheeple-test compiled-use? ] unit-test
[ f ] [ empty-mixin \ sheeple lookup-method \ sheeple-test compiled-use? ] unit-test
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ f ] [ object \ sheeple lookup-method \ sheeple-test compiled-use? ] unit-test
[ t ] [ empty-mixin \ sheeple lookup-method \ sheeple-test compiled-use? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ t ] [ object \ sheeple lookup-method \ sheeple-test compiled-use? ] unit-test
[ f ] [ empty-mixin \ sheeple lookup-method \ sheeple-test compiled-use? ] unit-test

4
basis/delegate/delegate.factor
View File

@ -91,7 +91,7 @@ M: broadcast (consult-method-quot)
\ protocol-consult word-prop delete-at ;
: unconsult-method ( word consultation -- )
[ class>> swap first method ] keep
[ class>> swap first lookup-method ] keep
over [
over "consultation" word-prop eq?
[ forget ] [ drop ] if
@ -124,7 +124,7 @@ M: consultation forget*
<PRIVATE
: forget-all-methods ( classes words -- )
[ first method forget ] cartesian-each ;
[ first lookup-method forget ] cartesian-each ;
: protocol-users ( protocol -- users )
protocol-consult keys ;

2
basis/math/intervals/intervals.factor
View File

@ -275,7 +275,7 @@ MEMO: array-capacity-interval ( -- interval )
: interval/-safe ( i1 i2 -- i3 )
#! Just a hack to make the compiler work if bootstrap.math
#! is not loaded.
\ integer \ / method [ interval/ ] [ 2drop f ] if ;
\ integer \ / ?lookup-method [ interval/ ] [ 2drop f ] if ;
: interval/i ( i1 i2 -- i3 )
[

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -127,7 +127,7 @@ M: word integer-op-input-classes
: define-math-ops ( op -- )
{ fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
[ [ dup 3array ] [ swap ?lookup-method ] 2bi ] with { } map>assoc
[ nip ] assoc-filter
[ def>> ] assoc-map
[ nip length 1 = ] assoc-filter

2
basis/see/see.factor
View File

@ -224,7 +224,7 @@ M: word see*
: seeing-implementors ( class -- seq )
dup implementors
[ [ reader? ] [ writer? ] bi or not ] filter
[ method ] with map
[ ?lookup-method ] with map
natural-sort ;
: seeing-methods ( generic -- seq )

3
basis/stack-checker/known-words/known-words.factor
View File

@ -25,6 +25,7 @@ stack-checker.transforms
stack-checker.dependencies
stack-checker.recursive-state
stack-checker.row-polymorphism ;
QUALIFIED-WITH: generic.single.private gsp
IN: stack-checker.known-words
: infer-special ( word -- )
@ -417,7 +418,7 @@ M: object infer-call* \ call bad-macro-input ;
\ innermost-frame-executing { callstack } { object } define-primitive
\ innermost-frame-scan { callstack } { fixnum } define-primitive
\ jit-compile { quotation } { } define-primitive
\ lookup-method { object array } { word } define-primitive
\ gsp:lookup-method { object array } { word } define-primitive
\ minor-gc { } { } define-primitive
\ modify-code-heap { array object object } { } define-primitive
\ nano-count { } { integer } define-primitive \ nano-count make-flushable

2
basis/tools/profiler/profiler.factor
View File

@ -30,7 +30,7 @@ IN: tools.profiler
all-words [ subwords ] cumulative-counters ;
: methods-on ( class -- methods )
dup implementors [ method ] with map ;
dup implementors [ lookup-method ] with map ;
: class-counters ( -- alist )
classes [ methods-on ] cumulative-counters ;

12
core/classes/tuple/tuple-tests.factor
View File

@ -476,7 +476,7 @@ must-fail-with
: accessor-exists? ( name -- ? )
[ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ;
">>" append "accessors" lookup ?lookup-method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test
[ t ] [ "y" accessor-exists? ] unit-test
@ -594,7 +594,7 @@ T{ reshape-test f "hi" } "tuple" set
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
[ f ] [ \ reshape-test \ x<< method ] unit-test
[ f ] [ \ reshape-test \ x<< ?lookup-method ] unit-test
[ "tuple" get 5 >>x ] must-fail
@ -678,7 +678,7 @@ SLOT: kex
drop
] unit-test
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
[ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
[ ] [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
@ -686,7 +686,7 @@ SLOT: kex
drop
] unit-test
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
[ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
[ ] [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
@ -694,8 +694,8 @@ SLOT: kex
drop
] unit-test
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
[ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
[ f ] [ \ change-slot-test \ kex>> ?lookup-method "reading" word-prop ] unit-test
DEFER: redefine-tuple-twice

4
core/classes/tuple/tuple.factor
View File

@ -319,8 +319,8 @@ M: tuple-class reset-class
[
dup "slots" word-prop [
name>>
[ reader-word method forget ]
[ writer-word method forget ] 2bi
[ reader-word ?lookup-method forget ]
[ writer-word ?lookup-method forget ] 2bi
] with each
] [
[ call-next-method ]

17
core/generic/generic.factor
View File

@ -25,9 +25,14 @@ M: generic definition drop f ;
PREDICATE: method < word
"method-generic" word-prop >boolean ;
: method ( class generic -- method/f )
ERROR: method-lookup-failed class generic ;
: ?lookup-method ( class generic -- method/f )
"methods" word-prop at ;
: lookup-method ( class generic -- method/* )
2dup ?lookup-method [ 2nip ] [ method-lookup-failed ] if* ;
<PRIVATE
: interesting-class? ( class1 class2 -- ? )
@ -56,7 +61,7 @@ PRIVATE>
method-classes interesting-classes smallest-class ;
: method-for-class ( class generic -- method/f )
[ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
[ nip ] [ nearest-class ] 2bi dup [ swap ?lookup-method ] [ 2drop f ] if ;
GENERIC: effective-method ( generic -- method )
@ -66,7 +71,7 @@ GENERIC: effective-method ( generic -- method )
method-classes [ class< ] with filter smallest-class ;
: next-method ( class generic -- method/f )
[ next-method-class ] keep method ;
[ next-method-class ] keep ?lookup-method ;
GENERIC: next-method-quot* ( class generic combination -- quot )
@ -131,7 +136,7 @@ M: method crossref?
2bi ;
: create-method ( class generic -- method )
2dup method dup [ 2nip dup reset-generic ] [
2dup ?lookup-method dup [ 2nip dup reset-generic ] [
drop
[ <method> dup ] 2keep
reveal-method
@ -158,7 +163,7 @@ M: method forget*
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
2dup method
2dup ?lookup-method
] keep eq?
[
[ [ delete-at ] with-methods ]
@ -195,4 +200,4 @@ M: generic subwords
] { } make ;
M: class forget-methods
[ implementors ] [ [ swap method ] curry ] bi map forget-all ;
[ implementors ] [ [ swap ?lookup-method ] curry ] bi map forget-all ;

3
core/generic/hook/hook.factor
View File

@ -3,6 +3,7 @@
USING: accessors definitions generic generic.single
generic.single.private kernel namespaces words kernel.private
quotations sequences ;
QUALIFIED-WITH: generic.single.private gsp
IN: generic.hook
TUPLE: hook-combination < single-combination var ;
@ -18,7 +19,7 @@ M: hook-combination picker
M: hook-combination dispatch# drop 0 ;
M: hook-combination mega-cache-quot
1quotation picker [ lookup-method (execute) ] surround ;
1quotation picker [ gsp:lookup-method (execute) ] surround ;
M: hook-generic definer drop \ HOOK: f ;

2
core/generic/math/math.factor
View File

@ -51,7 +51,7 @@ ERROR: no-math-method left right generic ;
<PRIVATE
: (math-method) ( generic class -- quot )
over method
over ?lookup-method
[ 1quotation ]
[ default-math-method ] ?if ;

6
core/generic/single/single.factor
View File

@ -46,8 +46,10 @@ M: single-combination next-method-quot* ( class generic combination -- quot )
] with-combination ;
: method-for-object ( obj word -- method )
[ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
[ "default-method" word-prop ]
[
[ method-classes [ instance? ] with filter smallest-class ] keep
?lookup-method
] [ "default-method" word-prop ]
bi or ;
M: single-combination make-default-method

2
core/generic/standard/standard-tests.factor
View File

@ -236,7 +236,7 @@ GENERIC: generic-forget-test ( a -- b )
M: f generic-forget-test ;
[ ] [ \ f \ generic-forget-test method "m" set ] unit-test
[ ] [ \ f \ generic-forget-test lookup-method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test

2
core/syntax/syntax.factor
View File

@ -108,7 +108,7 @@ IN: bootstrap.syntax
"POSTPONE:" [ scan-word suffix! ] define-core-syntax
"\\" [ scan-word <wrapper> suffix! ] define-core-syntax
"M\\" [ scan-word scan-word method <wrapper> suffix! ] define-core-syntax
"M\\" [ scan-word scan-word lookup-method <wrapper> suffix! ] define-core-syntax
"inline" [ word make-inline ] define-core-syntax
"recursive" [ word make-recursive ] define-core-syntax
"foldable" [ word make-foldable ] define-core-syntax