shithub: femtolisp

--- a/femtolisp/aliases.scm

+++ b/femtolisp/aliases.scm

@@ -295,3 +295,6 @@

   (let ((b (buffer)))

     (with-output-to b (thunk))

     (io.tostring! b)))

+(define (read-u8) (io.read *input-stream* 'uint8))

+(define modulo mod)

--- a/femtolisp/cvalues.c

+++ b/femtolisp/cvalues.c

@@ -43,6 +43,7 @@

 static size_t maxfinalizers=0;

 static size_t malloc_pressure = 0;

+#ifndef BOEHM_GC

 void add_finalizer(cvalue_t *cv)

     if (nfinalizers == maxfinalizers) {

@@ -81,7 +82,7 @@

 #ifndef NDEBUG

                 memset(cv_data(tmp), 0xbb, cv_len(tmp));

 #endif

-                free(cv_data(tmp));

+                LLT_FREE(cv_data(tmp));

             ndel++;

@@ -95,6 +96,12 @@

     malloc_pressure = 0;

+#else // BOEHM_GC

+void add_finalizer(cvalue_t *cv)

+{

+    (void)cv;

+}

+#endif // BOEHM_GC

 // compute the size of the metadata object for a cvalue

 static size_t cv_nwords(cvalue_t *cv)

@@ -153,7 +160,7 @@

             gc(0);

         pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);

         pcv->type = type;

-        pcv->data = malloc(sz);

+        pcv->data = LLT_ALLOC(sz);

         autorelease(pcv);

         malloc_pressure += sz;

@@ -232,7 +239,7 @@

         return;

     size_t sz = cv_len(cv);

     if (cv_isstr(cv)) sz++;

-    void *data = malloc(sz);

+    void *data = LLT_ALLOC(sz);

     memcpy(data, cv_data(cv), sz);

     cv->data = data;

     autorelease(cv);

@@ -664,6 +671,9 @@

     if (t->vtable != NULL && t->vtable->relocate != NULL)

         t->vtable->relocate(v, ncv);

     forward(v, ncv);

+#ifdef BOEHM_GC

+    cv->data = NULL;

+#endif

     return ncv;

@@ -679,7 +689,7 @@

     if (!isinlined(cv)) {

         size_t len = cv_len(cv);

         if (cv_isstr(cv)) len++;

-        ncv->data = malloc(len);

+        ncv->data = LLT_ALLOC(len);

         memcpy(ncv->data, cv_data(cv), len);

         autorelease(ncv);

         if (hasparent(cv)) {

@@ -888,7 +898,7 @@

 value_t cbuiltin(char *name, builtin_t f)

-    cvalue_t *cv = (cvalue_t*)malloc(CVALUE_NWORDS * sizeof(value_t));

+    cvalue_t *cv = (cvalue_t*)LLT_ALLOC(CVALUE_NWORDS * sizeof(value_t));

     cv->type = builtintype;

     cv->data = &cv->_space[0];

     cv->len = sizeof(value_t);

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -121,7 +121,7 @@

 static unsigned char *tospace;

 static unsigned char *curheap;

 static unsigned char *lim;

-static uint32_t heapsize = 512*1024;//bytes

+static uint32_t heapsize;//bytes

 static uint32_t *consflags;

 // error utilities ------------------------------------------------------------

@@ -245,7 +245,7 @@

     symbol_t *sym;

     size_t len = strlen(str);

-    sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);

+    sym = (symbol_t*)LLT_ALLOC(sizeof(symbol_t)-sizeof(void*) + len + 1);

     assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8

     sym->left = sym->right = NULL;

     sym->flags = 0;

@@ -564,7 +564,9 @@

     memory_exception_value = relocate(memory_exception_value);

     the_empty_vector = relocate(the_empty_vector);

+#ifndef BOEHM_GC

     sweep_finalizers();

+#endif

 #ifdef VERBOSEGC

     printf("GC: found %d/%d live conses\n",

@@ -578,7 +580,7 @@

     // more space to fill next time. if we grew tospace last time,

     // grow the other half of the heap this time to catch up.

     if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {

-        temp = realloc(tospace, grew ? heapsize : heapsize*2);

+        temp = LLT_REALLOC(tospace, grew ? heapsize : heapsize*2);

         if (temp == NULL)

             fl_raise(memory_exception_value);

         tospace = temp;

@@ -600,7 +602,7 @@

 static void grow_stack()

     size_t newsz = N_STACK + (N_STACK>>1);

-    value_t *ns = realloc(Stack, newsz*sizeof(value_t));

+    value_t *ns = LLT_REALLOC(Stack, newsz*sizeof(value_t));

     if (ns == NULL)

         lerror(MemoryError, "stack overflow");

     Stack = ns;

@@ -2145,14 +2147,16 @@

 extern void builtins_init();

 extern void comparehash_init();

-static void lisp_init(void)

+static void lisp_init(size_t initial_heapsize)

     int i;

     llt_init();

-    fromspace = malloc(heapsize);

-    tospace   = malloc(heapsize);

+    heapsize = initial_heapsize;

+    fromspace = LLT_ALLOC(heapsize);

+    tospace   = LLT_ALLOC(heapsize);

     curheap = fromspace;

     lim = curheap+heapsize-sizeof(cons_t);

     consflags = bitvector_new(heapsize/sizeof(cons_t), 1);

@@ -2159,7 +2163,7 @@

     htable_new(&printconses, 32);

     comparehash_init();

     N_STACK = 262144;

-    Stack = malloc(N_STACK*sizeof(value_t));

+    Stack = LLT_ALLOC(N_STACK*sizeof(value_t));

     FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);

     FL_T = builtin(OP_BOOL_CONST_T);

@@ -2243,9 +2247,9 @@

     return fl_applyn(1, symbol_value(evalsym), expr);

-void fl_init()

+void fl_init(size_t initial_heapsize)

-    lisp_init();

+    lisp_init(initial_heapsize);

 int fl_load_system_image(value_t sys_image_iostream)

--- a/femtolisp/flisp.h

+++ b/femtolisp/flisp.h

@@ -354,7 +354,7 @@

 value_t cvalue_byte(value_t *args, uint32_t nargs);

 value_t cvalue_wchar(value_t *args, uint32_t nargs);

-void fl_init();

+void fl_init(size_t initial_heapsize);

 int fl_load_system_image(value_t ios);

 #endif

--- a/femtolisp/flmain.c

+++ b/femtolisp/flmain.c

@@ -35,7 +35,7 @@

     char fname_buf[1024];

-    fl_init();

+    fl_init(512*1024);

     fname_buf[0] = '\0';

     value_t str = symbol_value(symbol("*install-dir*"));

--- a/femtolisp/read.c

+++ b/femtolisp/read.c

@@ -426,13 +426,13 @@

     value_t s;

     u_int32_t wc;

-    buf = malloc(sz);

+    buf = LLT_ALLOC(sz);

     while (1) {

         if (i >= sz-4) {  // -4: leaves room for longest utf8 sequence

             sz *= 2;

-            temp = realloc(buf, sz);

+            temp = LLT_REALLOC(buf, sz);

             if (temp == NULL) {

-                free(buf);

+                LLT_FREE(buf);

                 lerror(ParseError, "read: out of memory reading string");

             buf = temp;

@@ -439,7 +439,7 @@

         c = ios_getc(F);

         if (c == IOS_EOF) {

-            free(buf);

+            LLT_FREE(buf);

             lerror(ParseError, "read: unexpected end of input in string");

         if (c == '"')

@@ -447,7 +447,7 @@

         else if (c == '\\') {

             c = ios_getc(F);

             if (c == IOS_EOF) {

-                free(buf);

+                LLT_FREE(buf);

                 lerror(ParseError, "read: end of input in escape sequence");

             j=0;

@@ -474,7 +474,7 @@

                 eseq[j] = '\0';

                 if (j) wc = strtol(eseq, NULL, 16);

                 else {

-                    free(buf);

+                    LLT_FREE(buf);

                     lerror(ParseError, "read: invalid escape sequence");

                 if (ndig == 2)

@@ -492,7 +492,7 @@

     s = cvalue_string(i);

     memcpy(cvalue_data(s), buf, i);

-    free(buf);

+    LLT_FREE(buf);

     return s;

--- a/femtolisp/types.c

+++ b/femtolisp/types.c

@@ -22,7 +22,7 @@

         sz = ctype_sizeof(t, &align);

-    ft = (fltype_t*)malloc(sizeof(fltype_t));

+    ft = (fltype_t*)LLT_ALLOC(sizeof(fltype_t));

     ft->type = t;

     if (issymbol(t)) {

         ft->numtype = sym_to_numtype(t);

@@ -42,7 +42,7 @@

         if (isarray) {

             fltype_t *eltype = get_type(car_(cdr_(t)));

             if (eltype->size == 0) {

-                free(ft);

+                LLT_FREE(ft);

                 lerror(ArgError, "invalid array element type");

             ft->elsz = eltype->size;

@@ -70,7 +70,7 @@

 fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,

                              cvinitfunc_t init)

-    fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));

+    fltype_t *ft = (fltype_t*)LLT_ALLOC(sizeof(fltype_t));

     ft->type = sym;

     ft->size = sz;

     ft->numtype = N_NUMTYPES;

--- a/llt/dtypes.h

+++ b/llt/dtypes.h

@@ -16,7 +16,7 @@

   We assume the LP64 convention for 64-bit platforms.

*/

-#if 0

+#ifdef BOEHM_GC

 // boehm GC allocator

 #include <gc.h>

 #define LLT_ALLOC(n) GC_MALLOC(n)