2005-01-29 16:39:30 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2005-08-02 06:32:48 -04:00
|
|
|
IN: generic
|
|
|
|
USING: errors hashtables kernel kernel-internals lists math
|
|
|
|
namespaces parser sequences strings vectors words ;
|
2005-02-20 19:03:37 -05:00
|
|
|
|
2005-03-08 22:54:59 -05:00
|
|
|
! Tuples are really arrays in the runtime, but with a different
|
|
|
|
! type number. The layout is as follows:
|
|
|
|
|
|
|
|
! slot 0 - object header with type number (as usual)
|
|
|
|
! slot 1 - length, including class/delegate slots
|
|
|
|
! slot 2 - the class, a word
|
|
|
|
! slot 3 - the delegate tuple, or f
|
|
|
|
|
2005-08-02 06:32:48 -04:00
|
|
|
: class ( object -- class )
|
2005-08-14 18:13:16 -04:00
|
|
|
dup tuple? [ 2 slot ] [ type type>class ] ifte ; inline
|
2005-02-18 20:37:01 -05:00
|
|
|
|
2005-08-12 18:02:03 -04:00
|
|
|
: class-tuple ( object -- class )
|
|
|
|
dup tuple? [ 2 slot ] [ drop f ] ifte ; inline
|
|
|
|
|
2005-01-29 16:39:30 -05:00
|
|
|
: tuple-predicate ( word -- )
|
|
|
|
#! Make a foo? word for testing the tuple class at the top
|
|
|
|
#! of the stack.
|
2005-07-28 18:20:31 -04:00
|
|
|
dup predicate-word
|
2005-08-25 15:27:38 -04:00
|
|
|
[ \ class-tuple , over literalize , \ eq? , ] [ ] make
|
2005-08-03 18:47:32 -04:00
|
|
|
define-predicate ;
|
2005-01-29 16:39:30 -05:00
|
|
|
|
2005-05-15 21:17:56 -04:00
|
|
|
: forget-tuple ( class -- )
|
2005-05-16 17:01:39 -04:00
|
|
|
dup forget "predicate" word-prop car [ forget ] when* ;
|
2005-05-15 21:17:56 -04:00
|
|
|
|
2005-02-09 22:35:11 -05:00
|
|
|
: check-shape ( word slots -- )
|
|
|
|
#! If the new list of slots is different from the previous,
|
|
|
|
#! forget the old definition.
|
2005-08-23 18:16:42 -04:00
|
|
|
>r "in" get lookup dup [
|
2005-03-08 22:54:59 -05:00
|
|
|
dup "tuple-size" word-prop r> length 2 + =
|
2005-05-15 21:17:56 -04:00
|
|
|
[ drop ] [ forget-tuple ] ifte
|
2005-02-09 22:35:11 -05:00
|
|
|
] [
|
|
|
|
r> 2drop
|
|
|
|
] ifte ;
|
|
|
|
|
2005-08-19 21:46:12 -04:00
|
|
|
: delegate-slots { { 3 delegate set-delegate } } ;
|
|
|
|
|
2005-02-20 19:03:37 -05:00
|
|
|
: tuple-slots ( tuple slots -- )
|
2005-03-26 20:12:14 -05:00
|
|
|
2dup "slot-names" set-word-prop
|
2005-03-08 22:54:59 -05:00
|
|
|
2dup length 2 + "tuple-size" set-word-prop
|
2005-07-25 17:13:35 -04:00
|
|
|
dupd 4 simple-slots
|
2005-08-19 21:46:12 -04:00
|
|
|
2dup delegate-slots swap append "slots" set-word-prop
|
2005-07-25 17:13:35 -04:00
|
|
|
define-slots ;
|
2005-02-10 15:14:20 -05:00
|
|
|
|
2005-08-13 23:39:46 -04:00
|
|
|
: tuple-constructor ( class -- word )
|
|
|
|
word-name "in" get constructor-word dup save-location ;
|
|
|
|
|
|
|
|
: define-constructor ( word class def -- )
|
|
|
|
>r [
|
2005-08-03 23:56:28 -04:00
|
|
|
dup literalize , "tuple-size" word-prop , \ make-tuple ,
|
2005-08-25 15:27:38 -04:00
|
|
|
] [ ] make r> append define-compound ;
|
2005-02-10 15:14:20 -05:00
|
|
|
|
|
|
|
: default-constructor ( tuple -- )
|
2005-08-13 23:39:46 -04:00
|
|
|
[ tuple-constructor ] keep dup [
|
2005-07-25 17:13:35 -04:00
|
|
|
"slots" word-prop 1 swap tail-slice reverse-slice
|
|
|
|
[ peek unit , \ keep , ] each
|
2005-08-25 15:27:38 -04:00
|
|
|
] [ ] make define-constructor ;
|
2005-02-09 22:35:11 -05:00
|
|
|
|
|
|
|
: define-tuple ( tuple slots -- )
|
|
|
|
2dup check-shape
|
2005-02-20 19:03:37 -05:00
|
|
|
>r create-in
|
2005-02-10 15:14:20 -05:00
|
|
|
dup intern-symbol
|
|
|
|
dup tuple-predicate
|
2005-08-14 17:33:45 -04:00
|
|
|
dup tuple "superclass" set-word-prop
|
2005-03-05 14:45:23 -05:00
|
|
|
dup tuple "metaclass" set-word-prop
|
2005-02-20 19:03:37 -05:00
|
|
|
dup r> tuple-slots
|
2005-02-10 15:14:20 -05:00
|
|
|
default-constructor ;
|
2005-02-09 22:35:11 -05:00
|
|
|
|
2005-05-16 01:15:48 -04:00
|
|
|
! A sequence of all slots in a tuple, used for equality testing.
|
|
|
|
TUPLE: mirror tuple ;
|
|
|
|
|
|
|
|
C: mirror ( tuple -- mirror )
|
2005-08-19 21:46:12 -04:00
|
|
|
over tuple? [ "Not a tuple" throw ] unless
|
|
|
|
[ set-mirror-tuple ] keep ;
|
2005-04-12 13:35:27 -04:00
|
|
|
|
2005-05-16 01:15:48 -04:00
|
|
|
M: mirror nth ( n mirror -- elt )
|
|
|
|
bounds-check mirror-tuple array-nth ;
|
|
|
|
|
|
|
|
M: mirror set-nth ( n mirror -- elt )
|
|
|
|
bounds-check mirror-tuple set-array-nth ;
|
|
|
|
|
|
|
|
M: mirror length ( mirror -- len )
|
|
|
|
mirror-tuple array-capacity ;
|
|
|
|
|
2005-08-04 12:58:07 -04:00
|
|
|
: literal-tuple ( seq -- tuple )
|
2005-07-27 20:13:11 -04:00
|
|
|
dup first "tuple-size" word-prop <tuple>
|
2005-08-04 12:58:07 -04:00
|
|
|
[ <mirror> 0 swap rot copy-into ] keep ;
|
2005-07-27 20:13:11 -04:00
|
|
|
|
2005-02-07 11:51:22 -05:00
|
|
|
: clone-tuple ( tuple -- tuple )
|
|
|
|
#! Make a shallow copy of a tuple, without cloning its
|
|
|
|
#! delegate.
|
2005-06-08 18:11:53 -04:00
|
|
|
[ array-capacity <tuple> dup ] keep copy-array ;
|
2005-01-31 14:02:09 -05:00
|
|
|
|
2005-02-07 11:51:22 -05:00
|
|
|
M: tuple clone ( tuple -- tuple )
|
|
|
|
#! Clone a tuple and its delegate.
|
2005-03-08 22:54:59 -05:00
|
|
|
clone-tuple dup delegate clone over set-delegate ;
|
2005-02-07 11:51:22 -05:00
|
|
|
|
2005-01-31 14:02:09 -05:00
|
|
|
M: tuple hashcode ( vec -- n )
|
2005-03-08 22:54:59 -05:00
|
|
|
#! If the capacity is two, then all we have is the class
|
|
|
|
#! slot and delegate.
|
2005-06-08 04:49:05 -04:00
|
|
|
dup array-capacity 2 number= [
|
2005-01-31 14:02:09 -05:00
|
|
|
drop 0
|
|
|
|
] [
|
2005-05-28 20:52:23 -04:00
|
|
|
2 swap array-nth hashcode
|
2005-01-31 14:02:09 -05:00
|
|
|
] ifte ;
|
|
|
|
|
2005-04-12 13:35:27 -04:00
|
|
|
M: tuple = ( obj tuple -- ? )
|
|
|
|
2dup eq? [
|
|
|
|
2drop t
|
|
|
|
] [
|
|
|
|
over tuple? [
|
2005-05-16 01:15:48 -04:00
|
|
|
swap <mirror> swap <mirror> sequence=
|
2005-04-12 13:35:27 -04:00
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] ifte
|
|
|
|
] ifte ;
|
|
|
|
|
2005-08-14 23:26:40 -04:00
|
|
|
tuple [ 2drop f ] "class<" set-word-prop
|
|
|
|
|
2005-03-26 20:12:14 -05:00
|
|
|
PREDICATE: word tuple-class metaclass tuple = ;
|
2005-07-13 18:08:54 -04:00
|
|
|
|
|
|
|
: is? ( obj pred -- ? | pred: obj -- ? )
|
|
|
|
#! Tests if the object satisfies the predicate, or if
|
|
|
|
#! it delegates to an object satisfying it.
|
|
|
|
[ call ] 2keep rot [
|
|
|
|
2drop t
|
|
|
|
] [
|
|
|
|
over [ >r delegate r> is? ] [ 2drop f ] ifte
|
2005-07-18 02:08:41 -04:00
|
|
|
] ifte ; inline
|