stepping over a word

TODO.FACTOR.txt

@@ -14,7 +14,6 @@
 + linearizer/generator:
 
 - peephole optimizer
-- tail call optimization
 - getenv/setenv: if literal arg, compile as a load/store
 - compiler: drop literal peephole optimization
 
@@ -35,7 +34,6 @@
 
 + ffi:
 
-- port ffi to new compiler
 - is signed -vs- unsigned pointers an issue?
 - bitfields in C structs
 - SDL_Rect** type
@@ -68,7 +66,6 @@
 
 + misc:
 
-- some way to step over a word in the stepper
 - step: print NEXT word to execute, not word that JUST executed
 - perhaps /i should work with all numbers
 - unit test weirdness: 2 lines appears at end

examples/factoroids.factor

@@ -4,7 +4,6 @@
 !
 ! ./f factor.image -libraries:sdl=libSDL.so -libraries:sdl-gfx=libSDL_gfx.so
 !
-! "examples/oop.factor" run-file
 ! "examples/factoroids.factor" run-file
 
 IN: factoroids
@@ -16,7 +15,7 @@ USE: lists
 USE: logic
 USE: math
 USE: namespaces
-USE: oop
+USE: generic
 USE: random
 USE: sdl
 USE: sdl-event
@@ -116,18 +115,18 @@ M: ship draw ( actor -- )
     [
         surface get screen-xy radius get color get
         filledCircleColor
-    ] bind ;M
+    ] bind ;
 
-M: ship tick ( actor -- ? ) dup [ move ] bind active? ;M
+M: ship tick ( actor -- ? ) dup [ move ] bind active? ;
 
-: make-ship ( -- ship )
-    <ship> [
+C: ship ( -- ship )
+    [
         width get 2 /i  height get 50 - rect> position set
         white color set
         10 radius set
         0 velocity set
         active on
-    ] extend unit ;
+    ] extend ;
 
 ! Projectiles
 TRAITS: plasma
@@ -135,17 +134,17 @@ M: plasma draw ( actor -- )
     [
         surface get screen-xy dup len get + color get
         vlineColor
-    ] bind ;M
+    ] bind ;
 
 M: plasma tick ( actor -- ? )
-    dup [ move ] bind dup in-screen? swap active? and ;M
+    dup [ move ] bind dup in-screen? swap active? and ;
 
 M: plasma collide ( actor1 actor2 -- )
     #! Remove the other actor.
-    deactivate deactivate ;M
+    deactivate deactivate ;
 
-: make-plasma ( actor dy -- plasma )
-    <plasma> [
+C: plasma ( actor dy -- plasma )
+    [
         velocity set
         actor-xy
         blue color set
@@ -157,17 +156,17 @@ M: plasma collide ( actor1 actor2 -- )
 : player-fire ( -- )
     #! Do nothing if player is dead.
     player-actor [
-        #{ 0 -6 } make-plasma player-shots cons@
+        #{ 0 -6 } <plasma> player-shots cons@
     ] when* ;
 
 : enemy-fire ( actor -- )
-    #{ 0 5 } make-plasma enemy-shots cons@ ;
+    #{ 0 5 } <plasma> enemy-shots cons@ ;
 
 ! Background of stars
 TRAITS: particle
 
 M: particle draw ( actor -- )
-    [ surface get screen-xy color get pixelColor ] bind ;M
+    [ surface get screen-xy color get pixelColor ] bind ;
 
 : wrap ( -- )
     #! If current actor has gone beyond screen bounds, move it
@@ -178,7 +177,9 @@ M: particle draw ( actor -- )
     rect> position set ;
 
 M: particle tick ( actor -- )
-    [ move wrap t ] bind ;M
+    [ move wrap t ] bind ;
+
+C: particle ;
 
 SYMBOL: stars
 : star-count 100 ;
@@ -216,7 +217,7 @@ M: enemy draw ( actor -- )
     [
         surface get screen-xy radius get color get
         filledCircleColor
-    ] bind ;M
+    ] bind ;
 
 : attack-chance 30 ;
 
@@ -239,7 +240,9 @@ SYMBOL: wiggle-x
 M: enemy tick ( actor -- )
     dup attack
     dup [ wiggle move position get imaginary ] bind
-    y-in-screen? swap active? and ;M
+    y-in-screen? swap active? and ;
+
+C: enemy ;
 
 : spawn-enemy ( -- )
     <enemy> [
@@ -289,7 +292,7 @@ SYMBOL: event
 : init-game ( -- )
     #! Init game objects.
     init-stars
-    make-ship player set
+    <ship> unit player set
     <event> event set ;
 
 : each-layer ( quot -- )

examples/mandel.factor

@@ -8,7 +8,7 @@
 ! "examples/mandel.factor" run-file
 
 IN: mandel
-
+USE: compiler
 USE: alien
 USE: errors
 USE: kernel
@@ -43,14 +43,14 @@ USE: test
         ] times*
     ] make-list list>vector nip ;
 
-: absq >rect swap sq swap sq + ;
+: absq >rect swap sq swap sq + ; inline
 
 : iter ( c z nb-iter -- x )
     over absq 4 >= over 0 = or [
         nip nip
     ] [
         pred >r sq dupd + r> iter
-    ] ifte ;
+    ] ifte ; compiled
 
 : max-color 360 ;
 
@@ -71,7 +71,7 @@ SYMBOL: center
     x-inc get * center get real x-inc get width get 2 / * - + >float
     r>
     y-inc get * center get imaginary y-inc get height get 2 / * - + >float
-    rect> ;
+    rect> ; compiled
 
 : render ( -- )
     init-mandel

library/bootstrap/boot-stage2.factor

@@ -34,7 +34,12 @@ USE: stdio
 "Cold boot in progress..." print
 
 [
-    "/version.factor"
+    "/library/generic/generic.factor"
+    "/library/generic/object.factor"
+    "/library/generic/builtin.factor"
+    "/library/generic/predicate.factor"
+    "/library/generic/traits.factor"
+
     "/version.factor"
     "/library/stack.factor"
     "/library/combinators.factor"
@@ -57,11 +62,6 @@ USE: stdio
     "/library/errors.factor"
     "/library/continuations.factor"
     "/library/threads.factor"
-    "/library/generic/generic.factor"
-    "/library/generic/object.factor"
-    "/library/generic/builtin.factor"
-    "/library/generic/predicate.factor"
-    "/library/generic/traits.factor"
     "/library/io/stream.factor"
     "/library/io/stdio.factor"
     "/library/io/io-internals.factor"
@@ -71,7 +71,7 @@ USE: stdio
     "/library/syntax/parser.factor"
     "/library/syntax/parse-stream.factor"
     "/library/bootstrap/init.factor"
-    "/library/syntax/parse-syntax.factor"
+!    "/library/syntax/parse-syntax.factor"
 
     "/library/format.factor"
     "/library/syntax/unparser.factor"

library/bootstrap/init-stage2.factor

@@ -25,12 +25,12 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: init
+IN: kernel
 USE: ansi
 USE: compiler
 USE: errors
 USE: inference
-USE: kernel
+USE: command-line
 USE: listener
 USE: lists
 USE: math
@@ -75,7 +75,7 @@ USE: unparser
     warm-boot
     garbage-collection
     "interactive" get [ print-banner listener ] when
-    0 exit*
+    0 exit* 
 ] set-boot
 
 init-error-handler

library/bootstrap/init.factor

@@ -25,8 +25,7 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: init
-USE: kernel
+IN: kernel
 USE: namespaces
 USE: parser
 USE: stdio

library/cli.factor

@@ -25,7 +25,7 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: init
+IN: command-line
 USE: compiler
 USE: errors
 USE: files

library/compiler/compiler.factor

@@ -41,7 +41,16 @@ USE: unparser
 USE: vectors
 USE: words
 
+: supported-cpu? ( -- ? )
+    cpu "unknown" = not ;
+
+: check-architecture ( -- )
+    supported-cpu? [
+        "Unsupported CPU; compiler disabled" throw
+    ] unless ;
+
 : compiling ( word -- definition )
+    check-architecture
     "verbose-compile" get [
         "Compiling " write dup . flush
     ] when
@@ -67,7 +76,7 @@ USE: words
 
 : compiled ( -- )
     #! Compile the most recently defined word.
-    word compile ; parsing
+    "compile" get [ word compile ] when ; parsing
 
 : cannot-compile ( word -- )
     "verbose-compile" get [
@@ -81,10 +90,4 @@ USE: words
 
 : compile-all ( -- )
     #! Compile all words.
-    [
-       ! dup "infer-effect" word-property [
-            try-compile
-       ! ] [
-       !     drop
-       ! ] ifte
-    ] each-word ;
+    [ try-compile ] each-word ;

library/hashtables.factor

@@ -61,13 +61,20 @@ PREDICATE: vector hashtable ( obj -- ? )
     #! undefined value, or a value set to f.
     hash* dup [ cdr ] when ;
 
-: set-hash ( value key table -- )
+: set-hash* ( key table quot -- )
+    #! Apply the quotation to yield a new association list.
+    over >r -rot dupd (hashcode) r> vector-nth swap call ;
+    inline
+    
+! : set-hash ( value key table -- )
     #! Store the value in the hashtable. Either replaces an
     #! existing value in the appropriate bucket, or adds a new
-    #! key/value pair,
-    dup >r 2dup (hashcode) dup >r swap
-    vector-nth set-assoc
-    r> r> set-vector-nth ;
+    #! key/value pair.
+!    [ set-assoc ] set-hash* ;
+
+: remove-hash ( key table -- )
+    #! Remove a value from a hashtable.
+    [ remove-assoc ] set-hash* ;
 
 : hash-each ( hash code -- )
     #! Apply the code to each key/value pair of the hashtable.

library/test/benchmark/sort.factor

@@ -4,5 +4,9 @@ USE: kernel
 USE: math
 USE: random
 USE: test
+USE: compiler
 
-[ ] [ [ 100000 [ 0 10000 random-int , ] times ] make-list [ > ] sort drop ] unit-test
+: sort-benchmark
+    [ 100000 [ 0 10000 random-int , ] times ] make-list [ > ] sort drop ; compiled
+
+[ ] [ sort-benchmark ] unit-test

library/test/hashtables.factor

@@ -46,3 +46,15 @@ f 100 fac "testhash" get set-hash
 [ t ] [ #{ 2 3 } "testhash" get hash ] unit-test
 [ f ] [ 100 fac "testhash" get hash* cdr ] unit-test
 [ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test
+
+[
+    [ "salmon" | "fish" ]
+    [ "crocodile" | "reptile" ]
+    [ "cow" | "mammal" ]
+    [ "visual basic" | "language" ]
+] alist>hash "testhash" set
+
+[ f ] [
+    "visual basic" "testhash" get remove-hash
+    "visual basic" "testhash" get hash*
+] unit-test

library/test/init.factor

@@ -1,5 +1,5 @@
 IN: scratchpad
-USE: init
+USE: command-line
 USE: namespaces
 USE: test
 

library/tools/interpreter.factor

@@ -106,6 +106,16 @@ SYMBOL: meta-cf
 : do ( obj -- )
     dup word? [ meta-word ] [ push-d ] ifte ;
 
+: meta-word-1 ( word -- )
+    dup "meta-word" word-property dup [
+        nip call
+    ] [
+        drop host-word
+    ] ifte ;
+
+: do-1 ( obj -- )
+    dup word? [ meta-word-1 ] [ push-d ] ifte ;
+
 : (interpret) ( quot -- )
     #! The quotation is called with each word as its executed.
     done? [ drop ] [ [ next swap call ] keep (interpret) ] ifte ;
@@ -182,6 +192,10 @@ SYMBOL: meta-cf
     done? [ "Stepper is done." print drop ] [ call ] ifte ;
 
 : step
+    #! Step into current word.
+    [ next dup report do-1 ] not-done ;
+
+: into
     #! Step into current word.
     [ next dup report do ] not-done ;
 
@@ -191,7 +205,8 @@ SYMBOL: meta-cf
     "show stepper stacks." print
     \ &get prettyprint-1
     " ( var -- value ) inspects the stepper namestack." print
-    \ step prettyprint-1 " -- single step" print
+    \ step prettyprint-1 " -- single step over" print
+    \ into prettyprint-1 " -- single step into" print
     \ (trace) prettyprint-1 " -- trace until end" print
     \ (run) prettyprint-1 " -- run until end" print
     \ exit prettyprint-1 " -- exit single-stepper" print ;