: superclass-size ( class -- n )
superclasses but-last-slice
- [ slot-names length ] map sum ;
+ [ 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
{ [ dup word? ] [ word-flat-length ] }
[ drop 1 ]
} cond
- ] map sum ;
+ ] sigma ;
-: flat-length ( seq -- n )
- [ word-def (flat-length) ] with-scope ;
+: flat-length ( word -- n )
+ [ def>> (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
-: node-class# ( node n -- class )
- over node-in-d <reversed> ?nth node-class ;
+! : dispatching-class ( node generic -- method/f )
+! tuck dispatch# over in-d>> <reversed> ?nth 2dup node-literal?
+! [ node-literal swap single-effective-method ]
+! [ node-class swap specific-method ]
+! if ;
-: dispatching-class ( node word -- class )
- [ dispatch# node-class# ] keep specific-method ;
+: dispatching-class ( node generic -- method/f )
+ tuck dispatch# over in-d>> <reversed> ?nth
+ node-class swap specific-method ;
-: inline-standard-method ( node word -- node )
- 2dup dispatching-class dup
- [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
+: inline-standard-method ( node generic -- node )
+ dupd dispatching-class dup
+ [ 1quotation f splice-quot ] [ 2drop t ] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
-USING: arrays bit-arrays help.markup help.syntax math
-sequences.private vectors strings quotations sbufs kernel math.order ;
+USING: arrays help.markup help.syntax math
- sequences.private vectors strings sbufs kernel math.order
- layouts ;
++sequences.private vectors strings kernel math.order ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"