         [ define-tuple-slots ]
         [ define-tuple-predicate ]
         [ define-tuple-prototype ]
+        [ define-tuple-constructor ]
+        [ define-tuple-initial-quots ]
     } cleave ;
 
 : define-new-tuple-class ( class superclass slots -- )

        ] if*
    ] if* ;

: initial-values ( class -- slots )
    all-slots [ initial-value ] map ;

: pad-slots ( slots class -- slots' class )
    [ initial-values over length tail append ] keep ; inline

: tuple>array ( tuple -- array )
    prepare-tuple>array
    [ copy-tuple-slots ] dip
    first prefix ;

: tuple-slots ( tuple -- seq )
    prepare-tuple>array drop copy-tuple-slots ;

: slots>tuple ( seq class -- tuple )
    check-slots pad-slots
    tuple-layout <tuple> [
        [ tuple-size ]
        [ [ set-array-nth ] curry ]
        bi 2each
    ] keep ;

: >tuple ( seq -- tuple )
    unclip slots>tuple ;

ERROR: bad-superclass class ;

: tuple= ( tuple1 tuple2 -- ? )
    2dup [ tuple? ] both? [
        2dup [ layout-of ] bi@ eq? [
            [ drop tuple-size ]
            [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
            2bi all-integers?
        ] [ 2drop f ] if
    ] [ 2drop f ] if ; inline

<PRIVATE

: tuple-predicate-quot/1 ( class -- quot )
    #! Fast path for tuples with no superclass
    [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
    [ dup tuple? ] [ [ drop f ] if ] surround ;

: tuple-instance? ( object class offset -- ? )
    rot dup tuple? [
        layout-of
        2dup 1 slot fixnum<=
        [ swap slot eq? ] [ 3drop f ] if
    ] [ 3drop f ] if ; inline

: layout-class-offset ( echelon -- n )
    2 * 5 + ;

: tuple-predicate-quot ( class echelon -- quot )
    layout-class-offset [ tuple-instance? ] 2curry ;

: echelon-of ( class -- n )
    tuple-layout third ;

: define-tuple-predicate ( class -- )
    dup dup echelon-of {
        { 1 [ tuple-predicate-quot/1 ] }
        [ tuple-predicate-quot ]
    } case define-predicate ;

: class-size ( class -- n )
    superclasses [ "slots" word-prop length ] sigma ;

: (instance-check-quot) ( class -- quot )
    [
        \ dup ,
        [ "predicate" word-prop % ]
        [ [ literalize , \ bad-slot-value , ] [ ] make , ] 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 [ class>> instance-check-quot ] map spread>quot
    f like ;

: define-boa-check ( class -- )
    dup boa-check-quot "boa-check" set-word-prop ;

: tuple-prototype ( class -- prototype )
    [ initial-values ] keep
    over [ ] any? [ slots>tuple ] [ 2drop f ] if ;

: define-tuple-prototype ( class -- )
    dup tuple-prototype "prototype" set-word-prop ;

: prepare-slots ( slots superclass -- slots' )
    [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;

: define-tuple-slots ( class -- )
    dup "slots" word-prop over superclass prepare-slots
    define-accessors ;

: make-tuple-layout ( class -- layout )
    [
        {
            [ , ]
            [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
            [ superclasses length 1 - , ]
            [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
        } cleave
    ] { } make ;

: define-tuple-layout ( class -- )
    dup make-tuple-layout "layout" set-word-prop ;

: compute-slot-permutation ( new-slots old-slots -- triples )
    [ [ [ name>> ] map ] bi@ [ index ] curry map ]
    [ drop [ class>> ] map ]
    [ drop [ initial-value ] map ]
    2tri 3array flip ;

: update-slot ( old-values n class initial -- value )

M: tuple hashcode* tuple-hashcode ;

M: tuple-class new
    dup "constructor" word-prop {
        { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] }
        { "prototype" [ "prototype" word-prop (clone) ] }
        [ drop tuple-layout <tuple> ]
    } case ;

M: tuple-class boa
    [ "boa-check" word-prop [ call ] when* ]
