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

Fix stack effects for hooks

db4
Slava Pestov 2008-02-17 00:37:54 -06:00
parent c4ba816fc9
commit fa07776250
2 changed files with 15 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/generic/generic.factor
View File

@ -82,16 +82,16 @@ M: method-body stack-effect
[ <method-word> ] 3keep f \ method construct-boa [ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ; dup method-word over "method" set-word-prop ;
: redefine-method ( quot method -- ) : redefine-method ( quot class generic -- )
2dup set-method-def [ method set-method-def ] 3keep
method-word swap define ; [ make-method-def ] 2keep
method method-word swap define ;
: define-method ( quot class generic -- ) : define-method ( quot class generic -- )
>r bootstrap-word r> >r bootstrap-word r>
2dup method dup [ 2dup method [
2nip redefine-method redefine-method
] [ ] [
drop
[ <method> ] 2keep [ <method> ] 2keep
[ set-at ] with-methods [ set-at ] with-methods
] if ; ] if ;

17
core/generic/standard/standard.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions namespaces sequences vectors words quotations definitions
@ -77,7 +77,6 @@ TUPLE: no-method object generic ;
class-predicates alist>quot ; class-predicates alist>quot ;
: small-generic ( methods -- def ) : small-generic ( methods -- def )
[ 1quotation ] assoc-map
object method-alist>quot ; object method-alist>quot ;
: hash-methods ( methods -- buckets ) : hash-methods ( methods -- buckets )
@ -110,7 +109,7 @@ TUPLE: no-method object generic ;
: build-type-vtable ( alist-seq -- alist-seq ) : build-type-vtable ( alist-seq -- alist-seq )
dup length [ dup length [
vtable-class vtable-class
swap [ word-def ] assoc-map simplify-alist swap simplify-alist
class-predicates alist>quot class-predicates alist>quot
] 2map ; ] 2map ;
@ -145,7 +144,8 @@ TUPLE: no-method object generic ;
] if ; ] if ;
: standard-methods ( word -- alist ) : standard-methods ( word -- alist )
dup methods swap default-method add* ; dup methods swap default-method add*
[ 1quotation ] assoc-map ;
M: standard-combination make-default-method M: standard-combination make-default-method
standard-combination-# (dispatch#) standard-combination-# (dispatch#)
@ -161,9 +161,6 @@ TUPLE: hook-combination var ;
C: <hook-combination> hook-combination C: <hook-combination> hook-combination
M: hook-combination method-prologue
2drop [ drop ] ;
: with-hook ( combination quot -- quot' ) : with-hook ( combination quot -- quot' )
0 (dispatch#) [ 0 (dispatch#) [
swap slip swap slip
@ -175,7 +172,11 @@ M: hook-combination make-default-method
[ error-method ] with-hook ; [ error-method ] with-hook ;
M: hook-combination perform-combination M: hook-combination perform-combination
[ standard-methods single-combination ] with-hook ; [
standard-methods
[ [ drop ] swap append ] assoc-map
single-combination
] with-hook ;
: define-simple-generic ( word -- ) : define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ; T{ standard-combination f 0 } define-generic ;