cleanup, making infinities optional, fixing build for plan9

config.scm

@@ -108,7 +108,8 @@
          car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr
          cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
          caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
-         null? list? list length append reverse list-tail list-ref memq memv
+         null? list? list length append reverse reverse!
+         list-tail list-ref memq memv
          member assq assv assoc symbol? symbol->string string->symbol char?
          char=? char<? char>? char<=? char>=? char-ci=? char-ci<? char-ci>?
          char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace?

eval.c

@@ -1976,12 +1976,14 @@ static sexp sexp_close_port (sexp ctx, sexp port) {
   return SEXP_VOID;
 }
 
+#ifndef PLAN9
 static sexp sexp_file_exists_p (sexp ctx, sexp path) {
   struct stat buf;
   if (! sexp_stringp(path))
     return sexp_type_exception(ctx, "not a string", path);
   return (stat(sexp_string_data(path), &buf) ?  SEXP_FALSE : SEXP_TRUE);
 }
+#endif
 
 void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) {
   sexp x;

include/chibi/config.h

@@ -53,6 +53,10 @@
 /*   and write flonums directly through the sexp API. */
 /* #define USE_FLONUMS 0 */
 
+/* uncomment this to disable reading/writing IEEE infinities */
+/*   By default you can read/write +inf.0, -inf.0 and +nan.0 */
+/* #define USE_INFINITIES 0 */
+
 /* uncomment this if you want immediate flonums */
 /*   This is experimental, enablde at your own risk. */
 /* #define USE_IMMEDIATE_FLONUMS 1 */
@@ -177,6 +181,14 @@
 #define USE_FLONUMS 1
 #endif
 
+#ifndef USE_INFINITIES
+#if defined(PLAN9) || ! USE_FLONUMS
+#define USE_INFINITIES 0
+#else
+#define USE_INFINITIES 1
+#endif
+#endif
+
 #ifndef USE_IMMEDIATE_FLONUMS
 #define USE_IMMEDIATE_FLONUMS 0
 #endif

lib/srfi/1.module

@@ -19,11 +19,11 @@
    lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
    lset-diff+intersection lset-diff+intersection!)
   (import (scheme))
-  (include "srfi/1/constructors.scm"
+  (include "srfi/1/predicates.scm"
-           "srfi/1/predicates.scm"
            "srfi/1/selectors.scm"
-           "srfi/1/misc.scm"
            "srfi/1/search.scm"
+           "srfi/1/misc.scm"
+           "srfi/1/constructors.scm"
            "srfi/1/fold.scm"
            "srfi/1/deletion.scm"
            "srfi/1/alists.scm"

lib/srfi/1/fold.scm

@@ -59,7 +59,7 @@
             (let lp ((ls (cdr rev-ls)) (res (car rev-ls)))
               (if (null? ls) res (lp (cdr ls) (append (f (car ls) res))))
               )))
-      (if (and (pair? ls) (every pair lists))
+      (if (and (pair? ls) (every pair? lists))
           (let lp ((lists (cons ls lists)))
             (let ((vals (apply f (map car lists)))
                   (cdrs (map cdr lists)))

lib/srfi/1/misc.scm

@@ -3,18 +3,11 @@
   (let lp ((ls ls) (res init))
     (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res)))))
 
-(define (length+ x)
-  (if (not (pair? x))
-      0
-      (let lp ((hare (cdr x)) (tortoise x) (res 0))
-        (and (not (eq? hare tortoise))
-             (if (pair? hare)
-                 (lp (cddr hare) (cdr tortoise) (+ res 1))
-                 res)))))
-
 (define (append! . lists) (concatenate! lists))
 
-(define (concatenate lists) (reduce-right append '() lists))
+(define (concatenate lists)
+  (let lp ((ls (reverse lists)) (res '()))
+    (if (null? ls) res (lp (cdr ls) (append (car ls) res)))))
 
 (define (concatenate! lists)
   (if (null? lists)
@@ -45,7 +38,7 @@
   (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls)))
 (define (unzip5 ls)
   (values (map car ls) (map cadr ls) (map caddr ls)
-          (map cadddr ls) (map fifth ls)))
+          (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls)))
 
 (define (count pred ls . lists)
   (if (null? lists)

lib/srfi/1/predicates.scm

@@ -29,3 +29,11 @@
               (and (eq (car ls1) (car ls2))
                    (lp2 (cdr ls1) (cdr ls2))))))))
 
+(define (length+ x)
+  (if (not (pair? x))
+      0
+      (let lp ((hare (cdr x)) (tortoise x) (res 0))
+        (and (not (eq? hare tortoise))
+             (if (pair? hare)
+                 (lp (cddr hare) (cdr tortoise) (+ res 1))
+                 res)))))

opcodes.c

@@ -86,7 +86,6 @@ _FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file),
 _FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file),
 _FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port),
 _FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port),
-_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p),
 _FN0("make-environment", 0, sexp_make_env),
 _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env),
 _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env),
@@ -142,5 +141,6 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex
 #if PLAN9
 #include "opt/plan9-opcodes.c"
 #endif
+_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p),
 };
 

opt/plan9.c

@@ -3,21 +3,30 @@
 /*  BSD-style license: http://synthcode.com/license.txt  */
 
 sexp sexp_rand (sexp ctx) {
-  return sexp_make_integer(rand());
+  return sexp_make_fixnum(rand());
 }
 
 sexp sexp_srand (sexp ctx, sexp seed) {
-  srand(sexp_unbox_integer(seed));
+  srand(sexp_unbox_fixnum(seed));
   return SEXP_VOID;
 }
 
+sexp sexp_file_exists_p (sexp ctx, sexp path) {
+  int res;
+  uchar statbuf[STATMAX];
+  if (! sexp_stringp(path))
+    return sexp_type_exception(ctx, "file-exists?: not a string", path);
+  res = stat(sexp_string_data(path), statbuf, sizeof(statbuf));
+  return (res < 0) ? SEXP_FALSE : SEXP_TRUE;
+}
+
 sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) {
   FILE *f;
   if (! sexp_integerp(fd))
     return sexp_type_exception(ctx, "fdopen: not an integer", fd);
   if (! sexp_stringp(mode))
     return sexp_type_exception(ctx, "fdopen: not a mode string", mode);
-  f = fdopen(sexp_unbox_integer(fd), sexp_string_data(mode));
+  f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode));
   if (! f)
     return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd);
   /* maybe use fd2path to get the name of the fd */
@@ -30,15 +39,15 @@ sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) {
 sexp sexp_fileno (sexp ctx, sexp port) {
   if (! sexp_portp(port))
     return sexp_type_exception(ctx, "fileno: not a port", port);
-  return sexp_make_integer(fileno(sexp_port_stream(port)));
+  return sexp_make_fixnum(fileno(sexp_port_stream(port)));
 }
 
 sexp sexp_fork (sexp ctx) {
-  return sexp_make_integer(fork());
+  return sexp_make_fixnum(fork());
 }
 
 sexp sexp_exec (sexp ctx, sexp name, sexp args) {
-  int i, len = sexp_unbox_integer(sexp_length(ctx, args));
+  int i, len = sexp_unbox_fixnum(sexp_length(ctx, args));
   char **argv = malloc((len+1)*sizeof(char*));
   for (i=0; i<len; i++, args=sexp_cdr(args))
     argv[i] = sexp_string_data(sexp_car(args));
@@ -53,20 +62,20 @@ void sexp_exits (sexp ctx, sexp msg) {
 }
 
 sexp sexp_dup (sexp ctx, sexp oldfd, sexp newfd) {
-  return sexp_make_integer(dup(sexp_unbox_integer(oldfd),
+  return sexp_make_fixnum(dup(sexp_unbox_fixnum(oldfd),
-                               sexp_unbox_integer(newfd)));
+                               sexp_unbox_fixnum(newfd)));
 }
 
 sexp sexp_pipe (sexp ctx) {
   int fds[2];
   pipe(fds);
-  return sexp_list2(ctx, sexp_make_integer(fds[0]), sexp_make_integer(fds[1]));
+  return sexp_list2(ctx, sexp_make_fixnum(fds[0]), sexp_make_fixnum(fds[1]));
 }
 
 sexp sexp_sleep (sexp ctx, sexp msecs) {
   if (! sexp_integerp(msecs))
     return sexp_type_exception(ctx, "sleep: not an integer", msecs);
-  sleep(sexp_unbox_integer(msecs));
+  sleep(sexp_unbox_fixnum(msecs));
   return SEXP_VOID;
 }
 
@@ -106,7 +115,7 @@ sexp sexp_wait (sexp ctx) {     /* just return (pid msg) */
   sexp_gc_preserve(ctx, msg, s_msg);
   wmsg = wait();
   msg = sexp_c_string(ctx, wmsg->msg, -1);
-  res = sexp_list2(ctx, sexp_make_integer(wmsg->pid), msg);
+  res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg);
   sexp_gc_release(ctx, msg, s_msg);
   return res;
 }
@@ -116,7 +125,7 @@ sexp sexp_postnote (sexp ctx, sexp pid, sexp note) {
     return sexp_type_exception(ctx, "postnote: not an integer", pid);
   if (! sexp_stringp(note))
     return sexp_type_exception(ctx, "postnote: not a string", note);
-  postnote(PNPROC, sexp_unbox_integer(pid), sexp_string_data(note));
+  postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note));
   return SEXP_VOID;
 }
 
@@ -303,28 +312,30 @@ sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) {
   s.destroyreq = &sexp_9p_destroyreq;
   s.end = &sexp_9p_end;
   postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt),
-               sexp_unbox_integer(flags));
+               sexp_unbox_fixnum(flags));
   return SEXP_UNDEF;
 }
 
 sexp sexp_9p_req_offset (sexp ctx, sexp req) {
-  return sexp_make_integer(ctx, (Req*)sexp_cpointer_value(req)->ifcall.offset);
+  return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset);
 }
 
 sexp sexp_9p_req_count (sexp ctx, sexp req) {
-  return sexp_make_integer(ctx, (Req*)sexp_cpointer_value(req)->ifcall.count);
+  return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count);
 }
 
+#if 0
 sexp sexp_9p_req_path (sexp ctx, sexp req) {
-  return sexp_c_string(ctx, (Req*)sexp_cpointer_value(req)->fid.qid.path, -1);
+  return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1);
 }
+#endif
 
 sexp sexp_9p_req_fid (sexp ctx, sexp req) {
-  return sexp_make_cpointer(ctx, (Req*)sexp_cpointer_value(req)->fid);
+  return sexp_make_cpointer(ctx, ((Req*)sexp_cpointer_value(req))->fid);
 }
 
 sexp sexp_9p_req_newfid (sexp ctx, sexp req) {
-  return sexp_make_cpointer(ctx, (Req*)sexp_cpointer_value(req)->newfid);
+  return sexp_make_cpointer(ctx, ((Req*)sexp_cpointer_value(req))->newfid);
 }
 
 sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) {

sexp.c

@@ -976,10 +976,13 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
 #if ! USE_IMMEDIATE_FLONUMS
     case SEXP_FLONUM:
       f = sexp_flonum_value(obj);
+#if USE_INFINITIES
       if (isinf(f) || isnan(f)) {
         numbuf[0] = (isinf(f) && f < 0 ? '-' : '+');
         strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0");
-      } else {
+      } else
+#endif
+      {
         i = sprintf(numbuf, "%.15g", f);
         if (f == trunc(f) && ! strchr(numbuf, '.')) {
           numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
@@ -1039,10 +1042,13 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
 #if USE_IMMEDIATE_FLONUMS
   } else if (sexp_flonump(obj)) {
     f = sexp_flonum_value(obj);
+#if USE_INFINITIES
     if (isinf(f) || isnan(f)) {
       numbuf[0] = (isinf(f) && f < 0 ? '-' : '+');
       strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0");
-    } else {
+    } else
+#endif
+    {
       i = sprintf(numbuf, "%.15g", f);
       if (f == trunc(f) && ! strchr(numbuf, '.')) {
         numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
@@ -1485,7 +1491,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
     } else {
       sexp_push_char(ctx, c2, in);
       res = sexp_read_symbol(ctx, in, c1, 1);
-#if USE_FLONUMS
+#if USE_INFINITIES
       if (res == sexp_intern(ctx, "+inf.0"))
         res = sexp_make_flonum(ctx, 1.0/0.0);
       else if (res == sexp_intern(ctx, "-inf.0"))