107 lines
2.9 KiB
Factor
107 lines
2.9 KiB
Factor
! Copyright (C) 2005, 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: generic
|
|
USING: arrays errors hashtables kernel kernel-internals lists
|
|
math namespaces parser sequences sequences-internals strings
|
|
vectors words ;
|
|
|
|
: class ( object -- class )
|
|
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
|
|
|
|
: class-tuple ( object -- class )
|
|
dup tuple? [ 2 slot ] [ drop f ] if ; inline
|
|
|
|
IN: kernel-internals
|
|
|
|
: tuple= ( tuple tuple -- ? )
|
|
2dup [ array-capacity ] 2apply number= [
|
|
dup array-capacity
|
|
[ 2dup swap array-nth >r pick array-nth r> = ] all? 2nip
|
|
] [
|
|
2drop f
|
|
] if ; inline
|
|
|
|
: tuple-hashcode ( n tuple -- n )
|
|
dup class hashcode >r >r 1- r> 4 slot hashcode* r> bitxor ;
|
|
|
|
IN: generic
|
|
|
|
: tuple-predicate ( word -- )
|
|
dup predicate-word
|
|
[ \ class-tuple , over literalize , \ eq? , ] [ ] make
|
|
define-predicate ;
|
|
|
|
: forget-tuple ( class -- )
|
|
dup forget "predicate" word-prop car [ forget ] when* ;
|
|
|
|
: check-shape ( word slots -- )
|
|
>r in get lookup dup [
|
|
dup "tuple-size" word-prop r> length 2 + =
|
|
[ drop ] [ forget-tuple ] if
|
|
] [
|
|
r> 2drop
|
|
] if ;
|
|
|
|
: delegate-slots { { 3 object delegate set-delegate } } ;
|
|
|
|
: tuple-slots ( tuple slots -- )
|
|
2dup "slot-names" set-word-prop
|
|
2dup length 2 + "tuple-size" set-word-prop
|
|
dupd 4 simple-slots
|
|
2dup delegate-slots swap append "slots" set-word-prop
|
|
define-slots ;
|
|
|
|
PREDICATE: word tuple-class "tuple-size" word-prop ;
|
|
|
|
: check-tuple-class ( class -- )
|
|
tuple-class? [ "Not a tuple class" throw ] unless ;
|
|
|
|
: define-constructor ( word class def -- )
|
|
over check-tuple-class >r [
|
|
dup literalize , "tuple-size" word-prop , \ make-tuple ,
|
|
] [ ] make r> append define-compound ;
|
|
|
|
: default-constructor ( tuple -- )
|
|
[ create-constructor ] keep dup [
|
|
"slots" word-prop 1 swap tail-slice reverse-slice
|
|
[ peek unit , \ keep , ] each
|
|
] [ ] make define-constructor ;
|
|
|
|
: define-tuple ( tuple slots -- )
|
|
2dup check-shape
|
|
>r create-in
|
|
dup intern-symbol
|
|
dup tuple-predicate
|
|
dup \ tuple bootstrap-word "superclass" set-word-prop
|
|
dup define-class
|
|
dup r> tuple-slots
|
|
default-constructor ;
|
|
|
|
M: tuple clone ( tuple -- tuple )
|
|
(clone) dup delegate clone over set-delegate ;
|
|
|
|
M: tuple hashcode* ( n tuple -- n )
|
|
{
|
|
{ [ over 0 <= ] [ 2drop 0 ] }
|
|
{ [ dup array-capacity 2 <= ] [ nip class hashcode ] }
|
|
{ [ t ] [ tuple-hashcode ] }
|
|
} cond ;
|
|
|
|
M: tuple hashcode ( tuple -- n ) 2 swap hashcode* ;
|
|
|
|
M: tuple = ( obj tuple -- ? )
|
|
2dup eq?
|
|
[ 2drop t ] [ over tuple? [ tuple= ] [ 2drop f ] if ] if ;
|
|
|
|
: is? ( obj pred -- ? | pred: obj -- ? )
|
|
over [
|
|
2dup >r >r call
|
|
[ r> r> 2drop t ] [ r> delegate r> is? ] if
|
|
] [
|
|
2drop f
|
|
] if ; inline
|
|
|
|
: >tuple ( seq -- tuple )
|
|
>vector dup first "tuple-size" word-prop over set-length
|
|
>array array>tuple ;
|