improper lists, floats

This commit is contained in:
Peter McGoron 2024-06-21 22:45:46 -04:00
parent ac04cf7828
commit 413b9614d2
3 changed files with 121 additions and 38 deletions

View File

@ -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
View File

@ -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);

View File

@ -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)