~swisschili/bluejay

fc5c9413047d17191da203e8ec8025a3d447bc5f — swissChili 3 months ago 3f7f584 master
Add flet1, flet, update reference
M doc/lisp_reference/lisp_reference.tex => doc/lisp_reference/lisp_reference.tex +18 -2
@@ 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{

M lib/lisp/std/std.lisp => lib/lisp/std/std.lisp +15 -3
@@ 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")

M src/lisp/compiler.dasc => src/lisp/compiler.dasc +46 -32
@@ 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;

M src/lisp/compiler.h => src/lisp/compiler.h +1 -1
@@ 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

M src/lisp/lib/std.c => src/lisp/lib/std.c +19 -0
@@ 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);
		}
	}

M src/lisp/lisp.c => src/lisp/lisp.c +6 -6
@@ 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;
}

A src/lisp/test-flet.lisp => src/lisp/test-flet.lisp +5 -0
@@ 0,0 1,5 @@
(defun main ()
  (flet
      '((a () 123)
        (b () 456))
    (print (funcall b))))