improper lists, floats

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.

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) {
+		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 {
 			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("<undefined>");
 		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);

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
+; <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.
 
@@ -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 <undefined> (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)
-         (if (null? args)
+           `(__unilambda <undefined> (begin ,@body))
-             `(__unilambda ,larg ,@body)
+           (let ((larg (gensym)))
-             `(__bindlambda ,larg . body)
+             `(__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))
+     `(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)
 ;; runs (f vn (... (f v2 (f v1 start))))
 (define (foldl f start l)