eliminate library/primitives.factor

diff --git a/Makefile b/Makefile
index f0f5ea296b69eb69d7aa52af69651d3541c86fb9..d44483531a906cd137e2fb0cf2d661a34e0615a4 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -23,7 +23,7 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \
        native/ffi.o native/boolean.o \
        native/debug.o \
        native/hashtable.o \
-       native/walk.o
+       native/scan.o
 
 default:
        @echo "Run 'make' with one of the following parameters:"

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index feeb8bb1d182eb570d319f5ae3a155834fc3ba1f..6c4a2b9f9f536af26b2e330d95da9750a09df5b6 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -23,7 +23,6 @@
 - begin-scan, next-object, end-scan primitives\r
 - each-object, each-slot combinators\r
 - references primitive\r
-- ditch % for tuples?\r
 - resize window: world not updated until mouse moved\r
 - x>offset\r
 - fix completion invoke in middle of word\r

diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java
index 7337f04cb53d7d60ed0256c8fbfd1af38188dc17..7b3fe84d2203c7142b1f66a185d98e394ad88b90 100644 (file)
--- a/factor/jedit/FactorPlugin.java
+++ b/factor/jedit/FactorPlugin.java
@@ -130,6 +130,10 @@ public class FactorPlugin extends EditPlugin
                                        .getParentOfPath(imagePath)));
 
                                external = new ExternalFactor(PORT);
+
+                               process.getOutputStream().close();
+                               process.getInputStream().close();
+                               process.getErrorStream().close();
                        }
                        catch(Exception e)
                        {

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index e8827dbe132987c1f40be50e1c01a1cd3cd7072e..8fd5920415319b68ebeb74f2d22aa1fe89bdd3af 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -93,9 +93,6 @@ IN: alien : add-library 3drop ;
         "/library/tools/profiler.factor"\r
         "/library/tools/interpreter.factor"\r
     \r
-        ! Inference needs to know primitive stack effects at load time\r
-        "/library/primitives.factor"\r
-    \r
         "/library/inference/dataflow.factor"\r
         "/library/inference/inference.factor"\r
         "/library/inference/branches.factor"\r

diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 9030f3d3274275f3826bddd4c6ca342befec3471..a7c15b730f6839d04648080123d080b98f0595f8 100644 (file)
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -2,7 +2,10 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: image
 USING: kernel lists math memory namespaces parser words vectors
-hashtables generic ;
+hashtables generic alien assembler compiler errors files generic
+io-internals kernel kernel-internals lists math math-internals
+parser profiler random strings unparser vectors words
+hashtables ;
 
 ! Bring up a bare cross-compiling vocabulary.
 "syntax" vocab
@@ -22,182 +25,190 @@ vocabularies get [
 <namespace> classes set
 
 2 [
-    [[ "words" "execute" ]]
-    [[ "kernel" "call" ]]
-    [[ "kernel" "ifte" ]]
-    [[ "lists" "cons" ]]
-    [[ "vectors" "<vector>" ]]
-    [[ "strings" "str-nth" ]]
-    [[ "strings" "str-compare" ]]
-    [[ "strings" "str=" ]]
-    [[ "strings" "index-of*" ]]
-    [[ "strings" "substring" ]]
-    [[ "strings" "str-reverse" ]]
-    [[ "strings" "<sbuf>" ]]
-    [[ "strings" "sbuf-length" ]]
-    [[ "strings" "set-sbuf-length" ]]
-    [[ "strings" "sbuf-nth" ]]
-    [[ "strings" "set-sbuf-nth" ]]
-    [[ "strings" "sbuf-append" ]]
-    [[ "strings" "sbuf>str" ]]
-    [[ "strings" "sbuf-reverse" ]]
-    [[ "strings" "sbuf-clone" ]]
-    [[ "strings" "sbuf=" ]]
-    [[ "strings" "sbuf-hashcode" ]]
-    [[ "math-internals" "arithmetic-type" ]]
-    [[ "math" ">fixnum" ]]
-    [[ "math" ">bignum" ]]
-    [[ "math" ">float" ]]
-    [[ "math-internals" "(fraction>)" ]]
-    [[ "parser" "str>float" ]]
-    [[ "unparser" "(unparse-float)" ]]
-    [[ "math-internals" "<complex>" ]]
-    [[ "math-internals" "fixnum=" ]]
-    [[ "math-internals" "fixnum+" ]]
-    [[ "math-internals" "fixnum-" ]]
-    [[ "math-internals" "fixnum*" ]]
-    [[ "math-internals" "fixnum/i" ]]
-    [[ "math-internals" "fixnum/f" ]]
-    [[ "math-internals" "fixnum-mod" ]]
-    [[ "math-internals" "fixnum/mod" ]]
-    [[ "math-internals" "fixnum-bitand" ]]
-    [[ "math-internals" "fixnum-bitor" ]]
-    [[ "math-internals" "fixnum-bitxor" ]]
-    [[ "math-internals" "fixnum-bitnot" ]]
-    [[ "math-internals" "fixnum-shift" ]]
-    [[ "math-internals" "fixnum<" ]]
-    [[ "math-internals" "fixnum<=" ]]
-    [[ "math-internals" "fixnum>" ]]
-    [[ "math-internals" "fixnum>=" ]]
-    [[ "math-internals" "bignum=" ]]
-    [[ "math-internals" "bignum+" ]]
-    [[ "math-internals" "bignum-" ]]
-    [[ "math-internals" "bignum*" ]]
-    [[ "math-internals" "bignum/i" ]]
-    [[ "math-internals" "bignum/f" ]]
-    [[ "math-internals" "bignum-mod" ]]
-    [[ "math-internals" "bignum/mod" ]]
-    [[ "math-internals" "bignum-bitand" ]]
-    [[ "math-internals" "bignum-bitor" ]]
-    [[ "math-internals" "bignum-bitxor" ]]
-    [[ "math-internals" "bignum-bitnot" ]]
-    [[ "math-internals" "bignum-shift" ]]
-    [[ "math-internals" "bignum<" ]]
-    [[ "math-internals" "bignum<=" ]]
-    [[ "math-internals" "bignum>" ]]
-    [[ "math-internals" "bignum>=" ]]
-    [[ "math-internals" "float=" ]]
-    [[ "math-internals" "float+" ]]
-    [[ "math-internals" "float-" ]]
-    [[ "math-internals" "float*" ]]
-    [[ "math-internals" "float/f" ]]
-    [[ "math-internals" "float<" ]]
-    [[ "math-internals" "float<=" ]]
-    [[ "math-internals" "float>" ]]
-    [[ "math-internals" "float>=" ]]
-    [[ "math-internals" "facos" ]]
-    [[ "math-internals" "fasin" ]]
-    [[ "math-internals" "fatan" ]]
-    [[ "math-internals" "fatan2" ]]
-    [[ "math-internals" "fcos" ]]
-    [[ "math-internals" "fexp" ]]
-    [[ "math-internals" "fcosh" ]]
-    [[ "math-internals" "flog" ]]
-    [[ "math-internals" "fpow" ]]
-    [[ "math-internals" "fsin" ]]
-    [[ "math-internals" "fsinh" ]]
-    [[ "math-internals" "fsqrt" ]]
-    [[ "words" "<word>" ]]
-    [[ "words" "update-xt" ]]
-    [[ "profiler" "call-profiling" ]]
-    [[ "profiler" "allot-profiling" ]]
-    [[ "words" "compiled?" ]]
-    [[ "kernel" "drop" ]]
-    [[ "kernel" "dup" ]]
-    [[ "kernel" "swap" ]]
-    [[ "kernel" "over" ]]
-    [[ "kernel" "pick" ]]
-    [[ "kernel" ">r" ]]
-    [[ "kernel" "r>" ]]
-    [[ "kernel" "eq?" ]]
-    [[ "kernel-internals" "getenv" ]]
-    [[ "kernel-internals" "setenv" ]]
-    [[ "io-internals" "open-file" ]]
-    [[ "files" "stat" ]]
-    [[ "files" "(directory)" ]]
-    [[ "memory" "garbage-collection" ]]
-    [[ "memory" "gc-time" ]]
-    [[ "memory" "save-image" ]]
-    [[ "kernel" "datastack" ]]
-    [[ "kernel" "callstack" ]]
-    [[ "kernel" "set-datastack" ]]
-    [[ "kernel" "set-callstack" ]]
-    [[ "kernel" "exit*" ]]
-    [[ "io-internals" "client-socket" ]]
-    [[ "io-internals" "server-socket" ]]
-    [[ "io-internals" "close-port" ]]
-    [[ "io-internals" "add-accept-io-task" ]]
-    [[ "io-internals" "accept-fd" ]]
-    [[ "io-internals" "can-read-line?" ]]
-    [[ "io-internals" "add-read-line-io-task" ]]
-    [[ "io-internals" "read-line-fd-8" ]]
-    [[ "io-internals" "can-read-count?" ]]
-    [[ "io-internals" "add-read-count-io-task" ]]
-    [[ "io-internals" "read-count-fd-8" ]]
-    [[ "io-internals" "can-write?" ]]
-    [[ "io-internals" "add-write-io-task" ]]
-    [[ "io-internals" "write-fd-8" ]]
-    [[ "io-internals" "add-copy-io-task" ]]
-    [[ "io-internals" "pending-io-error" ]]
-    [[ "io-internals" "next-io-task" ]]
-    [[ "memory" "room" ]]
-    [[ "kernel" "os-env" ]]
-    [[ "kernel" "millis" ]]
-    [[ "random" "init-random" ]]
-    [[ "random" "(random-int)" ]]
-    [[ "kernel" "type" ]]
-    [[ "files" "cwd" ]]
-    [[ "files" "cd" ]]
-    [[ "assembler" "compiled-offset" ]]
-    [[ "assembler" "set-compiled-offset" ]]
-    [[ "assembler" "literal-top" ]]
-    [[ "assembler" "set-literal-top" ]]
-    [[ "memory" "address" ]]
-    [[ "alien" "dlopen" ]]
-    [[ "alien" "dlsym" ]]
-    [[ "alien" "dlclose" ]]
-    [[ "alien" "<alien>" ]]
-    [[ "alien" "<local-alien>" ]]
-    [[ "alien" "alien-cell" ]]
-    [[ "alien" "set-alien-cell" ]]
-    [[ "alien" "alien-4" ]]
-    [[ "alien" "set-alien-4" ]]
-    [[ "alien" "alien-2" ]]
-    [[ "alien" "set-alien-2" ]]
-    [[ "alien" "alien-1" ]]
-    [[ "alien" "set-alien-1" ]]
-    [[ "memory" "heap-stats" ]]
-    [[ "errors" "throw" ]]
-    [[ "kernel-internals" "string>memory" ]]
-    [[ "kernel-internals" "memory>string" ]]
-    [[ "alien" "local-alien?" ]]
-    [[ "alien" "alien-address" ]]
-    [[ "lists" ">cons" ]]
-    [[ "vectors" ">vector" ]]
-    [[ "strings" ">string" ]]
-    [[ "words" ">word" ]]
-    [[ "hashtables" ">hashtable" ]]
-    [[ "kernel-internals" "slot" ]]
-    [[ "kernel-internals" "set-slot" ]]
-    [[ "kernel-internals" "integer-slot" ]]
-    [[ "kernel-internals" "set-integer-slot" ]]
-    [[ "kernel-internals" "grow-array" ]]
-    [[ "hashtables" "<hashtable>" ]]
-    [[ "kernel-internals" "<array>" ]]
-    [[ "kernel-internals" "<tuple>" ]]
-    [[ "kernel-internals" ">array" ]]
-    [[ "kernel-internals" ">tuple" ]]
-    [[ "memory" "(instances)" ]]
+    [ "execute" "words"                       " word -- " ]
+    [ "call" "kernel"                         [ [ general-list ] [ ] ] ]
+    [ "ifte" "kernel"                         [ [ object general-list general-list ] [ ] ] ]
+    [ "cons" "lists"                          [ [ object object ] [ cons ] ] ]
+    [ "<vector>" "vectors"                    [ [ integer ] [ vector ] ] ]
+    [ "str-nth" "strings"                     [ [ integer string ] [ integer ] ] ]
+    [ "str-compare" "strings"                 [ [ string string ] [ integer ] ] ]
+    [ "str=" "strings"                        [ [ string string ] [ boolean ] ] ]
+    [ "index-of*" "strings"                   [ [ integer string text ] [ integer ] ] ]
+    [ "substring" "strings"                   [ [ integer integer string ] [ string ] ] ]
+    [ "str-reverse" "strings"                 [ [ string ] [ string ] ] ]
+    [ "<sbuf>" "strings"                      [ [ integer ] [ sbuf ] ] ]
+    [ "sbuf-length" "strings"                 [ [ sbuf ] [ integer ] ] ]
+    [ "set-sbuf-length" "strings"             [ [ integer sbuf ] [ ] ] ]
+    [ "sbuf-nth" "strings"                    [ [ integer sbuf ] [ integer ] ] ]
+    [ "set-sbuf-nth" "strings"                [ [ integer integer sbuf ] [ ] ] ]
+    [ "sbuf-append" "strings"                 [ [ text sbuf ] [ ] ] ]
+    [ "sbuf>str" "strings"                    [ [ sbuf ] [ string ] ] ]
+    [ "sbuf-reverse" "strings"                [ [ sbuf ] [ ] ] ]
+    [ "sbuf-clone" "strings"                  [ [ sbuf ] [ sbuf ] ] ]
+    [ "sbuf=" "strings"                       [ [ sbuf sbuf ] [ boolean ] ] ]
+    [ "sbuf-hashcode" "strings"               [ [ sbuf ] [ fixnum ] ] ]
+    [ "arithmetic-type" "math-internals"      [ [ object object ] [ object object fixnum ] ] ]
+    [ ">fixnum" "math"                        [ [ number ] [ fixnum ] ] ]
+    [ ">bignum" "math"                        [ [ number ] [ bignum ] ] ]
+    [ ">float" "math"                         [ [ number ] [ float ] ] ]
+    [ "(fraction>)" "math-internals"          [ [ integer integer ] [ rational ] ] ]
+    [ "str>float" "parser"                    [ [ string ] [ float ] ] ]
+    [ "(unparse-float)" "unparser"            [ [ float ] [ string ] ] ]
+    [ "<complex>" "math-internals"            [ [ real real ] [ number ] ] ]
+    [ "fixnum=" "math-internals"              [ [ fixnum fixnum ] [ boolean ] ] ]
+    [ "fixnum+" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
+    [ "fixnum-" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
+    [ "fixnum*" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
+    [ "fixnum/i" "math-internals"             [ [ fixnum fixnum ] [ integer ] ] ]
+    [ "fixnum/f" "math-internals"             [ [ fixnum fixnum ] [ integer ] ] ]
+    [ "fixnum-mod" "math-internals"           [ [ fixnum fixnum ] [ fixnum ] ] ]
+    [ "fixnum/mod" "math-internals"           [ [ fixnum fixnum ] [ integer fixnum ] ] ]
+    [ "fixnum-bitand" "math-internals"        [ [ fixnum fixnum ] [ fixnum ] ] ]
+    [ "fixnum-bitor" "math-internals"         [ [ fixnum fixnum ] [ fixnum ] ] ]
+    [ "fixnum-bitxor" "math-internals"        [ [ fixnum fixnum ] [ fixnum ] ] ]
+    [ "fixnum-bitnot" "math-internals"        [ [ fixnum ] [ fixnum ] ] ]
+    [ "fixnum-shift" "math-internals"         [ [ fixnum fixnum ] [ fixnum ] ] ]
+    [ "fixnum<" "math-internals"              [ [ fixnum fixnum ] [ boolean ] ] ]
+    [ "fixnum<=" "math-internals"             [ [ fixnum fixnum ] [ boolean ] ] ]
+    [ "fixnum>" "math-internals"              [ [ fixnum fixnum ] [ boolean ] ] ]
+    [ "fixnum>=" "math-internals"             [ [ fixnum fixnum ] [ boolean ] ] ]
+    [ "bignum=" "math-internals"              [ [ bignum bignum ] [ boolean ] ] ]
+    [ "bignum+" "math-internals"              [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum-" "math-internals"              [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum*" "math-internals"              [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum/i" "math-internals"             [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum/f" "math-internals"             [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum-mod" "math-internals"           [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum/mod" "math-internals"           [ [ bignum bignum ] [ bignum bignum ] ] ]
+    [ "bignum-bitand" "math-internals"        [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum-bitor" "math-internals"         [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum-bitxor" "math-internals"        [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum-bitnot" "math-internals"        [ [ bignum ] [ bignum ] ] ]
+    [ "bignum-shift" "math-internals"         [ [ bignum bignum ] [ bignum ] ] ]
+    [ "bignum<" "math-internals"              [ [ bignum bignum ] [ boolean ] ] ]
+    [ "bignum<=" "math-internals"             [ [ bignum bignum ] [ boolean ] ] ]
+    [ "bignum>" "math-internals"              [ [ bignum bignum ] [ boolean ] ] ]
+    [ "bignum>=" "math-internals"             [ [ bignum bignum ] [ boolean ] ] ]
+    [ "float=" "math-internals"               [ [ bignum bignum ] [ boolean ] ] ]
+    [ "float+" "math-internals"               [ [ float float ] [ float ] ] ]
+    [ "float-" "math-internals"               [ [ float float ] [ float ] ] ]
+    [ "float*" "math-internals"               [ [ float float ] [ float ] ] ]
+    [ "float/f" "math-internals"              [ [ float float ] [ float ] ] ]
+    [ "float<" "math-internals"               [ [ float float ] [ boolean ] ] ]
+    [ "float<=" "math-internals"              [ [ float float ] [ boolean ] ] ]
+    [ "float>" "math-internals"               [ [ float float ] [ boolean ] ] ]
+    [ "float>=" "math-internals"              [ [ float float ] [ boolean ] ] ]
+    [ "facos" "math-internals"                [ [ real ] [ float ] ] ]
+    [ "fasin" "math-internals"                [ [ real ] [ float ] ] ]
+    [ "fatan" "math-internals"                [ [ real ] [ float ] ] ]
+    [ "fatan2" "math-internals"               [ [ real real ] [ float ] ] ]
+    [ "fcos" "math-internals"                 [ [ real ] [ float ] ] ]
+    [ "fexp" "math-internals"                 [ [ real ] [ float ] ] ]
+    [ "fcosh" "math-internals"                [ [ real ] [ float ] ] ]
+    [ "flog" "math-internals"                 [ [ real ] [ float ] ] ]
+    [ "fpow" "math-internals"                 [ [ real real ] [ float ] ] ]
+    [ "fsin" "math-internals"                 [ [ real ] [ float ] ] ]
+    [ "fsinh" "math-internals"                [ [ real ] [ float ] ] ]
+    [ "fsqrt" "math-internals"                [ [ real ] [ float ] ] ]
+    [ "<word>" "words"                        [ [ ] [ word ] ] ]
+    [ "update-xt" "words"                     [ [ word ] [ ] ] ]
+    [ "call-profiling" "profiler"             [ [ integer ] [ ] ] ]
+    [ "allot-profiling" "profiler"            [ [ integer ] [ ] ] ]
+    [ "compiled?" "words"                     [ [ object ] [ ] ] ]
+    [ "drop" "kernel"                         [ [ object ] [ object object ] ] ]
+    [ "dup" "kernel"                          [ [ object object ] [ object object ] ] ]
+    [ "swap" "kernel"                         [ [ object object ] [ object object object ] ] ]
+    [ "over" "kernel"                         [ [ object object object ] [ object object object object ] ] ]
+    [ "pick" "kernel"                         [ [ object ] [ ] ] ]
+    [ ">r" "kernel"                           [ [ ] [ object ] ] ]
+    [ "r>" "kernel"                           [ [ object object ] [ boolean ] ] ]
+    [ "eq?" "kernel"                          [ [ fixnum ] [ object ] ] ]
+    [ "getenv" "kernel-internals"             [ [ object fixnum ] [ ] ] ]
+    [ "setenv" "kernel-internals"             [ [ string object object ] [ port ] ] ]
+    [ "open-file" "io-internals"              [ [ string ] [ general-list ] ] ]
+    [ "stat" "files"                          [ [ string ] [ general-list ] ] ]
+    [ "(directory)" "files"                   [ [ ] [ ] ] ]
+    [ "garbage-collection" "memory"           [ [ string ] [ ] ] ]
+    [ "gc-time" "memory"                      " -- ds "          ]
+    [ "save-image" "memory"                   " -- cs "          ]
+    [ "datastack" "kernel"                    " ds -- "          ]
+    [ "callstack" "kernel"                    " cs -- "          ]
+    [ "set-datastack" "kernel"                [ [ integer ] [ ] ] ]
+    [ "set-callstack" "kernel"                [ [ string integer ] [ port port ] ] ]
+    [ "exit*" "kernel"                        [ [ integer ] [ port ] ] ]
+    [ "client-socket" "io-internals"          [ [ port ] [ ] ] ]
+    [ "server-socket" "io-internals"          [ [ port general-list ] [ ] ] ]
+    [ "close-port" "io-internals"             [ [ port ] [ string integer port port ] ] ]
+    [ "add-accept-io-task" "io-internals"     [ [ port ] [ boolean ] ] ]
+    [ "accept-fd" "io-internals"              [ [ port general-list ] [ ] ] ]
+    [ "can-read-line?" "io-internals"         [ [ port ] [ sbuf ] ] ]
+    [ "add-read-line-io-task" "io-internals"  [ [ integer port ] [ boolean ] ] ]
+    [ "read-line-fd-8" "io-internals"         [ [ integer port general-list ] [ ] ] ]
+    [ "can-read-count?" "io-internals"        [ [ integer port ] [ sbuf ] ] ]
+    [ "add-read-count-io-task" "io-internals" [ [ integer port ] [ boolean ] ] ]
+    [ "read-count-fd-8" "io-internals"        [ [ port general-list ] [ ] ] ]
+    [ "can-write?" "io-internals"             [ [ text port ] [ ] ] ]
+    [ "add-write-io-task" "io-internals"      [ [ port port general-list ] [ ] ] ]
+    [ "write-fd-8" "io-internals"             [ [ ] [ ] ] ]
+    [ "add-copy-io-task" "io-internals"       [ [ ] [ general-list ] ] ]
+    [ "pending-io-error" "io-internals"       [ [ ] [ integer integer integer integer ] ] ]
+    [ "next-io-task" "io-internals"           [ [ string ] [ object ] ] ]
+    [ "room" "memory"                         [ [ ] [ integer ] ] ]
+    [ "os-env" "kernel"                       [ [ ] [ ] ] ]
+    [ "millis" "kernel"                       [ [ ] [ integer ] ] ]
+    [ "init-random" "random"                  [ [ object ] [ fixnum ] ] ]
+    [ "(random-int)" "random"                 [ [ integer ] [ ] ] ]
+    [ "type" "kernel"                         [ [ integer ] [ ] ] ]
+    [ "cwd" "files"                           [ [ ] [ string ] ] ]
+    [ "cd" "files"                            [ [ string ] [ ] ] ]
+    [ "compiled-offset" "assembler"           [ [ ] [ integer ] ] ]
+    [ "set-compiled-offset" "assembler"       [ [ integer ] [ ] ] ]
+    [ "literal-top" "assembler"               [ [ ] [ integer ] ] ]
+    [ "set-literal-top" "assembler"           [ [ integer ] [ ] ] ]
+    [ "address" "memory"                      [ [ object ] [ integer ] ] ]
+    [ "dlopen" "alien"                        [ [ string ] [ dll ] ] ]
+    [ "dlsym" "alien"                         [ [ string object ] [ integer ] ] ]
+    [ "dlclose" "alien"                       [ [ dll ] [ ] ] ]
+    [ "<alien>" "alien"                       [ [ integer ] [ alien ] ] ]
+    [ "<local-alien>" "alien"                 [ [ integer ] [ alien ] ] ]
+    [ "alien-cell" "alien"                    [ [ alien integer ] [ integer ] ] ]
+    [ "set-alien-cell" "alien"                [ [ integer alien integer ] [ ] ] ]
+    [ "alien-4" "alien"                       [ [ alien integer ] [ integer ] ] ]
+    [ "set-alien-4" "alien"                   [ [ integer alien integer ] [ ] ] ]
+    [ "alien-2" "alien"                       [ [ alien integer ] [ fixnum ] ] ]
+    [ "set-alien-2" "alien"                   [ [ integer alien integer ] [ ] ] ]
+    [ "alien-1" "alien"                       [ [ alien integer ] [ fixnum ] ] ]
+    [ "set-alien-1" "alien"                   [ [ integer alien integer ] [ ] ] ]
+    [ "heap-stats" "memory"                   [ [ ] [ general-list ] ] ]
+    [ "throw" "errors"                        [ [ object ] [ ] ] ]
+    [ "string>memory" "kernel-internals"      [ [ string integer ] [ ] ] ]
+    [ "memory>string" "kernel-internals"      [ [ integer integer ] [ string ] ] ]
+    [ "local-alien?" "alien"                  [ [ alien ] [ object ] ] ]
+    [ "alien-address" "alien"                 [ [ alien ] [ integer ] ] ]
+    [ ">cons" "lists"                         [ [ object ] [ cons ] ] ]
+    [ ">vector" "vectors"                     [ [ object ] [ vector ] ] ]
+    [ ">string" "strings"                     [ [ object ] [ string ] ] ]
+    [ ">word" "words"                         [ [ object ] [ word ] ] ]
+    [ ">hashtable" "hashtables"               [ [ object ] [ hashtable ] ] ]
+    [ "slot" "kernel-internals"               [ [ object fixnum ] [ object ] ] ]
+    [ "set-slot" "kernel-internals"           [ [ object object fixnum ] [ ] ] ]
+    [ "integer-slot" "kernel-internals"       [ [ object fixnum ] [ integer ] ] ]
+    [ "set-integer-slot" "kernel-internals"   [ [ integer object fixnum ] [ ] ] ]
+    [ "grow-array" "kernel-internals"         [ [ integer array ] [ object ] ] ]
+    [ "<hashtable>" "hashtables"              [ [ number ] [ hashtable ] ] ]
+    [ "<array>" "kernel-internals"            [ [ number ] [ array ] ] ]
+    [ "<tuple>" "kernel-internals"            [ [ number ] [ tuple ] ] ]
+    [ ">array" "kernel-internals"             [ [ object ] [ array ] ] ]
+    [ ">tuple" "kernel-internals"             [ [ object ] [ tuple ] ] ]
+    [ "(instances)" "memory"                  [ [ integer ] [ general-list ] ] ]
+    [ "begin-scan" "memory"                   [ [ ] [ ] ] ]
+    [ "next-object" "memory"                  [ [ ] [ object ] ] ]
+    [ "end-scan" "memory"                     [ [ ] [ object ] ] ]
 ] [
-    unswons create swap 1 + [ f define ] keep
+    3unlist >r create >r 1 + r> 2dup swap f define r>
+    dup string? [
+        "stack-effect" set-word-property
+    ] [
+        "infer-effect" set-word-property
+    ] ifte
 ] each drop

diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor
index 5731de60cbf047a8bb4c1ffe1c2656d8c7a7a12f..f2d570a2cc9c161ffe6a391808a1ee67f0694226 100644 (file)
--- a/library/compiler/alien.factor
+++ b/library/compiler/alien.factor
@@ -15,9 +15,6 @@ unparser ;
 ! parameter, or a missing abi parameter indicates the cdecl ABI
 ! should be used, which is common on Unix.
 
-BUILTIN: dll   15
-BUILTIN: alien 16
-
 M: alien hashcode ( obj -- n )
     alien-address >fixnum ;
 

diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index f3ecadd8d364da0edf9e7e22b02c5c6983af258c..4d564f3feb107548eec4dd08fdb32e15db2f73f0 100644 (file)
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -53,8 +53,7 @@ kernel-internals math hashtables errors vectors ;
     over "delegate" = [
         pick over "delegate-field" set-word-property
     ] when
-    [ 3dup define-mutator >r define-accessor r> ] keep -rot
-    3list ;
+    3dup define-mutator >r define-accessor r> cons ;
 
 : tuple-predicate ( word -- )
     #! Make a foo? word for testing the tuple class at the top
@@ -92,7 +91,7 @@ kernel-internals math hashtables errors vectors ;
 : default-constructor ( tuple -- )
     dup [
         "slot-words" word-property
-        reverse [ last unit , \ keep , ] each
+        reverse [ cdr unit , \ keep , ] each
     ] make-list define-constructor ;
 
 : define-tuple ( tuple slots -- )
@@ -102,7 +101,6 @@ kernel-internals math hashtables errors vectors ;
     dup save-location
     dup intern-symbol
     dup tuple-predicate
-    dup define-promise
     dup tuple "metaclass" set-word-property
     dup
     dup r> define-slots "slot-words" set-word-property

diff --git a/library/kernel.factor b/library/kernel.factor
index 6002ab66c5e7d7ff8ca207dabea2523a8ec22871..84d63468980d2a68d9921c3f5a8ef64c4b34b27c 100644 (file)
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -61,3 +61,10 @@ BUILTIN: f 9
 IN: kernel
 UNION: boolean f t ;
 COMPLEMENT: general-t f
+
+IN: alien
+
+! See compiler/alien.factor for the rest; this needs to be here
+! since primitive stack effects involve alien inputs/outputs.
+BUILTIN: dll   15
+BUILTIN: alien 16

diff --git a/library/primitives.factor b/library/primitives.factor
deleted file mode 100644 (file)
index f698001..0000000
--- a/library/primitives.factor
+++ /dev/null
@@ -1,197 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: alien
-DEFER: alien
-DEFER: dll
-
-USING: alien assembler compiler errors files generic
-io-internals kernel kernel-internals lists math math-internals
-parser profiler random strings unparser vectors words
-hashtables memory ;
-
-[
-    [ execute                " word -- "                          f ]
-    [ call                   [ [ general-list ] [ ] ] ]
-    [ ifte                   [ [ object general-list general-list ] [ ] ] ]
-    [ cons                   [ [ object object ] [ cons ] ] ]
-    [ <vector>               [ [ integer ] [ vector ] ] ]
-    [ str-nth                [ [ integer string ] [ integer ] ] ]
-    [ str-compare            [ [ string string ] [ integer ] ] ]
-    [ str=                   [ [ string string ] [ boolean ] ] ]
-    [ index-of*              [ [ integer string text ] [ integer ] ] ]
-    [ substring              [ [ integer integer string ] [ string ] ] ]
-    [ str-reverse            [ [ string ] [ string ] ] ]
-    [ <sbuf>                 [ [ integer ] [ sbuf ] ] ]
-    [ sbuf-length            [ [ sbuf ] [ integer ] ] ]
-    [ set-sbuf-length        [ [ integer sbuf ] [ ] ] ]
-    [ sbuf-nth               [ [ integer sbuf ] [ integer ] ] ]
-    [ set-sbuf-nth           [ [ integer integer sbuf ] [ ] ] ]
-    [ sbuf-append            [ [ text sbuf ] [ ] ] ]
-    [ sbuf>str               [ [ sbuf ] [ string ] ] ]
-    [ sbuf-reverse           [ [ sbuf ] [ ] ] ]
-    [ sbuf-clone             [ [ sbuf ] [ sbuf ] ] ]
-    [ sbuf=                  [ [ sbuf sbuf ] [ boolean ] ] ]
-    [ sbuf-hashcode          [ [ sbuf ] [ fixnum ] ] ]
-    [ arithmetic-type        [ [ object object ] [ object object fixnum ] ] ]
-    [ >fixnum                [ [ number ] [ fixnum ] ] ]
-    [ >bignum                [ [ number ] [ bignum ] ] ]
-    [ >float                 [ [ number ] [ float ] ] ]
-    [ (fraction>)            [ [ integer integer ] [ rational ] ] ]
-    [ str>float              [ [ string ] [ float ] ] ]
-    [ (unparse-float)        [ [ float ] [ string ] ] ]
-    [ <complex>              [ [ real real ] [ number ] ] ]
-    [ fixnum=                [ [ fixnum fixnum ] [ boolean ] ] ]
-    [ fixnum+                [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum-                [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum*                [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum/i               [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum/f               [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum-mod             [ [ fixnum fixnum ] [ fixnum ] ] ]
-    [ fixnum/mod             [ [ fixnum fixnum ] [ integer fixnum ] ] ]
-    [ fixnum-bitand          [ [ fixnum fixnum ] [ fixnum ] ] ]
-    [ fixnum-bitor           [ [ fixnum fixnum ] [ fixnum ] ] ]
-    [ fixnum-bitxor          [ [ fixnum fixnum ] [ fixnum ] ] ]
-    [ fixnum-bitnot          [ [ fixnum ] [ fixnum ] ] ]
-    [ fixnum-shift           [ [ fixnum fixnum ] [ fixnum ] ] ]
-    [ fixnum<                [ [ fixnum fixnum ] [ boolean ] ] ]
-    [ fixnum<=               [ [ fixnum fixnum ] [ boolean ] ] ]
-    [ fixnum>                [ [ fixnum fixnum ] [ boolean ] ] ]
-    [ fixnum>=               [ [ fixnum fixnum ] [ boolean ] ] ]
-    [ bignum=                [ [ bignum bignum ] [ boolean ] ] ]
-    [ bignum+                [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum-                [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum*                [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum/i               [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum/f               [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum-mod             [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum/mod             [ [ bignum bignum ] [ bignum bignum ] ] ]
-    [ bignum-bitand          [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum-bitor           [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum-bitxor          [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum-bitnot          [ [ bignum ] [ bignum ] ] ]
-    [ bignum-shift           [ [ bignum bignum ] [ bignum ] ] ]
-    [ bignum<                [ [ bignum bignum ] [ boolean ] ] ]
-    [ bignum<=               [ [ bignum bignum ] [ boolean ] ] ]
-    [ bignum>                [ [ bignum bignum ] [ boolean ] ] ]
-    [ bignum>=               [ [ bignum bignum ] [ boolean ] ] ]
-    [ float=                 [ [ bignum bignum ] [ boolean ] ] ]
-    [ float+                 [ [ float float ] [ float ] ] ]
-    [ float-                 [ [ float float ] [ float ] ] ]
-    [ float*                 [ [ float float ] [ float ] ] ]
-    [ float/f                [ [ float float ] [ float ] ] ]
-    [ float<                 [ [ float float ] [ boolean ] ] ]
-    [ float<=                [ [ float float ] [ boolean ] ] ]
-    [ float>                 [ [ float float ] [ boolean ] ] ]
-    [ float>=                [ [ float float ] [ boolean ] ] ]
-    [ facos                  [ [ real ] [ float ] ] ]
-    [ fasin                  [ [ real ] [ float ] ] ]
-    [ fatan                  [ [ real ] [ float ] ] ]
-    [ fatan2                 [ [ real real ] [ float ] ] ]
-    [ fcos                   [ [ real ] [ float ] ] ]
-    [ fexp                   [ [ real ] [ float ] ] ]
-    [ fcosh                  [ [ real ] [ float ] ] ]
-    [ flog                   [ [ real ] [ float ] ] ]
-    [ fpow                   [ [ real real ] [ float ] ] ]
-    [ fsin                   [ [ real ] [ float ] ] ]
-    [ fsinh                  [ [ real ] [ float ] ] ]
-    [ fsqrt                  [ [ real ] [ float ] ] ]
-    [ <word>                 [ [ ] [ word ] ] ]
-    [ update-xt              [ [ word ] [ ] ] ]
-    [ drop                   [ [ object ] [ ] ] ]
-    [ dup                    [ [ object ] [ object object ] ] ]
-    [ swap                   [ [ object object ] [ object object ] ] ]
-    [ over                   [ [ object object ] [ object object object ] ] ]
-    [ pick                   [ [ object object object ] [ object object object object ] ] ]
-    [ >r                     [ [ object ] [ ] ] ]
-    [ r>                     [ [ ] [ object ] ] ]
-    [ eq?                    [ [ object object ] [ boolean ] ] ]
-    [ getenv                 [ [ fixnum ] [ object ] ] ]
-    [ setenv                 [ [ object fixnum ] [ ] ] ]
-    [ open-file              [ [ string object object ] [ port ] ] ]
-    [ stat                   [ [ string ] [ general-list ] ] ]
-    [ (directory)            [ [ string ] [ general-list ] ] ]
-    [ garbage-collection     [ [ ] [ ] ] ]
-    [ save-image             [ [ string ] [ ] ] ]
-    [ datastack              " -- ds "          ]
-    [ callstack              " -- cs "          ]
-    [ set-datastack          " ds -- "          ]
-    [ set-callstack          " cs -- "          ]
-    [ exit*                  [ [ integer ] [ ] ] ]
-    [ client-socket          [ [ string integer ] [ port port ] ] ]
-    [ server-socket          [ [ integer ] [ port ] ] ]
-    [ close-port             [ [ port ] [ ] ] ]
-    [ add-accept-io-task     [ [ port general-list ] [ ] ] ]
-    [ accept-fd              [ [ port ] [ string integer port port ] ] ]
-    [ can-read-line?         [ [ port ] [ boolean ] ] ]
-    [ add-read-line-io-task  [ [ port general-list ] [ ] ] ]
-    [ read-line-fd-8         [ [ port ] [ sbuf ] ] ]
-    [ can-read-count?        [ [ integer port ] [ boolean ] ] ]
-    [ add-read-count-io-task [ [ integer port general-list ] [ ] ] ]
-    [ read-count-fd-8        [ [ integer port ] [ sbuf ] ] ]
-    [ can-write?             [ [ integer port ] [ boolean ] ] ]
-    [ add-write-io-task      [ [ port general-list ] [ ] ] ]
-    [ write-fd-8             [ [ text port ] [ ] ] ]
-    [ add-copy-io-task       [ [ port port general-list ] [ ] ] ]
-    [ pending-io-error       [ [ ] [ ] ] ]
-    [ next-io-task           [ [ ] [ general-list ] ] ]
-    [ room                   [ [ ] [ integer integer integer integer ] ] ]
-    [ os-env                 [ [ string ] [ object ] ] ]
-    [ millis                 [ [ ] [ integer ] ] ]
-    [ init-random            [ [ ] [ ] ] ]
-    [ (random-int)           [ [ ] [ integer ] ] ]
-    [ type                   [ [ object ] [ fixnum ] ] ]
-    [ call-profiling         [ [ integer ] [ ] ] ]
-    [ allot-profiling        [ [ integer ] [ ] ] ]
-    [ cwd                    [ [ ] [ string ] ] ]
-    [ cd                     [ [ string ] [ ] ] ]
-    [ compiled-offset        [ [ ] [ integer ] ] ]
-    [ set-compiled-offset    [ [ integer ] [ ] ] ]
-    [ literal-top            [ [ ] [ integer ] ] ]
-    [ set-literal-top        [ [ integer ] [ ] ] ]
-    [ address                [ [ object ] [ integer ] ] ]
-    [ dlopen                 [ [ string ] [ dll ] ] ]
-    [ dlsym                  [ [ string object ] [ integer ] ] ]
-    [ dlclose                [ [ dll ] [ ] ] ]
-    [ <alien>                [ [ integer ] [ alien ] ] ]
-    [ <local-alien>          [ [ integer ] [ alien ] ] ]
-    [ alien-cell             [ [ alien integer ] [ integer ] ] ]
-    [ set-alien-cell         [ [ integer alien integer ] [ ] ] ]
-    [ alien-4                [ [ alien integer ] [ integer ] ] ]
-    [ set-alien-4            [ [ integer alien integer ] [ ] ] ]
-    [ alien-2                [ [ alien integer ] [ fixnum ] ] ]
-    [ set-alien-2            [ [ integer alien integer ] [ ] ] ]
-    [ alien-1                [ [ alien integer ] [ fixnum ] ] ]
-    [ set-alien-1            [ [ integer alien integer ] [ ] ] ]
-    [ heap-stats             [ [ ] [ general-list ] ] ]
-    [ throw                  [ [ object ] [ ] ] ]
-    [ string>memory          [ [ string integer ] [ ] ] ]
-    [ memory>string          [ [ integer integer ] [ string ] ] ]
-    [ local-alien?           [ [ alien ] [ object ] ] ]
-    [ alien-address          [ [ alien ] [ integer ] ] ]
-    ! Note: a correct type spec for these would have [ X ] as
-    ! input, not [ object ]. However, we rely on the inferencer
-    ! to handle these specially, since they are also optimized
-    ! out in some cases, etc.
-    [ >cons                  [ [ object ] [ cons ] ] ]
-    [ >vector                [ [ object ] [ vector ] ] ]
-    [ >string                [ [ object ] [ string ] ] ]
-    [ >word                  [ [ object ] [ word ] ] ]
-    [ >hashtable             [ [ object ] [ hashtable ] ] ]
-    [ slot                   [ [ object fixnum ] [ object ] ] ]
-    [ set-slot               [ [ object object fixnum ] [ ] ] ]
-    [ integer-slot           [ [ object fixnum ] [ integer ] ] ]
-    [ set-integer-slot       [ [ integer object fixnum ] [ ] ] ]
-    [ grow-array             [ [ integer array ] [ object ] ] ]
-    [ <hashtable>            [ [ number ] [ hashtable ] ] ]
-    [ <array>                [ [ number ] [ array ] ] ]
-    [ <tuple>                [ [ number ] [ tuple ] ] ]
-    [ >array                 [ [ object ] [ array ] ] ]
-    [ >tuple                 [ [ object ] [ tuple ] ] ]
-    [ (instances)            [ [ integer ] [ general-list ] ] ]
-] [
-    2unlist dup string? [
-        "stack-effect" set-word-property
-    ] [
-        "infer-effect" set-word-property
-    ] ifte
-] each

diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index 745bbc0bb5b8013ec0b175b120bac002b2aab044..b3ed8213cb936f1e6ae8da3f3420a00147a9893c 100644 (file)
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -57,6 +57,9 @@ prettyprint stdio strings unparser vectors words math generic ;
 : port-closed-error ( obj -- )
     "Port closed: " write . ;
 
+: heap-scan-error ( obj -- )
+    "Cannot do next-object outside begin/end-scan" write drop ;
+
 GENERIC: error. ( error -- )
 
 PREDICATE: cons kernel-error ( obj -- ? )
@@ -79,6 +82,7 @@ M: kernel-error error. ( error -- )
         ffi-disabled-error
         ffi-error
         port-closed-error
+        heap-scan-error
     } vector-nth execute ;
 
 M: string error. ( error -- )

diff --git a/native/error.h b/native/error.h
index 033d7a275a3caaf71e90210de4437601f8dc3b56..55ee2009f6908d65220249a2841590ec43ad95c0 100644 (file)
--- a/native/error.h
+++ b/native/error.h
@@ -13,6 +13,7 @@
 #define ERROR_FFI_DISABLED (12<<3)
 #define ERROR_FFI (13<<3)
 #define ERROR_CLOSED (14<<3)
+#define ERROR_HEAP_SCAN (15<<3)
 
 /* When throw_error throws an error, it sets this global and
 longjmps back to the top-level. */

diff --git a/native/factor.h b/native/factor.h
index ea178dddd485d45d3f39aa4d91c20986b5c2219b..5b9de43071709a2895fe59f00bc615c03d76c143 100644 (file)
--- a/native/factor.h
+++ b/native/factor.h
@@ -127,6 +127,6 @@ typedef unsigned char BYTE;
 #include "relocate.h"
 #include "ffi.h"
 #include "debug.h"
-#include "walk.h"
+#include "scan.h"
 
 #endif /* __FACTOR_H__ */

diff --git a/native/gc.c b/native/gc.c
index 6c33083a435dd4b4a3b324fbf1ca7d1b78357cd9..65c294f51a6c4ab34520d2d88f193520de03af6e 100644 (file)
--- a/native/gc.c
+++ b/native/gc.c
@@ -117,6 +117,13 @@ void primitive_gc(void)
        int64_t start = current_millis();
        CELL scan;
 
+       if(heap_scan)
+       {
+               fprintf(stderr,"GC disabled\n");
+               fflush(stderr);
+               return;
+       }
+
        gc_in_progress = true;
 
        fprintf(stderr,"GC\n");

diff --git a/native/gc.h b/native/gc.h
index 1c03e41e489c935833149326e424b5b4f7f56584..00c3d1046b057c5cd950da24a4599794c3a8dd28 100644 (file)
--- a/native/gc.h
+++ b/native/gc.h
@@ -1,4 +1,8 @@
 bool gc_in_progress;
+
+/* GC is off during heap walking */
+bool heap_scan;
+
 int64_t gc_time;
 
 /* Given a pointer to oldspace, copy it to newspace. */

diff --git a/native/memory.c b/native/memory.c
index 83ce4ab1dc3a1446fde3ae536e2fbe56e7c00afe..21b739e82ecc35478ef4e7e574d28cf71db9e20b 100644 (file)
--- a/native/memory.c
+++ b/native/memory.c
@@ -58,6 +58,7 @@ void init_arena(CELL size)
        init_zone(&compiling,size);
        allot_profiling = false;
        gc_in_progress = false;
+       heap_scan = false;
        gc_time = 0;
 }
 

diff --git a/native/primitives.c b/native/primitives.c
index 05bfb8cf1417ffee1038459889c18a86025c68f5..2775f4a02e46bdce76a60215efcf2722c9be8a6c 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -179,7 +179,10 @@ void* primitives[] = {
        primitive_tuple,
        primitive_to_array,
        primitive_to_tuple,
-       primitive_instances
+       primitive_instances,
+       primitive_begin_scan,
+       primitive_next_object,
+       primitive_end_scan
 };
 
 CELL primitive_to_xt(CELL primitive)

diff --git a/native/scan.c b/native/scan.c
new file mode 100644 (file)
index 0000000..b7a2170
--- /dev/null
+++ b/native/scan.c
@@ -0,0 +1,115 @@
+#include "factor.h"
+
+void primitive_begin_scan(void)
+{
+       heap_scan_ptr = active.base;
+       heap_scan_end = active.here;
+       heap_scan = true;
+}
+
+void primitive_next_object(void)
+{
+       CELL value = get(heap_scan_ptr);
+       CELL obj = heap_scan_ptr;
+       CELL size, type;
+
+       if(!heap_scan)
+               general_error(ERROR_HEAP_SCAN,F);
+
+       if(heap_scan_ptr >= heap_scan_end)
+       {
+               dpush(F);
+               return;
+       }
+       
+       if(headerp(value))
+       {
+               size = align8(untagged_object_size(heap_scan_ptr));
+               type = untag_header(value);
+       }
+       else
+       {
+               size = CELLS * 2;
+               type = CONS_TYPE;
+       }
+
+       heap_scan_ptr += size;
+
+       if(type < HEADER_TYPE)
+               dpush(RETAG(obj,type));
+       else
+               dpush(RETAG(obj,OBJECT_TYPE));
+}
+
+void primitive_end_scan(void)
+{
+       heap_scan = false;
+}
+
+void primitive_heap_stats(void)
+{
+       int instances[TYPE_COUNT], bytes[TYPE_COUNT];
+       int i;
+       CELL list = F;
+
+       for(i = 0; i < TYPE_COUNT; i++)
+               instances[i] = 0;
+
+       for(i = 0; i < TYPE_COUNT; i++)
+               bytes[i] = 0;
+
+       begin_heap_scan();
+
+       for(;;)
+       {
+               CELL size, type;
+               heap_step(&size,&type);
+
+               if(walk_donep())
+                       break;
+
+               instances[type]++;
+               bytes[type] += size;
+       }
+
+       for(i = TYPE_COUNT - 1; i >= 0; i--)
+       {
+               list = cons(
+                       cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
+                       list);
+       }
+
+       dpush(list);
+}
+
+void primitive_instances(void)
+{
+       CELL list = F;
+       CELL search_type = to_fixnum(dpop());
+       CELL here;
+
+       primitive_gc();
+
+       here = active.here;
+
+       begin_heap_scan();
+       
+       for(;;)
+       {
+               CELL size, type;
+               CELL obj = heap_step(&size,&type);
+
+               if(walk_donep())
+                       break;
+
+               /* don't want an infinite loop if we ask for a list of all
+               conses in the image! */
+               if(heap_scan_ptr >= here)
+                       break;
+
+               if(search_type == type)
+                       list = cons(obj,list);
+       }
+
+       dpush(list);
+}

diff --git a/native/scan.h b/native/scan.h
new file mode 100644 (file)
index 0000000..a213dad
--- /dev/null
+++ b/native/scan.h
@@ -0,0 +1,51 @@
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+CELL heap_scan_ptr;
+
+/* End of heap when walk was started; prevents infinite loop if
+walk consing */
+CELL heap_scan_end;
+
+/* Begin iterating through the heap. This is not re-entrant. */
+INLINE void begin_heap_scan(void)
+{
+       heap_scan_ptr = active.base;
+}
+
+INLINE CELL heap_step(CELL* size, CELL* type)
+{
+       CELL value = get(heap_scan_ptr);
+       CELL obj = heap_scan_ptr;
+
+       if(headerp(value))
+       {
+               *size = align8(untagged_object_size(heap_scan_ptr));
+               *type = untag_header(value);
+       }
+       else
+       {
+               *size = CELLS * 2;
+               *type = CONS_TYPE;
+       }
+
+       heap_scan_ptr += *size;
+
+       if(*type < HEADER_TYPE)
+               obj = RETAG(obj,*type);
+       else
+               obj = RETAG(obj,OBJECT_TYPE);
+
+       return obj;
+}
+
+INLINE bool walk_donep(void)
+{
+       return (heap_scan_ptr >= active.here);
+}
+
+void primitive_heap_stats(void);
+void primitive_instances(void);
+
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);

diff --git a/native/walk.c b/native/walk.c
deleted file mode 100644 (file)
index 1555435..0000000
--- a/native/walk.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "factor.h"
-
-void primitive_heap_stats(void)
-{
-       int instances[TYPE_COUNT], bytes[TYPE_COUNT];
-       int i;
-       CELL list = F;
-
-       for(i = 0; i < TYPE_COUNT; i++)
-               instances[i] = 0;
-
-       for(i = 0; i < TYPE_COUNT; i++)
-               bytes[i] = 0;
-
-       begin_heap_walk();
-
-       for(;;)
-       {
-               CELL size, type;
-               heap_step(&size,&type);
-
-               if(walk_donep())
-                       break;
-
-               instances[type]++;
-               bytes[type] += size;
-       }
-
-       for(i = TYPE_COUNT - 1; i >= 0; i--)
-       {
-               list = cons(
-                       cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
-                       list);
-       }
-
-       dpush(list);
-}
-
-void primitive_instances(void)
-{
-       CELL list = F;
-       CELL search_type = to_fixnum(dpop());
-       CELL here;
-
-       primitive_gc();
-
-       here = active.here;
-
-       begin_heap_walk();
-       
-       for(;;)
-       {
-               CELL size, type;
-               CELL obj = heap_step(&size,&type);
-
-               if(walk_donep())
-                       break;
-
-               /* don't want an infinite loop if we ask for a list of all
-               conses in the image! */
-               if(heap_walk_ptr >= here)
-                       break;
-
-               if(search_type == type)
-                       list = cons(obj,list);
-       }
-
-       dpush(list);
-}

diff --git a/native/walk.h b/native/walk.h
deleted file mode 100644 (file)
index ae70259..0000000
--- a/native/walk.h
+++ /dev/null
@@ -1,43 +0,0 @@
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_walk_ptr;
-
-/* Begin iterating through the heap. This is not re-entrant. */
-INLINE void begin_heap_walk(void)
-{
-       heap_walk_ptr = active.base;
-}
-
-INLINE CELL heap_step(CELL* size, CELL* type)
-{
-       CELL value = get(heap_walk_ptr);
-       CELL obj = heap_walk_ptr;
-
-       if(headerp(value))
-       {
-               *size = align8(untagged_object_size(heap_walk_ptr));
-               *type = untag_header(value);
-       }
-       else
-       {
-               *size = CELLS * 2;
-               *type = CONS_TYPE;
-       }
-
-       heap_walk_ptr += *size;
-
-       if(*type < HEADER_TYPE)
-               obj = RETAG(obj,*type);
-       else
-               obj = RETAG(obj,OBJECT_TYPE);
-
-       return obj;
-}
-
-INLINE bool walk_donep(void)
-{
-       return (heap_walk_ptr >= active.here);
-}
-
-void primitive_heap_stats(void);
-void primitive_instances(void);