7 files changed, 110 insertions(+), 44 deletions(-)

M doc/lisp_reference/lisp_reference.tex
M lib/lisp/std/std.lisp
M src/lisp/compiler.dasc
M src/lisp/compiler.h
M src/lisp/lib/std.c
M src/lisp/lisp.c
A src/lisp/test-flet.lisp

@@ 113,7 113,10 @@ indicate particular values or meanings:
 \definition{
   (\optlist{
     \func{nilp} \text{ or } \func{not} \\
-    \func{integerp}
+    \func{closurep} \text{ or } \func{functionp} \\
+    \func{integerp} \\
+    \func{consp} \\
+    \func{symbolp}
   } \param{value})\index{nilp}\index{not}
 }{
   \ret{\T} if \param{value} is of the specified type, \ret{\nil}


@@ 133,12 136,25 @@ indicate particular values or meanings:
 }
 
 \definition{
-  (\mac{let1} (\param{variable} \param{form}) \param{body}\more)\index{let1}
+  (\mac{let1} (\param{variable} \param{form}) \param{body}\more)\index{let1} \\
+  (\mac{let} ((\param{variable} \param{form})\more) \param{body}\more)\index{let}
 }{
   First evaluate \param{form}, binding it to \param{variable}. Then
   evaluate \param{body}, finally evaluating to \ret{the final entry in
     \param{body}} or \ret{\nil} if \param{body} is
   empty. \param{variable} is no longer in scope after this form ends.
+  \mac{let} is similar to \mac{let*} in other lisps, later variables
+  can reference previous ones.
+}
+
+\definition{
+  (\mac{flet1} (\param{name} (\param{args}\more) \param{body}\more)) \\
+  (\mac{flet} ((\param{name} (\param{args}\more)\more) \param{body}\more))
+  \index{flet}\index{flet1}
+}{
+  Like \mac{let} and \mac{let1} but creates a lambda. Unlike other
+  lisps the defined function remains in the variable namespace as a
+  \type{function-object}.
 }
 
 \definition{

@@ 46,8 46,20 @@
 (defun funcall (fun & list)
   (apply fun list))
 
-;; (defmacro flet1 (func & body)
-;;   `(let1 (,(car func) ,(cons 'lambda (cdr func)))
-;;          ,@load))
+(defmacro flet1 (func & body)
+  `(let1 (,(car func)
+           (lambda ,@(cdr func)))
+         ,@body))
+
+(defun flet- (funcs body)
+  (if funcs
+      `(flet1 ,(car funcs)
+              ,(flet- (cdr funcs)
+                        body))
+      `(progn ,@body)))
+
+(defmacro flet (funcs & body)
+  ;; (flet- funcs body)
+  (print funcs))
 
 (list "body-functions.lisp")

@@ 189,7 189,7 @@ struct error compile_function(value_t args, enum namespace namespace,
 
 	for (value_t body_ = body; !nilp(body_); body_ = cdr(body_))
 	{
-		TRY(walk_and_alloc(env, &local, carref(body_)));
+		TRY(walk_and_alloc(env, &local, carref(body_), false));
 	}
 
 	| setup (local.num_stack_entries);


@@ 271,31 271,34 @@ struct error compile_tl(value_t val, struct environment *env, char *fname)
 	OKAY();
 }
 
-struct error walk_and_alloc(struct environment *env, struct local *local, value_t *bp)
+struct error walk_and_alloc(struct environment *env, struct local *local, value_t *bp, bool quoted)
 {
+	// Note: this kind of sucks. Some of the quote-handling code is
+	// duplicated here and compile_expression. TODO: refactor
+	// eventually.
+
 	E_INIT();
 
 	value_t body = *bp;
 
-	// TODO: handle macros
 	if (!listp(body))
 		OKAY();
 
 	value_t args = cdr(body);
 
-	if (symstreq(car(body), "let1"))
+	if (!quoted && symstreq(car(body), "let1"))
 	{
 		int slot = local_alloc(local);
 
 		value_t expr = cdr(args);
 		for (; !nilp(expr); expr = cdr(expr))
 		{
-			walk_and_alloc(env, local, carref(expr));
+			walk_and_alloc(env, local, carref(expr), false);
 		}
 
 		local_free(local, slot);
 	}
-	else if (symstreq(car(body), "lambda"))
+	else if (!quoted && symstreq(car(body), "lambda"))
 	{
 		// We don't want to walk the lambda because it's another function. When
 		// the lambda is compiled it will be walked.


@@ 303,31 306,46 @@ struct error walk_and_alloc(struct environment *env, struct local *local, value_
 	}
 	else
 	{
-		// Is this a macro?
+		if (quoted)
+		{
+			if (symstreq(car(body), "unquote") || symstreq(car(body), "unquote-splice"))
+			{
+				for (value_t b = cdr(body); !nilp(b); b = cdr(b))
+				{
+					walk_and_alloc(env, local, carref(b), false);
+				}
+			}
+		}
+		else
+		{
+			// Is this a macro?
 		
-		struct function *mac = NULL;
+			struct function *mac = NULL;
 
-		if (symbolp(car(body)))
-			mac = find_function(env, (char *)(car(body) ^ SYMBOL_TAG));
-		else
-			walk_and_alloc(env, local, carref(body));
+			if (symbolp(car(body)))
+				mac = find_function(env, (char *)(car(body) ^ SYMBOL_TAG));
+			else if (consp(car(body))) // consp, not just listp, since we don't care about nil.
+				walk_and_alloc(env, local, carref(body), false);
 
-		if (mac && mac->namespace == NS_MACRO)
-		{
-			unsigned char pool = push_pool(0);
-			value_t form = call_list(mac, args);
-			pop_pool(pool);
+			if (mac && mac->namespace == NS_MACRO)
+			{
+				unsigned char pool = push_pool(0);
+				value_t form = call_list(mac, args);
+				pop_pool(pool);
 
-			add_to_pool(form);
-			*bp = form;
+				add_to_pool(form);
+				*bp = form;
 
-			walk_and_alloc(env, local, bp);
-		}
-		else
-		{
-			for (; !nilp(args); args = cdr(args))
+				walk_and_alloc(env, local, bp, false);
+			}
+			else
 			{
-				walk_and_alloc(env, local, carref(args));
+				bool should_quote = symstreq(car(body), "quote") || symstreq(car(body), "backquote");
+
+				for (; !nilp(args); args = cdr(args))
+				{
+					walk_and_alloc(env, local, carref(args), should_quote);
+				}
 			}
 		}
 	}


@@ 351,12 369,13 @@ bool load(struct environment *env, char *path)
 
 	value_t val;
 
-	struct error read_error;
+	struct error compile_error, read_error;
 
 	while (IS_OKAY((read_error = read1(is, &val))))
 	{
-		if (!IS_OKAY(compile_tl(val, env, path)))
+		if (!IS_OKAY((compile_error = compile_tl(val, env, path))))
 		{
+			ereport(compile_error);
 			goto failure;
 		}
 	}


@@ 476,11 495,6 @@ struct error compile_backquote(struct environment *env, struct local *local,
 
 					value_t expr = car(cdr(v));
 
-					if (!listp(expr))
-					{
-						THROW(EINVALID, "unquote-splice (or ,@) argument must be a list");
-					}
-
 					TRY(compile_expression(env, local, expr, false, Dst));
 					| push eax;
 					| call_extern merge2;

@@ 166,7 166,7 @@ void del_env(struct environment *env);
 /**
  * Walk `body` and reserve space in `local` for any variable declarations.
  */
-struct error walk_and_alloc(struct environment *env, struct local *local, value_t *body);
+struct error walk_and_alloc(struct environment *env, struct local *local, value_t *body, bool quoted);
 
 /**
  * Compile a top level definition

@@ 128,6 128,16 @@ value_t l_num_eq(value_t a, value_t b)
 	return (a >> 3) == (b >> 3) ? t : nil;
 }
 
+#define LISP_PREDICATE(name) value_t l_##name(value_t v) { return name(v) ? t : nil; }
+
+LISP_PREDICATE(listp)
+LISP_PREDICATE(integerp)
+LISP_PREDICATE(symbolp)
+LISP_PREDICATE(closurep)
+LISP_PREDICATE(consp)
+
+#undef LISP_PREDICATE
+
 struct error load_std(struct environment *env)
 {
 	E_INIT();


@@ 147,6 157,13 @@ struct error load_std(struct environment *env)
 	add_c_function(env, "apply", l_apply, 2);
 
 	add_c_function(env, "nilp", l_nilp, 1);
+	add_c_function(env, "listp", l_listp, 1);
+	add_c_function(env, "integerp", l_integerp, 1);
+	add_c_function(env, "symbolp", l_symbolp, 1);
+	add_c_function(env, "closurep", l_closurep, 1);
+	add_c_function(env, "functionp", l_closurep, 1);
+	add_c_function(env, "consp", l_consp, 1);
+	
 	add_c_function(env, "elt", l_elt, 2);
 
 	if (!load_library(env, "std"))


@@ 171,6 188,7 @@ bool load_library(struct environment *env, char *name)
 
 		if (file_exists(path))
 		{
+			fprintf(stderr, "path: %s\n", path);
 			return load(env, path);
 		}
 


@@ 178,6 196,7 @@ bool load_library(struct environment *env, char *name)
 
 		if (file_exists(path))
 		{
+			fprintf(stderr, "path: %s\n", path);
 			return load(env, path);
 		}
 	}

@@ 716,13 716,13 @@ value_t *nilptr(value_t val)
 
 value_t merge2(value_t front, value_t back)
 {
-	if (!listp(front) || !listp(back))
-		return nil;
+	if (!listp(front) && listp(back))
+		return cons(front, back);
 
-	if (nilp(front))
-		return back;
-	else
-		*nilptr(front) = back;
+	if (listp(front) && !listp(back))
+		back = cons(back, nil);
+
+	*nilptr(front) = back;
 
 	return front;
 }

@@ 0,0 1,5 @@
+(defun main ()
+  (flet
+      '((a () 123)
+        (b () 456))
+    (print (funcall b))))