ref: 626801fd1fdb56ded6070dd424f99d8796053539
parent: 9ed9a5178645a5d8d575351101ecea73e9f82a43
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu Aug 13 23:17:21 EDT 2009
adding => form of cond clauses adding path.exists? R6RS psyntax simple example now works
--- a/femtolisp/aliases.scm
+++ b/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)
@@ -150,6 +154,8 @@
(let ((f (open-output-file name)))
(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))
--- a/femtolisp/builtins.c
+++ b/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 @@
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 @@
{ "rand.float", fl_randf }, { "path.cwd", fl_path_cwd },+ { "path.exists?", fl_path_exists }, { "os.getenv", fl_os_getenv }, { "os.setenv", fl_os_setenv },--- a/femtolisp/flisp.boot
+++ b/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- begin or if])] cond-clauses->if)])]) throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise+ 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 => 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--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -754,7 +754,7 @@
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);
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -72,10 +72,24 @@
(list 'or
(car clause)
(cond-clauses->if (cdr lst)))
- (list 'if
- (car clause)
- (cons 'begin (cdr clause))
- (cond-clauses->if (cdr lst))))))))
+ ; test => expression
+ (if (eq? (cadr clause) '=>)
+ (if (1arg-lambda? (caddr clause))
+ ; 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
- (let ((f (macrocall? e)))
- (if f
- (expand-in (apply f (cdr e)) env)
- (cond ((eq head 'quote) e)
- ((eq head 'lambda) (expand-lambda e env))
- ((eq head 'define) (expand-define e env))
- ((eq head 'let-syntax) (expand-let-syntax e env))
- (else
- (default))))))))))
+ ((macrocall? e) => (lambda (f)
+ (expand-in (apply f (cdr e)) env)))
+ ((eq? head 'quote) e)
+ ((eq? head 'lambda) (expand-lambda e env))
+ ((eq? head 'define) (expand-define e env))
+ ((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
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -887,7 +887,7 @@
*princ-to-string
- path.exists?
+*path.exists?
path.dir?
path.combine
path.parts
--- a/llt/bitvector-ops.c
+++ b/llt/bitvector-ops.c
@@ -122,6 +122,40 @@
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;
--- a/llt/bitvector.c
+++ b/llt/bitvector.c
@@ -57,7 +57,7 @@
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)
@@ -71,38 +71,4 @@
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);
- }
}
--- a/llt/bitvector.h
+++ b/llt/bitvector.h
@@ -33,6 +33,7 @@
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);