49 lines
1.3 KiB
Factor
49 lines
1.3 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: generic
|
|
USING: arrays kernel kernel-internals math namespaces
|
|
parser sequences strings words ;
|
|
|
|
: define-typecheck ( class generic def -- )
|
|
over define-generic -rot define-method ;
|
|
|
|
: define-slot-word ( class slot word quot -- )
|
|
over [
|
|
rot >fixnum add* define-typecheck
|
|
] [
|
|
2drop 2drop
|
|
] if ;
|
|
|
|
: define-reader ( class slot decl reader -- )
|
|
[ slot ] rot dup object eq? [
|
|
drop
|
|
] [
|
|
1array [ declare ] swap add* append
|
|
] if define-slot-word ;
|
|
|
|
: define-writer ( class slot writer -- )
|
|
[ set-slot ] define-slot-word ;
|
|
|
|
: define-slot ( class slot decl reader writer -- )
|
|
>r >r >r 2dup r> r> define-reader r> define-writer ;
|
|
|
|
: intern-slots ( spec -- spec )
|
|
[ [ dup array? [ first2 create ] when ] map ] map ;
|
|
|
|
: define-slots ( class spec -- )
|
|
[ first4 define-slot ] each-with ;
|
|
|
|
: reader-word ( class name -- word )
|
|
>r word-name "-" r> append3 in get 2array ;
|
|
|
|
: writer-word ( class name -- word )
|
|
[ swap "set-" % word-name % "-" % % ] "" make in get 2array ;
|
|
|
|
: simple-slot ( class name -- )
|
|
2dup reader-word , writer-word , ;
|
|
|
|
: simple-slots ( class slots base -- spec )
|
|
over length [ + ] map-with
|
|
[ [ , object , dupd simple-slot ] { } make ] 2map nip intern-slots ;
|