shithub: femtolisp

--- a/femtolisp/aliases.scm

+++ b/femtolisp/aliases.scm

@@ -13,6 +13,7 @@

 			    (equal? (car x) "noexpand"))

 		       (cadr x)

 		       x)))))

+(define (command-line) *argv*)

 (define gensym

   (let (($gensym gensym))

@@ -61,6 +62,8 @@

 (define char>? >)

 (define char<=? <=)

 (define char>=? >=)

+(define (char-whitespace? c) (not (not (string.find *whitespace* c))))

+(define (char-numeric? c) (not (not (string.find "0123456789" c))))

 (define string=? eqv?)

 (define string<? <)

@@ -94,6 +97,7 @@

 (define close-input-port io.close)

 (define close-output-port io.close)

 (define (read-char (s *input-stream*)) (io.getc s))

+(define (peek-char (s *input-stream*)) (io.peekc s))

 (define (write-char c (s *output-stream*)) (io.putc s c))

 (define (port-eof? p) (io.eof? p))

 (define (open-input-string str)

@@ -109,8 +113,9 @@

 (define (get-output-string b)

   (let ((p (io.pos b)))

     (io.seek b 0)

-    (prog1 (io.readall b)

-	   (io.seek b p))))

+    (let ((s (io.readall b)))

+      (io.seek b p)

+      (if (eof-object? s) "" s))))

 (define (open-input-file name) (file name :read))

 (define (open-output-file name) (file name :write :create))

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -713,7 +713,12 @@

 int isnumber(value_t v)

-    return (isfixnum(v) || iscprim(v));

+    if (isfixnum(v)) return 1;

+    if (iscprim(v)) {

+        cprim_t *c = (cprim_t*)ptr(v);

+        return c->type != wchartype;

+    }

+    return 0;

 // read -----------------------------------------------------------------------

@@ -1230,7 +1235,7 @@

             Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;

         OP(OP_NUMBERP)

             v = Stack[SP-1];

-            Stack[SP-1] = (isfixnum(v) || iscprim(v) ? FL_T:FL_F); NEXT_OP;

+            Stack[SP-1] = (isnumber(v) ? FL_T:FL_F); NEXT_OP;

         OP(OP_FIXNUMP)

             Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;

         OP(OP_BOUNDP)

@@ -2145,6 +2150,7 @@

     setc(symbol("eq"), builtin(OP_EQ));

     setc(symbol("procedure?"), builtin(OP_FUNCTIONP));

+    setc(symbol("top-level-bound?"), builtin(OP_BOUNDP));

 #ifdef LINUX

     setc(symbol("*os-name*"), symbol("linux"));

--- a/femtolisp/iostream.c

+++ b/femtolisp/iostream.c

@@ -134,6 +134,16 @@

     return mk_wchar(wc);

+value_t fl_iopeekc(value_t *args, u_int32_t nargs)

+{

+    argcount("io.peekc", nargs, 1);

+    ios_t *s = toiostream(args[0], "io.peekc");

+    uint32_t wc;

+    if (ios_peekutf8(s, &wc) == IOS_EOF)

+        return FL_EOF;

+    return mk_wchar(wc);

+}

 value_t fl_ioputc(value_t *args, u_int32_t nargs)

     argcount("io.putc", nargs, 2);

@@ -397,6 +407,7 @@

     { "io.pos",   fl_iopos },

     { "io.getc" , fl_iogetc },

     { "io.putc" , fl_ioputc },

+    { "io.peekc" , fl_iopeekc },

     { "io.discardbuffer", fl_iopurge },

     { "io.read", fl_ioread },

     { "io.write", fl_iowrite },

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -54,7 +54,7 @@

   * (nconc x) => x  for any x

   . (copy-list (list|append|nconc ...)) => (list|append|nconc ...)

   * (apply vector (list ...)) => (vector ...)

-  . (nconc (cons x nil) y) => (cons x y)

+  * (nconc (cons x nil) y) => (cons x y)

 * let form without initializers (let (a b) ...), defaults to nil

 * print (quote a) as 'a, same for ` etc.

@@ -975,7 +975,7 @@

 * fix make-system-image to save aliases of builtins

 * reading named characters, e.g. #\newline etc.

 - #+, #- reader macros

-- printing improvements: *print-big*, keep track of horiz. position

+- printing improvements: *print-length*, keep track of horiz. position

   per-stream so indenting works across print calls

 - remaining c types

 - remaining cvalues functions

--- a/llt/ios.c

+++ b/llt/ios.c

@@ -247,6 +247,8 @@

         if (s->bm == bm_mem || s->fd == -1) {

             // can't get any more data

             s->bpos += avail;

+            if (avail == 0 && n > 0)

+                s->_eof = 1;

             return avail;

@@ -450,7 +452,7 @@

 int ios_eof(ios_t *s)

     if (s->bm == bm_mem)

-        return (s->bpos >= s->size);

+        return (s->_eof ? 1 : 0);

     if (s->fd == -1)

         return 1;

     if (s->_eof)

@@ -817,6 +819,7 @@

     if (s->bpos > 0) {

         s->bpos--;

         s->buf[s->bpos] = (char)c;

+        s->_eof = 0;

         return c;

     if (s->size == s->maxsize) {

@@ -826,6 +829,7 @@

     memmove(s->buf + 1, s->buf, s->size);

     s->buf[0] = (char)c;

     s->size++;

+    s->_eof = 0;

     return c;

@@ -853,6 +857,29 @@

     size_t i = s->bpos;

     *pwc = u8_nextchar(s->buf, &i);

     ios_read(s, buf, sz+1);

+    return 1;

+}

+int ios_peekutf8(ios_t *s, uint32_t *pwc)

+{

+    int c;

+    size_t sz;

+    char c0;

+    char buf[8];

+    c = ios_peekc(s);

+    if (c == IOS_EOF)

+        return IOS_EOF;

+    c0 = (char)c;

+    sz = u8_seqlen(&c0)-1;

+    if (sz == 0) {

+        *pwc = (uint32_t)c0;

+        return 1;

+    }

+    if (ios_readprep(s, sz) < sz)

+        return IOS_EOF;

+    size_t i = s->bpos;

+    *pwc = u8_nextchar(s->buf, &i);

     return 1;

--- a/llt/ios.h

+++ b/llt/ios.h

@@ -110,6 +110,7 @@

 /* high-level stream functions - input */

 int ios_getnum(ios_t *s, char *data, uint32_t type);

 int ios_getutf8(ios_t *s, uint32_t *pwc);

+int ios_peekutf8(ios_t *s, uint32_t *pwc);

 int ios_ungetutf8(ios_t *s, uint32_t wc);

 int ios_getstringz(ios_t *dest, ios_t *src);

 int ios_getstringn(ios_t *dest, ios_t *src, size_t nchars);