adding => form of cond clauses

adding path.exists?
R6RS psyntax simple example now works

femtolisp/aliases.scm

@@ -14,6 +14,10 @@
 		       (cadr x)
 		       x)))))
 
+(define gensym
+  (let (($gensym gensym))
+    (lambda ((x #f)) ($gensym))))
+
 (define vector-ref aref)
 (define vector-set! aset!)
 (define vector-length length)
@@ -151,6 +155,8 @@
     (prog1 (proc f)
 	   (io.close f))))
 
+(define (file-exists? f) (path.exists? f))
+
 (define (display x (port *output-stream*))
   (with-output-to port (princ x))
   #t)

femtolisp/builtins.c

@@ -11,6 +11,7 @@
 #include <ctype.h>
 #include <sys/types.h>
 #include <sys/time.h>
+#include <sys/stat.h>
 #include <errno.h>
 #include "llt.h"
 #include "flisp.h"
@@ -350,6 +351,19 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
     return FL_T;
 }
 
+#ifdef WIN32
+#define stat _stat
+#endif
+static value_t fl_path_exists(value_t *args, uint32_t nargs)
+{
+    argcount("path.exists?", nargs, 1);
+    char *str = tostring(args[0], "path.exists?");
+    struct stat sbuf;
+    if (stat(str, &sbuf) == -1)
+        return FL_F;
+    return FL_T;
+}
+
 static value_t fl_os_getenv(value_t *args, uint32_t nargs)
 {
     argcount("os.getenv", nargs, 1);
@@ -453,6 +467,7 @@ static builtinspec_t builtin_info[] = {
     { "rand.float", fl_randf },
 
     { "path.cwd", fl_path_cwd },
+    { "path.exists?", fl_path_exists },
 
     { "os.getenv", fl_os_getenv },
     { "os.setenv", fl_os_setenv },

femtolisp/flisp.boot

@@ -12,8 +12,10 @@
   lambda prog1 trycatch begin raise]) gensym])  define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax!
   quote nconc lambda copy-list])  receive #fn("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values
   lambda nconc copy-list])  unless #fn("=000s1c0|^c1}KL4;" [if begin])  let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6;0c0~|L3530|}K;" [label])
-  nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;^;" [])])])  cond #fn("9000s0c0q^41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else
+  nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;^;" [])])])  cond #fn("9000s0c0q^41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn("<000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;|\x84c3\x82W0e4e5|31316A0c6qe7e5|313141;c8qe93041;c:|Mc1|NKi10~N31L4;" [else
-  begin or if])] cond-clauses->if)])])  throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise
+  begin or => 1arg-lambda? caddr #fn("=000r1c0|~ML2L1c1|c2e3e4~3131Ki20i10N31L4L3;" [let
+  if begin cddr caddr]) caadr #fn("<000r1c0|~ML2L1c1|e2~31|L2i20i10N31L4L3;" [let
+  if caddr]) gensym if])] cond-clauses->if)])])  throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise
   list quote thrown-value])  time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let
   time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym])  let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc
   lambda copy-list caar let* cadar])  case #fn(":000s1c0q^41;" [#fn("7000r1c0m02c1qe23041;" [#fn(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else
@@ -111,7 +113,7 @@
   keyargs emit-optional-arg-inits > 255 largc lvargc vargc argc compile-in
   lastcdr caddr ret values function encode-byte-code bcode:code
   const-to-idx-vec]) filter keyword-arg?]) length]) length]) make-code-emitter
-  lastcdr lambda-vars filter #.pair? lambda])] #0=[#:g697 ()])
+  lastcdr lambda-vars filter #.pair? lambda])] #0=[#:g701 ()])
 	  compile-for #fn(":000r5e0g4316X0e1|}^g2342e1|}^g3342e1|}^g4342e2|c342;e4c541;" [1arg-lambda?
   compile-in emit for error "for: third form must be a 1-argument lambda"] compile-for)
 	  compile-if #fn("<000r4c0qe1|31e1|31g3\x84e2g331e3g331F6;0e4g331530^45;" [#fn("=000r5g2]\x82>0e0~\x7fi02g344;g2^\x82>0e0~\x7fi02g444;e0~\x7f^g2342e1~c2|332e0~\x7fi02g3342i026<0e1~c3325:0e1~c4}332e5~|322e0~\x7fi02g4342e5~}42;" [compile-in
@@ -266,7 +268,9 @@
 						    *directory-separator*
 						    *argv* that *print-pretty*
 						    *print-width*
-						    *print-readably*)] make-system-image)
+						    *print-readably*
+						    *print-level*
+						    *print-length*)] make-system-image)
 	  map #fn(";000s2c0q^41;" [#fn("9000r1c0qm02i02\x85<0e1~\x7f_L143;|~\x7fi02K42;" [#fn("=000r2}M\x8540_;|e0c1}_L133Q2~|e0c2}_L13332K;" [map1
   #.car #.cdr] mapn) map1])] map)
 	  map! #fn("9000r2}^}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int

femtolisp/print.c

@@ -754,7 +754,7 @@ void print(ios_t *f, value_t v)
     fl_print_child(f, v);
 
     if (print_level >= 0 || print_length >= 0) {
-        bitvector_fill(consflags, 0, 0, heapsize/sizeof(cons_t));
+        memset(consflags, 0, 4*bitvector_nwords(heapsize/sizeof(cons_t)));
     }
 
     htable_reset(&printconses, 32);

femtolisp/system.lsp

@@ -72,10 +72,24 @@
 		  (list 'or
 			(car clause)
 			(cond-clauses->if (cdr lst)))
-		  (list 'if
+		  ; test => expression
-			(car clause)
+		  (if (eq? (cadr clause) '=>)
-			(cons 'begin (cdr clause))
+		      (if (1arg-lambda? (caddr clause))
-			(cond-clauses->if (cdr lst))))))))
+			  ; test => (lambda (x) ...)
+			  (let ((var (caadr (caddr clause))))
+			    `(let ((,var ,(car clause)))
+			       (if ,var ,(cons 'begin (cddr (caddr clause)))
+				   ,(cond-clauses->if (cdr lst)))))
+			  ; test => proc
+			  (let ((b (gensym)))
+			    `(let ((,b ,(car clause)))
+			       (if ,b
+				   (,(caddr clause) ,b)
+				   ,(cond-clauses->if (cdr lst))))))
+		      (list 'if
+			    (car clause)
+			    (cons 'begin (cdr clause))
+			    (cond-clauses->if (cdr lst)))))))))
   (cond-clauses->if clauses))
 
 ; standard procedures ---------------------------------------------------------
@@ -797,16 +811,13 @@
 		     (not (symbol? head))
 		     (bound? head))
 		 (default))
-		(else
+		((macrocall? e) =>      (lambda (f)
-		 (let ((f (macrocall? e)))
+				          (expand-in (apply f (cdr e)) env)))
-		   (if f
+		((eq? head 'quote)      e)
-		       (expand-in (apply f (cdr e)) env)
+		((eq? head 'lambda)     (expand-lambda e env))
-		       (cond ((eq head 'quote)      e)
+		((eq? head 'define)     (expand-define e env))
-			     ((eq head 'lambda)     (expand-lambda e env))
+		((eq? head 'let-syntax) (expand-let-syntax e env))
-			     ((eq head 'define)     (expand-define e env))
+		(else                   (default))))))
-			     ((eq head 'let-syntax) (expand-let-syntax e env))
-			     (else
-			      (default))))))))))
   (expand-in e ()))
 
 (define (eval x) ((compile-thunk (expand x))))
@@ -949,7 +960,8 @@
 (define (make-system-image fname)
   (let ((f (file fname :write :create :truncate))
 	(excludes '(*linefeed* *directory-separator* *argv* that
-			       *print-pretty* *print-width* *print-readably*)))
+			       *print-pretty* *print-width* *print-readably*
+			       *print-level* *print-length*)))
     (with-bindings ((*print-pretty* #t)
 		    (*print-readably* #t))
       (let ((syms

femtolisp/todo

@@ -887,7 +887,7 @@ IOStream API
 *princ-to-string
 
 
- path.exists?
+*path.exists?
  path.dir?
  path.combine
  path.parts

llt/bitvector-ops.c

@@ -122,6 +122,40 @@ void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s,
         dest[i] = sc;
 }
 
+// set nbits to c, starting at given bit offset
+// assumes offs < 32
+void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c, u_int32_t nbits)
+{
+    index_t i;
+    u_int32_t nw, tail;
+    u_int32_t mask;
+
+    if (nbits == 0) return;
+    nw = (offs+nbits+31)>>5;
+
+    if (nw == 1) {
+        mask = (lomask(nbits)<<offs);
+        if (c) b[0]|=mask; else b[0]&=(~mask);
+        return;
+    }
+
+    mask = lomask(offs);
+    if (c) b[0]|=(~mask); else b[0]&=mask;
+
+    if (c) mask=ONES32; else mask = 0;
+    for(i=1; i < nw-1; i++)
+        b[i] = mask;
+
+    tail = (offs+nbits)&31;
+    if (tail==0) {
+        b[i] = mask;
+    }
+    else {
+        mask = lomask(tail);
+        if (c) b[i]|=mask; else b[i]&=(~mask);
+    }
+}
+
 void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
 {
     index_t i;

llt/bitvector.c

@@ -57,7 +57,7 @@ u_int32_t *bitvector_new(u_int64_t n, int initzero)
 
 size_t bitvector_nwords(u_int64_t nbits)
 {
-    return ((nbits+31)>>5) * 4;
+    return ((nbits+31)>>5);
 }
 
 void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c)
@@ -72,37 +72,3 @@ u_int32_t bitvector_get(u_int32_t *b, u_int64_t n)
 {
     return b[n>>5] & (1<<(n&31));
 }
-
-// set nbits to c, starting at given bit offset
-// assumes offs < 32
-void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c, u_int32_t nbits)
-{
-    index_t i;
-    u_int32_t nw, tail;
-    u_int32_t mask;
-
-    if (nbits == 0) return;
-    nw = (offs+nbits+31)>>5;
-
-    if (nw == 1) {
-        mask = (lomask(nbits)<<offs);
-        if (c) b[0]|=mask; else b[0]&=(~mask);
-        return;
-    }
-
-    mask = lomask(offs);
-    if (c) b[0]|=(~mask); else b[0]&=mask;
-
-    if (c) mask=ONES32; else mask = 0;
-    for(i=1; i < nw-1; i++)
-        b[i] = mask;
-
-    tail = (offs+nbits)&31;
-    if (tail==0) {
-        b[i] = mask;
-    }
-    else {
-        mask = lomask(tail);
-        if (c) b[i]|=mask; else b[i]&=(~mask);
-    }
-}

llt/bitvector.h

@@ -33,6 +33,7 @@ u_int32_t bitreverse(u_int32_t x);
 
 u_int32_t *bitvector_new(u_int64_t n, int initzero);
 u_int32_t *bitvector_resize(u_int32_t *b, u_int64_t n, int initzero);
+size_t bitvector_nwords(u_int64_t nbits);
 void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c);
 u_int32_t bitvector_get(u_int32_t *b, u_int64_t n);