misc. cleanup

adding without-delimited-continuations

adding skeleton for stream objects

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,14 +301,14 @@ todo:
 
  (let ((x 0))
    (while (< x 10)
-     (progn (#.print x) (setq x (+ 1 x)))))
+     (progn (print x) (setq x (+ 1 x)))))
  =>
   (let ((x 0))
     (reset
      (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)))))

femtolisp/cvalues.c

@@ -827,7 +827,8 @@ value_t cbuiltin(char *name, builtin_t f)
 #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 @@ void cvalues_init()
     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(""));

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
 */
 

femtolisp/stream.c

@@ -0,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);
+}

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)

femtolisp/table.c

@@ -76,10 +76,9 @@ value_t fl_tablep(value_t *args, uint32_t nargs)
 
 static htable_t *totable(value_t v, char *fname)
 {
-    if (ishashtable(v))
+    if (!ishashtable(v))
-        return (htable_t*)cv_data((cvalue_t*)ptr(v));
+        type_error(fname, "table", v);
-    type_error(fname, "table", v);
+    return (htable_t*)cv_data((cvalue_t*)ptr(v));
-    return NULL;
 }
 
 value_t fl_table(value_t *args, uint32_t nargs)

femtolisp/todo

@@ -834,8 +834,8 @@ String API
 IOStream API
 
  read             - (read[ stream]) ; get next sexpr from stream
- print, sprint
+ print
- princ, sprinc
+ princ
  iostream         - (stream[ cvalue-as-bytestream])
  file
  stream.eof

femtolisp/types.c

@@ -93,27 +93,3 @@ void relocate_typetable()
         }
     }
 }
-
-#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));
-}