improper lists, floats
This commit is contained in:
parent
ac04cf7828
commit
413b9614d2
|
@ -3,6 +3,7 @@ Flatrate LISP
|
||||||
=============
|
=============
|
||||||
|
|
||||||
Flatrate is a minimalistic LISP. It's designed to test out my garbage
|
Flatrate is a minimalistic LISP. It's designed to test out my garbage
|
||||||
collectors.
|
collectors. It is C89+ and as portable as one can reasonably make a
|
||||||
|
program.
|
||||||
|
|
||||||
The default macro system is non-hygenic.
|
The default macro system is non-hygenic.
|
||||||
|
|
83
main.c
83
main.c
|
@ -42,8 +42,10 @@ enum token_type {
|
||||||
UNQUOTE,
|
UNQUOTE,
|
||||||
UNQUOTE_LIST,
|
UNQUOTE_LIST,
|
||||||
T_IDENT,
|
T_IDENT,
|
||||||
T_NUMBER,
|
T_INT,
|
||||||
|
T_FLOAT,
|
||||||
T_STRING,
|
T_STRING,
|
||||||
|
T_DOT,
|
||||||
TOKEN_NUM
|
TOKEN_NUM
|
||||||
};
|
};
|
||||||
|
|
||||||
|
@ -58,13 +60,16 @@ static const char *token2string[TOKEN_NUM] = {
|
||||||
",@",
|
",@",
|
||||||
"IDENT",
|
"IDENT",
|
||||||
"NUMBER_TOK",
|
"NUMBER_TOK",
|
||||||
"STRING_TOK"
|
"STRING_TOK",
|
||||||
|
"."
|
||||||
};
|
};
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
struct token {
|
struct token {
|
||||||
enum token_type typ;
|
enum token_type typ;
|
||||||
struct uns_ctr dat;
|
struct uns_ctr dat;
|
||||||
|
|
||||||
|
double f;
|
||||||
long i;
|
long i;
|
||||||
};
|
};
|
||||||
|
|
||||||
|
@ -145,19 +150,27 @@ static int tonum(int c)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
static void tok_num(FILE *input, struct token *tok, int mul)
|
static void tok_num(FILE *input, struct token *tok, int c)
|
||||||
{
|
{
|
||||||
int c = getc(input);
|
int is_float = 0;
|
||||||
|
|
||||||
tok->typ = T_NUMBER;
|
|
||||||
uns_string_alloc(&gc, &tok->dat, 32);
|
uns_string_alloc(&gc, &tok->dat, 32);
|
||||||
do {
|
do {
|
||||||
|
if (c == '.' || c == 'e' || c == 'E')
|
||||||
|
is_float = 1;
|
||||||
uns_string_append_char(&gc, &tok->dat, c);
|
uns_string_append_char(&gc, &tok->dat, c);
|
||||||
c = getc(input);
|
c = getc(input);
|
||||||
} while (tonum(c) >= 0);
|
} while (tonum(c) >= 0);
|
||||||
ungetc(c, input);
|
ungetc(c, input);
|
||||||
|
|
||||||
tok->i = mul*strtol(uns_string_cstring(&gc, &tok->dat), NULL, 10);
|
if (is_float) {
|
||||||
|
tok->typ = T_FLOAT;
|
||||||
|
tok->f = strtod(uns_string_cstring(&gc, &tok->dat), NULL);
|
||||||
|
} else {
|
||||||
|
tok->typ = T_INT;
|
||||||
|
tok->i = strtol(uns_string_cstring(&gc, &tok->dat), NULL, 10);
|
||||||
|
}
|
||||||
|
|
||||||
tok->dat.p = NULL;
|
tok->dat.p = NULL;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -215,17 +228,29 @@ static void tokenize(FILE *input, struct token *tok)
|
||||||
case '"':
|
case '"':
|
||||||
tok_string(input, tok);
|
tok_string(input, tok);
|
||||||
return;
|
return;
|
||||||
|
tok->typ = T_STRING;
|
||||||
|
return;
|
||||||
case '+': case '-':
|
case '+': case '-':
|
||||||
c2 = getc(input);
|
c2 = getc(input);
|
||||||
ungetc(c2, input);
|
ungetc(c2, input);
|
||||||
if (tonum(c2) >= 0) {
|
if (tonum(c2) >= 0) {
|
||||||
tok_num(input, tok, c == '+' ? 1 : -1);
|
tok_num(input, tok, c);
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
/* FALLTHROUGH */
|
||||||
default:
|
default:
|
||||||
if (tonum(c) >= 0) {
|
if (c == '.') {
|
||||||
ungetc(c, input);
|
c2 = getc(input);
|
||||||
tok_num(input, tok, 1);
|
/* Flatrate does not have floating point. */
|
||||||
|
if (part_of_ident(c2)) {
|
||||||
|
tok_ident(input, tok, c);
|
||||||
|
} else if (tonum(c2) >= 0) {
|
||||||
|
tok_num(input, tok, c);
|
||||||
|
} else {
|
||||||
|
tok->typ = T_DOT;
|
||||||
|
}
|
||||||
|
} else if (tonum(c) >= 0) {
|
||||||
|
tok_num(input, tok, c);
|
||||||
} else {
|
} else {
|
||||||
tok_ident(input, tok, c);
|
tok_ident(input, tok, c);
|
||||||
}
|
}
|
||||||
|
@ -237,6 +262,7 @@ enum item_type {
|
||||||
CELL,
|
CELL,
|
||||||
LAMBDA,
|
LAMBDA,
|
||||||
INTEGER,
|
INTEGER,
|
||||||
|
FLOAT,
|
||||||
STRING,
|
STRING,
|
||||||
SYMBOL,
|
SYMBOL,
|
||||||
EMPTY_LIST,
|
EMPTY_LIST,
|
||||||
|
@ -305,6 +331,16 @@ static void alloc_integer(struct uns_ctr *ctr, long l)
|
||||||
gc.record_set_ptr(ctr->p, 1, p);
|
gc.record_set_ptr(ctr->p, 1, p);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static void alloc_float(struct uns_ctr *ctr, double f)
|
||||||
|
{
|
||||||
|
void *p;
|
||||||
|
alloc_of_type(ctr, FLOAT);
|
||||||
|
|
||||||
|
p = gc.alloc(&gc, sizeof(double));
|
||||||
|
memcpy(p, &f, sizeof(double));
|
||||||
|
gc.record_set_ptr(ctr->p, 1, p);
|
||||||
|
}
|
||||||
|
|
||||||
static int expr_all(FILE *input, struct token *tok, struct uns_ctr *expr);
|
static int expr_all(FILE *input, struct token *tok, struct uns_ctr *expr);
|
||||||
|
|
||||||
static int list_expr(FILE *input, struct uns_ctr *expr, struct token *tok)
|
static int list_expr(FILE *input, struct uns_ctr *expr, struct token *tok)
|
||||||
|
@ -334,6 +370,19 @@ static int list_expr(FILE *input, struct uns_ctr *expr, struct token *tok)
|
||||||
break;
|
break;
|
||||||
|
|
||||||
alloc_of_type(&in_cdr, CELL);
|
alloc_of_type(&in_cdr, CELL);
|
||||||
|
|
||||||
|
if (tok->typ == T_DOT) {
|
||||||
|
tokenize(input, tok);
|
||||||
|
expr_all(input, tok, &in_cdr);
|
||||||
|
gc.record_set_ptr(cur_head.p, 2, in_cdr.p);
|
||||||
|
tokenize(input, tok);
|
||||||
|
if (tok->typ != RPAREN) {
|
||||||
|
r = 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
goto end;
|
||||||
|
}
|
||||||
|
|
||||||
gc.record_set_ptr(cur_head.p, 2, in_cdr.p);
|
gc.record_set_ptr(cur_head.p, 2, in_cdr.p);
|
||||||
cur_head.p = in_cdr.p;
|
cur_head.p = in_cdr.p;
|
||||||
}
|
}
|
||||||
|
@ -398,14 +447,17 @@ static int expr_all(FILE *input, struct token *tok, struct uns_ctr *expr)
|
||||||
alloc_of_type(expr, SYMBOL);
|
alloc_of_type(expr, SYMBOL);
|
||||||
gc.record_set_ptr(expr->p, 1, tok->dat.p);
|
gc.record_set_ptr(expr->p, 1, tok->dat.p);
|
||||||
break;
|
break;
|
||||||
case T_NUMBER:
|
case T_INT:
|
||||||
alloc_integer(expr, tok->i);
|
alloc_integer(expr, tok->i);
|
||||||
break;
|
break;
|
||||||
|
case T_FLOAT:
|
||||||
|
alloc_float(expr, tok->f);
|
||||||
|
break;
|
||||||
case T_STRING:
|
case T_STRING:
|
||||||
alloc_of_type(expr, STRING);
|
alloc_of_type(expr, STRING);
|
||||||
gc.record_set_ptr(expr->p, 1, tok->dat.p);
|
gc.record_set_ptr(expr->p, 1, tok->dat.p);
|
||||||
break;
|
break;
|
||||||
case RPAREN: case T_EOF: case TOKEN_NUM:
|
case RPAREN: case T_EOF: case TOKEN_NUM: case T_DOT:
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -474,9 +526,10 @@ static void display(struct uns_ctr *ctr)
|
||||||
{
|
{
|
||||||
struct uns_ctr tmp = {0};
|
struct uns_ctr tmp = {0};
|
||||||
long l;
|
long l;
|
||||||
|
double f;
|
||||||
|
|
||||||
if (!ctr->p) {
|
if (!ctr->p) {
|
||||||
printf("__null");
|
printf("<undefined>");
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -500,6 +553,10 @@ static void display(struct uns_ctr *ctr)
|
||||||
memcpy(&l, gc.record_get_ptr(ctr->p, 1), sizeof(long));
|
memcpy(&l, gc.record_get_ptr(ctr->p, 1), sizeof(long));
|
||||||
printf("%ld ", l);
|
printf("%ld ", l);
|
||||||
return;
|
return;
|
||||||
|
case FLOAT:
|
||||||
|
memcpy(&f, gc.record_get_ptr(ctr->p, 1), sizeof(float));
|
||||||
|
printf("%f ", f);
|
||||||
|
return;
|
||||||
case STRING:
|
case STRING:
|
||||||
tmp.p = gc.record_get_ptr(ctr->p, 1);
|
tmp.p = gc.record_get_ptr(ctr->p, 1);
|
||||||
uns_root_add(&gc, &tmp);
|
uns_root_add(&gc, &tmp);
|
||||||
|
|
67
prelude.scm
67
prelude.scm
|
@ -34,8 +34,10 @@
|
||||||
;
|
;
|
||||||
; Others:
|
; Others:
|
||||||
; __uniapply: Apply function to single argument
|
; __uniapply: Apply function to single argument
|
||||||
; __null: A value that can only be passed to __unilambda. It cannot be
|
; <undefined>: A value that can only be passed to __unilambda. It cannot
|
||||||
; bound to a top-level, or "set!", or added to a list.
|
; be bound to a top-level, or "set!", or added to a list.
|
||||||
|
; It can also be the parameter of a __unilambda, although
|
||||||
|
; it still cannot be used.
|
||||||
;
|
;
|
||||||
; Macros are functions that return an sexpr.
|
; Macros are functions that return an sexpr.
|
||||||
|
|
||||||
|
@ -48,7 +50,7 @@
|
||||||
; (cdr (car (car args))) = (a)
|
; (cdr (car (car args))) = (a)
|
||||||
`((__unilambda ,(car (car (car args)))
|
`((__unilambda ,(car (car (car args)))
|
||||||
(let ,(cdr (car args)) ,@body))
|
(let ,(cdr (car args)) ,@body))
|
||||||
,(car (cdr (car (car args))))
|
. ,(car (cdr (car (car args))))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
@ -56,6 +58,20 @@
|
||||||
|
|
||||||
(__define-macro let* let)
|
(__define-macro let* let)
|
||||||
|
|
||||||
|
; if and __unilambda only execute one statement. This uses Flatrate's
|
||||||
|
; evaluation order (arguments first) and tail-call optimization to simulate
|
||||||
|
; multiple statements.
|
||||||
|
(__define-macro begin body
|
||||||
|
(let ((first (car body))
|
||||||
|
(rest (cdr body))
|
||||||
|
)
|
||||||
|
(if (null? rest)
|
||||||
|
first
|
||||||
|
`((__unilambda <undefined> (begin ,@rest)) . ,first)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
(__define-macro __bindlambda
|
(__define-macro __bindlambda
|
||||||
(__unilambda l
|
(__unilambda l
|
||||||
(let ((larg (car l))
|
(let ((larg (car l))
|
||||||
|
@ -66,7 +82,7 @@
|
||||||
`(__unilambda larg
|
`(__unilambda larg
|
||||||
(if (not (null? larg))
|
(if (not (null? larg))
|
||||||
(raise "incorrect number of arguments")
|
(raise "incorrect number of arguments")
|
||||||
,body
|
(begin ,@body)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
(let* ((argval (cons args))
|
(let* ((argval (cons args))
|
||||||
|
@ -90,10 +106,10 @@
|
||||||
)
|
)
|
||||||
(if (symbol? args)
|
(if (symbol? args)
|
||||||
`(__unilambda ,args ,@body)
|
`(__unilambda ,args ,@body)
|
||||||
(let ((larg (gensym)))
|
|
||||||
(if (null? args)
|
(if (null? args)
|
||||||
`(__unilambda ,larg ,@body)
|
`(__unilambda <undefined> (begin ,@body))
|
||||||
`(__bindlambda ,larg . body)
|
(let ((larg (gensym)))
|
||||||
|
`(__bindlambda ,larg ,@body)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
@ -110,23 +126,12 @@
|
||||||
(tmpname (gensym))
|
(tmpname (gensym))
|
||||||
)
|
)
|
||||||
`(__define-macro ,name
|
`(__define-macro ,name
|
||||||
(lambda ,args ,body)
|
(lambda ,args ,@body)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
(define-macro (define name . body)
|
|
||||||
(if (symbol? name)
|
|
||||||
`(__define ,name ,@body)
|
|
||||||
`(__define ,(car name) (lambda ,(cdr name) ,@body))
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-macro (begin . body)
|
|
||||||
`((lambda () ,@body))
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-macro (and . body)
|
(define-macro (and . body)
|
||||||
(if (null? body)
|
(if (null? body)
|
||||||
1
|
1
|
||||||
|
@ -157,13 +162,33 @@
|
||||||
(val (car (cdr argval)))
|
(val (car (cdr argval)))
|
||||||
(rest (cdr args))
|
(rest (cdr args))
|
||||||
)
|
)
|
||||||
`(let ((,arg __null))
|
`(let ((,arg <undefined>))
|
||||||
(letrec ,rest (set! ,arg ,val) ,@body)
|
(letrec ,rest (begin (set! ,arg ,val) ,@body))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
(define-macro (define name . body)
|
||||||
|
(if (symbol? name)
|
||||||
|
`(__define ,name ,@body)
|
||||||
|
(let ((fname (car name))
|
||||||
|
(args (cdr name))
|
||||||
|
(tmparg (gensym))
|
||||||
|
)
|
||||||
|
`(__define ,fname
|
||||||
|
(lambda ,tmparg
|
||||||
|
(letrec ((,fname (lambda ,args ,@body)))
|
||||||
|
(,fname . ,tmparg)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;; Standard Library ;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; for a list of (v1 v2 ... vn)
|
;; for a list of (v1 v2 ... vn)
|
||||||
;; runs (f vn (... (f v2 (f v1 start))))
|
;; runs (f vn (... (f v2 (f v1 start))))
|
||||||
(define (foldl f start l)
|
(define (foldl f start l)
|
||||||
|
|
Reference in New Issue