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

adding support for eof-object 

renaming exported symbol NIL to FL_NIL
making default vector fill #f
some misc. cleanup
This commit is contained in:
JeffBezanson 2009-08-09 18:04:03 +00:00
parent 51f645a916
commit 929ec92a65
14 changed files with 82 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/aliases.scm
View File

@ -39,6 +39,7 @@
(define (exact? x) (integer? x))
(define (inexact? x) (not (exact? x)))
(define quotient div0)
(define remainder mod0)
(define (inexact x) x)
(define (exact x)
(if (exact? x) x
@ -90,6 +91,7 @@
(define close-output-port io.close)
(define (read-char (s *input-stream*)) (io.getc s))
(define (write-char c (s *output-stream*)) (io.putc s c))
(define (port-eof? p) (io.eof? p))
(define (open-input-string str)
(let ((b (buffer)))
(io.write b str)

18
femtolisp/builtins.c
View File

@ -29,8 +29,8 @@ size_t llength(value_t v)
static value_t fl_nconc(value_t *args, u_int32_t nargs)
{
if (nargs == 0)
return NIL;
value_t lst, first=NIL;
return FL_NIL;
value_t lst, first=FL_NIL;
value_t *pcdr = &first;
cons_t *c;
uint32_t i=0;
@ -44,7 +44,7 @@ static value_t fl_nconc(value_t *args, u_int32_t nargs)
c = (cons_t*)ptr(c->cdr);
pcdr = &c->cdr;
}
else if (lst != NIL) {
else if (lst != FL_NIL) {
type_error("nconc", "cons", lst);
}
}
@ -100,7 +100,7 @@ static value_t fl_length(value_t *args, u_int32_t nargs)
if (cv_class(cv)->eltype != NULL)
return size_wrap(cvalue_arraylen(a));
}
else if (a == NIL) {
else if (a == FL_NIL) {
return fixnum(0);
}
else if (iscons(a)) {
@ -120,7 +120,7 @@ static value_t fl_exit(value_t *args, u_int32_t nargs)
if (nargs > 0)
exit(tofixnum(args[0], "exit"));
exit(0);
return NIL;
return FL_NIL;
}
static value_t fl_symbol(value_t *args, u_int32_t nargs)
@ -173,7 +173,7 @@ value_t fl_global_env(value_t *args, u_int32_t nargs)
{
(void)args;
argcount("environment", nargs, 0);
value_t lst = NIL;
value_t lst = FL_NIL;
fl_gc_handle(&lst);
global_env_list(symtab, &lst);
fl_free_gc_handles(1);
@ -286,9 +286,9 @@ static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
if (nargs == 2)
f = args[1];
else
f = NIL;
v = alloc_vector((unsigned)i, f==NIL);
if (f != NIL) {
f = FL_F;
v = alloc_vector((unsigned)i, f==FL_F);
if (f != FL_F) {
int k;
for(k=0; k < i; k++)
vector_elt(v,k) = f;

2
femtolisp/color.lsp
View File

@ -84,6 +84,6 @@
(let ((result ()))
(dotimes (x 25)
(dotimes (y 25)
(if (and (/= x y) (can-attack x y))
(if (and (not (= x y)) (can-attack x y))
(set! result (cons (cons x y) result)) ())))
result))

2
femtolisp/cvalues.c
View File

@ -638,6 +638,8 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
return booleansym;
if (args[0] == NIL)
return nullsym;
if (args[0] == FL_EOF)
return symbol("eof-object");
if (isbuiltin(args[0]))
return builtinsym;
return FUNCTION;

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

13
femtolisp/flisp.c
View File

@ -89,13 +89,12 @@ static uint32_t curr_frame = 0;
static value_t *GCHandleStack[N_GC_HANDLES];
static uint32_t N_GCHND = 0;
value_t NIL, FL_T, FL_F;
value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
value_t printwidthsym, printreadablysym, printprettysym;
value_t QUOTE;
static value_t LAMBDA, IF, TRYCATCH;
static value_t NIL, LAMBDA, IF, TRYCATCH;
static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
@ -378,7 +377,7 @@ value_t alloc_vector(size_t n, int init)
if (init) {
unsigned int i;
for(i=0; i < n; i++)
vector_elt(v, i) = NIL;
vector_elt(v, i) = FL_F;
}
return v;
}
@ -1242,7 +1241,8 @@ static value_t apply_cl(uint32_t nargs)
NEXT_OP;
OP(OP_FUNCTIONP)
v = Stack[SP-1];
Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&v!=FL_F&&v!=FL_T&&v!=NIL) ||
Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&
(uintval(v)<=OP_ASET || v>(N_BUILTINS<<3))) ||
iscbuiltin(v)) ? FL_T : FL_F;
NEXT_OP;
OP(OP_VECTORP)
@ -2100,9 +2100,10 @@ static void lisp_init(void)
N_STACK = 262144;
Stack = malloc(N_STACK*sizeof(value_t));
NIL = builtin(OP_THE_EMPTY_LIST);
FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);
FL_T = builtin(OP_BOOL_CONST_T);
FL_F = builtin(OP_BOOL_CONST_F);
FL_EOF = builtin(OP_EOF_OBJECT);
LAMBDA = symbol("lambda"); FUNCTION = symbol("function");
QUOTE = symbol("quote"); TRYCATCH = symbol("trycatch");
BACKQUOTE = symbol("backquote"); COMMA = symbol("*comma*");

4
femtolisp/flisp.h
View File

@ -56,7 +56,7 @@ typedef struct _symbol_t {
#define issymbol(x) (tag(x) == TAG_SYM)
#define isfixnum(x) (((x)&3) == TAG_NUM)
#define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && (x) < (OP_BOOL_CONST_T<<3))
#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && uintval(x) <= OP_ASET)
#define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (tag(x) == TAG_CVALUE)
#define iscprim(x) (tag(x) == TAG_CPRIM)
@ -113,7 +113,7 @@ void fl_free_gc_handles(uint32_t n);
#define N_BUILTINS ((int)N_OPCODES)
extern value_t NIL, FL_T, FL_F;
extern value_t FL_NIL, FL_T, FL_F, FL_EOF;
/* read, eval, print main entry points */
value_t read_sexpr(value_t f);

38
femtolisp/iostream.c
View File

@ -49,6 +49,19 @@ value_t fl_iostreamp(value_t *args, uint32_t nargs)
return isiostream(args[0]) ? FL_T : FL_F;
}
value_t fl_eof_object(value_t *args, uint32_t nargs)
{
(void)args;
argcount("eof-object", nargs, 0);
return FL_EOF;
}
value_t fl_eof_objectp(value_t *args, uint32_t nargs)
{
argcount("eof-object?", nargs, 1);
return (FL_EOF == args[0]) ? FL_T : FL_F;
}
static ios_t *toiostream(value_t v, char *fname)
{
if (!isiostream(v))
@ -101,8 +114,11 @@ value_t fl_read(value_t *args, u_int32_t nargs)
else {
arg = args[0];
}
(void)toiostream(arg, "read");
return read_sexpr(arg);
ios_t *s = toiostream(arg, "read");
value_t v = read_sexpr(arg);
if (ios_eof(s))
return FL_EOF;
return v;
}
value_t fl_iogetc(value_t *args, u_int32_t nargs)
@ -111,7 +127,8 @@ value_t fl_iogetc(value_t *args, u_int32_t nargs)
ios_t *s = toiostream(args[0], "io.getc");
uint32_t wc;
if (ios_getutf8(s, &wc) == IOS_EOF)
lerror(IOError, "io.getc: end of file reached");
//lerror(IOError, "io.getc: end of file reached");
return FL_EOF;
return mk_wchar(wc);
}
@ -215,7 +232,8 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
else data = cp_data((cprim_t*)ptr(cv));
size_t got = ios_read(value2c(ios_t*,args[0]), data, n);
if (got < n)
lerror(IOError, "io.read: end of input reached");
//lerror(IOError, "io.read: end of input reached");
return FL_EOF;
return cv;
}
@ -306,7 +324,7 @@ value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
}
((char*)cv->data)[n] = '\0';
if (n == 0 && ios_eof(src))
return FL_F;
return FL_EOF;
return str;
}
@ -345,7 +363,7 @@ value_t stream_to_string(value_t *ps)
else {
char *b = ios_takebuf(st, &n); n--;
b[n] = '\0';
str = cvalue_from_ref(stringtype, b, n, NIL);
str = cvalue_from_ref(stringtype, b, n, FL_NIL);
cv_autorelease((cvalue_t*)ptr(str));
}
return str;
@ -362,6 +380,8 @@ value_t fl_iotostring(value_t *args, u_int32_t nargs)
static builtinspec_t iostreamfunc_info[] = {
{ "iostream?", fl_iostreamp },
{ "eof-object", fl_eof_object },
{ "eof-object?", fl_eof_objectp },
{ "dump", fl_dump },
{ "file", fl_file },
{ "buffer", fl_buffer },
@ -399,9 +419,9 @@ void iostream_init()
assign_global_builtins(iostreamfunc_info);
setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout,
sizeof(ios_t), NIL));
sizeof(ios_t), FL_NIL));
setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr,
sizeof(ios_t), NIL));
sizeof(ios_t), FL_NIL));
setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin,
sizeof(ios_t), NIL));
sizeof(ios_t), FL_NIL));
}

2
femtolisp/opcodes.h
View File

@ -29,7 +29,7 @@ enum {
OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_EOF_OBJECT,
N_OPCODES
};

5
femtolisp/print.c
View File

@ -386,9 +386,12 @@ void fl_print_child(ios_t *f, value_t v)
else if (v == FL_F) {
outsn("#f", f, 2);
}
else if (v == NIL) {
else if (v == FL_NIL) {
outsn("()", f, 2);
}
else if (v == FL_EOF) {
outsn("#<eof>", f, 6);
}
else if (isbuiltin(v)) {
if (!print_princ)
outsn("#.", f, 2);

6
femtolisp/string.c
View File

@ -151,7 +151,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
size_t len = cv_len((cvalue_t*)ptr(args[0]));
size_t dlen = cv_len((cvalue_t*)ptr(args[1]));
size_t ssz, tokend=0, tokstart=0, i=0;
value_t first=NIL, c=NIL, last;
value_t first=FL_NIL, c=FL_NIL, last;
size_t junk;
fl_gc_handle(&first);
fl_gc_handle(&last);
@ -164,7 +164,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
tokend = i;
ssz = tokend - tokstart;
last = c; // save previous cons cell
c = fl_cons(cvalue_string(ssz), NIL);
c = fl_cons(cvalue_string(ssz), FL_NIL);
// we've done allocation; reload movable pointers
s = cv_data((cvalue_t*)ptr(args[0]));
@ -173,7 +173,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
// link new cell
if (last == NIL)
if (last == FL_NIL)
first = c; // first time, save first cons
else
((cons_t*)ptr(last))->cdr = c;

12
femtolisp/system.lsp
View File

@ -97,7 +97,6 @@
((eqv? (caar lst) item) (car lst))
(#t (assv item (cdr lst)))))
(define (/= a b) (not (= a b)))
(define (> a b) (< b a))
(define (<= a b) (or (< a b) (= a b)))
(define (>= a b) (or (< b a) (= a b)))
@ -116,8 +115,6 @@
-1))
0)))
(define (mod x y) (- x (* (div x y) y)))
(define quotient div0)
(define remainder mod0)
(define (random n)
(if (integer? n)
(mod (rand) n)
@ -547,7 +544,10 @@
(define (io.readall s)
(let ((b (buffer)))
(io.copy b s)
(io.tostring! b)))
(let ((str (io.tostring! b)))
(if (and (equal? str "") (io.eof? s))
(eof-object)
str))))
(define-macro (with-output-to stream . body)
`(with-bindings ((*output-stream* ,stream))
@ -777,7 +777,7 @@
(if p
(symbol (string.join (map string (reverse! p)) "/"))
'lambda)))
(let ((st (reverse! (list-tail st 5)))
(let ((st (reverse! (list-tail st (if *interactive* 5 4))))
(e (filter closure? (map (lambda (s) (and (bound? s)
(top-level-value s)))
(environment))))
@ -883,8 +883,10 @@
(__init_globals)
(if (pair? (cdr argv))
(begin (set! *argv* (cdr argv))
(set! *interactive* #f)
(__script (cadr argv)))
(begin (set! *argv* argv)
(set! *interactive* #t)
(princ *banner*)
(repl)))
(exit 0))

2
femtolisp/table.c
View File

@ -99,7 +99,7 @@ value_t fl_table(value_t *args, uint32_t nargs)
htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt));
htable_new(h, cnt/2);
uint32_t i;
value_t k=NIL, arg=NIL;
value_t k=FL_NIL, arg=FL_NIL;
FOR_ARGS(i,0,arg,args) {
if (i&1)
equalhash_put(h, (void*)k, (void*)arg);

13
femtolisp/unittest.lsp
View File

@ -152,6 +152,9 @@
(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
; keyword arguments
(assert (keyword? kw:))
(assert (not (keyword? 'kw)))
(assert (not (keyword? ':)))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
'(1 0 0 (8 4 5))))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
@ -178,6 +181,16 @@
(assert (not (equal? (string (gensym)) (string (gensym)))))
(let ((gs (gensym))) (assert (eq? gs gs)))
; eof object
(assert (eof-object? (eof-object)))
(assert (not (eof-object? 1)))
(assert (not (eof-object? 'a)))
(assert (not (eof-object? '())))
(assert (not (eof-object? #f)))
(assert (not (null? (eof-object))))
(assert (not (builtin? (eof-object))))
(assert (not (function? (eof-object))))
; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765))