clean up bignum cached constants

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index d9587eda36c23797f8bfb8e7cf1913c85d9e200c..07d4f8d7d38b29672d1519dfc1281dcb814ed500 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,11 +1,14 @@
-don't crash on bad prim #\r
-fixnum/string pseudo-type for error reporting\r
-to_c_string allots too much\r
+- alist -vs- assoc terminology\r
+- some way to run httpd from command line\r
+- 'default responder' for when we go to root\r
+- file responder:\r
+  - directory listings\r
+  - index.html\r
+  - if a directory is requested and URL does not end with /, redirect\r
+- doc strings with native factor\r
 \r
 + bignums:\r
 \r
-- cached 0/-1/1 should be cross compiled in image\r
-- bignum cross compiling\r
 - move some s48_ functions into bignum.c\r
 - remove unused functions\r
 \r
@@ -50,7 +53,6 @@ to_c_string allots too much
 - fedit broken with listener\r
 - maple-like: press enter at old commands to evaluate there\r
 - input style after clicking link\r
-- plugin not unloaded\r
 - listener backspace overzealous\r
 - completion in the listener\r
 - special completion for USE:/IN:\r
@@ -82,10 +84,8 @@ to_c_string allots too much
 \r
 + misc:\r
 \r
-- alist -vs- assoc terminology\r
 - 'cascading' styles\r
 - jedit ==> jedit-word, jedit takes a file name\r
-- some way to run httpd from command line\r
 - rethink strhead/strtail&co\r
 - namespace clone drops static var bindings\r
 - ditch expand\r
@@ -94,10 +94,6 @@ to_c_string allots too much
 + httpd:\r
 \r
 - quit responder breaks with multithreading\r
-- 'default responder' for when we go to root\r
-- file responder:\r
-  - port to native\r
-  - if a directory is requested and URL does not end with /, redirect\r
 - wiki responder:\r
   - port to native\r
   - text styles\r

diff --git a/library/image.factor b/library/image.factor
index aeecb3ad9fd3c4fe7b034e023b6bf48ecfd1fee3..e98f06df65c49931a5b92a7ad90c79f8fec91ad0 100644 (file)
--- a/library/image.factor
+++ b/library/image.factor
@@ -139,13 +139,14 @@ USE: words
 ( Bignums )
 
 : 'bignum ( bignum -- tagged )
-    'fixnum ;
-!    #! Very bad!
-!    object-tag here-as >r
-!    bignum-type >header emit
-!    1 emit ( capacity )
-!    0 emit ( sign XXXX )
-!    ( bignum -- ) emit r> ;
+    object-tag here-as >r
+    bignum-type >header emit
+    dup 0 = 1 2 ? emit ( capacity )
+    dup 0 < [
+        1 emit neg emit
+    ] [
+        0 emit     emit
+    ] ifte r> ;
 
 ( Special objects )
 
@@ -154,10 +155,15 @@ USE: words
 : f, object-tag here-as "f" set f-type >header emit 0 'fixnum emit ;
 : t, object-tag here-as "t" set t-type >header emit 0 'fixnum emit ;
 
+:  0,  0 'bignum drop ;
+:  1,  1 'bignum drop ;
+: -1, -1 'bignum drop ;
+
 ( Beginning of the image )
-! The image proper begins with the header, then F, T
+! The image proper begins with the header, then F, T,
+! and the bignums 0, 1, and -1.
 
-: begin ( -- ) header f, t, ;
+: begin ( -- ) header f, t, 0, 1, -1, ;
 
 ( Words )
 

diff --git a/library/platform/native/debugger.factor b/library/platform/native/debugger.factor
index daa368480c1cc5c3ae6da2800a8eca2a5c036cab..03cd97b2ae99364a1b08cb395d3ec5393f4905af 100644 (file)
--- a/library/platform/native/debugger.factor
+++ b/library/platform/native/debugger.factor
@@ -89,6 +89,9 @@ USE: words
 : negative-array-size-error ( obj -- )
     "Cannot allocate array with negative size " write . ;
 
+: bad-primitive-error ( obj -- )
+    "Bad primitive number: " write . ;
+
 : kernel-error. ( obj n -- str )
     {
         expired-port-error
@@ -104,6 +107,7 @@ USE: words
         signal-error
         profiling-disabled-error
         negative-array-size-error
+        bad-primitive-error
     } vector-nth execute ;
 
 : kernel-error? ( obj -- ? )

diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor
index dfebc48f5272506058fffd09bb193ffb9875ada6..f2ac8606058af4a646105b5320d9168160705399 100644 (file)
--- a/library/platform/native/kernel.factor
+++ b/library/platform/native/kernel.factor
@@ -97,6 +97,7 @@ USE: vectors
         [ 101 | "fixnum/bignum/ratio" ]
         [ 102 | "fixnum/bignum/ratio/float" ]
         [ 103 | "fixnum/bignum/ratio/float/complex" ]
+        [ 104 | "fixnum/string" ]
     ] assoc ;
 
 : java? f ;

diff --git a/library/platform/native/math.factor b/library/platform/native/math.factor
index 1ef8121532f8a09ab967573dd4108447ed97958d..fc626d085bd6781d783c2aa48dd55144fb2e6574 100644 (file)
--- a/library/platform/native/math.factor
+++ b/library/platform/native/math.factor
@@ -31,7 +31,6 @@ USE: kernel
 USE: stack
 
 : (gcd) ( x y -- z )
-    USE: prettyprint .s
     dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
 
 : gcd ( x y -- z )

diff --git a/library/test/parser.factor b/library/test/parser.factor
index 0322a699ed74e4744d69cb22e1c10252ab5066cc..40d23deba0987e619e48db03b9af7b48091b9ba7 100644 (file)
--- a/library/test/parser.factor
+++ b/library/test/parser.factor
@@ -1,4 +1,5 @@
 IN: scratchpad
+USE: combinators
 USE: parser
 USE: test
 USE: unparser

diff --git a/native/bignum.c b/native/bignum.c
index d505c57b0d1a1656373977653d5303107f509e72..1eb89097fe3caa755fe0f7f1eef074a33d6c3eb9 100644 (file)
--- a/native/bignum.c
+++ b/native/bignum.c
@@ -1,16 +1,5 @@
 #include "factor.h"
 
-void init_bignum(void)
-{
-       bignum_zero = bignum_allocate(0,0);
-
-       bignum_pos_one = bignum_allocate(1,0);
-       (BIGNUM_REF (bignum_pos_one, 0)) = 1;
-
-       bignum_neg_one = bignum_allocate(1,1);
-       (BIGNUM_REF (bignum_neg_one, 0)) = 1;
-}
-
 void primitive_bignump(void)
 {
        drepl(tag_boolean(typep(BIGNUM_TYPE,dpeek())));
@@ -214,7 +203,7 @@ CELL not_bignum(ARRAY* x)
 
 void copy_bignum_constants(void)
 {
-       bignum_zero = copy_array(bignum_zero);
-       bignum_pos_one = copy_array(bignum_pos_one);
-       bignum_neg_one = copy_array(bignum_neg_one);
+       copy_object(&bignum_zero);
+       copy_object(&bignum_pos_one);
+       copy_object(&bignum_neg_one);
 }

diff --git a/native/bignum.h b/native/bignum.h
index 84efe04f3719fd19ed552302c6feb8d10488c70d..feab8de6007e9e95a13d46fed41767e42c6214ed 100644 (file)
--- a/native/bignum.h
+++ b/native/bignum.h
@@ -4,11 +4,10 @@ INLINE ARRAY* untag_bignum(CELL tagged)
        return (ARRAY*)UNTAG(tagged);
 }
 
-ARRAY* bignum_zero;
-ARRAY* bignum_pos_one;
-ARRAY* bignum_neg_one;
+CELL bignum_zero;
+CELL bignum_pos_one;
+CELL bignum_neg_one;
 
-void init_bignum(void);
 void primitive_bignump(void);
 ARRAY* to_bignum(CELL tagged);
 void primitive_to_bignum(void);

diff --git a/native/error.h b/native/error.h
index c0d5d66f32ad4e6694759e0a5e20b2e14067d51b..71be1c72028bad081e1e74f98866649d6355f2ac 100644 (file)
--- a/native/error.h
+++ b/native/error.h
@@ -11,6 +11,7 @@
 #define ERROR_SIGNAL (10<<3)
 #define ERROR_PROFILING_DISABLED (11<<3)
 #define ERROR_NEGATIVE_ARRAY_SIZE (12<<3)
+#define ERROR_BAD_PRIMITIVE (13<<3)
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);

diff --git a/native/factor.c b/native/factor.c
index 1244ce629a71386de134171c4bd2c3e9cea44089..cbd2682ac777a997c4c6a27dc47df7272417b54a 100644 (file)
--- a/native/factor.c
+++ b/native/factor.c
@@ -16,7 +16,6 @@ int main(int argc, char** argv)
        load_image(argv[1]);
        init_stacks();
        init_io();
-       init_bignum();
        init_signals();
 
        args = F;

diff --git a/native/gc.c b/native/gc.c
index 6ff2f934133caa75cf17f0fc274810f705fb49ca..838030cb7705cad92e87efe9477584b9e39a6b58 100644 (file)
--- a/native/gc.c
+++ b/native/gc.c
@@ -120,11 +120,10 @@ void collect_roots(void)
        gc_debug("collect_roots",scan);
        /* these two must be the first in the heap */
        copy_object(&F);
-       gc_debug("f",F);
        copy_object(&T);
-       gc_debug("t",T);
-       copy_object(&callframe);
+       /* the bignum 0 1 -1 constants must be the next three */
        copy_bignum_constants();
+       copy_object(&callframe);
 
        for(ptr = ds_bot; ptr < ds; ptr += CELLS)
                copy_object((void*)ptr);

diff --git a/native/primitives.c b/native/primitives.c
index 27d558e6e40a2fa82429a017e1f922e83b0af9bc..209a1630276b3d3a4a8f4eee5db943a439823bad 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -147,7 +147,7 @@ XT primitives[] = {
 CELL primitive_to_xt(CELL primitive)
 {
        if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
-               critical_error("Bad primitive number",primitive);
+               general_error(ERROR_BAD_PRIMITIVE,tag_fixnum(primitive));
 
        return (CELL)primitives[primitive];
 }

diff --git a/native/relocate.c b/native/relocate.c
index 3b5276c7587b3b1aec3770f9fa8311fbd57de9bf..c049f43f62ad4ff7226fe5c1dfbd5c42c11bd7d3 100644 (file)
--- a/native/relocate.c
+++ b/native/relocate.c
@@ -45,6 +45,14 @@ void relocate_next()
        }
 }
 
+void init_object(CELL* handle, CELL type)
+{
+       if(untag_header(get(relocating)) != type)
+               fatal_error("init_object() failed",get(relocating));
+       *handle = tag_object((CELL*)relocating);
+       relocate_next();
+}
+
 void relocate(CELL r)
 {
        relocation_base = r;
@@ -55,16 +63,14 @@ void relocate(CELL r)
        relocating = active->base;
 
        /* The first two objects in the image must always be F, T */
-       if(untag_header(get(relocating)) != F_TYPE)
-               fatal_error("Not F",get(relocating));
-       F = tag_object((CELL*)relocating);
-       relocate_next();
-
-       if(untag_header(get(relocating)) != T_TYPE)
-               fatal_error("Not T",get(relocating));
-       T = tag_object((CELL*)relocating);
-       relocate_next();
+       init_object(&F,F_TYPE);
+       init_object(&T,T_TYPE);
 
+       /* The next three must be bignum 0, 1, -1  */
+       init_object(&bignum_zero,BIGNUM_TYPE);
+       init_object(&bignum_pos_one,BIGNUM_TYPE);
+       init_object(&bignum_neg_one,BIGNUM_TYPE);
+       
        for(;;)
        {
                if(relocating >= active->here)

diff --git a/native/s48_bignumint.h b/native/s48_bignumint.h
index aa3fca6c812dd15ac2c31a33b7b43b7d421e30cb..4b8a8bab0dadfeea8674abed064bb1ff8b9c5676 100644 (file)
--- a/native/s48_bignumint.h
+++ b/native/s48_bignumint.h
@@ -102,9 +102,9 @@ typedef long bignum_length_type;
 
 /* These definitions are here to facilitate caching of the constants
    0, 1, and -1. */
-#define BIGNUM_ZERO() bignum_zero
+#define BIGNUM_ZERO() (ARRAY*)UNTAG(bignum_zero)
 #define BIGNUM_ONE(neg_p) \
-   (neg_p ? bignum_neg_one : bignum_pos_one)
+   (ARRAY*)UNTAG(neg_p ? bignum_neg_one : bignum_pos_one)
 
 #define BIGNUM_ONE_P(bignum,negative_p) ((bignum) == BIGNUM_ONE(negative_p))
 

diff --git a/native/sbuf.c b/native/sbuf.c
index 7b05c1436ea478e1fa09abd124397bc44ee748bd..3642124c38394bf2a11bc88bf81db6caf6425036 100644 (file)
--- a/native/sbuf.c
+++ b/native/sbuf.c
@@ -96,7 +96,7 @@ void primitive_sbuf_append(void)
                sbuf_append_string(sbuf,untag_string(object));
                break;
        default:
-               type_error(STRING_TYPE,object);
+               type_error(TEXT_TYPE,object);
                break;
        }
 }

diff --git a/native/string.c b/native/string.c
index 091f33171fcf681b6ef1312d9e6ebc3176a2012c..c3215c3052e67d712792a09934b5bfb0f39654e5 100644 (file)
--- a/native/string.c
+++ b/native/string.c
@@ -74,7 +74,7 @@ STRING* from_c_string(const char* c_string)
 /* untagged */
 char* to_c_string(STRING* s)
 {
-       STRING* _c_str = allot_string(s->capacity + 1 /* null byte */);
+       STRING* _c_str = allot_string(s->capacity / CHARS + 1);
        CELL i;
 
        char* c_str = (char*)(_c_str + 1);

diff --git a/native/types.h b/native/types.h
index 4b8d55a5b0c0d3bb23a13a8a9e9bfb5406d27551..e38d1f586125e97b11a43adec7abfbcadcec5bf1 100644 (file)
--- a/native/types.h
+++ b/native/types.h
@@ -37,6 +37,7 @@ CELL T;
 #define RATIONAL_TYPE 101 /* INTEGER or RATIO */
 #define REAL_TYPE 102 /* RATIONAL or FLOAT */
 #define NUMBER_TYPE 103 /* COMPLEX or REAL */
+#define TEXT_TYPE 104 /* FIXNUM or STRING */
 
 CELL type_of(CELL tagged);
 bool typep(CELL type, CELL tagged);

diff --git a/native/write.c b/native/write.c
index 655abc8fc087f23148dd73f0240725676edec08b..917d335524424d31464ed4b1756407b2fbe4b2ea 100644 (file)
--- a/native/write.c
+++ b/native/write.c
@@ -26,25 +26,16 @@ bool can_write(PORT* port, FIXNUM len)
        if(port->type != PORT_WRITE)
                general_error(ERROR_INCOMPATIBLE_PORT,tag_object(port));
 
-       switch(port->type)
+       buf_capacity = port->buffer->capacity * CHARS;
+       /* Is the string longer than the buffer? */
+       if(port->buf_fill == 0 && len > buf_capacity)
        {
-       case PORT_READ:
-               return false;
-       case PORT_WRITE:
-               buf_capacity = port->buffer->capacity * CHARS;
-               /* Is the string longer than the buffer? */
-               if(port->buf_fill == 0 && len > buf_capacity)
-               {
-                       /* Increase the buffer to fit the string */
-                       port->buffer = allot_string(len / CHARS + 1);
-                       return true;
-               }
-               else
-                       return (port->buf_fill + len <= buf_capacity);
-       default:
-               critical_error("Bad port->type",port->type);
-               return false;
+               /* Increase the buffer to fit the string */
+               port->buffer = allot_string(len / CHARS + 1);
+               return true;
        }
+       else
+               return (port->buf_fill + len <= buf_capacity);
 }
 
 void primitive_can_write(void)
@@ -132,7 +123,7 @@ void primitive_write_8(void)
                write_string_8(port,str);
                break;
        default:
-               type_error(STRING_TYPE,text);
+               type_error(TEXT_TYPE,text);
                break;
        }
 }