ref: 9716ee3452a1d573990ae94dc6a842f683c3bd6e
parent: 6ed023e96610bc5d1ebcba9ea9601734b94729f8
author: JeffBezanson <[email protected]>
date: Tue Dec 30 23:45:08 EST 2008
making list a builtin increasing default heapsize, giving better performance adding hexdump and int2str functions to llt
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -56,7 +56,7 @@
"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 *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 @@
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 @@
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 @@
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))) {--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -105,7 +105,7 @@
// 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,
--- 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)
--- a/llt/Makefile
+++ b/llt/Makefile
@@ -2,7 +2,7 @@
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
--- /dev/null
+++ b/llt/dump.c
@@ -1,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);
+}
--- /dev/null
+++ b/llt/int2str.c
@@ -1,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];
+}
--- a/llt/ios.h
+++ b/llt/ios.h
@@ -103,6 +103,8 @@
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);
--- a/llt/utils.h
+++ b/llt/utils.h
@@ -45,6 +45,8 @@
// 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)