* eval.c (bindings_helper): Fix format arguments.

(eval_init): Registered new functions: symbol-function,
func-get-form, func-get-env, functionp, interp-fun-p.

* lib.c (nappend2, getplist_f, improper_plist_to_alist):
tail variable renamed to avoid clash in macro.
(func_get_form, func_get_env, interp_fun_p): New functions.

* lib.h (func_get_form, func_get_env, interp_fun_p): Declared.
(list_collect): Fix macro not to throw error, but handle the case.

* match.c (vars_to_bindings, extract_bindings): tail variable
renamed to avoid clash in macro.

* txr.1: Documentation stubs.

6 files changed, 77 insertions, 16 deletions

diff --git a/ChangeLog b/ChangeLog
index 3885dd09..9ea07c80 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,21 @@
+2011-12-18  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (bindings_helper): Fix format arguments.
+	(eval_init): Registered new functions: symbol-function,
+	func-get-form, func-get-env, functionp, interp-fun-p.
+
+	* lib.c (nappend2, getplist_f, improper_plist_to_alist):
+	tail variable renamed to avoid clash in macro.
+	(func_get_form, func_get_env, interp_fun_p): New functions.
+
+	* lib.h (func_get_form, func_get_env, interp_fun_p): Declared.
+	(list_collect): Fix macro not to throw error, but handle the case.
+
+	* match.c (vars_to_bindings, extract_bindings): tail variable
+	renamed to avoid clash in macro.
+
+	* txr.1: Documentation stubs.
+
 2011-12-16  Kaz Kylheku  <kaz@kylheku.com>
 
 	* hash.c (equal_hash): Eliminating displacement from character
diff --git a/eval.c b/eval.c
index d5c67a22..f093a11a 100644
--- a/eval.c
+++ b/eval.c
@@ -378,7 +378,7 @@ static val bindings_helper(val vars, val env, val sequential, val ctx_form)
 
     if (consp(item)) {
       if (!consp(cdr(item))) 
-        eval_error(ctx_form, lit("let: invalid syntax: ~s"),
+        eval_error(ctx_form, lit("~s: invalid syntax: ~s"),
                    car(ctx_form), item, nao);
       var = first(item);
       val = eval(second(item), nenv, ctx_form);
@@ -388,7 +388,7 @@ static val bindings_helper(val vars, val env, val sequential, val ctx_form)
 
     if (symbolp(var)) {
       if (!bindable(var))
-        eval_error(ctx_form, lit("let: ~s is not a bindable sybol"),
+        eval_error(ctx_form, lit("~s: ~s is not a bindable sybol"),
                    car(ctx_form), var, nao);
     }
 
@@ -1037,6 +1037,11 @@ static val mappendv(val fun, val list_of_lists)
   }
 }
 
+static val symbol_function(val sym)
+{
+  return lookup_fun(nil, sym);
+}
+
 static void reg_fun(val sym, val fun)
 {
   sethash(top_fb, sym, cons(sym, fun));
@@ -1305,6 +1310,12 @@ void eval_init(void)
 
   reg_fun(intern(lit("length"), user_package), func_n1(length));
 
+  reg_fun(intern(lit("symbol-function"), user_package), func_n1(symbol_function));
+  reg_fun(intern(lit("func-get-form"), user_package), func_n1(func_get_form));
+  reg_fun(intern(lit("func-get-env"), user_package), func_n1(func_get_env));
+  reg_fun(intern(lit("functionp"), user_package), func_n1(functionp));
+  reg_fun(intern(lit("interp-fun-p"), user_package), func_n1(interp_fun_p));
+
   eval_error_s = intern(lit("eval-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
 }
diff --git a/lib.c b/lib.c
index cd15cd1b..61c7bb49 100644
--- a/lib.c
+++ b/lib.c
@@ -393,10 +393,10 @@ val nappend2(val list1, val list2)
 
 val ldiff(val list1, val list2)
 {
-  list_collect_decl (out, tail);
+  list_collect_decl (out, ptail);
 
   while (list1 && list1 != list2) {
-    list_collect (tail, car(list1));
+    list_collect (ptail, car(list1));
     list1 = cdr(list1);
   }
 
@@ -763,12 +763,12 @@ val getplist_f(val list, val key, val *found)
 
 val proper_plist_to_alist(val list)
 {
-  list_collect_decl (out, tail);
+  list_collect_decl (out, ptail);
 
   for (; list; list = cdr(cdr(list))) {
     val ind = first(list);
     val prop = second(list);
-    list_collect (tail, cons(ind, prop));
+    list_collect (ptail, cons(ind, prop));
   }
 
   return out;
@@ -776,16 +776,16 @@ val proper_plist_to_alist(val list)
 
 val improper_plist_to_alist(val list, val boolean_keys)
 {
-  list_collect_decl (out, tail);
+  list_collect_decl (out, ptail);
 
   for (; list; list = cdr(list)) {
     val ind = first(list);
 
     if (memqual(ind, boolean_keys)) {
-      list_collect (tail, cons(ind, t));
+      list_collect (ptail, cons(ind, t));
     } else {
       val prop = second(list);
-      list_collect (tail, cons(ind, prop));
+      list_collect (ptail, cons(ind, prop));
       list = cdr(list);
     }
   }
@@ -1888,6 +1888,21 @@ val func_interp(val env, val form)
   return obj;
 }
 
+val func_get_form(val fun)
+{
+  type_check(fun, FUN);
+  if (fun->f.functype != FINTERP)
+    uw_throwf(error_s, lit("func_get_form: ~a is not an interpreted function"),
+              fun, nao);
+  return fun->f.f.interp_fun;
+}
+
+val func_get_env(val fun)
+{
+  type_check(fun, FUN);
+  return fun->f.env;
+}
+
 val functionp(val obj)
 {
   if (!obj) {
@@ -1898,6 +1913,11 @@ val functionp(val obj)
   }
 }
 
+val interp_fun_p(val obj)
+{
+  return (functionp(obj) && obj->f.functype == FINTERP) ? t : nil;
+}
+
 val funcall(val fun)
 {
   type_check(fun, FUN);
diff --git a/lib.h b/lib.h
index 345c3e35..3c9781b0 100644
--- a/lib.h
+++ b/lib.h
@@ -469,7 +469,10 @@ val func_n2v(val (*fun)(val, val, val rest));
 val func_n3v(val (*fun)(val, val, val, val rest));
 val func_n4v(val (*fun)(val, val, val, val, val rest));
 val func_interp(val env, val form);
+val func_get_form(val fun);
+val func_get_env(val fun);
 val functionp(val);
+val interp_fun_p(val);
 val funcall(val fun);
 val funcall1(val fun, val arg);
 val funcall2(val fun, val arg1, val arg2);
@@ -571,7 +574,7 @@ INLINE val eq(val a, val b) { return ((a) == (b) ? t : nil); }
 #define list_collect(PTAIL, OBJ)                \
   do {                                          \
     if (*PTAIL)                                 \
-      internal_error("mixed collect style");    \
+      PTAIL = tail(*PTAIL);                     \
     *PTAIL = cons(OBJ, nil);                    \
     PTAIL = cdr_l(*PTAIL);                      \
   } while(0)
diff --git a/match.c b/match.c
index e8cdf22a..c8367f22 100644
--- a/match.c
+++ b/match.c
@@ -317,7 +317,7 @@ static val txeval(val spec, val form, val bindings);
 static val vars_to_bindings(val spec, val vars, val bindings)
 {
   val iter;
-  list_collect_decl (fixed_vars, tail);
+  list_collect_decl (fixed_vars, ptail);
 
   if (vars && !consp(vars)) 
     sem_error(spec, lit("not a valid variable list: ~a"), vars, nao);
@@ -325,10 +325,10 @@ static val vars_to_bindings(val spec, val vars, val bindings)
   for (iter = vars; iter; iter = cdr(iter)) {
     val item = car(iter);
     if (bindable(item)) {
-      list_collect (tail, cons(item, noval_s));
+      list_collect (ptail, cons(item, noval_s));
     } else if (consp(item) && bindable(first(item))) {
-      list_collect (tail, cons(first(item), 
-                               txeval(spec, second(item), bindings)));
+      list_collect (ptail, cons(first(item), 
+                                txeval(spec, second(item), bindings)));
     } else { 
       sem_error(spec, lit("not a variable spec: ~a"), item, nao);
     }
@@ -1498,12 +1498,12 @@ static val extract_vars(val output_spec)
 
 static val extract_bindings(val bindings, val output_spec)
 {
-  list_collect_decl (bindings_out, tail);
+  list_collect_decl (bindings_out, ptail);
   val var_list = extract_vars(output_spec);
 
   for (; bindings; bindings = cdr(bindings))
     if (memq(car(car(bindings)), var_list))
-      list_collect(tail, car(bindings));
+      list_collect(ptail, car(bindings));
 
   return bindings_out;
 }
diff --git a/txr.1 b/txr.1
index 58805f3e..3658f6b0 100644
--- a/txr.1
+++ b/txr.1
@@ -5692,6 +5692,15 @@ yields (1 2 3 4 5). In TXR Lisp, this usage can be simulated using
 
 .SS Function length
 
+.SS Function symbol-function
+
+.SS Function func-get-form
+
+.SS Function func-get-env
+
+.SS Function functionp
+
+.SS Function interp-fun-p
 
 .SH APPENDIX A: NOTES ON EXOTIC REGULAR EXPRESSIONS