From 413b9614d2f82b784cb9da239878ff9565529491 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Fri, 21 Jun 2024 22:45:46 -0400 Subject: [PATCH] improper lists, floats --- README.rst | 3 +- main.c | 83 ++++++++++++++++++++++++++++++++++++++++++++--------- prelude.scm | 73 ++++++++++++++++++++++++++++++---------------- 3 files changed, 121 insertions(+), 38 deletions(-) diff --git a/README.rst b/README.rst index e531dc1..0c2d608 100644 --- a/README.rst +++ b/README.rst @@ -3,6 +3,7 @@ Flatrate LISP ============= 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. diff --git a/main.c b/main.c index 1fb1cf0..6ba589f 100644 --- a/main.c +++ b/main.c @@ -42,8 +42,10 @@ enum token_type { UNQUOTE, UNQUOTE_LIST, T_IDENT, - T_NUMBER, + T_INT, + T_FLOAT, T_STRING, + T_DOT, TOKEN_NUM }; @@ -58,13 +60,16 @@ static const char *token2string[TOKEN_NUM] = { ",@", "IDENT", "NUMBER_TOK", - "STRING_TOK" + "STRING_TOK", + "." }; #endif struct token { enum token_type typ; struct uns_ctr dat; + + double f; 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); do { + if (c == '.' || c == 'e' || c == 'E') + is_float = 1; uns_string_append_char(&gc, &tok->dat, c); c = getc(input); } while (tonum(c) >= 0); 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; } @@ -215,17 +228,29 @@ static void tokenize(FILE *input, struct token *tok) case '"': tok_string(input, tok); return; + tok->typ = T_STRING; + return; case '+': case '-': c2 = getc(input); ungetc(c2, input); if (tonum(c2) >= 0) { - tok_num(input, tok, c == '+' ? 1 : -1); + tok_num(input, tok, c); return; } + /* FALLTHROUGH */ default: - if (tonum(c) >= 0) { - ungetc(c, input); - tok_num(input, tok, 1); + if (c == '.') { + c2 = getc(input); + /* 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 { tok_ident(input, tok, c); } @@ -237,6 +262,7 @@ enum item_type { CELL, LAMBDA, INTEGER, + FLOAT, STRING, SYMBOL, EMPTY_LIST, @@ -305,6 +331,16 @@ static void alloc_integer(struct uns_ctr *ctr, long l) 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 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; 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); 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); gc.record_set_ptr(expr->p, 1, tok->dat.p); break; - case T_NUMBER: + case T_INT: alloc_integer(expr, tok->i); break; + case T_FLOAT: + alloc_float(expr, tok->f); + break; case T_STRING: alloc_of_type(expr, STRING); gc.record_set_ptr(expr->p, 1, tok->dat.p); break; - case RPAREN: case T_EOF: case TOKEN_NUM: + case RPAREN: case T_EOF: case TOKEN_NUM: case T_DOT: return 0; } @@ -474,9 +526,10 @@ static void display(struct uns_ctr *ctr) { struct uns_ctr tmp = {0}; long l; + double f; if (!ctr->p) { - printf("__null"); + printf(""); return; } @@ -500,6 +553,10 @@ static void display(struct uns_ctr *ctr) memcpy(&l, gc.record_get_ptr(ctr->p, 1), sizeof(long)); printf("%ld ", l); return; + case FLOAT: + memcpy(&f, gc.record_get_ptr(ctr->p, 1), sizeof(float)); + printf("%f ", f); + return; case STRING: tmp.p = gc.record_get_ptr(ctr->p, 1); uns_root_add(&gc, &tmp); diff --git a/prelude.scm b/prelude.scm index 097ca64..cb22b18 100644 --- a/prelude.scm +++ b/prelude.scm @@ -34,8 +34,10 @@ ; ; Others: ; __uniapply: Apply function to single argument -; __null: A value that can only be passed to __unilambda. It cannot be -; bound to a top-level, or "set!", or added to a list. +; : A value that can only be passed to __unilambda. It cannot +; 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. @@ -48,7 +50,7 @@ ; (cdr (car (car args))) = (a) `((__unilambda ,(car (car (car args))) (let ,(cdr (car args)) ,@body)) - ,(car (cdr (car (car args)))) + . ,(car (cdr (car (car args)))) ) ) ) @@ -56,6 +58,20 @@ (__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 (begin ,@rest)) . ,first) + ) + ) +) + (__define-macro __bindlambda (__unilambda l (let ((larg (car l)) @@ -66,7 +82,7 @@ `(__unilambda larg (if (not (null? larg)) (raise "incorrect number of arguments") - ,body + (begin ,@body) ) ) (let* ((argval (cons args)) @@ -90,12 +106,12 @@ ) (if (symbol? args) `(__unilambda ,args ,@body) - (let ((larg (gensym))) - (if (null? args) - `(__unilambda ,larg ,@body) - `(__bindlambda ,larg . body) - ) - ) + (if (null? args) + `(__unilambda (begin ,@body)) + (let ((larg (gensym))) + `(__bindlambda ,larg ,@body) + ) + ) ) ) ) @@ -110,23 +126,12 @@ (tmpname (gensym)) ) `(__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) (if (null? body) 1 @@ -157,13 +162,33 @@ (val (car (cdr argval))) (rest (cdr args)) ) - `(let ((,arg __null)) - (letrec ,rest (set! ,arg ,val) ,@body) + `(let ((,arg )) + (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) ;; runs (f vn (... (f v2 (f v1 start)))) (define (foldl f start l)