shithub: femtolisp

--- a/femtolisp/cps.lsp

+++ b/femtolisp/cps.lsp

@@ -155,6 +155,9 @@

              `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))

                 ,(cps- E *top-k*))))

+          ((eq (car form) 'without-delimited-continuations)

+           `(,k ,(cadr form)))

           ((and (constantp (car form))

                 (builtinp (eval (car form))))

            (builtincall->cps form k))

@@ -298,7 +301,7 @@

  (let ((x 0))

    (while (< x 10)

-     (progn (#.print x) (setq x (+ 1 x)))))

+     (progn (print x) (setq x (+ 1 x)))))

=>

   (let ((x 0))

     (reset

@@ -305,7 +308,7 @@

      (let ((l nil))

        (let ((k (shift k (k k))))

          (if (< x 10)

-             (progn (setq l (progn (#.print x)

+             (progn (setq l (progn (print x)

                                    (setq x (+ 1 x))))

                     (k k))

            l)))))

--- a/femtolisp/cvalues.c

+++ b/femtolisp/cvalues.c

@@ -827,7 +827,8 @@

 #define ctor_cv_intern(tok) \

     cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok))

-void types_init();

+#define mk_primtype(name) \

+  name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init

 void cvalues_init()

@@ -879,7 +880,23 @@

     wcstringtypesym = symbol("*wcstring-type*");

     setc(wcstringtypesym, list2(arraysym, wcharsym));

-    types_init();

+    mk_primtype(int8);

+    mk_primtype(uint8);

+    mk_primtype(int16);

+    mk_primtype(uint16);

+    mk_primtype(int32);

+    mk_primtype(uint32);

+    mk_primtype(int64);

+    mk_primtype(uint64);

+    mk_primtype(long);

+    mk_primtype(ulong);

+    mk_primtype(byte);

+    mk_primtype(wchar);

+    mk_primtype(float);

+    mk_primtype(double);

+    stringtype = get_type(symbol_value(stringtypesym));

+    wcstringtype = get_type(symbol_value(wcstringtypesym));

     emptystringsym = symbol("*empty-string*");

     setc(emptystringsym, cvalue_static_cstring(""));

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -30,7 +30,7 @@

   * strings

   - hash tables

-  by Jeff Bezanson (C) 2008

+  by Jeff Bezanson (C) 2009

   Distributed under the BSD License

*/

--- /dev/null

+++ b/femtolisp/stream.c

@@ -1,0 +1,56 @@

+#include <stdlib.h>

+#include <stdio.h>

+#include <stdarg.h>

+#include <string.h>

+#include <assert.h>

+#include <sys/types.h>

+#include "llt.h"

+#include "flisp.h"

+static value_t streamsym;

+static fltype_t *streamtype;

+void print_stream(value_t v, ios_t *f, int princ)

+{

+}

+void free_stream(value_t self)

+{

+}

+void relocate_stream(value_t oldv, value_t newv)

+{

+}

+cvtable_t stream_vtable = { print_stream, relocate_stream, free_stream, NULL };

+int isstream(value_t v)

+{

+    return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == streamtype;

+}

+value_t fl_streamp(value_t *args, uint32_t nargs)

+{

+    argcount("streamp", nargs, 1);

+    return isstream(args[0]) ? T : NIL;

+}

+static ios_t *tostream(value_t v, char *fname)

+{

+    if (!isstream(v))

+        type_error(fname, "stream", v);

+    return (ios_t*)cv_data((cvalue_t*)ptr(v));

+}

+static builtinspec_t streamfunc_info[] = {

+    { "streamp", fl_streamp },

+    { NULL, NULL }

+};

+void stream_init()

+{

+    streamsym = symbol("stream");

+    streamtype = define_opaque_type(streamsym, sizeof(ios_t),

+                                    &stream_vtable, NULL);

+    assign_global_builtins(streamfunc_info);

+}

--- a/femtolisp/system.lsp

+++ b/femtolisp/system.lsp

@@ -1,5 +1,5 @@

 ; femtoLisp standard library

-; by Jeff Bezanson (C) 2008

+; by Jeff Bezanson (C) 2009

 ; Distributed under the BSD License

 ; convert a sequence of body statements to a single expression.

@@ -165,12 +165,12 @@

 (defun listp (a) (or (eq a ()) (consp a)))

-(defun nthcdr (n lst)

+(defun nthcdr (lst n)

   (if (<= n 0) lst

-    (nthcdr (- n 1) (cdr lst))))

+    (nthcdr (cdr lst) (- n 1))))

 (defun list-ref (lst n)

-  (car (nthcdr n lst)))

+  (car (nthcdr lst n)))

 (defun list* l

   (if (atom (cdr l))

@@ -376,11 +376,11 @@

         (cdadr   rplacd   cadr)

         (cddar   rplacd   cdar)

         (cdddr   rplacd   cddr)

+        (list-ref rplaca  nthcdr)

         (get     put      identity)

         (aref    aset     identity)

         (symbol-function   set                identity)

         (symbol-value      set                identity)

-        (symbol-plist      set-symbol-plist   identity)

         (symbol-syntax     set-syntax         identity)))

 (defun setf-place-mutator (place val)

--- a/femtolisp/table.c

+++ b/femtolisp/table.c

@@ -76,10 +76,9 @@

 static htable_t *totable(value_t v, char *fname)

-    if (ishashtable(v))

-        return (htable_t*)cv_data((cvalue_t*)ptr(v));

-    type_error(fname, "table", v);

-    return NULL;

+    if (!ishashtable(v))

+        type_error(fname, "table", v);

+    return (htable_t*)cv_data((cvalue_t*)ptr(v));

 value_t fl_table(value_t *args, uint32_t nargs)

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -834,8 +834,8 @@

 IOStream API

  read             - (read[ stream]) ; get next sexpr from stream

- print, sprint

- princ, sprinc

+ print

+ princ

  iostream         - (stream[ cvalue-as-bytestream])

  file

  stream.eof

--- a/femtolisp/types.c

+++ b/femtolisp/types.c

@@ -93,27 +93,3 @@

-#define mk_primtype(name) \

-  name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init

-void types_init()

-{

-    mk_primtype(int8);

-    mk_primtype(uint8);

-    mk_primtype(int16);

-    mk_primtype(uint16);

-    mk_primtype(int32);

-    mk_primtype(uint32);

-    mk_primtype(int64);

-    mk_primtype(uint64);

-    mk_primtype(long);

-    mk_primtype(ulong);

-    mk_primtype(byte);

-    mk_primtype(wchar);

-    mk_primtype(float);

-    mk_primtype(double);

-    stringtype = get_type(symbol_value(stringtypesym));

-    wcstringtype = get_type(symbol_value(wcstringtypesym));

-}