! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions hashtables kernel
-kernel.private math namespaces sequences sequences.private
-strings vectors words quotations memory combinators generic
-classes classes.private slots.deprecated slots.private slots
-compiler.units math.private accessors assocs ;
+USING: arrays definitions hashtables kernel kernel.private math
+namespaces sequences sequences.private strings vectors words
+quotations memory combinators generic classes classes.algebra
+classes.private slots.deprecated slots.private slots
+compiler.units math.private accessors assocs effects ;
IN: classes.tuple
M: tuple class 1 slot 2 slot { word } declare ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
-ERROR: not-a-tuple-class class ;
-
-: check-tuple-class ( class -- class )
- dup tuple-class? [ not-a-tuple-class ] unless ; inline
-
<PRIVATE
+: (tuple) ( layout -- tuple )
+ #! In non-optimized code, this word simply calls the
+ #! <tuple> primitive. In optimized code, an intrinsic
+ #! is generated which allocates a tuple but does not set
+ #! any of its slots. This means that any code that uses
+ #! (tuple) must fill in the slots before the next
+ #! call to GC.
+ #!
+ #! This word is only used in the expansion of <tuple-boa>,
+ #! where this invariant is guaranteed to hold.
+ <tuple> ;
+
: tuple-layout ( class -- layout )
- check-tuple-class "layout" word-prop ;
+ "layout" word-prop ;
+
+: layout-of ( tuple -- layout )
+ 1 slot { tuple-layout } declare ; inline
: tuple-size ( tuple -- size )
- 1 slot layout-size ; inline
+ layout-of size>> ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
+ check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
- layout-class prefix ;
+ class>> prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-: slots>tuple ( tuple class -- array )
+: all-slots ( class -- slots )
+ superclasses [ "slots" word-prop ] map concat ;
+
+: check-slots ( seq class -- seq class )
+ [ ] [
+ 2dup all-slots [
+ class>> 2dup instance?
+ [ 2drop ] [ bad-slot-value ] if
+ ] 2each
+ ] if-bootstrapping ; inline
+
+GENERIC: slots>tuple ( seq class -- tuple )
+
+M: tuple-class slots>tuple
+ check-slots
tuple-layout <tuple> [
- [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
+ [ tuple-size ]
+ [ [ set-array-nth ] curry ]
+ bi 2each
] keep ;
-: >tuple ( tuple -- seq )
+: >tuple ( seq -- tuple )
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop
- [ dup array? [ second ] when ] map ;
-
-: all-slot-names ( class -- slots )
- superclasses [ slot-names ] map concat \ class prefix ;
+ "slot-names" word-prop ;
ERROR: bad-superclass class ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- 2dup [ 1 slot ] bi@ eq? [
+ 2dup [ layout-of ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
- ] if ;
+ ] if ; inline
-! Predicate generation. We optimize at the expense of simplicity
-
-: (tuple-predicate-quot) ( class -- quot )
- #! 4 slot == layout-superclasses
- #! 5 slot == layout-echelon
- [
- [ 1 slot dup 5 slot ] %
- dup tuple-layout layout-echelon ,
- [ fixnum>= ] %
- [
- dup tuple-layout layout-echelon ,
- [ swap 4 slot array-nth ] %
- literalize ,
- [ eq? ] %
- ] [ ] make ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: tuple-predicate-quot ( class -- quot )
- [
- [ dup tuple? ] %
- (tuple-predicate-quot) ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
+: tuple-instance? ( object class echelon -- ? )
+ #! 4 slot == superclasses>>
+ rot dup tuple? [
+ layout-of 4 slot
+ 2dup array-capacity fixnum<
+ [ array-nth eq? ] [ 3drop f ] if
+ ] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )
- dup tuple-predicate-quot define-predicate ;
+ dup dup tuple-layout echelon>>
+ [ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n )
superclasses but-last-slice
[ slot-names length ] sigma ;
+: (instance-check-quot) ( class -- quot )
+ [
+ \ dup ,
+ [ "predicate" word-prop % ]
+ [ [ bad-slot-value ] curry , ] bi
+ \ unless ,
+ ] [ ] make ;
+
+: (fixnum-check-quot) ( class -- quot )
+ (instance-check-quot) fixnum "coercer" word-prop prepend ;
+
+: instance-check-quot ( class -- quot )
+ {
+ { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+ { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+ { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
+ [ (instance-check-quot) ]
+ } cond ;
+
+: boa-check-quot ( class -- quot )
+ all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
+
+: define-boa-check ( class -- )
+ dup boa-check-quot "boa-check" set-word-prop ;
+
+: tuple-prototype ( class -- prototype )
+ [ all-slots [ initial>> ] map ] keep slots>tuple ;
+
+: define-tuple-prototype ( class -- )
+ dup tuple-prototype "prototype" set-word-prop ;
+
: generate-tuple-slots ( class slots -- slot-specs )
- over superclass-size 2 + simple-slots ;
+ over superclass-size 2 + make-slots deprecated-slots ;
: define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: compute-slot-permutation ( class old-slot-names -- permutation )
- >r all-slot-names r> [ index ] curry map ;
+: compute-slot-permutation ( new-slots old-slots -- triples )
+ [ [ [ name>> ] map ] bi@ [ index ] curry map ]
+ [ drop [ class>> ] map ]
+ [ drop [ initial>> ] map ]
+ 2tri 3array flip ;
+
+: update-slot ( old-values n class initial -- value )
+ pick [
+ >r >r swap nth dup r> instance?
+ [ r> drop ] [ drop r> ] if
+ ] [ >r 3drop r> ] if ;
-: apply-slot-permutation ( old-values permutation -- new-values )
- [ [ swap ?nth ] [ drop f ] if* ] with map ;
+: apply-slot-permutation ( old-values triples -- new-values )
+ [ first3 update-slot ] with map ;
-: permute-slots ( old-values -- new-values )
- dup first dup outdated-tuples get at
+: permute-slots ( old-values layout -- new-values )
+ [ class>> all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
apply-slot-permutation ;
-: change-tuple ( tuple quot -- newtuple )
- >r tuple>array r> call >tuple ; inline
-
: update-tuple ( tuple -- newtuple )
- [ permute-slots ] change-tuple ;
+ [ tuple-slots ] [ layout-of ] bi
+ [ permute-slots ] [ class>> ] bi
+ slots>tuple ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [ >r class r> key? ] curry instances
+ [
+ over tuple?
+ [ >r layout-of r> key? ] [ 2drop f ] if
+ ] curry instances
dup [ update-tuple ] map become
] if ;
[ update-tuples ] update-tuples-hook set-global
: update-tuples-after ( class -- )
- outdated-tuples get [ all-slot-names ] cache drop ;
+ [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
M: tuple-class update-class
- [ define-tuple-layout ]
- [ define-tuple-slots ]
- [ define-tuple-predicate ]
- tri ;
+ {
+ [ define-tuple-layout ]
+ [ define-tuple-slots ]
+ [ define-tuple-predicate ]
+ [ define-tuple-prototype ]
+ [ define-boa-check ]
+ } cleave ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f f tuple-class define-class ]
define-new-tuple-class ;
M: tuple-class define-tuple-class
+ over check-superclass
3dup tuple-class-unchanged?
- [ over check-superclass 3dup redefine-tuple-class ] unless
- 3drop ;
+ [ 3drop ] [ redefine-tuple-class ] if ;
+
+: thrower-effect ( slots -- effect )
+ [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
: define-error-class ( class superclass slots -- )
- [ define-tuple-class ] [ 2drop ] 3bi
- dup [ boa throw ] curry define ;
+ [ define-tuple-class ]
+ [ [ dup [ boa throw ] curry ] [ drop ] [ thrower-effect ] tri* ] 3bi
+ define-declared ;
M: tuple-class reset-class
[
- dup "slot-names" word-prop [
+ dup "slots" word-prop [
+ name>>
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
[ call-next-method ]
- [ { "layout" "slots" } reset-props ]
- bi
+ [
+ {
+ "layout" "slots" "slot-names" "boa-check" "prototype"
+ } reset-props
+ ] bi
] bi ;
M: tuple-class rank-class drop 0 ;
+M: tuple-class instance?
+ dup tuple-layout echelon>> tuple-instance? ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
] 2curry each
] recursive-hashcode ;
+M: tuple-class new
+ "prototype" word-prop (clone) ;
+
+M: tuple-class boa
+ [ "boa-check" word-prop call ]
+ [ tuple-layout ]
+ bi <tuple-boa> ;
+
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
projects / factor.git / blobdiff