Unit test fixes
							parent
							
								
									868189e847
								
							
						
					
					
						commit
						febcd88459
					
				| 
						 | 
				
			
			@ -99,8 +99,8 @@ unit-test
 | 
			
		|||
        3
 | 
			
		||||
        H{ } clone
 | 
			
		||||
        2 [
 | 
			
		||||
            2dup [ , f ] cache
 | 
			
		||||
            2dup [ , f ] cache drop
 | 
			
		||||
        ] times
 | 
			
		||||
        2drop
 | 
			
		||||
    ] make
 | 
			
		||||
    ] { } make
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -30,7 +30,7 @@ HELP: class-types
 | 
			
		|||
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
 | 
			
		||||
 | 
			
		||||
HELP: class<
 | 
			
		||||
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
 | 
			
		||||
{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
 | 
			
		||||
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 | 
			
		||||
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -81,8 +81,8 @@ unit-test
 | 
			
		|||
    -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ 2 ] [
 | 
			
		||||
    SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
 | 
			
		||||
[ 1 ] [
 | 
			
		||||
    SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
! Test slow shuffles
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,7 +5,7 @@ TUPLE: foo bar baz ;
 | 
			
		|||
 | 
			
		||||
C: <foo> foo
 | 
			
		||||
 | 
			
		||||
[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
 | 
			
		||||
[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,13 +5,11 @@ arrays classes slots slots.private tuples math vectors
 | 
			
		|||
quotations sorting prettyprint ;
 | 
			
		||||
IN: mirrors
 | 
			
		||||
 | 
			
		||||
GENERIC: object-slots ( obj -- seq )
 | 
			
		||||
: all-slots ( class -- slots )
 | 
			
		||||
    superclasses [ "slots" word-prop ] map concat ;
 | 
			
		||||
 | 
			
		||||
M: object object-slots class "slots" word-prop ;
 | 
			
		||||
 | 
			
		||||
M: tuple object-slots
 | 
			
		||||
    dup class superclasses [ "slots" word-prop ] map concat
 | 
			
		||||
    swap delegate [ 1 tail-slice ] unless ;
 | 
			
		||||
: object-slots ( obj -- seq )
 | 
			
		||||
    class all-slots ;
 | 
			
		||||
 | 
			
		||||
TUPLE: mirror object slots ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -191,7 +191,7 @@ HELP: define-tuple-predicate
 | 
			
		|||
$low-level-note ;
 | 
			
		||||
 | 
			
		||||
HELP: redefine-tuple-class
 | 
			
		||||
{ $values { "class" class } { "superclass" class } { "newslots" "a sequence of strings" } }
 | 
			
		||||
{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
 | 
			
		||||
{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
 | 
			
		||||
$nl
 | 
			
		||||
"If the class is not a tuple class word, this word does nothing." }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -36,7 +36,7 @@ PRIVATE>
 | 
			
		|||
    [ layout-size swap [ array-nth ] curry map ] keep
 | 
			
		||||
    layout-class add* ;
 | 
			
		||||
 | 
			
		||||
: >tuple ( sequence -- tuple )
 | 
			
		||||
: >tuple ( seq -- tuple )
 | 
			
		||||
    dup first tuple-layout <tuple> [
 | 
			
		||||
        >r 1 tail-slice dup length r>
 | 
			
		||||
        [ tuple-size min ] keep
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
USING: kernel words inspector slots quotations sequences assocs
 | 
			
		||||
math arrays inference effects shuffle continuations debugger
 | 
			
		||||
tuples namespaces vectors bit-arrays byte-arrays strings sbufs
 | 
			
		||||
math.functions macros sequences.private combinators ;
 | 
			
		||||
math.functions macros sequences.private combinators mirrors ;
 | 
			
		||||
IN: inverse
 | 
			
		||||
 | 
			
		||||
TUPLE: fail ;
 | 
			
		||||
| 
						 | 
				
			
			@ -191,7 +191,7 @@ MACRO: undo ( quot -- ) [undo] ;
 | 
			
		|||
    "predicate" word-prop [ dupd call assure ] curry ;
 | 
			
		||||
 | 
			
		||||
: slot-readers ( class -- quot )
 | 
			
		||||
    "slots" word-prop 1 tail ! tail gets rid of delegate
 | 
			
		||||
    all-slots 1 tail ! tail gets rid of delegate
 | 
			
		||||
    [ slot-spec-reader 1quotation [ keep ] curry ] map concat
 | 
			
		||||
    [ ] like [ drop ] compose ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
USING: kernel sequences slots parser words classes
 | 
			
		||||
slots.private ;
 | 
			
		||||
slots.private mirrors ;
 | 
			
		||||
IN: tuple-syntax
 | 
			
		||||
 | 
			
		||||
! TUPLE: foo bar baz ;
 | 
			
		||||
| 
						 | 
				
			
			@ -10,8 +10,7 @@ IN: tuple-syntax
 | 
			
		|||
 | 
			
		||||
: parse-slot-writer ( tuple -- slot# )
 | 
			
		||||
    scan dup "}" = [ 2drop f ] [
 | 
			
		||||
        1 head* swap class "slots" word-prop
 | 
			
		||||
        [ slot-spec-name = ] with find nip slot-spec-offset
 | 
			
		||||
        1 head* swap object-slots slot-named slot-spec-offset
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
: parse-slots ( accum tuple -- accum tuple )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,16 +1,16 @@
 | 
			
		|||
! Copyright (C) 2007 Doug Coleman.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: kernel macros sequences slots words ;
 | 
			
		||||
USING: kernel macros sequences slots words mirrors ;
 | 
			
		||||
IN: tuples.lib
 | 
			
		||||
 | 
			
		||||
: reader-slots ( seq -- quot )
 | 
			
		||||
    [ slot-spec-reader ] map [ get-slots ] curry ;
 | 
			
		||||
 | 
			
		||||
MACRO: >tuple< ( class -- )
 | 
			
		||||
    "slots" word-prop 1 tail-slice reader-slots ;
 | 
			
		||||
    all-slots 1 tail-slice reader-slots ;
 | 
			
		||||
 | 
			
		||||
MACRO: >tuple*< ( class -- )
 | 
			
		||||
    "slots" word-prop
 | 
			
		||||
    all-slots
 | 
			
		||||
    [ slot-spec-name "*" tail? ] subset
 | 
			
		||||
    reader-slots ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue