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

Slots work in progress

db4
Slava Pestov 2008-06-27 23:10:19 -05:00
parent 5ddaeccf21
commit 0b86e87544
1 changed files with 29 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
core/slots/slots.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math namespaces USING: arrays kernel kernel.private math namespaces
sequences strings words effects generic generic.standard sequences strings words effects generic generic.standard
classes slots.private combinators ; classes slots.private combinators accessors ;
IN: slots IN: slots
TUPLE: slot-spec type name offset reader writer ; TUPLE: slot-spec type name offset reader writer ;
@ -10,8 +10,10 @@ TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- ) : define-typecheck ( class generic quot -- )
over define-simple-generic [
>r create-method r> define ; dup define-simple-generic
create-method
] dip define ;
: define-slot-word ( class slot word quot -- ) : define-slot-word ( class slot word quot -- )
rot >fixnum prefix define-typecheck ; rot >fixnum prefix define-typecheck ;
@ -30,14 +32,26 @@ C: <slot-spec> slot-spec
: reader-word ( name -- word ) : reader-word ( name -- word )
">>" append (( object -- value )) create-accessor ; ">>" append (( object -- value )) create-accessor ;
: define-reader ( class slot name -- ) : define-reader ( class slot name decl -- )
reader-word object reader-quot define-slot-word ; [ reader-word ] dip reader-quot define-slot-word ;
: writer-word ( name -- word ) : writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ; "(>>" swap ")" 3append (( value object -- )) create-accessor ;
: define-writer ( class slot name -- ) ERROR: bad-slot-value value object index ;
writer-word [ set-slot ] define-slot-word ;
: writer-quot ( decl -- quot )
[
dup object bootstrap-word eq?
[ drop \ set-slot , ] [
\ pick ,
"predicate" word-prop %
[ [ set-slot ] [ bad-slot-value ] if ] %
] if
] [ ] make ;
: define-writer ( class slot name decl -- )
[ writer-word ] dip writer-quot define-slot-word ;
: setter-word ( name -- word ) : setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ; ">>" prepend (( object value -- object )) create-accessor ;
@ -60,17 +74,16 @@ C: <slot-spec> slot-spec
] [ ] make define-inline ] [ ] make define-inline
] [ 2drop ] if ; ] [ 2drop ] if ;
: define-slot-methods ( class slot name -- ) : define-slot-methods ( class slot-spec -- )
dup define-changer {
dup define-setter [ [ drop ] [ name>> ] bi* define-changer ]
3dup define-reader [ [ drop ] [ name>> ] bi* define-setter ]
define-writer ; [ [ offset>> ] [ name>> ] [ type>> ] tri define-reader ]
[ [ offset>> ] [ name>> ] [ type>> ] tri define-writer ]
} 2cleave ;
: define-accessors ( class specs -- ) : define-accessors ( class specs -- )
[ [ define-slot-methods ] with each ;
dup slot-spec-offset swap slot-spec-name
define-slot-methods
] with each ;
: slot-named ( name specs -- spec/f ) : slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ; [ slot-spec-name = ] with find nip ;