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

initial-quot: works fully, need to make a couple simplifications

db4
Doug Coleman 2009-06-12 09:21:51 -05:00
parent 360807aaab
commit 21a33419a7
1 changed files with 46 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -50,19 +50,11 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE> PRIVATE>
: initial-value ( slot -- obj ) : initial-quots? ( class -- ? )
dup initial>> [ all-slots [ initial-quot>> ] any? ;
nip
] [
dup initial-quot>> [
nip call( -- obj )
] [
drop f
] if*
] if* ;
: initial-values ( class -- slots ) : initial-values ( class -- slots )
all-slots [ initial-value ] map ; all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class ) : pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline [ initial-values over length tail append ] keep ; inline
@ -75,7 +67,9 @@ PRIVATE>
: tuple-slots ( tuple -- seq ) : tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ; prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( seq class -- tuple ) GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots check-slots pad-slots
tuple-layout <tuple> [ tuple-layout <tuple> [
[ tuple-size ] [ tuple-size ]
@ -156,8 +150,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ; dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype ) : tuple-prototype ( class -- prototype )
[ initial-values ] keep [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
over [ ] any? [ slots>tuple ] [ 2drop f ] if ; [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
@ -182,10 +176,40 @@ ERROR: bad-superclass class ;
: define-tuple-layout ( class -- ) : define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ; dup make-tuple-layout "layout" set-word-prop ;
: define-tuple-constructor ( class -- )
{
{ [ dup initial-quots? ] [ "initial-quots" ] }
{ [ dup "prototype" word-prop ] [ "prototype" ] }
[ f ]
} cond "constructor" set-word-prop ;
: define-tuple-initial-quots ( class -- )
dup all-slots [ initial-quot>> ] filter
[
[
[ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
[ offset>> , ] bi \ set-slot ,
] each
] [ ] make "initial-quots-setter" set-word-prop ;
: set-initial-quots ( tuple -- tuple' )
dup class "initial-quots-setter" word-prop call( obj -- obj ) ;
: calculate-initial-value ( slot-spec -- value )
dup initial>> [
nip
] [
dup initial-quot>> [
nip call( -- obj )
] [
drop f
] if*
] if* ;
: compute-slot-permutation ( new-slots old-slots -- triples ) : compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ] [ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ] [ drop [ class>> ] map ]
[ drop [ initial-value ] map ] [ drop [ calculate-initial-value ] map ]
2tri 3array flip ; 2tri 3array flip ;
: update-slot ( old-values n class initial -- value ) : update-slot ( old-values n class initial -- value )
@ -233,6 +257,8 @@ M: tuple-class update-class
[ define-tuple-slots ] [ define-tuple-slots ]
[ define-tuple-predicate ] [ define-tuple-predicate ]
[ define-tuple-prototype ] [ define-tuple-prototype ]
[ define-tuple-constructor ]
[ define-tuple-initial-quots ]
} cleave ; } cleave ;
: define-new-tuple-class ( class superclass slots -- ) : define-new-tuple-class ( class superclass slots -- )
@ -349,8 +375,11 @@ M: tuple tuple-hashcode
M: tuple hashcode* tuple-hashcode ; M: tuple hashcode* tuple-hashcode ;
M: tuple-class new M: tuple-class new
dup "prototype" word-prop dup "constructor" word-prop {
[ (clone) ] [ tuple-layout <tuple> ] ?if ; { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] }
{ "prototype" [ "prototype" word-prop (clone) ] }
[ drop tuple-layout <tuple> ]
} case ;
M: tuple-class boa M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ] [ "boa-check" word-prop [ call ] when* ]