From 8c299f44b94d4462147b9e3cb782c52c3669a1e5 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 16 Feb 2012 18:56:39 -0800
Subject: * eval.c (eval_init): Register match-fun.

* match.c (v_do): Store match context.
(match_fun): New function.

* match.h (match_fun): Declared.

* stream.c (streamp): New function.

* stream.h (streamp): Declared.

* txr.1: Stub section for match-fun.

* txr.vim: Highlight match-fun.
---
 ChangeLog | 17 +++++++++++++++++
 eval.c    |  2 ++
 match.c   | 21 +++++++++++++++++++++
 match.h   |  1 +
 stream.c  |  5 +++++
 stream.h  |  1 +
 txr.1     |  2 ++
 txr.vim   |  2 +-
 8 files changed, 50 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index ee49c755..41926727 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2012-02-16  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (eval_init): Register match-fun.
+
+	* match.c (v_do): Store match context.
+	(match_fun): New function.
+
+	* match.h (match_fun): Declared.
+
+	* stream.c (streamp): New function.
+
+	* stream.h (streamp): Declared.
+
+	* txr.1: Stub section for match-fun.
+
+	* txr.vim: Highlight match-fun.
+
 2012-02-16  Kaz Kylheku  <kaz@kylheku.com>
 
 	* match.c (match_funcall): Function renamed to match_filter.
diff --git a/eval.c b/eval.c
index 4aa1019b..3375b15b 100644
--- a/eval.c
+++ b/eval.c
@@ -2228,6 +2228,8 @@ void eval_init(void)
   reg_fun(intern(lit("throwf"), user_package), func_n2v(uw_throwfv));
   reg_fun(error_s, func_n1v(uw_errorfv));
 
+  reg_fun(intern(lit("match-fun"), user_package), func_n4(match_fun));
+
   eval_error_s = intern(lit("eval-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
 }
diff --git a/match.c b/match.c
index 21e3d51a..b5e489dd 100644
--- a/match.c
+++ b/match.c
@@ -3378,6 +3378,7 @@ static val v_do(match_files_ctx *c)
 {
   spec_bind (specline, first_spec, c->spec);
   val args = rest(first_spec);
+  uw_set_match_context(cons(c->spec, c->bindings));
   (void) eval_progn(args, make_env(c->bindings, nil, nil), specline);
   return next_spec_k;
 }
@@ -3539,6 +3540,26 @@ val match_filter(val name, val arg, val other_args)
   }
 }
 
+val match_fun(val name, val args, val input, val files)
+{
+  val spec = cons(cons(cons(name, args), nil), nil);
+  cons_bind (in_spec, in_bindings, uw_get_match_context());
+  val data = if3(streamp(input),
+                 lazy_stream_cons(input),
+                 input);
+  /* TODO: pass through source location context */
+  match_files_ctx c = mf_all(spec, files, in_bindings, data, num(0));
+  val ret = v_fun(&c);
+
+  if (ret == nil)
+    return nil;
+
+  if (ret == decline_k)
+    sem_error(nil, lit("match_fun: function ~s not found"), name, nao);
+
+  return cons(c.bindings, cons(c.data, c.data_lineno));
+}
+
 int extract(val spec, val files, val predefined_bindings)
 {
   cons_bind (bindings, success, match_files(mf_all(spec, files, 
diff --git a/match.h b/match.h
index bb9a174d..719fc13b 100644
--- a/match.h
+++ b/match.h
@@ -27,5 +27,6 @@
 extern val text_s, choose_s, gather_s, do_s, mod_s, modlast_s, counter_k;
 val format_field(val string_or_list, val modifier, val filter, val eval_fun);
 val match_filter(val name, val arg, val other_args);
+val match_fun(val name, val args, val input, val files);
 int extract(val spec, val filenames, val bindings);
 void match_init(void);
diff --git a/stream.c b/stream.c
index ac14a83c..023e8390 100644
--- a/stream.c
+++ b/stream.c
@@ -680,6 +680,11 @@ val make_dir_stream(DIR *dir)
   return cobj((mem_t *) dir, stream_s, &dir_ops.cobj_ops);
 }
 
+val streamp(val obj)
+{
+  return typeof(obj) == stream_s ? t : nil;
+}
+
 val close_stream(val stream, val throw_on_error)
 {
   type_check (stream, COBJ);
diff --git a/stream.h b/stream.h
index a65954ba..14208f7a 100644
--- a/stream.h
+++ b/stream.h
@@ -35,6 +35,7 @@ val get_string_from_stream(val);
 val make_strlist_output_stream(void);
 val get_list_from_stream(val);
 val make_dir_stream(DIR *);
+val streamp(val obj);
 val close_stream(val stream, val throw_on_error);
 val get_line(val);
 val get_char(val);
diff --git a/txr.1 b/txr.1
index 7efd5bbf..79943997 100644
--- a/txr.1
+++ b/txr.1
@@ -6628,6 +6628,8 @@ Certain object types have a custom equal function.
 
 .SS Functions throw, throwf and error
 
+.SS Function match-fun
+
 .SH APPENDIX A: NOTES ON EXOTIC REGULAR EXPRESSIONS
 
 Users familiar with regular expressions may not be familiar with the complement
diff --git a/txr.vim b/txr.vim
index f20c58b5..4d2f4805 100644
--- a/txr.vim
+++ b/txr.vim
@@ -81,7 +81,7 @@ syn keyword txl_keyword contained make-random-state random-state-p
 syn keyword txl_keyword contained random-fixnum random
 
 syn keyword txl_keyword contained range range* generate repeat force
-syn keyword txl_keyword contained throw throwf error 
+syn keyword txl_keyword contained throw throwf error match-fun
 
 syn match txr_hash "#" contained
 syn match txr_quote "[,']" contained
-- 
cgit v1.2.3