Fixing unit tests

2008-03-26 17:07:50 -05:00 · 2008-03-26 17:07:50 -05:00 · 89a531d4a2
parent 4844bae31a
commit 89a531d4a2
10 changed files with 110 additions and 93 deletions
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@ -358,7 +358,9 @@ builtins get num-tags get tail f union-class define-class
 "null" "kernel" create { } f union-class define-class

 ! Create special tombstone values
-"tombstone" "hashtables.private" create { } define-tuple-class
+"tombstone" "hashtables.private" create
+"tuple" "kernel" lookup
+{ } define-tuple-class

 "((empty))" "hashtables.private" create
 "tombstone" "hashtables.private" lookup f
@ -370,6 +372,7 @@ builtins get num-tags get tail f union-class define-class

 ! Some tuple classes
 "hashtable" "hashtables" create
+"tuple" "kernel" lookup
 {
    {
        { "array-capacity" "sequences.private" }
@ -390,6 +393,7 @@ builtins get num-tags get tail f union-class define-class
 } define-tuple-class

 "sbuf" "sbufs" create
+"tuple" "kernel" lookup
 {
    {
        { "string" "strings" }
@ -405,6 +409,7 @@ builtins get num-tags get tail f union-class define-class
 } define-tuple-class

 "vector" "vectors" create
+"tuple" "kernel" lookup
 {
    {
        { "array" "arrays" }
@ -420,6 +425,7 @@ builtins get num-tags get tail f union-class define-class
 } define-tuple-class

 "byte-vector" "byte-vectors" create
+"tuple" "kernel" lookup
 {
    {
        { "byte-array" "byte-arrays" }
@ -435,6 +441,7 @@ builtins get num-tags get tail f union-class define-class
 } define-tuple-class

 "bit-vector" "bit-vectors" create
+"tuple" "kernel" lookup
 {
    {
        { "bit-array" "bit-arrays" }
@ -450,6 +457,7 @@ builtins get num-tags get tail f union-class define-class
 } define-tuple-class

 "float-vector" "float-vectors" create
+"tuple" "kernel" lookup
 {
    {
        { "float-array" "float-arrays" }
@ -465,6 +473,7 @@ builtins get num-tags get tail f union-class define-class
 } define-tuple-class

 "curry" "kernel" create
+"tuple" "kernel" lookup
 {
    {
        { "object" "kernel" }
@ -484,6 +493,7 @@ dup f "inline" set-word-prop
 dup tuple-layout [ <tuple-boa> ] curry define

 "compose" "kernel" create
+"tuple" "kernel" lookup
 {
    {
        { "object" "kernel" }
--- a/core/io/encodings/encodings-tests.factor
+++ b/core/io/encodings/encodings-tests.factor
@ -6,7 +6,7 @@ IN: io.streams.encodings.tests
    resource-path ascii <file-reader> ;
    
 [ { } ]
-[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
+[ "core/io/test/empty-file.txt" <resource-reader> lines ]
 unit-test

 : lines-test ( stream -- line1 line2 )
@ -16,21 +16,21 @@ unit-test
    "This is a line."
    "This is another line."
 ] [
-    "/core/io/test/windows-eol.txt" <resource-reader> lines-test
+    "core/io/test/windows-eol.txt" <resource-reader> lines-test
 ] unit-test

 [
    "This is a line."
    "This is another line."
 ] [
-    "/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+    "core/io/test/mac-os-eol.txt" <resource-reader> lines-test
 ] unit-test

 [
    "This is a line."
    "This is another line."
 ] [
-    "/core/io/test/unix-eol.txt" <resource-reader> lines-test
+    "core/io/test/unix-eol.txt" <resource-reader> lines-test
 ] unit-test

 [
--- a/core/io/io-tests.factor
+++ b/core/io/io-tests.factor
@ -4,7 +4,7 @@ io.encodings.binary ;
 IN: io.tests

 [ f ] [
-    "resource:/core/io/test/no-trailing-eol.factor" run-file
+    "resource:core/io/test/no-trailing-eol.factor" run-file
    "foo" "io.tests" lookup
 ] unit-test

@ -14,14 +14,14 @@ IN: io.tests
 [
    "This is a line.\rThis is another line.\r"
 ] [
-    "/core/io/test/mac-os-eol.txt" <resource-reader>
+    "core/io/test/mac-os-eol.txt" <resource-reader>
    [ 500 read ] with-stream
 ] unit-test

 [
    255
 ] [
-    "/core/io/test/binary.txt" <resource-reader>
+    "core/io/test/binary.txt" <resource-reader>
    [ read1 ] with-stream >fixnum
 ] unit-test

@ -36,7 +36,7 @@ IN: io.tests
    }
 ] [
    [
-        "/core/io/test/separator-test.txt" <resource-reader> [
+        "core/io/test/separator-test.txt" <resource-reader> [
            "J" read-until 2array ,
            "i" read-until 2array ,
            "X" read-until 2array ,
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@ -288,6 +288,14 @@ M: no-word summary
 : CREATE-METHOD ( -- method )
    scan-word bootstrap-word scan-word create-method-in ;

+: parse-tuple-definition ( -- class superclass slots )
+    CREATE-CLASS
+    scan {
+        { ";" [ tuple f ] }
+        { "<" [ scan-word ";" parse-tokens ] }
+        [ >r tuple ";" parse-tokens r> add* ]
+    } case ;
+
 ERROR: staging-violation word ;

 M: staging-violation summary
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@ -154,7 +154,7 @@ IN: bootstrap.syntax
    ] define-syntax

    "TUPLE:" [
-        CREATE-CLASS ";" parse-tokens define-tuple-class
+        parse-tuple-definition define-tuple-class
    ] define-syntax

    "C:" [
@ -164,9 +164,9 @@ IN: bootstrap.syntax
    ] define-syntax

    "ERROR:" [
-        CREATE-CLASS dup ";" parse-tokens define-tuple-class
-        dup save-location
-        dup [ construct-boa throw ] curry define
+        parse-tuple-definition
+        pick save-location
+        define-error-class
    ] define-syntax

    "FORGET:" [
--- a/core/tuples/tuples-tests.factor
+++ b/core/tuples/tuples-tests.factor
@ -233,49 +233,49 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 : cons-test-1 \ erg's-reshape-problem construct-empty ;
 : cons-test-2 \ erg's-reshape-problem construct-boa ;

-! "IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
-! 
-! [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-! 
-! [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-! 
-! [
-!     "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-! ] [ [ no-tuple-class? ] is? ] must-fail-with
-! 
-! ! Hardcore unit tests
-! USE: threads
-! 
-! \ thread "slot-names" word-prop "slot-names" set
-! 
-! [ ] [
-!     [
-!         \ thread { "xxx" } "slot-names" get append
-!         define-tuple-class
-!     ] with-compilation-unit
-! 
-!     [ 1337 sleep ] "Test" spawn drop
-! 
-!     [
-!         \ thread "slot-names" get
-!         define-tuple-class
-!     ] with-compilation-unit
-! ] unit-test
-! 
-! USE: vocabs
-! 
-! \ vocab "slot-names" word-prop "slot-names" set
-! 
-! [ ] [
-!     [
-!         \ vocab { "xxx" } "slot-names" get append
-!         define-tuple-class
-!     ] with-compilation-unit
-! 
-!     all-words drop
-! 
-!     [
-!         \ vocab "slot-names" get
-!         define-tuple-class
-!     ] with-compilation-unit
-! ] unit-test
+"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
+
+[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
+
+[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
+
+[
+    "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
+] [ [ no-tuple-class? ] is? ] must-fail-with
+
+! Hardcore unit tests
+USE: threads
+
+\ thread "slot-names" word-prop "slot-names" set
+
+[ ] [
+    [
+        \ thread { "xxx" } "slot-names" get append
+        define-tuple-class
+    ] with-compilation-unit
+
+    [ 1337 sleep ] "Test" spawn drop
+
+    [
+        \ thread "slot-names" get
+        define-tuple-class
+    ] with-compilation-unit
+] unit-test
+
+USE: vocabs
+
+\ vocab "slot-names" word-prop "slot-names" set
+
+[ ] [
+    [
+        \ vocab { "xxx" } "slot-names" get append
+        define-tuple-class
+    ] with-compilation-unit
+
+    all-words drop
+
+    [
+        \ vocab "slot-names" get
+        define-tuple-class
+    ] with-compilation-unit
+] unit-test
--- a/core/tuples/tuples.factor
+++ b/core/tuples/tuples.factor
@ -103,33 +103,39 @@ M: tuple-class tuple-layout "layout" word-prop ;
        become
    ] 2curry after-compilation ;

-: tuple-class-unchanged 2drop ;
+: tuple-class-unchanged ( class superclass slots -- ) 3drop ;

 : prepare-tuple-class ( class slots -- )
    dupd define-tuple-slots
    dup define-tuple-layout
    define-tuple-predicate ;

-: redefine-tuple-class ( class slots -- )
+: redefine-tuple-class ( class superclass slots -- )
+    nip
    2dup forget-slots
    2dup reshape-tuples
    over changed-word
    over redefined
    prepare-tuple-class ;

-: define-new-tuple-class ( class slots -- )
+: define-new-tuple-class ( class superclass slots -- )
+    nip
    over f tuple tuple-class define-class
    prepare-tuple-class ;

 PRIVATE>

-: define-tuple-class ( class slots -- )
+: define-tuple-class ( class superclass slots -- )
    {
-        { [ over tuple-class? not ] [ define-new-tuple-class ] }
-        { [ over "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
+        { [ pick tuple-class? not ] [ define-new-tuple-class ] }
+        { [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
        { [ t ] [ redefine-tuple-class ] }
    } cond ;

+: define-error-class ( class superclass slots -- )
+    pick >r define-tuple-class r>
+    dup [ construct-boa throw ] curry define ;
+
 M: tuple clone
    (clone) dup delegate clone over set-delegate ;

--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@ -1,7 +1,8 @@
-! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
-!                    Eduardo Cavazos, Daniel Ehrenberg.
+! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
+!                          Doug Coleman, Eduardo Cavazos,
+!                          Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators namespaces quotations hashtables
+USING: kernel combinators fry namespaces quotations hashtables
 sequences assocs arrays inference effects math math.ranges
 arrays.lib shuffle macros bake combinators.cleave
 continuations ;
@ -34,9 +35,8 @@ MACRO: nwith ( quot n -- )

 MACRO: napply ( n -- )
  2 [a,b]
-  [ [ ] [ 1- ] bi
-    [ , ntuck , nslip ]
-    bake ]
+  [ [ 1- ] [ ] bi
+    '[ , ntuck , nslip ] ]
  map concat >quotation [ call ] append ;

 : 3apply ( obj obj obj quot -- ) 3 napply ; inline
@ -88,26 +88,21 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
 ! ifte
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

+MACRO: preserving ( predicate -- quot )
+    dup infer effect-in
+    dup 1+
+    '[ , , nkeep , nrot ] ;
+
 MACRO: ifte ( quot quot quot -- )
-    pick infer effect-in
-    dup 1+ swap
-    [ >r >r , nkeep , nrot r> r> if ]
-    bake ;
+    '[ , preserving , , if ] ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! switch
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: preserving ( predicate -- quot )
-    dup infer effect-in
-    dup 1+ spin
-    [ , , nkeep , nrot ]
-    bake ;
-
 MACRO: switch ( quot -- )
-    [ [ preserving ] [ ] bi* ] assoc-map
-    [ , cond ]
-    bake ;
+    [ [ [ preserving ] curry ] dip ] assoc-map
+    [ cond ] curry ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--- a/extra/io/encodings/8-bit/8-bit.factor
+++ b/extra/io/encodings/8-bit/8-bit.factor
@ -54,10 +54,8 @@ IN: io.encodings.8-bit
    [ byte>ch ] [ ch>byte ] bi ;

 : empty-tuple-class ( string -- class )
-    in get create
-    dup { f } "slots" set-word-prop
-    dup predicate-word drop
-    dup { } define-tuple-class ;
+    "io.encodings.8-bit" create
+    dup tuple { } define-tuple-class ;

 : data-quot ( class word data -- quot )
    >r [ word-name ] 2apply "/" swap 3append
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@ -25,7 +25,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;

 [ ] [ ssl-v23 new-ctx ] unit-test

-[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
+[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test

 ! TODO: debug 'Memory protection fault at address 6c'
 ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
@ -33,10 +33,10 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
 [ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test

 ! Enter PEM pass phrase: password
-[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
+[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
 SSL_FILETYPE_PEM use-private-key ] unit-test

-[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
+[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f
 verify-load-locations ] unit-test

 [ ] [ get-ctx 1 set-verify-depth ] unit-test
@ -45,7 +45,7 @@ verify-load-locations ] unit-test
 ! Load Diffie-Hellman parameters
 ! =========================================================

-[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
+[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test

 [ ] [ get-bio f f f read-pem-dh-params ] unit-test

@ -129,7 +129,7 @@ verify-load-locations ] unit-test
 ! Dump errors to file
 ! =========================================================

-[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
+[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test

 [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test