diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 39ca59b..b5da9b1 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -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))) { diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index f5ed0c9..f5a58dc 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -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, diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 343da22..8bf252b 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -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) diff --git a/llt/Makefile b/llt/Makefile index 9176538..b59a617 100644 --- a/llt/Makefile +++ b/llt/Makefile @@ -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 diff --git a/llt/dump.c b/llt/dump.c new file mode 100644 index 0000000..59a6050 --- /dev/null +++ b/llt/dump.c @@ -0,0 +1,41 @@ +#include +#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); +} diff --git a/llt/int2str.c b/llt/int2str.c new file mode 100644 index 0000000..7f87960 --- /dev/null +++ b/llt/int2str.c @@ -0,0 +1,25 @@ +#include +#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]; +} diff --git a/llt/ios.h b/llt/ios.h index 44e801f..c3b6de6 100644 --- a/llt/ios.h +++ b/llt/ios.h @@ -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); diff --git a/llt/utils.h b/llt/utils.h index 26f8f53..1a532a4 100644 --- a/llt/utils.h +++ b/llt/utils.h @@ -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)