/core/slots/slots.factor
http://github.com/abeaumont/factor · Factor · 285 lines · 218 code · 55 blank · 12 comment · 26 complexity · 3009d665425796f728d9048487db41ae MD5 · raw file
- ! Copyright (C) 2005, 2011 Slava Pestov.
- ! See http://factorcode.org/license.txt for BSD license.
- USING: accessors alien arrays assocs byte-arrays classes
- classes.algebra classes.algebra.private classes.maybe
- combinators generic generic.standard hashtables kernel
- kernel.private make math quotations sequences sequences.private
- slots.private strings words ;
- IN: slots
- TUPLE: slot-spec name offset class initial read-only ;
- PREDICATE: reader < word "reader" word-prop ;
- PREDICATE: reader-method < method "reading" word-prop >boolean ;
- PREDICATE: writer < word "writer" word-prop ;
- PREDICATE: writer-method < method "writing" word-prop >boolean ;
- : <slot-spec> ( -- slot-spec )
- slot-spec new
- object bootstrap-word >>class ;
- : define-typecheck ( class generic quot props -- )
- [ create-method ] 2dip
- [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
- [ drop define ]
- [ 2drop make-inline ]
- 3tri ;
- GENERIC# reader-quot 1 ( class slot-spec -- quot )
- M: object reader-quot
- nip [
- dup offset>> ,
- \ slot ,
- dup class>> object bootstrap-word eq?
- [ drop ] [ class>> 1array , \ declare , ] if
- ] [ ] make ;
- : reader-word ( name -- word )
- ">>" append "accessors" create
- dup t "reader" set-word-prop ;
- : reader-props ( slot-spec -- assoc )
- "reading" associate ;
- : define-reader-generic ( name -- )
- reader-word ( object -- value ) define-simple-generic ;
- : define-reader ( class slot-spec -- )
- [ nip name>> define-reader-generic ]
- [
- {
- [ drop ]
- [ nip name>> reader-word ]
- [ reader-quot ]
- [ nip reader-props ]
- } 2cleave define-typecheck
- ] 2bi ;
- : writer-word ( name -- word )
- "<<" append "accessors" create
- dup t "writer" set-word-prop ;
- ERROR: bad-slot-value value class ;
- GENERIC: instance-check-quot ( obj -- quot )
- M: class instance-check-quot ( class -- quot )
- {
- { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
- { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
- [ call-next-method ]
- } cond ;
- M: object instance-check-quot
- [
- \ dup ,
- [ predicate-def % ]
- [ [ bad-slot-value ] curry , ] bi
- \ unless ,
- ] [ ] make ;
- GENERIC# writer-quot 1 ( class slot-spec -- quot )
- M: object writer-quot
- nip
- [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
- [ offset>> [ set-slot ] curry ]
- bi append ;
- : writer-props ( slot-spec -- assoc )
- "writing" associate ;
- : define-writer-generic ( name -- )
- writer-word ( value object -- ) define-simple-generic ;
- : define-writer ( class slot-spec -- )
- [ nip name>> define-writer-generic ] [
- {
- [ drop ]
- [ nip name>> writer-word ]
- [ writer-quot ]
- [ nip writer-props ]
- } 2cleave define-typecheck
- ] 2bi ;
- : setter-word ( name -- word )
- ">>" prepend "accessors" create ;
- : define-setter ( name -- )
- dup setter-word dup deferred? [
- [ \ over , swap writer-word , ] [ ] make
- ( object value -- object ) define-inline
- ] [ 2drop ] if ;
- : changer-word ( name -- word )
- "change-" prepend "accessors" create ;
- : define-changer ( name -- )
- dup changer-word dup deferred? [
- [
- \ over ,
- over reader-word 1quotation
- [ dip call ] curry [ ] like [ dip swap ] curry %
- swap setter-word ,
- ] [ ] make ( object quot -- object ) define-inline
- ] [ 2drop ] if ;
- : define-slot-methods ( class slot-spec -- )
- [ define-reader ]
- [
- dup read-only>> [ 2drop ] [
- [ name>> define-setter drop ]
- [ name>> define-changer drop ]
- [ define-writer ]
- 2tri
- ] if
- ] 2bi ;
- : define-accessors ( class specs -- )
- [ define-slot-methods ] with each ;
- : define-protocol-slot ( name -- )
- {
- [ define-reader-generic ]
- [ define-writer-generic ]
- [ define-setter ]
- [ define-changer ]
- } cleave ;
- DEFER: initial-value
- GENERIC: initial-value* ( class -- object ? )
- M: class initial-value* drop f f ;
- M: maybe initial-value*
- drop f t ;
- ! Default initial value is f, 0, or the default inital value
- ! of the smallest class. Special case 0 because float is ostensibly
- ! smaller than integer in union{ integer float } because of
- ! alphabetical sorting.
- M: anonymous-union initial-value*
- {
- { [ f over instance? ] [ drop f t ] }
- { [ 0 over instance? ] [ drop 0 t ] }
- [
- members>> sort-classes [ initial-value ] { } map>assoc
- ?last [ second t ] [ f f ] if*
- ]
- } cond ;
- ! See if any of the initial values fit the intersection class,
- ! or else return that none do, and leave it up to the user to provide
- ! an initial: value.
- M: anonymous-intersection initial-value*
- {
- { [ f over instance? ] [ drop f t ] }
- { [ 0 over instance? ] [ drop 0 t ] }
- [
- [ ]
- [ participants>> sort-classes [ initial-value ] { } map>assoc ]
- [ ] tri
- [ [ first2 nip ] dip instance? ] curry find swap [
- nip second t
- ] [
- 2drop f f
- ] if
- ]
- } cond ;
- : initial-value ( class -- object ? )
- {
- { [ dup only-classoid? ] [ dup initial-value* ] }
- { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
- { [ \ f bootstrap-word over class<= ] [ f t ] }
- { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
- { [ bignum bootstrap-word over class<= ] [ 0 >bignum t ] }
- { [ float bootstrap-word over class<= ] [ 0.0 t ] }
- { [ string bootstrap-word over class<= ] [ "" t ] }
- { [ array bootstrap-word over class<= ] [ { } t ] }
- { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
- { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
- { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
- [ dup initial-value* ]
- } cond [ drop ] 2dip ;
- GENERIC: make-slot ( desc -- slot-spec )
- M: string make-slot
- <slot-spec>
- swap >>name ;
- : peel-off-name ( slot-spec array -- slot-spec array )
- [ first >>name ] [ rest ] bi ; inline
- : init-slot-class ( slot-spec class -- slot-spec )
- [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ;
- : peel-off-class ( slot-spec array -- slot-spec array )
- dup empty? [
- dup first classoid? [
- [ first init-slot-class ]
- [ rest ]
- bi
- ] when
- ] unless ;
- ERROR: bad-slot-attribute key ;
- : peel-off-attributes ( slot-spec array -- slot-spec array )
- dup empty? [
- unclip {
- { initial: [ [ first >>initial ] [ rest ] bi ] }
- { read-only [ [ t >>read-only ] dip ] }
- [ bad-slot-attribute ]
- } case
- ] unless ;
- ERROR: bad-initial-value name initial-value class ;
- : check-initial-value ( slot-spec -- slot-spec )
- [ ] [
- [ ] [ initial>> ] [ class>> ] tri
- 2dup instance? [
- 2drop
- ] [
- [ name>> ] 2dip bad-initial-value
- ] if
- ] if-bootstrapping ;
- M: array make-slot
- <slot-spec>
- swap
- peel-off-name
- peel-off-class
- [ dup empty? ] [ peel-off-attributes ] until drop
- check-initial-value ;
- M: slot-spec make-slot
- check-initial-value ;
- : make-slots ( slots -- specs )
- [ make-slot ] map ;
- : finalize-slots ( specs base -- specs )
- over length iota [ + ] with map [ >>offset ] 2map ;
- : slot-named* ( name specs -- offset spec/f )
- [ name>> = ] with find ;
- : slot-named ( name specs -- spec/f )
- slot-named* nip ;
- ! Predefine some slots, because there are change-* words in other vocabs
- ! that nondeterministically cause ambiguities when USEd alongside
- ! accessors
- SLOT: at
- SLOT: nth
- SLOT: global