From 626801fd1fdb56ded6070dd424f99d8796053539 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 14 Aug 2009 03:17:21 +0000 Subject: [PATCH] adding => form of cond clauses adding path.exists? R6RS psyntax simple example now works --- femtolisp/aliases.scm | 6 ++++++ femtolisp/builtins.c | 15 +++++++++++++++ femtolisp/flisp.boot | 12 ++++++++---- femtolisp/print.c | 2 +- femtolisp/system.lsp | 42 +++++++++++++++++++++++++++--------------- femtolisp/todo | 2 +- llt/bitvector-ops.c | 34 ++++++++++++++++++++++++++++++++++ llt/bitvector.c | 36 +----------------------------------- llt/bitvector.h | 1 + 9 files changed, 94 insertions(+), 56 deletions(-) diff --git a/femtolisp/aliases.scm b/femtolisp/aliases.scm index 0b0fb84..b9be536 100644 --- 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) @@ -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) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index aeaf55f..3d457ca 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -11,6 +11,7 @@ #include #include #include +#include #include #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 }, diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index 5a9c141..5c84dae 100644 --- 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 diff --git a/femtolisp/print.c b/femtolisp/print.c index 7544cd5..82e1e2c 100644 --- a/femtolisp/print.c +++ b/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); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 7d20026..5adcc6c 100644 --- 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 diff --git a/femtolisp/todo b/femtolisp/todo index 4af4753..7e581b7 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -887,7 +887,7 @@ IOStream API *princ-to-string - path.exists? +*path.exists? path.dir? path.combine path.parts diff --git a/llt/bitvector-ops.c b/llt/bitvector-ops.c index 7f42576..82e6b27 100644 --- a/llt/bitvector-ops.c +++ b/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)<>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)<