Merge branch 'master' of git://factorcode.org/git/factor

core/inference/class/class-tests.factor

@@ -283,3 +283,8 @@ cell-bits 32 = [
     [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
     \ number= inlined?
 ] unit-test
+
+[ t ] [
+    [ HEX: ff bitand 0 HEX: ff between? ]
+    \ >= inlined?
+] unit-test

extra/benchmark/sockets/sockets.factor

@@ -23,10 +23,9 @@ IN: benchmark.sockets
     ] with-stream ;
 
 : clients ( n -- )
-    dup pprint " clients: " write
+    dup pprint " clients: " write [
-        [
         [ simple-server ] in-thread
-        100 sleep
+        yield yield
         [ drop simple-client ] parallel-each
         stop-server
         yield yield

extra/builder/builder.factor

@@ -1,11 +1,7 @@
 
-USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
+USING: kernel namespaces sequences splitting system combinators continuations
-       arrays system continuations namespaces sequences splitting math.parser
+       parser io io.files io.launcher io.sockets prettyprint threads
-       prettyprint tools.time calendar bake vars http.client
+       bootstrap.image benchmark vars bake smtp builder.util accessors ;
-       combinators bootstrap.image bootstrap.image.download
-       combinators.cleave benchmark
-       classes strings quotations words parser-combinators new-slots accessors
-       assocs.lib smtp builder.util ;
 
 IN: builder
 

extra/builder/util/util.factor

@@ -3,8 +3,8 @@ USING: kernel words namespaces classes parser continuations
        io io.files io.launcher io.sockets
        math math.parser
        combinators sequences splitting quotations arrays strings tools.time
-       parser-combinators accessors assocs.lib
+       parser-combinators new-slots accessors assocs.lib
-       combinators.cleave bake calendar new-slots ;
+       combinators.cleave bake calendar  ;
 
 IN: builder.util
 

extra/channels/examples/examples.factor

@@ -24,7 +24,7 @@ IN: channels.examples
         from swap dupd mod zero? not [ swap to ] [ 2drop ] if     
     ] 3keep filter ;
 
-:: (sieve) | prime c |
+:: (sieve) | prime c | ( prime c -- )
     [let | p [ c from ] 
            newc [ <channel> ] |
         p prime to

extra/concurrency/concurrency.factor

@@ -145,12 +145,12 @@ M: process send ( message process -- )
 
 : receive ( -- message )
     self process-mailbox mailbox-get dup linked-exception? [
-        linked-exception-error throw
+        linked-exception-error rethrow
     ] when ;
 
 : receive-if ( pred -- message )
     self process-mailbox mailbox-get? dup linked-exception? [
-        linked-exception-error throw
+        linked-exception-error rethrow
     ] when ; inline
 
 : rethrow-linked ( error -- )
@@ -285,7 +285,7 @@ TUPLE: future value processes ;
     #! place the result on the stack. Return the result
     #! immediately if the future has completed.
     dup future-value [
-        first2 [ throw ] unless
+        first2 [ rethrow ] unless
     ] [
         dup [ future-processes push stop ] curry callcc0 ?future
     ] ?if ;

extra/cpu/8080/8080.factor

@@ -249,32 +249,3 @@ INSTRUCTION: EI           ; opcode FB cycles 04
 INSTRUCTION: CALL M,nn    ; opcode FC cycles 11 
 INSTRUCTION: CP   n       ; opcode FE cycles 07 
 INSTRUCTION: RST  38H     ; opcode FF cycles 11 
-
-! : each-8bit ( n quot -- )
-!   8 [ ! n quot bit
-!    pick over -1 * shift 1 bitand pick call 
-!   ] repeat 2drop ;
-! 
-! : >ppm ( cpu filename -- cpu )
-!   #! Dump the current screen image to a ppm image file with the given name.
-!   <file-writer> [
-!     "P3" print
-!     "256 224" print
-!     "1" print
-!     224 [
-!       32 [
-!         over 32 * over +  HEX: 2400 + ! cpu h w addr
-!         >r pick r> swap cpu-ram nth [
-!           0 = [
-!             " 0 0 0" write
-!           ] [
-!             " 1 1 1" write
-!           ] if
-!         ] each-8bit
-!       ] repeat nl
-!     ] repeat
-!   ] with-stream ;
-
-: time-test ( -- )
-  test-cpu [ 1000000 run-n ] time ;
-

extra/cpu/8080/emulator/emulator.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel math sequences words arrays io 
+USING: kernel math sequences words arrays io io.files namespaces
-       io.files namespaces math.parser kernel.private
+math.parser assocs quotations parser parser-combinators
-       assocs quotations parser parser-combinators tools.time
+tools.time ;
-       sequences.private compiler.units ;
 IN: cpu.8080.emulator
 
 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@@ -396,39 +395,18 @@ M: cpu write-port ( value port cpu -- )
 : instruction-cycles ( -- vector )
   #! Return a 256 element vector containing the cycles for
   #! each opcode in the 8080 instruction set.
-  { 
+  << 256 f <array> parsed >> ;
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
-
-: instructions ( -- vector )
-  #! Return a 256 element vector containing the emulation words for
-  #! each opcode in the 8080 instruction set.
-  { 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; 
 
 : not-implemented ( <cpu> -- )
   drop ;
 
-instructions length [ 
+: instructions ( -- vector )
-  dup instructions nth [
+  #! Return a 256 element vector containing the emulation words for
-    drop
+  #! each opcode in the 8080 instruction set.
-  ] [
+  << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
-    [ not-implemented ] swap instructions set-nth 
+
-  ] if
+: set-instruction ( quot n -- )
-] each
+  tuck >r 2array r> instructions set-nth ;
 
 M: cpu reset ( cpu -- )
   #! Reset the CPU to its poweron state
@@ -517,15 +495,6 @@ SYMBOL: rom-root
     ] if     
   ] if ;
 
-: step ( cpu -- )
-  #! Run a single 8080 instruction
-  [ read-instruction ] keep ! n cpu
-  over get-cycles over inc-cycles
-  [ swap instructions dispatch ] keep
-  [ cpu-pc HEX: FFFF bitand ] keep 
-  [ set-cpu-pc ] keep 
-  process-interrupts ;
-
 : peek-instruction ( cpu -- word )
   #! Return the next instruction from the cpu's program
   #! counter, but don't increment the counter.
@@ -560,18 +529,6 @@ SYMBOL: rom-root
   [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep 
   nl drop ;
 
-: test-step ( cpu -- cpu )
-  [ step ] keep dup cpu. ;
-
-: test-cpu ( -- cpu )
-  <cpu> "invaders.rom" over load-rom dup cpu. ;
-
-: test-n ( n -- )
-  test-cpu swap [ test-step ] times ;
-
-: run-n ( cpu n -- cpu )
-  [ dup step ] times ;
-
 : register-lookup ( string -- vector )
   #! Given a string containing a register name, return a vector
   #! where the 1st item is the getter and the 2nd is the setter
@@ -1337,11 +1294,9 @@ SYMBOL: last-opcode
   #! Process the list of strings, which should make
   #! up an 8080 instruction, and output a quotation
   #! that would implement that instruction.
-  [
+  dup " " join instruction-quotations
-    dup " " join instruction-quotations
+  >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at  
-    >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at  
+  r> define ;
-    r> define
-  ] with-compilation-unit ;
 
 : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
 
@@ -1352,5 +1307,5 @@ SYMBOL: last-opcode
 : opcode ( -- )
   #! Set the opcode number for the last instruction that was defined.
   last-instruction global at 1quotation scan 16 base>
-  dup last-opcode global set-at instructions set-nth ; parsing
+  dup last-opcode global set-at set-instruction ; parsing
 

extra/cpu/8080/test/test.factor

@@ -0,0 +1,51 @@
+USING: kernel cpu.8080 cpu.8080.emulator math math io
+tools.time combinators sequences io.files ;
+IN: cpu.8080.test
+
+: step ( cpu -- )
+  #! Run a single 8080 instruction
+  [ read-instruction ] keep ! n cpu
+  over get-cycles over inc-cycles
+  [ swap instructions case ] keep
+  [ cpu-pc HEX: FFFF bitand ] keep 
+  [ set-cpu-pc ] keep 
+  process-interrupts ;
+
+
+: test-step ( cpu -- cpu )
+  [ step ] keep dup cpu. ;
+
+: test-cpu ( -- cpu )
+  <cpu> "invaders.rom" over load-rom dup cpu. ;
+
+: test-n ( n -- )
+  test-cpu swap [ test-step ] times drop ;
+
+: run-n ( cpu n -- cpu )
+  [ dup step ] times ;
+
+: each-8bit ( n quot -- )
+  8 -rot [ >r bit? r> call ] 2curry each ; inline
+
+: >ppm ( cpu filename -- cpu )
+  #! Dump the current screen image to a ppm image file with the given name.
+  <file-writer> [
+    "P3" print
+    "256 224" print
+    "1" print
+    224 [
+      32 [
+        over 32 * over +  HEX: 2400 + ! cpu h w addr
+        >r pick r> swap cpu-ram nth [
+          0 = [
+            " 0 0 0" write
+          ] [
+            " 1 1 1" write
+          ] if
+        ] each-8bit drop
+      ] each drop nl
+    ] each
+  ] with-stream ;
+
+: time-test ( -- )
+  test-cpu [ 1000000 run-n drop ] time ;

extra/db/mysql/mysql.factor

@@ -26,12 +26,6 @@ M: mysql-statement prepare-statement ( statement -- )
 M: mysql-statement bind-statement* ( statement -- )
     ;
 
-M: mysql-statement rebind-statement ( statement -- )
-    ;
-
-M: mysql-statement execute-statement ( statement -- )
-    ;
-
 M: mysql-statement query-results ( query -- result-set )
     ;
 

extra/space-invaders/space-invaders.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel
+USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
-       shuffle arrays io.files combinators kernel.private
+sequences kernel shuffle arrays io.files combinators ui.gestures
-       ui.gestures ui.gadgets ui.render opengl.gl system 
+ui.gadgets ui.render opengl.gl system threads concurrency match
-       threads concurrency match ui byte-arrays combinators.lib
+ui byte-arrays combinators.lib ;
-       sequences.private ;
 IN: space-invaders
 
 TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
@@ -191,7 +190,7 @@ M: space-invaders reset ( cpu -- )
 : gui-step ( cpu -- )
   [ read-instruction ] keep ! n cpu
   over get-cycles over inc-cycles
-  [ swap instructions dispatch ] keep  
+  [ swap instructions case ] keep  
   [ cpu-pc HEX: FFFF bitand ] keep 
   set-cpu-pc ;
 
@@ -345,11 +344,13 @@ M: space-invaders update-video ( value addr cpu -- )
   #! concurrent process. Messages can be sent to
   #! signal key presses, etc.
   dup invaders-gadget-quit? [
+    2drop
+  ] [
     [ sync-frame ] dip
     [ invaders-gadget-cpu gui-frame ] keep
     [ relayout-1 ] keep
     invaders-process 
-  ] unless ;
+  ] if ;
 
 M: invaders-gadget graft* ( gadget -- )
  dup invaders-gadget-cpu init-sounds