conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

making nconc, assq, and memq builtins 

some small optimizations to string.map, string.trim,
string.inc, string.dec, aref
This commit is contained in:
JeffBezanson 2009-03-17 03:29:17 +00:00
parent 5681745bc3
commit 5edb75af2c
7 changed files with 113 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
femtolisp/builtins.c
View File

@ -26,7 +26,59 @@ size_t llength(value_t v)
return n;
}
value_t fl_exit(value_t *args, u_int32_t nargs)
static value_t fl_nconc(value_t *args, u_int32_t nargs)
{
if (nargs == 0)
return NIL;
value_t first=NIL;
value_t *pcdr = &first;
cons_t *c;
int a;
for(a=0; a < (int)nargs-1; a++) {
if (iscons(args[a])) {
*pcdr = args[a];
c = (cons_t*)ptr(args[a]);
while (iscons(c->cdr))
c = (cons_t*)ptr(c->cdr);
pcdr = &c->cdr;
}
else if (args[a] != NIL) {
type_error("nconc", "cons", args[a]);
}
}
*pcdr = args[a];
return first;
}
static value_t fl_assq(value_t *args, u_int32_t nargs)
{
argcount("assq", nargs, 2);
value_t item = args[0];
value_t v = args[1];
value_t bind;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == item)
return bind;
v = cdr_(v);
}
return FL_F;
}
static value_t fl_memq(value_t *args, u_int32_t nargs)
{
argcount("memq", nargs, 2);
while (iscons(args[1])) {
cons_t *c = (cons_t*)ptr(args[1]);
if (c->car == args[0])
return args[1];
args[1] = c->cdr;
}
return FL_F;
}
static value_t fl_exit(value_t *args, u_int32_t nargs)
{
if (nargs > 0)
exit(tofixnum(args[0], "exit"));
@ -34,7 +86,7 @@ value_t fl_exit(value_t *args, u_int32_t nargs)
return NIL;
}
value_t fl_intern(value_t *args, u_int32_t nargs)
static value_t fl_intern(value_t *args, u_int32_t nargs)
{
argcount("intern", nargs, 1);
if (!isstring(args[0]))
@ -42,7 +94,7 @@ value_t fl_intern(value_t *args, u_int32_t nargs)
return symbol(cvalue_data(args[0]));
}
value_t fl_setconstant(value_t *args, u_int32_t nargs)
static value_t fl_setconstant(value_t *args, u_int32_t nargs)
{
argcount("set-constant!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-constant!");
@ -55,7 +107,7 @@ value_t fl_setconstant(value_t *args, u_int32_t nargs)
extern value_t LAMBDA;
value_t fl_setsyntax(value_t *args, u_int32_t nargs)
static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
{
argcount("set-syntax!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-syntax!");
@ -73,7 +125,7 @@ value_t fl_setsyntax(value_t *args, u_int32_t nargs)
return args[1];
}
value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
static value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
{
argcount("symbol-syntax", nargs, 1);
symbol_t *sym = tosymbol(args[0], "symbol-syntax");
@ -111,7 +163,7 @@ static void global_env_assoc_list(symbol_t *root, value_t *pv)
extern symbol_t *symtab;
value_t fl_syntax_env(value_t *args, u_int32_t nargs)
static value_t fl_syntax_env(value_t *args, u_int32_t nargs)
{
(void)args;
argcount("syntax-environment", nargs, 0);
@ -130,7 +182,7 @@ value_t fl_global_env(value_t *args, u_int32_t nargs)
extern value_t QUOTE;
value_t fl_constantp(value_t *args, u_int32_t nargs)
static value_t fl_constantp(value_t *args, u_int32_t nargs)
{
argcount("constant?", nargs, 1);
if (issymbol(args[0]))
@ -143,7 +195,7 @@ value_t fl_constantp(value_t *args, u_int32_t nargs)
return FL_T;
}
value_t fl_integerp(value_t *args, u_int32_t nargs)
static value_t fl_integerp(value_t *args, u_int32_t nargs)
{
argcount("integer?", nargs, 1);
value_t v = args[0];
@ -172,7 +224,7 @@ value_t fl_integerp(value_t *args, u_int32_t nargs)
return FL_F;
}
value_t fl_fixnum(value_t *args, u_int32_t nargs)
static value_t fl_fixnum(value_t *args, u_int32_t nargs)
{
argcount("fixnum", nargs, 1);
if (isfixnum(args[0])) {
@ -194,7 +246,7 @@ value_t fl_fixnum(value_t *args, u_int32_t nargs)
lerror(ArgError, "fixnum: cannot convert argument");
}
value_t fl_truncate(value_t *args, u_int32_t nargs)
static value_t fl_truncate(value_t *args, u_int32_t nargs)
{
argcount("truncate", nargs, 1);
if (isfixnum(args[0]))
@ -217,7 +269,7 @@ value_t fl_truncate(value_t *args, u_int32_t nargs)
type_error("truncate", "number", args[0]);
}
value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
{
fixnum_t i;
value_t f, v;
@ -239,7 +291,7 @@ value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
return v;
}
value_t fl_time_now(value_t *args, u_int32_t nargs)
static value_t fl_time_now(value_t *args, u_int32_t nargs)
{
argcount("time.now", nargs, 0);
(void)args;
@ -258,7 +310,7 @@ static double todouble(value_t a, char *fname)
type_error(fname, "number", a);
}
value_t fl_time_string(value_t *args, uint32_t nargs)
static value_t fl_time_string(value_t *args, uint32_t nargs)
{
argcount("time.string", nargs, 1);
double t = todouble(args[0], "time.string");
@ -267,7 +319,7 @@ value_t fl_time_string(value_t *args, uint32_t nargs)
return string_from_cstr(buf);
}
value_t fl_path_cwd(value_t *args, uint32_t nargs)
static value_t fl_path_cwd(value_t *args, uint32_t nargs)
{
if (nargs > 1)
argcount("path.cwd", nargs, 1);
@ -282,7 +334,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs)
return FL_T;
}
value_t fl_os_getenv(value_t *args, uint32_t nargs)
static value_t fl_os_getenv(value_t *args, uint32_t nargs)
{
argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv");
@ -293,7 +345,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs)
return cvalue_static_cstring(val);
}
value_t fl_os_setenv(value_t *args, uint32_t nargs)
static value_t fl_os_setenv(value_t *args, uint32_t nargs)
{
argcount("os.setenv", nargs, 2);
char *name = tostring(args[0], "os.setenv");
@ -310,7 +362,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
return FL_T;
}
value_t fl_rand(value_t *args, u_int32_t nargs)
static value_t fl_rand(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
fixnum_t r;
@ -321,7 +373,7 @@ value_t fl_rand(value_t *args, u_int32_t nargs)
#endif
return fixnum(r);
}
value_t fl_rand32(value_t *args, u_int32_t nargs)
static value_t fl_rand32(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
ulong r = random();
@ -331,18 +383,18 @@ value_t fl_rand32(value_t *args, u_int32_t nargs)
return mk_uint32(r);
#endif
}
value_t fl_rand64(value_t *args, u_int32_t nargs)
static value_t fl_rand64(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
uint64_t r = (((uint64_t)random())<<32) | random();
return mk_uint64(r);
}
value_t fl_randd(value_t *args, u_int32_t nargs)
static value_t fl_randd(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
return mk_double(rand_double());
}
value_t fl_randf(value_t *args, u_int32_t nargs)
static value_t fl_randf(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
return mk_float(rand_float());
@ -365,6 +417,9 @@ static builtinspec_t builtin_info[] = {
{ "fixnum", fl_fixnum },
{ "truncate", fl_truncate },
{ "integer?", fl_integerp },
{ "nconc", fl_nconc },
{ "assq", fl_assq },
{ "memq", fl_memq },
{ "vector.alloc", fl_vector_alloc },

24
femtolisp/cvalues.c
View File

@ -275,7 +275,7 @@ num_init(uint64, uint64, T_UINT64)
num_init(float, double, T_FLOAT)
num_init(double, double, T_DOUBLE)
#define num_ctor(typenam, ctype, tag) \
#define num_ctor_init(typenam, ctype, tag) \
value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
{ \
if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \
@ -284,7 +284,9 @@ value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
args[0], cp_data((cprim_t*)ptr(cp)))) \
type_error(#typenam, "number", args[0]); \
return cp; \
} \
}
#define num_ctor_ctor(typenam, ctype, tag) \
value_t mk_##typenam(ctype##_t n) \
{ \
value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \
@ -292,6 +294,10 @@ value_t mk_##typenam(ctype##_t n) \
return cp; \
}
#define num_ctor(typenam, ctype, tag) \
num_ctor_init(typenam, ctype, tag) \
num_ctor_ctor(typenam, ctype, tag)
num_ctor(int8, int8, T_INT8)
num_ctor(uint8, uint8, T_UINT8)
num_ctor(int16, int16, T_INT16)
@ -823,8 +829,20 @@ static value_t cvalue_array_aref(value_t *args)
{
char *data; ulong_t index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
value_t el = cvalue(eltype, eltype->size);
value_t el;
numerictype_t nt = eltype->numtype;
if (nt >= T_INT32)
el = cvalue(eltype, eltype->size);
check_addr_args("aref", args[0], args[1], &data, &index);
if (nt < T_INT32) {
if (nt == T_INT8)
return fixnum((int8_t)data[index]);
else if (nt == T_UINT8)
return fixnum((uint8_t)data[index]);
else if (nt == T_INT16)
return fixnum(((int16_t*)data)[index]);
return fixnum(((uint16_t*)data)[index]);
}
char *dest = cptr(el);
size_t sz = eltype->size;
if (sz == 1)

20
femtolisp/flisp.c
View File

@ -71,7 +71,7 @@ static char *builtin_names[] =
"compare",
// sequences
"vector", "aref", "aset!", "length", "assq", "for",
"vector", "aref", "aset!", "length", "for",
"", "", "" };
#define N_STACK 98304
@ -608,20 +608,6 @@ int isnumber(value_t v)
// eval -----------------------------------------------------------------------
// return a cons element of v whose car is item
static value_t assq(value_t item, value_t v)
{
value_t bind;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == item)
return bind;
v = cdr_(v);
}
return FL_F;
}
/*
take the final cdr as an argument so the list builtin can give
the same result as (lambda x x).
@ -1299,10 +1285,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
lerror(ArgError, "prog1: too few arguments");
v = Stack[saveSP+1];
break;
case F_ASSQ:
argcount("assq", nargs, 2);
v = assq(Stack[SP-2], Stack[SP-1]);
break;
case F_FOR:
argcount("for", nargs, 3);
lo = tofixnum(Stack[SP-3], "for");

2
femtolisp/flisp.h
View File

@ -112,7 +112,7 @@ enum {
F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH,
F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR,
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR,
F_TRUE, F_FALSE, F_NIL,
N_BUILTINS,
};

4
femtolisp/string.c
View File

@ -264,7 +264,7 @@ value_t fl_string_inc(value_t *args, u_int32_t nargs)
while (cnt--) {
if (i >= len)
bounds_error("string.inc", args[0], args[1]);
u8_inc(s, &i);
(void)(isutf(s[++i]) || isutf(s[++i]) || isutf(s[++i]) || ++i);
}
return size_wrap(i);
}
@ -285,7 +285,7 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs)
while (cnt--) {
if (i == 0)
bounds_error("string.dec", args[0], args[1]);
u8_dec(s, &i);
(void)(isutf(s[--i]) || isutf(s[--i]) || isutf(s[--i]) || --i);
}
return size_wrap(i);
}

35
femtolisp/system.lsp
View File

@ -60,14 +60,6 @@
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
#f))
(define (nconc . lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
((null? (car lsts)) (apply nconc (cdr lsts)))
(#t (prog1 (car lsts)
(set-cdr! (last (car lsts))
(apply nconc (cdr lsts)))))))
(define (append . lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
@ -81,10 +73,6 @@
(cond ((atom? lst) #f)
((equal? (car lst) item) lst)
(#t (member item (cdr lst)))))
(define (memq item lst)
(cond ((atom? lst) #f)
((eq? (car lst) item) lst)
(#t (memq item (cdr lst)))))
(define (memv item lst)
(cond ((atom? lst) #f)
((eqv? (car lst) item) lst)
@ -121,9 +109,6 @@
(define (cadr x) (car (cdr x)))
;(set! *special-forms* '(quote cond if and or while lambda trycatch
; set! begin))
(define (macroexpand e)
((label mexpand
(lambda (e env f)
@ -574,27 +559,27 @@
(define (string.trim s at-start at-end)
(define (trim-start s chars i L)
(if (and (< i L)
(string.find chars (string.char s i)))
(trim-start s chars (string.inc s i) L)
(if (and (#.< i L)
(#.string.find chars (#.string.char s i)))
(trim-start s chars (#.string.inc s i) L)
i))
(define (trim-end s chars i)
(if (and (> i 0)
(string.find chars (string.char s (string.dec s i))))
(trim-end s chars (string.dec s i))
(#.string.find chars (#.string.char s (#.string.dec s i))))
(trim-end s chars (#.string.dec s i))
i))
(let ((L (length s)))
(let ((L (#.length s)))
(string.sub s
(trim-start s at-start 0 L)
(trim-end s at-end L))))
(define (string.map f s)
(let ((b (buffer))
(n (length s)))
(n (#.length s)))
(let ((i 0))
(while (< i n)
(begin (io.putc b (f (string.char s i)))
(set! i (string.inc s i)))))
(while (#.< i n)
(begin (#.io.putc b (f (#.string.char s i)))
(set! i (#.string.inc s i)))))
(io.tostring! b)))
(define (print-to-string v)

4
femtolisp/todo
View File

@ -137,6 +137,8 @@ for internal use:
instead, unless the value is part of an aggregate (e.g. struct).
. this avoids allocating a new type for every size.
. and/or add function array.alloc
x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
. this made no difference in a string.map microbenchmark
bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains
@ -957,8 +959,6 @@ consolidated todo list as of 8/30:
- eliminate string copy in lerror() when possible
* fix printing lists of short strings
- preallocate all byte,int8,uint8 values, and some wchars
- remaining c types
- remaining cvalues functions
- finish ios