debugging I/O code, getenv/setenv are unsafe but a bit faster, each-object tweak, miscellaneous fixes

Makefile

@@ -34,8 +34,6 @@ default:
 	@echo "linux"
 	@echo "linux-ppc - to compile Factor on Linux/PowerPC"
 	@echo "macosx"
-	@echo "solaris"
-	@echo "windows"
 	@echo ""
 	@echo "Also, you might want to set the SITE_CFLAGS environment"
 	@echo "variable to enable some CPU-specific optimizations; this"
@@ -45,34 +43,29 @@ default:
 
 bsd:
 	$(MAKE) f \
-		CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic -pthread" \
+		CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -pthread" \
 		LIBS="$(DEFAULT_LIBS)"
 
 bsd-nopthread:
 	$(MAKE) f \
-		CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic" \
+		CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
 		LIBS="$(DEFAULT_LIBS)"
 
 macosx:
 	$(MAKE) f \
-		CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \
+		CFLAGS="$(DEFAULT_CFLAGS)" \
 		LIBS="$(DEFAULT_LIBS)" 
 
 linux:
 	$(MAKE) f \
-		CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic" \
+		CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
 		LIBS="$(DEFAULT_LIBS) -ldl" 
 
 linux-ppc:
 	$(MAKE) f \
-		CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic -mregnames" \
+		CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \
 		LIBS="$(DEFAULT_LIBS) -ldl" 
 
-solaris:
-	$(MAKE) f \
-		CFLAGS="$(DEFAULT_CFLAGS)" \
-		LIBS="$(DEFAULT_LIBS) -lsocket -lnsl -lm"
-
 f: $(OBJS)
 	$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
 	$(STRIP) $@

TODO.FACTOR.txt

@@ -90,6 +90,7 @@
 
 + i/o:
 
+- 0 read broken
 - review errno
 - separate words for writing characters and strings
 - perhaps:

library/collections/namespaces.factor

@@ -99,15 +99,15 @@ strings vectors ;
     over >r bind r> ; inline
 
 ! Building sequences
-SYMBOL: sequence
+SYMBOL: building
 
 : make-seq ( quot sequence -- sequence )
     #! Call , and % from the quotation to append to a sequence.
-    [ sequence set call sequence get ] with-scope ; inline
+    [ building set call building get ] with-scope ; inline
 
 : , ( obj -- )
     #! Add to the sequence being built with make-seq.
-    sequence get dup sbuf? [ sbuf-append ] [ push ] ifte ;
+    building get dup sbuf? [ sbuf-append ] [ push ] ifte ;
 
 : literal, ( word -- )
     #! Append some code that pushes the word on the stack. Used
@@ -117,11 +117,11 @@ SYMBOL: sequence
 : unique, ( obj -- )
     #! Add the object to the sequence being built with make-seq
     #! unless an equal object has already been added.
-    sequence get 2dup index -1 = [ push ] [ 2drop ] ifte ;
+    building get 2dup index -1 = [ push ] [ 2drop ] ifte ;
 
 : % ( seq -- )
     #! Append to the sequence being built with make-seq.
-    sequence get swap nappend ;
+    building get swap nappend ;
 
 : make-vector ( quot -- vector )
     100 <vector> make-seq ; inline

library/collections/sbuf.factor

@@ -7,6 +7,8 @@ M: sbuf length sbuf-length ;
 M: sbuf set-length set-sbuf-length ;
 M: sbuf nth sbuf-nth ;
 M: sbuf set-nth set-sbuf-nth ;
+M: sbuf clone sbuf-clone ;
+M: sbuf = sbuf= ;
 
 : >sbuf ( seq -- sbuf ) 0 <sbuf> [ swap nappend ] keep ;
 

library/collections/strings.factor

@@ -7,8 +7,6 @@ BUILTIN: string 12 [ 1 length f ] [ 2 hashcode f ] ;
 M: string = string= ;
 
 BUILTIN: sbuf 13 ;
-M: sbuf = sbuf= ;
-
 UNION: text string integer ;
 
 M: string nth string-nth ;

library/collections/vectors-epilogue.factor

@@ -5,7 +5,8 @@ math-internals sequences ;
 
 IN: vectors
 
-: >vector ( list -- vector ) 0 <vector> [ swap nappend ] keep ;
+: >vector ( list -- vector )
+    dup length <vector> [ swap nappend ] keep ;
 
 : vector-project ( n quot -- vector )
     #! Execute the quotation n times, passing the loop counter

library/syntax/parse-syntax.factor

@@ -24,7 +24,7 @@ namespaces parser strings syntax unparse vectors words ;
 
 ! The canonical t is a heap-allocated dummy object. It is always
 ! the first in the image.
-BUILTIN: t 7 ;  : t t swons ; parsing
+BUILTIN: t 14 ; : t t swons ; parsing
 
 ! In the runtime, the canonical f is represented as a null
 ! pointer with tag 3. So

library/test/combinators.factor

@@ -4,6 +4,7 @@ USE: math
 USE: test
 USE: stdio
 USE: prettyprint
+USE: namespaces
 
 [ slip ] unit-test-fails
 [ 1 slip ] unit-test-fails
@@ -11,7 +12,6 @@ USE: prettyprint
 [ 1 2 3 slip ] unit-test-fails
 
 [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
-[ 6 ] [ [ 2 2 + ] 1 1 2slip + + ] unit-test
 
 [ [ ] keep ] unit-test-fails
 
@@ -29,3 +29,7 @@ USE: prettyprint
 
 [ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?ifte ] with-string ] unit-test
 [ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?ifte ] with-string ] unit-test
+
+[ [ 9 8 7 6 5 4 3 2 1 ] ]
+[ [ 10 [ , ] [ 1 - dup dup 0 = [ drop f ] when ] while ] make-list nip ]
+unit-test

library/test/io/io.factor

@@ -43,3 +43,5 @@ USE: math
 [ ] [ "\0" write ] unit-test
 
 [ -1 read ] unit-test-fails
+
+[ "" ] [ 0 read ] unit-test

library/test/lists/combinators.factor

@@ -28,12 +28,6 @@ USE: strings
 [ t ] [ [ 1/2 ] all=? ] unit-test
 [ t ] [ [ 1.0 10/10 1 ] all=? ] unit-test
 
-[ 5 ] [ [ 5 ] [ < ] top ] unit-test
-[ 5 ] [ [ 5 6 ] [ < ] top ] unit-test
-[ 6 ] [ [ 5 6 ] [ > ] top ] unit-test
-[ 99 ] [ 100 count [ > ] top ] unit-test
-[ 0 ] [ 100 count [ < ] top ] unit-test
-
 [ f ] [ [ ] [ ] some? ] unit-test
 [ t ] [ [ 1 ] [ ] some? >boolean ] unit-test
 [ t ] [ [ 1 2 3 ] [ 2 > ] some? >boolean ] unit-test

library/test/memory.factor

@@ -1,12 +1,14 @@
 IN: temporary
-USING: generic kernel lists math memory words ;
+USING: generic kernel lists math memory words prettyprint test ;
 
-num-types [
-    [
-        builtin-type [
-            "predicate" word-prop instances [
-                class drop
-            ] each
-        ] when*
-    ] keep
-] repeat
+[ ] [
+    num-types [
+        [
+            builtin-type [
+                "predicate" word-prop instances [
+                    class drop
+                ] each
+            ] when*
+        ] keep
+    ] repeat
+] unit-test

library/test/sbuf.factor

@@ -3,9 +3,9 @@ USING: kernel namespaces sequences strings test ;
 
 [ "Hello" ] [
     100 <sbuf> "buf" set
-    "Hello" "buf" get nappend
-    "buf" get sbuf-clone "buf-clone" set
-    "World" "buf-clone" get nappend
+    "Hello" "buf" get swap nappend
+    "buf" get clone "buf-clone" set
+    "World" "buf-clone" get swap nappend
     "buf" get sbuf>string
 ] unit-test
 

library/test/strings.factor

@@ -1,14 +1,13 @@
 IN: temporary
-USING: sequences ;
-
 USE: errors
 USE: kernel
 USE: math
 USE: namespaces
 USE: strings
 USE: test
+USE: sequences
 
-[ "abc" ] [ [ "a" "b" "c" ] cat ] unit-test
+[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test
 
 [ "abc" ] [ "ab" "c" cat2 ] unit-test
 [ "abc" ] [ "a" "b" "c" cat3 ] unit-test

library/test/test.factor

@@ -67,9 +67,9 @@ SYMBOL: failures
             "namespaces" "generic" "tuple" "files" "parser"
             "parse-number" "prettyprint" "image" "init" "io/io"
             "listener" "vectors" "words" "unparser" "random"
-            "stream" "math/bignum" "math/bitops" "math/gcd"
+            "stream" "math/bitops"
             "math/math-combinators" "math/rational" "math/float"
-            "math/complex" "math/irrational"
+            "math/complex" "math/irrational" "math/integer"
             "httpd/url-encoding" "httpd/html" "httpd/httpd"
             "crashes" "sbuf" "threads" "parsing-word"
             "inference" "dataflow" "interpreter" "alien"

library/test/unparser.factor

@@ -5,6 +5,7 @@ USE: parser
 USE: test
 USE: unparser
 USE: kernel
+USE: kernel-internals
 USE: io-internals
 
 [ "\"hello\\\\backslash\"" ]
@@ -27,6 +28,7 @@ unit-test
 [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
 
 [ ] [ { 1 2 3 } unparse drop ] unit-test
-[ stdin unparse parse ] unit-test-fails
+! Unreadable objects
+[ { 1 2 3 } vector-array unparse parse ] unit-test-fails
 
 [ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test

library/tools/debugger.factor

@@ -42,7 +42,7 @@ parser prettyprint stdio streams strings unparser vectors words ;
     "FFI: " write print ;
 
 : heap-scan-error. ( obj -- )
-    "Cannot do next-object outside begin/end-scan" write drop ;
+    "Cannot do next-object outside begin/end-scan" print drop ;
 
 PREDICATE: cons kernel-error ( obj -- ? )
     car kernel-error = ;

library/tools/memory.factor

@@ -22,13 +22,12 @@ namespaces prettyprint sequences stdio unparser vectors words ;
 ! Some words for iterating through the heap.
 
 : each-object ( quot -- )
-    #! Applies the quotation to each object in the image.
-    [
-        begin-scan
-        [ next-object ] while
-    ] [
-        end-scan rethrow
-    ] catch ;
+    #! Applies the quotation to each object in the image. We
+    #! use the lower-level >c and c> words here to avoid
+    #! copying the stacks.
+    [ end-scan rethrow ] >c
+    begin-scan [ next-object ] while
+    f c> call ;
 
 : instances ( quot -- list )
     #! Return a list of all object that return true when the
@@ -63,7 +62,8 @@ M: object (each-slot) ( quot obj -- )
 
 : references ( obj -- list )
     #! Return a list of all objects that refer to a given object
-    #! in the image.
+    #! in the image. If only one reference exists, find
+    #! something referencing that, and so on.
     [ dupd refers? ] instances nip ;
 
 : seq+ ( n index vector -- )

library/unix/io.factor

@@ -106,7 +106,9 @@ SYMBOL: io-tasks
 : open-read ( path -- fd )
     O_RDONLY file-mode open dup io-error ;
 
-TUPLE: reader line ready? ;
+! The cr slot is set to true by read-line-loop if the last
+! character read was \r.
+TUPLE: reader line ready? cr ;
 
 C: reader ( handle -- reader )
     [ >r buffered-port r> set-delegate ] keep ;
@@ -123,21 +125,35 @@ C: reader ( handle -- reader )
         "reader not ready" throw
     ] ifte ;
 
+: reader-cr> ( reader -- ? )
+    dup reader-cr >r f swap set-reader-cr r> ;
+
 ! Reading lines
-: read-line-loop ( line buffer -- ? )
+: read-line-char ( reader ch -- )
+    f pick set-reader-cr  swap reader-line push ;
+
+: read-line-loop ( reader -- ? )
     dup buffer-length 0 = [
-        2drop f
+        drop f
     ] [
-        dup buffer-pop dup CHAR: \n = [
-            3drop t
+        dup buffer-pop
+        dup CHAR: \r = [
+            drop t swap set-reader-cr t
         ] [
-            pick push read-line-loop
+            dup CHAR: \n = [
+                drop dup reader-cr> [
+                    read-line-loop
+                ] [
+                    drop t
+                ] ifte
+            ] [
+                dupd read-line-char read-line-loop
+            ] ifte
         ] ifte
     ] ifte ;
 
 : read-line-step ( reader -- ? )
-    [ dup reader-line swap read-line-loop dup ] keep
-    set-reader-ready? ;
+    [ read-line-loop dup ] keep set-reader-ready? ;
 
 : init-reader ( count reader -- ) >r <sbuf> r> set-reader-line ;
 
@@ -182,37 +198,35 @@ M: read-line-task io-task-events ( task -- events )
 
 : wait-to-read-line ( port -- )
     dup can-read-line? [
-        drop
-    ] [
-        [
-            swap <read-line-task> add-io-task stop
-        ] callcc0 drop
-    ] ifte ;
+        [ swap <read-line-task> add-io-task stop ] callcc0
+    ] unless drop ;
 
 M: reader stream-readln ( stream -- line )
     dup wait-to-read-line read-fin ;
 
 ! Reading character counts
 : read-count-step ( count reader -- ? )
-    dup reader-line -rot >r over length - r>
+    dup reader-line -rot >r over length - ( remaining) r>
     2dup buffer-fill <= [
-        buffer> swap nappend t
+        buffer> nappend t
     ] [
-        buffer>> nip swap nappend f
+        buffer>> nip nappend f
     ] ifte ;
 
 : can-read-count? ( count reader -- ? )
     dup pending-error
-    2dup reader-line length >= [
-        2drop t
+    2dup init-reader
+    2dup reader-line length <= [
+        t swap set-reader-ready? drop t
     ] [
-        2dup init-reader read-count-step
+        read-count-step
     ] ifte ;
 
 TUPLE: read-task count ;
 
-C: read-task ( port -- task )
-    [ >r <io-task> r> set-delegate ] keep ;
+C: read-task ( count port -- task )
+    [ >r <io-task> r> set-delegate ] keep
+    [ set-read-task-count ] keep ;
 
 : >read-task< dup read-task-count swap io-task-port ;
 
@@ -220,7 +234,7 @@ M: read-task do-io-task ( task -- ? )
     >read-task< dup refill dup eof? [
         nip reader-eof t
     ] [
-        read-count-step
+        [ read-count-step dup ] keep set-reader-ready?
     ] ifte ;
 
 M: read-task io-task-events ( task -- events )
@@ -228,15 +242,11 @@ M: read-task io-task-events ( task -- events )
 
 : wait-to-read ( count port -- )
     2dup can-read-count? [
-        2drop
-    ] [
-        [
-            swap <read-task> add-io-task stop
-        ] callcc0 2drop
-    ] ifte ;
+        [ -rot <read-task> add-io-task stop ] callcc0 
+    ] unless 2drop ;
 
 M: reader stream-read ( count stream -- string )
-    2dup wait-to-read read-fin ;
+    [ wait-to-read ] keep read-fin ;
 
 ! Writers
 

native/factor.h

@@ -89,9 +89,9 @@ typedef signed long long s64;
 	#include <netdb.h>
 #endif
 
-#if defined(FFI) && !defined(WIN32)
+#if !defined(WIN32)
 #include <dlfcn.h>
-#endif /* FFI */
+#endif
 
 #define INLINE inline static
 

native/gc.c

@@ -51,7 +51,7 @@ CELL copy_object_impl(CELL pointer)
 	gc_debug("copy_object",pointer);
 	newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
 		object_size(pointer));
-	put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
+	put(UNTAG(pointer),RETAG(newpointer,OBJECT_TYPE));
 
 	return newpointer;
 }

native/gc.h

@@ -20,6 +20,7 @@ INLINE CELL copy_object(CELL pointer)
 {
 	CELL tag;
 	CELL header;
+	CELL untagged;
 
 	if(pointer == F)
 		return F;
@@ -30,8 +31,9 @@ INLINE CELL copy_object(CELL pointer)
 		return pointer;
 
 	header = get(UNTAG(pointer));
-	if(TAG(header) == GC_COLLECTED)
-		return RETAG(UNTAG(header),tag);
+	untagged = UNTAG(header);
+	if(TAG(header) != FIXNUM_TYPE && in_zone(&active,untagged))
+		return RETAG(untagged,tag);
 	else
 		return RETAG(copy_object_impl(pointer),tag);
 }

native/run.c

@@ -105,17 +105,13 @@ void primitive_ifte(void)
 
 void primitive_getenv(void)
 {
-	F_FIXNUM e = to_fixnum(dpeek());
-	if(e < 0 || e >= USER_ENV)
-		range_error(F,0,tag_fixnum(e),USER_ENV);
+	F_FIXNUM e = to_fixnum_fast(dpeek());
 	drepl(userenv[e]);
 }
 
 void primitive_setenv(void)
 {
-	F_FIXNUM e = to_fixnum(dpop());
+	F_FIXNUM e = to_fixnum_fast(dpop());
 	CELL value = dpop();
-	if(e < 0 || e >= USER_ENV)
-		range_error(F,0,tag_fixnum(e),USER_ENV);
 	userenv[e] = value;
 }