Fixing unit tests

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" }

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
 
 [

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 ,

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

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
+        parse-tuple-definition
-        dup save-location
+        pick save-location
-        dup [ construct-boa throw ] curry define
+        define-error-class
     ] define-syntax
 
     "FORGET:" [

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
+"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
+[ ] [ 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
+[ 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
+    "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-! ] [ [ no-tuple-class? ] is? ] must-fail-with
+] [ [ no-tuple-class? ] is? ] must-fail-with
-! 
+
-! ! Hardcore unit tests
+! Hardcore unit tests
-! USE: threads
+USE: threads
-! 
+
-! \ thread "slot-names" word-prop "slot-names" set
+\ thread "slot-names" word-prop "slot-names" set
-! 
+
-! [ ] [
+[ ] [
-!     [
+    [
-!         \ thread { "xxx" } "slot-names" get append
+        \ thread { "xxx" } "slot-names" get append
-!         define-tuple-class
+        define-tuple-class
-!     ] with-compilation-unit
+    ] with-compilation-unit
-! 
+
-!     [ 1337 sleep ] "Test" spawn drop
+    [ 1337 sleep ] "Test" spawn drop
-! 
+
-!     [
+    [
-!         \ thread "slot-names" get
+        \ thread "slot-names" get
-!         define-tuple-class
+        define-tuple-class
-!     ] with-compilation-unit
+    ] with-compilation-unit
-! ] unit-test
+] unit-test
-! 
+
-! USE: vocabs
+USE: vocabs
-! 
+
-! \ vocab "slot-names" word-prop "slot-names" set
+\ vocab "slot-names" word-prop "slot-names" set
-! 
+
-! [ ] [
+[ ] [
-!     [
+    [
-!         \ vocab { "xxx" } "slot-names" get append
+        \ vocab { "xxx" } "slot-names" get append
-!         define-tuple-class
+        define-tuple-class
-!     ] with-compilation-unit
+    ] with-compilation-unit
-! 
+
-!     all-words drop
+    all-words drop
-! 
+
-!     [
+    [
-!         \ vocab "slot-names" get
+        \ vocab "slot-names" get
-!         define-tuple-class
+        define-tuple-class
-!     ] with-compilation-unit
+    ] with-compilation-unit
-! ] unit-test
+] unit-test

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 ] }
+        { [ pick tuple-class? not ] [ define-new-tuple-class ] }
-        { [ over "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
+        { [ 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 ;
 

extra/combinators/lib/lib.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
+! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
-!                    Eduardo Cavazos, Daniel Ehrenberg.
+!                          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
+  [ [ 1- ] [ ] bi
-    [ , ntuck , nslip ]
+    '[ , ntuck , nslip ] ]
-    bake ]
   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
+    '[ , preserving , , if ] ;
-    dup 1+ swap
-    [ >r >r , nkeep , nrot r> r> if ]
-    bake ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! switch
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: preserving ( predicate -- quot )
-    dup infer effect-in
-    dup 1+ spin
-    [ , , nkeep , nrot ]
-    bake ;
-
 MACRO: switch ( quot -- )
-    [ [ preserving ] [ ] bi* ] assoc-map
+    [ [ [ preserving ] curry ] dip ] assoc-map
-    [ , cond ]
+    [ cond ] curry ;
-    bake ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

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
+    "io.encodings.8-bit" create
-    dup { f } "slots" set-word-prop
+    dup tuple { } define-tuple-class ;
-    dup predicate-word drop
-    dup { } define-tuple-class ;
 
 : data-quot ( class word data -- quot )
     >r [ word-name ] 2apply "/" swap 3append

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