lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

adding => form of cond clauses 

adding path.exists?
R6RS psyntax simple example now works
This commit is contained in:
JeffBezanson 2009-08-14 03:17:21 +00:00
parent 9ed9a51786
commit 626801fd1f
9 changed files with 94 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
femtolisp/aliases.scm
View File

@ -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)

15
femtolisp/builtins.c
View File

@ -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 },

12
femtolisp/flisp.boot
View File

@ -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

2
femtolisp/print.c
View File

@ -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);

42
femtolisp/system.lsp
View File

@ -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

2
femtolisp/todo
View File

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

34
llt/bitvector-ops.c
View File

@ -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;

36
llt/bitvector.c
View File

@ -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);
}
}

1
llt/bitvector.h
View File

@ -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);