adding support for eof-object

renaming exported symbol NIL to FL_NIL
making default vector fill #f
some misc. cleanup

femtolisp/aliases.scm

@@ -39,6 +39,7 @@
 (define (exact? x) (integer? x))
 (define (inexact? x) (not (exact? x)))
 (define quotient div0)
+(define remainder mod0)
 (define (inexact x) x)
 (define (exact x)
   (if (exact? x) x
@@ -90,6 +91,7 @@
 (define close-output-port io.close)
 (define (read-char (s *input-stream*)) (io.getc s))
 (define (write-char c (s *output-stream*)) (io.putc s c))
+(define (port-eof? p) (io.eof? p))
 (define (open-input-string str)
   (let ((b (buffer)))
     (io.write b str)

femtolisp/builtins.c

@@ -29,8 +29,8 @@ size_t llength(value_t v)
 static value_t fl_nconc(value_t *args, u_int32_t nargs)
 {
     if (nargs == 0)
-        return NIL;
+        return FL_NIL;
-    value_t lst, first=NIL;
+    value_t lst, first=FL_NIL;
     value_t *pcdr = &first;
     cons_t *c;
     uint32_t i=0;
@@ -44,7 +44,7 @@ static value_t fl_nconc(value_t *args, u_int32_t nargs)
                 c = (cons_t*)ptr(c->cdr);
             pcdr = &c->cdr;
         }
-        else if (lst != NIL) {
+        else if (lst != FL_NIL) {
             type_error("nconc", "cons", lst);
         }
     }
@@ -100,7 +100,7 @@ static value_t fl_length(value_t *args, u_int32_t nargs)
         if (cv_class(cv)->eltype != NULL)
             return size_wrap(cvalue_arraylen(a));
     }
-    else if (a == NIL) {
+    else if (a == FL_NIL) {
         return fixnum(0);
     }
     else if (iscons(a)) {
@@ -120,7 +120,7 @@ static value_t fl_exit(value_t *args, u_int32_t nargs)
     if (nargs > 0)
         exit(tofixnum(args[0], "exit"));
     exit(0);
-    return NIL;
+    return FL_NIL;
 }
 
 static value_t fl_symbol(value_t *args, u_int32_t nargs)
@@ -173,7 +173,7 @@ value_t fl_global_env(value_t *args, u_int32_t nargs)
 {
     (void)args;
     argcount("environment", nargs, 0);
-    value_t lst = NIL;
+    value_t lst = FL_NIL;
     fl_gc_handle(&lst);
     global_env_list(symtab, &lst);
     fl_free_gc_handles(1);
@@ -286,9 +286,9 @@ static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
     if (nargs == 2)
         f = args[1];
     else
-        f = NIL;
+        f = FL_F;
-    v = alloc_vector((unsigned)i, f==NIL);
+    v = alloc_vector((unsigned)i, f==FL_F);
-    if (f != NIL) {
+    if (f != FL_F) {
         int k;
         for(k=0; k < i; k++)
             vector_elt(v,k) = f;

femtolisp/color.lsp

@@ -84,6 +84,6 @@
   (let ((result ()))
     (dotimes (x 25)
       (dotimes (y 25)
-        (if (and (/= x y) (can-attack x y))
+        (if (and (not (= x y)) (can-attack x y))
             (set! result (cons (cons x y) result)) ())))
     result))

femtolisp/cvalues.c

@@ -638,6 +638,8 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
             return booleansym;
         if (args[0] == NIL)
             return nullsym;
+        if (args[0] == FL_EOF)
+            return symbol("eof-object");
         if (isbuiltin(args[0]))
             return builtinsym;
         return FUNCTION;

femtolisp/flisp.c

@@ -89,13 +89,12 @@ static uint32_t curr_frame = 0;
 static value_t *GCHandleStack[N_GC_HANDLES];
 static uint32_t N_GCHND = 0;
 
-value_t NIL, FL_T, FL_F;
+value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
 value_t printwidthsym, printreadablysym, printprettysym;
 
-value_t QUOTE;
+static value_t NIL, LAMBDA, IF, TRYCATCH;
-static value_t LAMBDA, IF, TRYCATCH;
 static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
 
 static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
@@ -378,7 +377,7 @@ value_t alloc_vector(size_t n, int init)
     if (init) {
         unsigned int i;
         for(i=0; i < n; i++)
-            vector_elt(v, i) = NIL;
+            vector_elt(v, i) = FL_F;
     }
     return v;
 }
@@ -1242,7 +1241,8 @@ static value_t apply_cl(uint32_t nargs)
             NEXT_OP;
         OP(OP_FUNCTIONP)
             v = Stack[SP-1];
-            Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&v!=FL_F&&v!=FL_T&&v!=NIL) ||
+            Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&
+                            (uintval(v)<=OP_ASET || v>(N_BUILTINS<<3))) ||
                            iscbuiltin(v)) ? FL_T : FL_F;
             NEXT_OP;
         OP(OP_VECTORP)
@@ -2100,9 +2100,10 @@ static void lisp_init(void)
     N_STACK = 262144;
     Stack = malloc(N_STACK*sizeof(value_t));
 
-    NIL = builtin(OP_THE_EMPTY_LIST);
+    FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);
     FL_T = builtin(OP_BOOL_CONST_T);
     FL_F = builtin(OP_BOOL_CONST_F);
+    FL_EOF = builtin(OP_EOF_OBJECT);
     LAMBDA = symbol("lambda");        FUNCTION = symbol("function");
     QUOTE = symbol("quote");          TRYCATCH = symbol("trycatch");
     BACKQUOTE = symbol("backquote");  COMMA = symbol("*comma*");

femtolisp/flisp.h

@@ -56,7 +56,7 @@ typedef struct _symbol_t {
 #define issymbol(x)  (tag(x) == TAG_SYM)
 #define isfixnum(x)  (((x)&3) == TAG_NUM)
 #define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
-#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && (x) < (OP_BOOL_CONST_T<<3))
+#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && uintval(x) <= OP_ASET)
 #define isvector(x) (tag(x) == TAG_VECTOR)
 #define iscvalue(x) (tag(x) == TAG_CVALUE)
 #define iscprim(x)  (tag(x) == TAG_CPRIM)
@@ -113,7 +113,7 @@ void fl_free_gc_handles(uint32_t n);
 
 #define N_BUILTINS ((int)N_OPCODES)
 
-extern value_t NIL, FL_T, FL_F;
+extern value_t FL_NIL, FL_T, FL_F, FL_EOF;
 
 /* read, eval, print main entry points */
 value_t read_sexpr(value_t f);

femtolisp/iostream.c

@@ -49,6 +49,19 @@ value_t fl_iostreamp(value_t *args, uint32_t nargs)
     return isiostream(args[0]) ? FL_T : FL_F;
 }
 
+value_t fl_eof_object(value_t *args, uint32_t nargs)
+{
+    (void)args;
+    argcount("eof-object", nargs, 0);
+    return FL_EOF;
+}
+
+value_t fl_eof_objectp(value_t *args, uint32_t nargs)
+{
+    argcount("eof-object?", nargs, 1);
+    return (FL_EOF == args[0]) ? FL_T : FL_F;
+}
+
 static ios_t *toiostream(value_t v, char *fname)
 {
     if (!isiostream(v))
@@ -101,8 +114,11 @@ value_t fl_read(value_t *args, u_int32_t nargs)
     else {
         arg = args[0];
     }
-    (void)toiostream(arg, "read");
+    ios_t *s = toiostream(arg, "read");
-    return read_sexpr(arg);
+    value_t v = read_sexpr(arg);
+    if (ios_eof(s))
+        return FL_EOF;
+    return v;
 }
 
 value_t fl_iogetc(value_t *args, u_int32_t nargs)
@@ -111,7 +127,8 @@ value_t fl_iogetc(value_t *args, u_int32_t nargs)
     ios_t *s = toiostream(args[0], "io.getc");
     uint32_t wc;
     if (ios_getutf8(s, &wc) == IOS_EOF)
-        lerror(IOError, "io.getc: end of file reached");
+        //lerror(IOError, "io.getc: end of file reached");
+        return FL_EOF;
     return mk_wchar(wc);
 }
 
@@ -215,7 +232,8 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
     else data = cp_data((cprim_t*)ptr(cv));
     size_t got = ios_read(value2c(ios_t*,args[0]), data, n);
     if (got < n)
-        lerror(IOError, "io.read: end of input reached");
+        //lerror(IOError, "io.read: end of input reached");
+        return FL_EOF;
     return cv;
 }
 
@@ -306,7 +324,7 @@ value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
     }
     ((char*)cv->data)[n] = '\0';
     if (n == 0 && ios_eof(src))
-        return FL_F;
+        return FL_EOF;
     return str;
 }
 
@@ -345,7 +363,7 @@ value_t stream_to_string(value_t *ps)
     else {
         char *b = ios_takebuf(st, &n); n--;
         b[n] = '\0';
-        str = cvalue_from_ref(stringtype, b, n, NIL);
+        str = cvalue_from_ref(stringtype, b, n, FL_NIL);
         cv_autorelease((cvalue_t*)ptr(str));
     }
     return str;
@@ -362,6 +380,8 @@ value_t fl_iotostring(value_t *args, u_int32_t nargs)
 
 static builtinspec_t iostreamfunc_info[] = {
     { "iostream?", fl_iostreamp },
+    { "eof-object", fl_eof_object },
+    { "eof-object?", fl_eof_objectp },
     { "dump", fl_dump },
     { "file", fl_file },
     { "buffer", fl_buffer },
@@ -399,9 +419,9 @@ void iostream_init()
     assign_global_builtins(iostreamfunc_info);
 
     setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout,
-                                             sizeof(ios_t), NIL));
+                                             sizeof(ios_t), FL_NIL));
     setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr,
-                                             sizeof(ios_t), NIL));
+                                             sizeof(ios_t), FL_NIL));
     setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin,
-                                             sizeof(ios_t), NIL));
+                                             sizeof(ios_t), FL_NIL));
 }

femtolisp/opcodes.h

@@ -29,7 +29,7 @@ enum {
     OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
     OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
 
-    OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
+    OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_EOF_OBJECT,
 
     N_OPCODES
 };

femtolisp/print.c

@@ -386,9 +386,12 @@ void fl_print_child(ios_t *f, value_t v)
         else if (v == FL_F) {
             outsn("#f", f, 2);
         }
-        else if (v == NIL) {
+        else if (v == FL_NIL) {
             outsn("()", f, 2);
         }
+        else if (v == FL_EOF) {
+            outsn("#<eof>", f, 6);
+        }
         else if (isbuiltin(v)) {
             if (!print_princ)
                 outsn("#.", f, 2);

femtolisp/string.c

@@ -151,7 +151,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
     size_t len = cv_len((cvalue_t*)ptr(args[0]));
     size_t dlen = cv_len((cvalue_t*)ptr(args[1]));
     size_t ssz, tokend=0, tokstart=0, i=0;
-    value_t first=NIL, c=NIL, last;
+    value_t first=FL_NIL, c=FL_NIL, last;
     size_t junk;
     fl_gc_handle(&first);
     fl_gc_handle(&last);
@@ -164,7 +164,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
             tokend = i;
         ssz = tokend - tokstart;
         last = c;  // save previous cons cell
-        c = fl_cons(cvalue_string(ssz), NIL);
+        c = fl_cons(cvalue_string(ssz), FL_NIL);
 
         // we've done allocation; reload movable pointers
         s = cv_data((cvalue_t*)ptr(args[0]));
@@ -173,7 +173,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
         if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
 
         // link new cell
-        if (last == NIL)
+        if (last == FL_NIL)
             first = c;   // first time, save first cons
         else
             ((cons_t*)ptr(last))->cdr = c;

femtolisp/system.lsp

@@ -97,7 +97,6 @@
 	((eqv?       (caar lst) item) (car lst))
 	(#t          (assv item (cdr lst)))))
 
-(define (/= a b) (not (= a b)))
 (define (>  a b) (< b a))
 (define (<= a b) (or (< a b) (= a b)))
 (define (>= a b) (or (< b a) (= a b)))
@@ -116,8 +115,6 @@
 				  -1))
 			 0)))
 (define (mod x y) (- x (* (div x y) y)))
-(define quotient div0)
-(define remainder mod0)
 (define (random n)
   (if (integer? n)
       (mod (rand) n)
@@ -547,7 +544,10 @@
 (define (io.readall s)
   (let ((b (buffer)))
     (io.copy b s)
-    (io.tostring! b)))
+    (let ((str (io.tostring! b)))
+      (if (and (equal? str "") (io.eof? s))
+	  (eof-object)
+	  str))))
 
 (define-macro (with-output-to stream . body)
   `(with-bindings ((*output-stream* ,stream))
@@ -777,7 +777,7 @@
       (if p
 	  (symbol (string.join (map string (reverse! p)) "/"))
 	  'lambda)))
-  (let ((st (reverse! (list-tail st 5)))
+  (let ((st (reverse! (list-tail st (if *interactive* 5 4))))
 	(e (filter closure? (map (lambda (s) (and (bound? s)
 						  (top-level-value s)))
 				 (environment))))
@@ -883,8 +883,10 @@
   (__init_globals)
   (if (pair? (cdr argv))
       (begin (set! *argv* (cdr argv))
+	     (set! *interactive* #f)
 	     (__script (cadr argv)))
       (begin (set! *argv* argv)
+	     (set! *interactive* #t)
 	     (princ *banner*)
 	     (repl)))
   (exit 0))

femtolisp/table.c

@@ -99,7 +99,7 @@ value_t fl_table(value_t *args, uint32_t nargs)
     htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt));
     htable_new(h, cnt/2);
     uint32_t i;
-    value_t k=NIL, arg=NIL;
+    value_t k=FL_NIL, arg=FL_NIL;
     FOR_ARGS(i,0,arg,args) {
         if (i&1)
             equalhash_put(h, (void*)k, (void*)arg);

femtolisp/unittest.lsp

@@ -152,6 +152,9 @@
 (assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
 
 ; keyword arguments
+(assert (keyword? kw:))
+(assert (not (keyword? 'kw)))
+(assert (not (keyword? ':)))
 (assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
 		'(1 0 0 (8 4 5))))
 (assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
@@ -178,6 +181,16 @@
 (assert (not (equal? (string (gensym)) (string (gensym)))))
 (let ((gs (gensym))) (assert (eq? gs gs)))
 
+; eof object
+(assert (eof-object? (eof-object)))
+(assert (not (eof-object? 1)))
+(assert (not (eof-object? 'a)))
+(assert (not (eof-object? '())))
+(assert (not (eof-object? #f)))
+(assert (not (null? (eof-object))))
+(assert (not (builtin? (eof-object))))
+(assert (not (function? (eof-object))))
+
 ; ok, a couple end-to-end tests as well
 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
 (assert (equal? (fib 20) 6765))