An example can be found at http://wee-url.com/responder/pastebin/show-
paste?n=219.
Changes from the current object system:
- Slot access is redone. See the example.
- Single inheritance among tuple classes: this way tuple slots can be
inherited.
- Multiple inheritance of 'mixins': this way method implementations
can be inherited.
- This is very rough code and is not fully debugged or very clean at
all!
- It will be a while before any of these features actually make it
into the object system in the core.
Dan, Eduardo, please give feedback! :-)
-------8<------
USING: arrays classes kernel math namespaces parser quotations
sequences slots tuples tuples.private words vocabs ;
IN: new-obj-sys
: mixin-instance? ( class classes -- ? )
over [
2dup memq? [
2drop t
] [
>r superclass r> mixin-instance?
] if
] [
2drop f
] if ;
: mixin-predicate-quot ( class -- quot )
"members" word-prop [ >r class r> mixin-instance? ] curry ;
: define-mixin ( word -- )
dup V{ } clone "members" set-word-prop
dup define-class
dup predicate-word over mixin-predicate-quot
define-predicate ;
: add-instance ( class mixin -- )
tuck "members" word-prop push define-class ;
: MIXIN: CREATE define-mixin ; parsing
: INSTANCE: scan-word scan-word add-instance ; parsing
: simple-slot-word ( name -- )
append "slot-access" create ;
: simple-reader-word ( name -- word )
">>" simple-slot-word ;
: simple-writer-word ( name -- word )
">>" swap simple-slot-word ;
: simple-change-word ( name -- word )
"change-" swap simple-slot-word ;
: define-change-word ( word name -- )
[
[ over >r >r ] %
dup simple-reader-word ,
[ r> call r> ] %
simple-writer-word ,
] [ ] make define-inline ;
: simple-slot ( name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
over simple-reader-word over set-slot-spec-reader
over simple-writer-word over set-slot-spec-writer
>r dup simple-change-word swap define-change-word r> ;
: new-simple-slots ( slots base -- specs )
over length [ + ] map-with [ simple-slot ] 2map ;
: initial-offset superclass "slot-names" word-prop length 4 + ;
: define-custom-slots ( class slots -- )
2dup "slot-names" set-word-prop
over initial-offset new-simple-slots
2dup delegate-slot-spec add* "slots" set-word-prop
define-slots ;
: subclass? ( sub super -- ? )
2dup eq? [
2drop t
] [
>r superclass r> subclass?
] if ;
: custom-predicate ( class -- )
dup predicate-word over [ >r class r> subclass? ] curry
define-predicate ;
: define-custom-class ( class superclass slots -- )
>r dupd "superclass" set-word-prop r>
2dup check-shape
>r dup custom-predicate
dup define-class
r> define-custom-slots ;
: CLASS:
CREATE ";" parse-tokens
0 over ?nth "<" = [
dup second search swap 2 tail
] [
\ tuple bootstrap-word swap
] if define-custom-class ; parsing
: get-slots ( tuple seq -- ... )
[ execute ] each-with ;
: set-slots ( ... tuple seq -- )
<reversed> [
dup array? [ first2 swapd ] when execute
] each-with ;
: new-tuple-size
dup { f tuple } memq? [
drop 2
] [
dup superclass new-tuple-size
swap "slot-names" word-prop length +
] if ;
: construct ( ... seq class -- tuple )
dup new-tuple-size <tuple> [ swap set-slots ] keep ;
: boa-construct ( ... class -- tuple )
dup "slots" word-prop 1 tail-slice
[ slot-spec-writer ] map
swap construct ;
"slot-access" create-vocab drop
-------------------------------------------------------------------------
This SF.net email is sponsored by: Splunk Inc.
Still grepping through log files to find problems? Stop.
Now Search log events and configuration files using AJAX and a browser.
Download your FREE copy of Splunk now >> http://get.splunk.com/
_______________________________________________
Factor-talk mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/factor-talk
