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