inspector bug fix, sleep word

TODO.FACTOR.txt

@@ -1,8 +1,6 @@
 - reader syntax for arrays, byte arrays, displaced aliens
 - sleep word
-- docstrings appear twice
 - fix infer hang
-- fix sort out of bounds
 
 + ui:
 
@@ -82,7 +80,6 @@
 
 - split: return vectors
 - specialized arrays
-- clear special word props when redefining words
 - there is a problem with hashcodes of words and bootstrapping
 - delegating generic words with a non-standard picker
 - powerpc has weird callstack residue

library/alien/compiler.factor

@@ -26,11 +26,7 @@ namespaces prettyprint sequences strings words ;
 
 ! FFI code does not run in the interpreter.
 
-TUPLE: alien-error symbol library ;
-
-C: alien-error ( lib sym -- )
-    [ set-alien-error-symbol ] keep
-    [ set-alien-error-library ] keep ;
+TUPLE: alien-error library symbol ;
 
 M: alien-error error. ( error -- )
     "C library interface words cannot be interpreted. " write

library/bootstrap/boot-stage1.factor

@@ -33,6 +33,7 @@ sequences io vectors words ;
         "/library/math/ratio.factor"
         "/library/math/float.factor"
         "/library/math/complex.factor"
+        "/library/math/random.factor"
 
         "/library/collections/growable.factor"
         "/library/collections/cons.factor"
@@ -50,6 +51,7 @@ sequences io vectors words ;
         "/library/collections/sequence-sort.factor"
         "/library/collections/strings-epilogue.factor"
         "/library/collections/tree-each.factor"
+        "/library/collections/queues.factor"
 
         "/library/math/matrices.factor"
 
@@ -66,8 +68,8 @@ sequences io vectors words ;
         "/library/io/string-streams.factor"
         "/library/io/c-streams.factor"
         "/library/io/files.factor"
-
-        "/library/threads.factor"
+        "/library/io/directories.factor"
+        "/library/io/binary.factor"
 
         "/library/syntax/parse-numbers.factor"
         "/library/syntax/parse-words.factor"
@@ -91,10 +93,29 @@ sequences io vectors words ;
         
         "/library/syntax/prettyprint.factor"
 
+        "/library/io/logging.factor"
+
         "/library/tools/gensym.factor"
         "/library/tools/interpreter.factor"
         "/library/tools/debugger.factor"
         "/library/tools/memory.factor"
+        "/library/tools/listener.factor"
+        "/library/tools/word-tools.factor"
+        "/library/tools/walker.factor"
+        "/library/tools/jedit.factor"
+
+        "/library/test/test.factor"
+
+        "/library/tools/annotations.factor"
+        "/library/tools/inspector.factor"
+
+        "/library/syntax/see.factor"
+
+        "/library/threads.factor"
+        
+        "/library/tools/telnetd.factor"
+
+        "/library/bootstrap/image.factor"
 
         "/library/inference/dataflow.factor"
         "/library/inference/inference.factor"
@@ -128,8 +149,6 @@ sequences io vectors words ;
 
         "/library/cli.factor"
         
-        "/library/tools/memory.factor"
-    
         "/library/bootstrap/init.factor"
     } [ dup print parse-resource % ] each
     

library/bootstrap/boot-stage2.factor

@@ -34,8 +34,6 @@ cpu "ppc" = [
     "/library/compiler/ppc/alien.factor"
 ] pull-in
 
-"Compiling base..." print
-
 "statically-linked" get [
     unix? [
         "sdl"      "libSDL.so"     "cdecl"    add-library
@@ -59,6 +57,8 @@ cpu "ppc" = [
 : compile? "compile" get supported-cpu? and ;
 
 compile? [
+    "Compiling base..." print
+
     \ car compile
     \ * compile
     \ = compile
@@ -78,27 +78,6 @@ t [
     "/library/math/pow.factor"
     "/library/math/trig-hyp.factor"
     "/library/math/arc-trig-hyp.factor"
-    "/library/math/random.factor"
-
-    "/library/in-thread.factor"
-
-    "/library/io/directories.factor"
-    "/library/io/binary.factor"
-    
-    "/library/eval-catch.factor"
-    "/library/tools/listener.factor"
-    "/library/tools/word-tools.factor"
-    "/library/syntax/see.factor"
-    "/library/test/test.factor"
-    "/library/tools/walker.factor"
-    "/library/tools/annotations.factor"
-    "/library/tools/inspector.factor"
-    "/library/bootstrap/image.factor"
-    
-    "/library/io/logging.factor"
-
-    "/library/tools/telnetd.factor"
-    "/library/tools/jedit.factor"
 
     "/library/httpd/load.factor"
     "/library/sdl/load.factor"

library/collections/cons.factor

@@ -35,21 +35,6 @@ PREDICATE: general-list list ( list -- ? )
 : 2car ( cons cons -- car car ) swap car swap car ; inline
 : 2cdr ( cons cons -- car car ) swap cdr swap cdr ; inline
 
-: <queue> ( -- queue )
-    #! Make a new functional queue.
-    [[ [ ] [ ] ]] ; foldable
-
-: queue-empty? ( queue -- ? )
-    uncons or not ; foldable
-
-: enque ( obj queue -- queue )
-    uncons >r cons r> cons ; foldable
-
-: deque ( queue -- obj queue )
-    uncons
-    [ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;
-    foldable
-
 M: cons = ( obj cons -- ? )
     2dup eq? [
         2drop t

library/collections/queues.factor

@@ -0,0 +1,24 @@
+IN: queues
+USING: errors kernel lists math sequences vectors ;
+
+TUPLE: queue in out ;
+
+C: queue ( -- queue ) ;
+
+: queue-empty? ( queue -- ? )
+    dup queue-in swap queue-out or not ;
+
+: enque ( obj queue -- )
+    [ queue-in cons ] keep set-queue-in ;
+
+: deque ( queue -- obj )
+    dup queue-out [
+        uncons rot set-queue-out
+    ] [
+        dup queue-in [
+            reverse uncons pick set-queue-out
+            f rot set-queue-in
+        ] [
+            "Empty queue" throw
+        ] ifte*
+    ] ifte* ;

library/collections/sequence-sort.factor

@@ -72,7 +72,7 @@ DEFER: (nsort)
 IN: sequences
 
 : nsort ( seq quot -- | quot: elt elt -- -1/0/1 )
-    swap dup empty?
+    swap dup length 1 <=
     [ 2drop ] [ 0 over length 1 - (nsort) ] ifte ; inline
 
 : sort ( seq quot -- seq | quot: elt elt -- -1/0/1 )

library/eval-catch.factor

@@ -1,9 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: parser USING: kernel errors io ;
-
-: eval-catch ( str -- )
-    [ eval ] [ [ print-error debug-help drop ] when* ] catch ;
-
-: eval>string ( in -- out )
-    [ eval-catch ] string-out ;

library/generic/generic.factor

@@ -62,7 +62,7 @@ SYMBOL: builtin
     "methods" word-prop hash-keys [ class-compare ] sort ;
 
 : make-generic ( word -- )
-    dup dup "combination" word-prop call (define-compound) ;
+    dup dup "combination" word-prop call define-compound ;
 
 : define-method ( class generic definition -- )
     -rot

library/in-thread.factor

@@ -1,19 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: threads
-USING: errors kernel lists namespaces sequences ;
-
-: in-thread ( quot -- )
-    #! Execute a quotation in a co-operative thread. The
-    #! quotation begins executing immediately, and execution
-    #! after the 'in-thread' call in the original thread
-    #! resumes when the quotation yields, either due to blocking
-    #! I/O or an explicit call to 'yield'.
-    [
-        schedule-thread
-        ! Clear stacks since we never go up from this point
-        [ ] set-catchstack
-        { } set-callstack
-        try
-        stop
-    ] callcc0 drop ;

library/io/c-streams.factor

@@ -34,6 +34,8 @@ M: c-stream stream-close ( stream -- )
 : init-io ( -- )
     13 getenv  14 getenv  t <c-stream> <line-reader> stdio set ;
 
+: io-multiplex ( ms -- ) drop ;
+
 IN: io
 
 : <file-reader> ( path -- stream )

library/syntax/generic.factor

@@ -8,11 +8,11 @@ words ;
 
 : GENERIC:
     #! GENERIC: bar == G: bar simple-combination ;
-    CREATE define-generic ; parsing
+    CREATE dup reset-word define-generic ; parsing
 
 : G:
     #! G: word combination ;
-    CREATE [ define-generic* ] [ ] ; parsing
+    CREATE dup reset-word [ define-generic* ] [ ] ; parsing
 
 : COMPLEMENT: ( -- )
     #! Followed by a class name, then a complemented class.

library/syntax/parse-syntax.factor

@@ -62,7 +62,8 @@ words ;
 ! Word definitions
 : :
     #! Begin a word definition. Word name follows.
-    CREATE [ define-compound ] [ ] "in-definition" on ; parsing
+    CREATE dup reset-generic [ define-compound ]
+    [ ] "in-definition" on ; parsing
 
 : ;
     #! End a word definition.
@@ -71,7 +72,7 @@ words ;
 ! Symbols
 : SYMBOL:
     #! A symbol is a word that pushes itself when executed.
-    CREATE define-symbol ; parsing
+    CREATE dup reset-generic define-symbol ; parsing
 
 : \
     #! Word literals: \ foo
@@ -90,7 +91,7 @@ words ;
 : DEFER:
     #! Create a word with no definition. Used for mutually
     #! recursive words.
-    CREATE drop ; parsing
+    CREATE dup reset-generic drop ; parsing
 
 : FORGET:
     #! Followed by a word name. The word is removed from its

library/syntax/prettyprint.factor

@@ -321,7 +321,7 @@ M: wrapper pprint* ( wrapper -- )
 
 : unparse-short ( object -- str ) [ pprint-short ] string-out ;
 
-: unparse-short ( object -- )
+: unparse-short. ( object -- )
     dup unparse-short swap write-object terpri ;
 
 : [.] ( sequence -- ) [ unparse-short. ] each ;

library/test/inspector.factor

@@ -1,7 +1,11 @@
 IN: temporary
-USING: test inspector prettyprint math ;
+USING: inspector math namespaces prettyprint test ;
+
+[[ "hello" "world" ]] inspect
+
+[ "hello" ] [ 0 get ] unit-test
+[ "world" ] [ 1 get ] unit-test
 
-[[ 1 2 ]] inspect
 [ 1 2 3 ] inspect
 f inspect
 \ + inspect

library/test/listener.factor

@@ -1,11 +0,0 @@
-IN: temporary
-USE: namespaces
-USE: io
-USE: test
-USE: parser
-
-[
-    [ 4 ] [ "2 2 +" eval-catch ] unit-test
-    "The following will print an error; ignore it." print terpri
-    [ ] [ "clear drop" eval-catch ] unit-test
-] with-scope

library/test/lists/queues.factor

@@ -1,7 +1,12 @@
 IN: temporary
-USING: kernel lists math sequences test ;
+USING: kernel math namespaces queues sequences test ;
 
-[ { 1 2 3 4 5 } ] [
-    <queue> [ 1 2 3 4 5 ] [ swap enque ] each
-    5 [ drop deque swap ] map nip
-] unit-test
+<queue> "queue" set
+
+[ t ] [ "queue" get queue-empty? ] unit-test
+
+[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test
+
+[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test
+
+[ "queue" get deque ] unit-test-fails

library/test/parser.factor

@@ -69,8 +69,4 @@ unit-test
 ! Test EOL comments in multiline strings.
 [ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test 
 
-[ 4 ] [ "2 2 +" eval-catch ] unit-test
-[ "4\n" ] [ "2 2 + ." eval>string ] unit-test
-[ ] [ "fdafdf" eval-catch ] unit-test
-
 [ word ] [ \ f class ] unit-test

library/test/test.factor

@@ -80,7 +80,7 @@ SYMBOL: failures
         "continuations" "errors" "hashtables" "strings"
         "namespaces" "generic" "tuple" "files" "parser"
         "parse-number" "init" "io/io"
-        "listener" "vectors" "words" "prettyprint" "random"
+        "vectors" "words" "prettyprint" "random"
         "stream" "math/bitops"
         "math/math-combinators" "math/rational" "math/float"
         "math/complex" "math/irrational" "math/integer"

library/threads.factor

@@ -2,32 +2,48 @@
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: threads
-USING: errors kernel kernel-internals lists namespaces ;
- 
-! Core of the multitasker. Used by io-internals.factor and
-! in-thread.factor.
+USING: errors hashtables io-internals kernel lists math
+namespaces queues sequences vectors ;
 
-: run-queue ( -- queue ) 9 getenv ;
-: set-run-queue ( queue -- ) 9 setenv ;
-: init-threads ( -- ) <queue> set-run-queue ;
+! Co-operative multitasker.
+
+: run-queue ( -- queue ) \ run-queue global hash ;
+
+: schedule-thread ( quot -- ) run-queue enque ;
+
+: sleep-queue ( -- vec ) \ sleep-queue global hash ;
+
+: sleep-queue* ( -- vec )
+    sleep-queue dup [ 2car swap - ] nsort ;
+
+: sleep-time ( sorted-queue -- ms )
+    dup empty? [ drop -1 ] [ peek car millis - 0 max ] ifte ;
+
+DEFER: next-thread
+
+: do-sleep ( -- quot )
+    sleep-queue* dup sleep-time dup 0 =
+    [ drop pop ] [ io-multiplex next-thread ] ifte ;
 
 : next-thread ( -- quot )
-    run-queue dup queue-empty? [
-        drop f
-    ] [
-        deque set-run-queue
-    ] ifte ;
+    run-queue dup queue-empty? [ drop do-sleep ] [ deque ] ifte ;
 
-: schedule-thread ( quot -- )
-    run-queue enque set-run-queue ;
+: stop ( -- ) next-thread call ;
 
-: stop ( -- )
-    #! Stop the current thread and begin executing the next one.
-    next-thread [ call ] [ "No more tasks" throw ] ifte* ;
+: yield ( -- ) [ schedule-thread stop ] callcc0 ;
 
-: yield ( -- )
-    #! Add the current continuation to the run queue, and yield
-    #! to the next quotation. The current continuation will
-    #! eventually be restored by a future call to stop or
-    #! yield.
-    [ schedule-thread stop ] callcc0 ;
+: sleep ( ms -- )
+    millis + [ cons sleep-queue push stop ] callcc0 drop ;
+
+: in-thread ( quot -- )
+    [
+        schedule-thread
+        [ ] set-catchstack { } set-callstack
+        try stop
+    ] callcc0 drop ;
+
+: init-threads ( -- )
+    global [
+        <queue> \ run-queue set
+        10 <vector> \ sleep-queue set
+    ] bind ;

library/tools/annotations.factor

@@ -10,7 +10,7 @@ USING: interpreter io kernel lists namespaces prettyprint
 sequences strings test ;
 
 : annotate ( word quot -- | quot: word def -- def )
-    over >r >r dup word-def r> call r> swap (define-compound) ;
+    over >r >r dup word-def r> call r> swap define-compound ;
     inline
 
 : (watch) ( word def -- def )

library/tools/inspector.factor

@@ -28,8 +28,11 @@ M: hashtable sheet dup hash-keys swap hash-values 2vector ;
     [ max-length ] keep
     [ swap CHAR: \s pad-right ] map-with ;
 
+: sheet-numbers ( sheet -- sheet )
+    dup first length >vector 1vector swap append ;
+
 : format-sheet ( sheet -- list )
-    dup first length >vector swons
+    sheet-numbers
     dup peek over first [ set ] 2each
     [ format-column ] map
     flip

library/tools/jedit.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: jedit
-USING: io kernel lists namespaces parser prettyprint sequences
-strings unparser vectors words ;
+USING: errors io kernel lists namespaces parser prettyprint
+sequences strings unparser vectors words ;
 
 ! Some words to send requests to a running jEdit instance to
 ! edit files and position the cursor on a specific line number.
@@ -63,6 +63,9 @@ strings unparser vectors words ;
 
 : read-packet ( -- string ) 4 read be> read ;
 
+: eval>string ( str -- )
+    [ [ [ eval ] keep ] try drop ] string-out ;
+
 : wire-server ( -- )
     #! Repeatedly read jEdit requests and execute them. Return
     #! on EOF.

library/unix/io.factor

@@ -300,10 +300,6 @@ M: port stream-close ( stream -- )
 : <fd-stream> ( infd outfd flush? -- stream )
     >r >r <reader> r> <writer> r> <duplex-stream> ;
 
-: idle-io-task ( -- )
-    [ schedule-thread 10 io-multiplex stop ] callcc0
-    idle-io-task ;
-
 USE: io
 
 : init-io ( -- )
@@ -315,5 +311,4 @@ USE: io
         <namespace> write-tasks set
         FD_SETSIZE <bit-array> write-fdset set
         0 1 t <fd-stream> stdio set
-    ] bind
-    [ idle-io-task ] in-thread ;
+    ] bind ;

library/vocabularies.factor

@@ -85,10 +85,10 @@ SYMBOL: vocabularies
 : init-search-path ( -- )
     "scratchpad" "in" set
     [
-        "compiler" "errors" "gadgets" "generic"
-        "hashtables" "help" "inference" "inspector" "interpreter"
+        "compiler" "errors" "gadgets" "generic" "hashtables"
+        "help" "inference" "inspector" "interpreter" "io"
         "jedit" "kernel" "listener" "lists" "math" "matrices"
-        "memory" "namespaces" "parser" "prettyprint"
-        "sequences" "io" "strings" "styles" "syntax" "test"
-        "threads" "vectors" "words" "scratchpad"
+        "memory" "namespaces" "parser" "prettyprint" "queues"
+        "scratchpad" "sequences" "strings" "styles" "syntax"
+        "test" "threads" "vectors" "words"
     ] "use" set ;

library/words.factor

@@ -111,18 +111,18 @@ M: symbol definer drop \ SYMBOL: ;
 PREDICATE: word compound  ( obj -- ? ) word-primitive 1 = ;
 M: compound definer drop \ : ;
 
-: (define-compound) ( word def -- )
+: define-compound ( word def -- )
     >r dup dup remove-crossref r> 1 swap define add-crossref ;
 
 : reset-props ( word seq -- )
     [ f swap set-word-prop ] each-with ;
 
-: reset-generic ( word -- )
-    #! Make a word no longer be generic.
-    { "methods" "combination" } reset-props ;
+: reset-word ( word -- )
+    { "parsing" "inline" "foldable" "flushable" "predicating" }
+    reset-props ;
 
-: define-compound ( word def -- )
-     over reset-generic (define-compound) ;
+: reset-generic ( word -- )
+    dup reset-word { "methods" "combination" } reset-props ;
 
 GENERIC: literalize ( obj -- obj )
 

native/run.h

@@ -8,7 +8,7 @@
 #define CATCHSTACK_ENV 6 /* used by library only */
 #define CPU_ENV        7
 #define BOOT_ENV       8
-#define RUNQUEUE_ENV   9 /* used by library only */
+#define UNUSED_ENV     9
 #define ARGS_ENV       10
 #define OS_ENV         11
 #define ERROR_ENV      12 /* a marker consed onto kernel errors */