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

making list a builtin 

increasing default heapsize, giving better performance

adding hexdump and int2str functions to llt
This commit is contained in:
JeffBezanson 2008-12-31 04:45:08 +00:00
parent 6ed023e966
commit 9716ee3452
8 changed files with 112 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
femtolisp/flisp.c
View File

@ -56,7 +56,7 @@ static char *builtin_names[] =
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
"builtinp", "vectorp", "fixnump", "equal",
"cons", "car", "cdr", "rplaca", "rplacd",
"cons", "list", "car", "cdr", "rplaca", "rplacd",
"eval", "eval*", "apply", "prog1", "raise",
"+", "-", "*", "/", "<", "~", "&", "!", "$",
"vector", "aref", "aset", "length", "assoc", "compare",
@ -95,7 +95,7 @@ static unsigned char *fromspace;
static unsigned char *tospace;
static unsigned char *curheap;
static unsigned char *lim;
static uint32_t heapsize = 256*1024;//bytes
static uint32_t heapsize = 512*1024;//bytes
static uint32_t *consflags;
// error utilities ------------------------------------------------------------
@ -596,6 +596,31 @@ static value_t assoc(value_t item, value_t v)
return NIL;
}
/*
take the final cdr as an argument so the list builtin can give
the same result as (lambda x x).
however, there is still one interesting difference.
(eq a (apply list a)) is always false for nonempty a, while
(eq a (apply (lambda x x) a)) is always true. the justification for this
is that a vararg lambda often needs to recur by applying itself to the
tail of its argument list, so copying the list would be unacceptable.
*/
static void list(value_t *pv, int nargs, value_t *plastcdr)
{
cons_t *c;
int i;
*pv = cons_reserve(nargs);
c = (cons_t*)ptr(*pv);
for(i=SP-nargs; i < (int)SP; i++) {
c->car = Stack[i];
c->cdr = tagptr(c+1, TAG_CONS);
c++;
}
(c-1)->cdr = *plastcdr;
POPN(nargs);
}
#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0))
#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1))
#define tail_eval(xpr) do { SP = saveSP; \
@ -870,6 +895,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
c->cdr = Stack[SP-1];
v = tagptr(c, TAG_CONS);
break;
case F_LIST:
if (nargs) {
Stack[saveSP] = v;
list(&v, nargs, &Stack[saveSP]);
}
// else v is already set to the final cdr, which is the result
break;
case F_CAR:
argcount("car", nargs, 1);
v = car(Stack[SP-1]);
@ -1255,18 +1287,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
PUSH(v);
Stack[saveSP] = cdr_(Stack[saveSP]);
}
nargs = SP-i;
if (nargs) {
Stack[i-1] = cons_reserve(nargs);
c = (cons_t*)ptr(Stack[i-1]);
for(; i < (int)SP; i++) {
c->car = Stack[i];
c->cdr = tagptr(c+1, TAG_CONS);
c++;
}
(c-1)->cdr = Stack[saveSP];
POPN(nargs);
}
if (SP > (uint32_t)i)
list(&Stack[i-1], SP-i, &Stack[saveSP]);
}
}
if (__unlikely(iscons(*argsyms))) {

2
femtolisp/flisp.h
View File

@ -105,7 +105,7 @@ enum {
// functions
F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP,
F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL,
F_CONS, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
F_CONS, F_LIST, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
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_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, F_FOR,

10
femtolisp/system.lsp
View File

@ -2,8 +2,6 @@
; by Jeff Bezanson (C) 2008
; Distributed under the BSD License
(setq list (lambda args args))
; convert a sequence of body statements to a single expression.
; this allows define, defun, defmacro, let, etc. to contain multiple
; body expressions as in Common Lisp.
@ -18,7 +16,7 @@
(list 'lambda args (f-body body)))))
(defmacro label (name fn)
(list (list 'lambda (cons name nil) (list 'setq name fn)) nil))
(list (list 'lambda (list name) (list 'setq name fn)) nil))
; support both CL defun and Scheme-style define
(defmacro defun (name args . body)
@ -463,11 +461,11 @@
(cons 'nconc forms)))))))
(defun bq-bracket (x)
(cond ((atom x) (list cons (bq-process x) nil))
((eq (car x) '*comma*) (list cons (cadr x) nil))
(cond ((atom x) (list list (bq-process x)))
((eq (car x) '*comma*) (list list (cadr x)))
((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
((eq (car x) '*comma-dot*) (cadr x))
(T (list cons (bq-process x) nil))))
(T (list list (bq-process x)))))
; bracket without splicing
(defun bq-bracket1 (x)

2
llt/Makefile
View File

@ -2,7 +2,7 @@ CC = gcc
SRCS = bitvector.c hashing.c socket.c timefuncs.c utils.c dblprint.c ptrhash.c \
utf8.c ios.c operators.c cplxprint.c dirpath.c htable.c \
bitvector-ops.c fp.c
bitvector-ops.c fp.c int2str.c dump.c
OBJS = $(SRCS:%.c=%.o)
DOBJS = $(SRCS:%.c=%.do)
TARGET = libllt.a

41
llt/dump.c Normal file
View File

@ -0,0 +1,41 @@
#include <stdlib.h>
#include "dtypes.h"
#include "ios.h"
#include "utils.h"
static char hexdig[] = "0123456789abcdef";
/*
display a given number of bytes from a buffer, with the first
address label being startoffs
*/
void hexdump(ios_t *dest, char *buffer, size_t len, size_t startoffs)
{
size_t offs=0;
size_t i, pos, nc;
char ch, linebuffer[16];
char hexc[4];
hexc[2] = hexc[3] = ' ';
do {
ios_printf(dest, "%.8x ", offs+startoffs);
pos = 10;
for(i=0; i < 16 && (offs+i) < len; i++) {
ch = buffer[offs + i];
linebuffer[i] = (ch<32 || ch>=0x7f) ? '.' : ch;
hexc[0] = hexdig[((unsigned char)ch)>>4];
hexc[1] = hexdig[ch&0x0f];
nc = (i==7 || i==15) ? 4 : 3;
ios_write(dest, hexc, nc);
pos += nc;
}
for(; i < 16; i++)
linebuffer[i] = ' ';
for(i=0; i < 60-pos; i++)
ios_putc(' ', dest);
ios_putc('|', dest);
ios_write(dest, linebuffer, 16);
ios_write(dest, "|\n", 2);
offs += 16;
} while (offs < len);
}

25
llt/int2str.c Normal file
View File

@ -0,0 +1,25 @@
#include <stdlib.h>
#include "dtypes.h"
char *int2str(char *dest, size_t n, long num, uint32_t base)
{
int i = n-1;
int b = (int)base;
int neg = (num<0 ? 1 : 0);
char ch;
dest[i--] = '\0';
while (i >= 0) {
ch = (char)(num % b);
if (ch < 10)
ch += '0';
else
ch = ch-10+'a';
dest[i--] = ch;
num /= b;
if (num == 0)
break;
}
if (i >= 0 && neg)
dest[i--] = '-';
return &dest[i+1];
}

2
llt/ios.h
View File

@ -103,6 +103,8 @@ int ios_pututf8(ios_t *s, uint32_t wc);
int ios_putstringz(ios_t *s, char *str, bool_t do_write_nulterm);
int ios_printf(ios_t *s, char *format, ...);
void hexdump(ios_t *dest, char *buffer, size_t len, size_t startoffs);
/* high-level stream functions - input */
int ios_getnum(ios_t *s, char *data, uint32_t type);
int ios_getutf8(ios_t *s, uint32_t *pwc);

2
llt/utils.h
View File

@ -45,6 +45,8 @@ void snprint_cplx(char *s, size_t cnt, double re, double im,
// print spaces around sign in a+bi
int spflag);
char *int2str(char *dest, size_t n, long num, uint32_t base);
extern double trunc(double x);
STATIC_INLINE double fpart(double arg)