X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=XmlExpr.cs;h=e18f7d34c09b1636a159e494dd07bd974ce13433;hb=822f9574d588bc1c847a2de1ab2e03a345f7a6e8;hp=714c61aa2c9b8a25eaa26be2e5bb1755a78bd269;hpb=5fc29f7650bef0519ac6e50558e8cb2e34096366;p=m17n%2Fm17n-lib-cs.git diff --git a/XmlExpr.cs b/XmlExpr.cs index 714c61a..e18f7d3 100644 --- a/XmlExpr.cs +++ b/XmlExpr.cs @@ -6,60 +6,62 @@ using System.Xml; namespace System.Xml.Expression { - public class Xex + public class Xexpression { - public struct Name : IEquatable + public static int debug_level = 0; + + public struct Symbol : IEquatable { private static NameTable nt = new NameTable (); - private string name; + internal string name; - public Name (string str) + public Symbol (string str) { name = nt.Add (str); } - public static implicit operator Name (string str) + public static implicit operator Symbol (string str) { - return new Name (str); + return new Symbol (str); } - public static implicit operator string (Name name) + public static implicit operator string (Symbol name) { return name.name; } - public static bool operator== (Name n1, Name n2) + public static bool operator== (Symbol n1, Symbol n2) { return (object) n1.name == (object) n2.name; } - public static bool operator!= (Name n1, Name n2) + public static bool operator!= (Symbol n1, Symbol n2) { return (object) n1.name != (object) n2.name; } - public static bool operator== (Name n1, string n2) + public static bool operator== (Symbol n1, string n2) { return (object) n1.name == (object) n2; } - public static bool operator!= (Name n1, string n2) + public static bool operator!= (Symbol n1, string n2) { return (object) n1.name != (object) n2; } - public static bool operator== (string n1, Name n2) + public static bool operator== (string n1, Symbol n2) { return (object) n1 == (object) n2.name; } - public static bool operator!= (string n1, Name n2) + public static bool operator!= (string n1, Symbol n2) { return (object) n1 != (object) n2.name; } - public bool Equals (Name name) + public bool Equals (Symbol name) { return Object.ReferenceEquals (this.name, name.name); } @@ -79,305 +81,482 @@ namespace System.Xml.Expression public override string ToString () { return name; } } - private static Name Nexpr = "expr"; - private static Name Ntype = "type"; - - private static Name Ninteger = "integer"; - private static Name Nstring = "string"; - private static Name Nboolean = "boolean"; - private static Name Nsymbol = "symbol"; - private static Name Nlist = "list"; - private static Name Nobject = "object"; - - private static Name Ndefun = "defun"; - private static Name Nfname = "fname"; - private static Name Nargs = "args"; - private static Name Noptional = "optional"; - private static Name Nrest = "rest"; - private static Name Nbody = "body"; - - private static Name Ndefvar = "defvar"; - private static Name Nconst = "const"; - private static Name Nvariable = "variable"; - private static Name Ndescription = "description"; - private static Name Npossible_value = "possible-value"; - - private static Name Nfuncall = "funcall"; - private static Name Nprogn = "progn"; - - internal class Function + private static Symbol Qexpr = "expr"; + + private static Symbol Qnull = ""; + private static Symbol Qfuncall = "funcall"; + private static Symbol Qvarref = "varref"; + private static Symbol Qinteger = "integer"; + private static Symbol Qstring = "string"; + private static Symbol Qsymbol = "symbol"; + private static Symbol Qlist = "list"; + + private static Symbol Qdefun = "defun"; + private static Symbol Qfname = "fname"; + private static Symbol Qargs = "args"; + private static Symbol Qargs_unevalled = "args-unevalled"; + private static Symbol Qfixed = "fixed"; + private static Symbol Qoptional = "optional"; + private static Symbol Qrest = "rest"; + + private static Symbol Qdefvar = "defvar"; + private static Symbol Qvname = "vname"; + private static Symbol Qdescription = "description"; + private static Symbol Qrange = "range"; + + public abstract class Function { - internal class Lambda - { - internal Xex[] args; - internal Xex[] body; - - public void SetArgs (XmlNode node, int nargs, Domain domain) - { - args = new Xex[nargs]; - node = node.FirstChild; - for (int i = 0; i < nargs; node = node.NextSibling) - if (node.Name != Noptional && node.Name != Nrest) - args[i++] = new Xex (node, domain); - } - - public void SetBody (XmlNode node, Domain domain) - { - XmlNodeList nlist = node.ChildNodes; - - body = new Xex[nlist.Count]; - for (int i = 0; i < nlist.Count; i++) - body[i] = new Xex (nlist[i], domain); - } - } - - public readonly Name name; - public Builtin builtin; + public Symbol name; public int min_arg, max_arg; - internal Lambda lambda; - public bool specialp = false; - public Function (Name name, Builtin builtin, - int min_arg, int max_arg, bool specialp) + public Function () { } + + public Function (Symbol name, int min_arg, int max_arg) { this.name = name; - this.builtin = builtin; this.min_arg = min_arg; this.max_arg = max_arg; - this.specialp = specialp; } - public Function (Name name, int min_arg, int max_arg) + public abstract Term Call (Domain domain, Variable vari, Term[] args); + + public override string ToString () { - this.name = name; - this.min_arg = min_arg; - this.max_arg = max_arg; + return name; } - public void Setup (XmlNode node, Domain domain) + internal class Subroutine : Function { - lambda = new Lambda (); - node = node.FirstChild; - if (node.Name == Nargs) + public Builtin builtin; + public bool setvar; + + public Subroutine (Builtin builtin, Symbol name, bool setvar, + int min_arg, int max_arg) + : base (name, min_arg, max_arg) { - lambda.SetArgs (node, max_arg, domain); - node = node.NextSibling; + this.builtin = builtin; + this.setvar = setvar; } - if (node.Name == Nbody) - lambda.SetBody (node, domain); + + public override Term Call (Domain domain, Variable vari, Term[] args) + { + args = (Term[]) args.Clone (); + for (int i = 0; i < args.Length; i++) + { + args[i] = args[i].Eval (domain); + if (domain.Thrown) + return args[i]; + } + return builtin (domain, vari, args); + } } - public static Name ParseHead (XmlNode node, - out int min_arg, out int max_arg) + internal class SpecialForm : Function { - Name name = node.Attributes[Nfname].Value; - int nargs = 0, noptions = 0, nrest = 0; - XmlNode n; - - for (n = node.FirstChild; n != null; n = n.NextSibling) + public Builtin builtin; + + public SpecialForm (Builtin builtin, Symbol name, + int min_arg, int max_arg) + : base (name, min_arg, max_arg) { - if (n.Name == Noptional || n.Name == Nrest) - break; - nargs++; + this.builtin = builtin; } - if (n != null && n.Name == Noptional) - for (n = n.NextSibling; n != null; n = n.NextSibling) - { - if (n.Name == Nrest) - break; - noptions++; - } - if (n != null && n.Name == Nrest) - for (n = n.NextSibling; n != null; n = n.NextSibling) - nrest++; - min_arg = nargs; - max_arg = nargs + noptions + nrest; - if (nrest == 1) - max_arg = - max_arg; - return name; + + public override Term Call (Domain domain, Variable vari, Term[] args) + { + return builtin (domain, vari, args); + } } - public object Call (Xex[] args, Domain domain) + internal class Lambda : Function { - Bindings current = domain.bindings; - object result = false; - - Console.Write ("calling (" + this); - try { - foreach (Xex e in args) - Console.Write (" " + e); - Console.Write (") => "); - if (builtin != null) - { - if (! specialp) - foreach (Xex a in args) - if (a.Eval (domain) == null) - throw new Exception (a + ":evaled to null"); - result = builtin (args, domain); - Console.WriteLine (result); - return result; - } + internal bool args_evalled; + internal Variable[] args; + internal Term[] body; + + public Lambda (Domain domain, XmlNode node) + { + int nfixed = 0; + int noptional = 0; + int nrest = 0; + name = node.Attributes[Qfname].Value; + + node = node.FirstChild; + if (node != null + && (node.Name == Qargs || node.Name == Qargs_unevalled)) + { + XmlNode n; + args_evalled = node.Name == Qargs; + for (n = node.FirstChild; n != null; n = n.NextSibling) + { + if (n.Name == Qfixed) + nfixed++; + else if (n.Name == Qoptional) + noptional++; + else if (n.Name == Qrest) + nrest++; + else + throw new Exception ("Invalid argument type: " + n); + } + min_arg = nfixed; + max_arg = nfixed + noptional + nrest; + args = new Variable[max_arg]; + n = node.FirstChild; + for (int i = 0; i < max_arg; n = n.NextSibling) + args[i++] = domain.Defvar ((Symbol) n.Attributes[0].Value); + if (nrest == 1) + max_arg = - max_arg; + } + else + { + min_arg = max_arg = 0; + } + } + + public Lambda (Domain domain, Symbol name, bool args_evalled, Symbol[] args) + { + int nfixed = 0; + int noptional = 0; + int nrest = 0; + + this.name = name; + this.args_evalled = args_evalled; + if (args != null) + { + int i = 0; + for (i = 0; i < args.Length; i++, nfixed++) + if (args[i] == Qoptional || args[i] == Qrest) + break; + if (i < args.Length) + { + if (args[i] == Qoptional) + { + for (i++; i < args.Length; i++, noptional++) + if (args[i] == Qrest) + break; + if (i < args.Length) + nrest = 1; + } + } + min_arg = nfixed; + max_arg = nfixed + noptional + nrest; + this.args = new Variable[max_arg]; + int j; + for (i = j = 0; j < this.args.Length; i++) + if (args[i] != Qoptional || args[i] != Qrest) + this.args[j++] = domain.Defvar (args[i]); + } + else + { + min_arg = max_arg = 0; + } + } - int i; - for (i = 0; i < min_arg; i++) + public void SetBody (Domain domain, XmlNode node) + { + for (node = node.FirstChild; node != null; node = node.NextSibling) + if (node.Name != Qdescription + && node.Name != Qargs + && node.Name != Qargs_unevalled) + break; + int nterms = 0; + for (XmlNode n = node; n != null; n = n.NextSibling) + nterms++; + if (nterms > 0) { - Xex a = lambda.args[i]; - bool isdirect = a.args == null; - Name name = isdirect ? (Name) a.val : (Name) a.args[0].val; - Variable var = new VarMisc (name, null); - - domain.variables[name] = var; - if (isdirect) - domain.Bind (var, args[i]); - else - domain.Bind (var, args[i].Eval (domain)); + body = new Term[nterms]; + for (nterms = 0; node != null; node = node.NextSibling, nterms++) + body[nterms] = new Term (domain, node); } - foreach (Xex e in lambda.body) - result = e.Eval (domain); - Console.WriteLine (result); - } finally { - domain.UnboundTo (current); } - return result; - } - public override string ToString () - { - string str; + public void SetBody (Term[] body) + { + this.body = body; + } - if (builtin != null) - str = name; - else - { - str = "(" + name; - foreach (Xex a in lambda.args) - str += " " + a; - str += ")"; + public override Term Call (Domain domain, Variable vari, Term[] args) + { + Bindings current = domain.bindings; + Term result = Zero; + + try { + int i; + if (args_evalled) + { + Term[] newargs = new Term[args.Length]; + for (i = 0; i < min_arg; i++) + newargs[i] = args[i].Eval (domain); + args = newargs; + } + for (i = 0; i < min_arg; i++) + domain.Bind (this.args[i], args[i]); + if (body != null) + { + try { + if (args_evalled) + domain.Catch (CatchTag.Return); + foreach (Term term in body) + { + result = term.Eval (domain); + if (domain.Thrown) + return result; + } + } finally { + if (args_evalled) + domain.Uncatch (); + } + } + } finally { + domain.UnboundTo (current); } - return str; + return result; + } } } - internal abstract class Variable + public class Variable : TermValue { - public readonly Name name; - public readonly Name type; - internal object val; + public readonly Symbol name; + public string desc; + internal Term default_val; + internal Term val; + object range; - public Variable (Name name, Name type, object value) + public Variable (Symbol name, Term value) { - if (value != null) - Value = value; this.name = name; - this.type = type; + val = value; + default_val = Zero; } - public object Value + public virtual bool ValueP (Term val) { return true; } + + public override TermValue Clone () { - get { return val; } - set - { - if (! ValueP (value)) - throw new Exception ("Invalid value type: " + value); - val = value; - } + Variable v = new Variable (name, val); + v.desc = desc; + v.default_val = default_val; + v.range = range; + return v; } - public abstract bool ValueP (object value); + public Term Value + { + get { return val; } + set { + if (! ValueP (value)) + throw new Exception ("Invalid value: " + value); + val = value; + } + } - public override string ToString () { return name + "=" + val; } - } + public Term DefaultValue + { + get { return default_val; } + set { + if (! ValueP (value)) + throw new Exception ("Invalid value: " + value); + default_val = value; + } + } - internal class VarInt : Variable - { - public struct Range + public virtual object Range { - public int from, to; + get { return range; } + set { range = value; } } - public Range[] ranges; + public override Term Eval (Domain domain) { return val; } - public VarInt (Name name, object value) : base (name, Ninteger, value) { } + public override string ToString () { return name + "(" + val + ")"; } - public override bool ValueP (object value) + public class Int : Variable { - int i; - - if (! (value is int)) - return false; - if (ranges == null) - return true; - i = (int) value; - foreach (Range r in ranges) - if (i >= r.from && i <= r.to) + public int[] range; + + private static bool SubsetP (int[] r1, int[] r2) + { + if (r2 == null) + return true; + for (int i = 0; i < r1.Length; i += 2) + { + int j; + for (j = 0; j < r2.Length; j += 2) + if (r2[j] <= r1[i] && r2[j + 1] >= r1[i + 1]) + break; + if (j >= r2.Length) + return false; + } return true; - return false; - } - } + } - internal class VarStr : Variable - { - public string[] ranges; + private static bool SubsetP (int val, int[] r) + { + if (r == null) + return true; + for (int i = 0; i < r.Length; i += 2) + if (r[i] <= val && r[i + 1] >= val) + return true; + return false; + } + + public Int (Symbol name, string description, int value, int[] range) + : base (name, new Term (value)) + { + if (! SubsetP (value, range)) + throw new Exception ("Invalid value: " + value); + desc = description; + default_val = val; + this.range = range; + } - public VarStr (Name name, object value) : base (name, Nstring, value) { } + public override bool ValueP (Term term) + { + if (! term.IsInt) + return false; + return SubsetP (term.Intval, range); + } + + public override object Range { + get { return range; } + set { + int[] r = (int[]) value; + if (! SubsetP (r, range) + || ! SubsetP (val.Intval, r) + || ! SubsetP (default_val.Intval, r)) + throw new Exception ("Invalid range"); + range = r; + } + } + } - public override bool ValueP (object value) + public class Str : Variable { - string str; + public string[] range; - if (! (value is string)) - return false; - if (ranges == null) - return true; - str = (string) value; - foreach (string s in ranges) - if (s == str) + private static bool SubsetP (string[] r1, string[] r2) + { + if (r2 == null) + return true; + foreach (string s in r1) + if (! SubsetP (s, r2)) + return false; return true; - return false; - } - } + } - internal class VarBool : Variable - { - public VarBool (Name name, object value) - : base (name, Nboolean, value) { } + private static bool SubsetP (string str, string[] r) + { + if (r == null) + return true; + foreach (string s in r) + if (str == s) + return true; + return false; + } - public override bool ValueP (object value) - { - if (! (value is bool)) - return false; - return true; - } - } + public Str (Symbol name, string description, string value, string[] range) + : base (name, new Term (value)) + { + if (! SubsetP (value, range)) + throw new Exception ("Invalid value: " + value); + desc = description; + default_val = val; + this.range = range; + } - internal class VarMisc : Variable - { - public VarMisc (Name name, object value) : base (name, Nobject, value) { } + public override bool ValueP (Term term) + { + if (! (term.objval is string)) + return false; + return SubsetP (term.Strval, range); + } + + public override object Range { + get { return range; } + set { + string[] r = (string[]) value; + if (! SubsetP (r, range) + || ! SubsetP (val.Strval, r) + || ! SubsetP (default_val.Strval, r)) + throw new Exception ("Invalid range"); + range = r; + } + } + } - public override bool ValueP (object value) + public class Sym : Variable { - return true; + public Symbol[] range; + + private static bool SubsetP (Symbol[] r1, Symbol[] r2) + { + if (r2 == null) + return true; + foreach (Symbol n in r1) + if (! SubsetP (n, r2)) + return false; + return true; + } + + private static bool SubsetP (Symbol name, Symbol[] r) + { + if (r == null) + return true; + foreach (Symbol n in r) + if (name == n) + return true; + return false; + } + + public Sym (Symbol name, string description, Symbol value, Symbol[] range) + : base (name, new Term (value)) + { + if (! SubsetP (value, range)) + throw new Exception ("Invalid value: " + value); + desc = description; + default_val = val; + this.range = range; + } + + public override bool ValueP (Term term) + { + if (! (term.objval is Symbol)) + return false; + return SubsetP (term.Symval, range); + } + + public override object Range { + get { return range; } + set { + Symbol[] r = (Symbol[]) value; + if (! SubsetP (r, range) + || ! SubsetP (val.Symval, r) + || ! SubsetP (default_val.Symval, r)) + throw new Exception ("Invalid range"); + range = r; + } + } } } internal class Bindings { private Variable vari; - private object old_value; + private Term old_value; private Bindings next; - private Bindings (Variable vari, object value) + private Bindings (Variable vari) { this.vari = vari; - old_value = value; + old_value = vari.val; } - public static Bindings Bind (Bindings bindings, - Variable vari, object value) + public static Bindings Bind (Bindings bindings, Variable vari, Term val) { - Bindings b = new Bindings (vari, vari.val); + Bindings b = new Bindings (vari); - b.vari.Value = value; + b.vari.Value = val; b.next = bindings; return b; } @@ -385,7 +564,7 @@ namespace System.Xml.Expression internal Bindings UnboundTo (Bindings boundary) { for (Bindings b = this; b != boundary; b = b.next) - vari.val = b.old_value; + b.vari.val = b.old_value; return boundary; } @@ -393,7 +572,7 @@ namespace System.Xml.Expression { string str = "(bindings"; for (Bindings b = this; b != null; b = b.next) - str += " " + vari; + str += " " + vari.name + "=" + b.old_value; return str + ")"; } } @@ -401,10 +580,10 @@ namespace System.Xml.Expression #if false internal class ThrowException : Exception { - Name tag; + Symbol tag; public object value; - public ThrowException (Name tag, object value) : base () + public ThrowException (Symbol tag, object value) : base () { this.tag = tag; this.value = value; @@ -412,32 +591,56 @@ namespace System.Xml.Expression } #endif + internal class CatchTag : IEquatable + { + private object val; + + public CatchTag (Symbol name) { val = name.name; } + private CatchTag (int i) { val = i; } + + public static CatchTag Return = new CatchTag (0); + public static CatchTag Break = new CatchTag (1); + + public static bool operator== (CatchTag t1, CatchTag t2) + { return t1.val == t2.val; } + + public static bool operator!= (CatchTag t1, CatchTag t2) + { return t1.val != t2.val; } + + public bool Equals (CatchTag tag) { return this.val == tag.val; } + public override bool Equals (object val) { return this.val == val; } + + public override int GetHashCode () { return val.GetHashCode (); } + } + public class Domain { public object context; - - internal Dictionary functions; - internal Dictionary variables; + public int depth = 0; + + internal Dictionary termtypes + = new Dictionary (); + internal Dictionary functions + = new Dictionary (); + internal Dictionary variables + = new Dictionary (); internal Bindings bindings; + private Stack catch_stack = new Stack (); + private int catch_count = 0; - internal Domain () - { - functions = new Dictionary (); - variables = new Dictionary (); - } + internal Domain () { } - public Domain (object context) : this (basic, context) - { - } + public Domain (object context) : this (basic, context) { } public Domain (Domain parent, object context) { - functions = new Dictionary (parent.functions); - variables = new Dictionary (parent.variables); + termtypes = new Dictionary (parent.termtypes); + functions = new Dictionary (parent.functions); + variables = new Dictionary (parent.variables); this.context = context; } - internal void Bind (Variable vari, object value) + internal void Bind (Variable vari, Term value) { bindings = Bindings.Bind (bindings, vari, value); } @@ -448,124 +651,260 @@ namespace System.Xml.Expression bindings = bindings.UnboundTo (boundary); } - public void Defun (Name name, Builtin builtin, int min_arg, int max_arg) + internal void Catch (CatchTag tag) { - Defun (name, builtin, min_arg, max_arg, false); + catch_stack.Push (tag); + catch_count++; } - public void Defun (Name name, Builtin builtin, - int min_arg, int max_arg, bool specialp) + internal void Uncatch () { - Function func; + catch_stack.Pop (); + if (catch_count > catch_stack.Count) + catch_count--; + } + + public bool Thrown { + get { return catch_count < catch_stack.Count; } + } - if (functions.TryGetValue (name, out func)) + internal void ThrowReturn () + { + foreach (CatchTag tag in catch_stack) { - if (func.min_arg < min_arg || func.max_arg > max_arg) - throw new Exception ("Incompatible argument numbers to override: " - + name); - func.builtin = builtin; - func.lambda = null; - func.min_arg = min_arg; - func.max_arg = max_arg; - func.specialp = specialp; + catch_count--; + if (tag == CatchTag.Return) + break; } - else + } + + internal void ThrowBreak () + { + if (catch_stack.Peek () != CatchTag.Break) + throw new Exception ("No outer loop to break"); + catch_count--; + } + + internal void ThrowTag (CatchTag tag) + { + foreach (CatchTag elt in catch_stack) { - functions[name] - = new Function (name, builtin, min_arg, max_arg, specialp); + catch_count--; + if (elt == tag) + break; } } - internal Function RegisterFunction (XmlNode node) + public void DefTerm (Symbol name, TermParser parser) { - int min_arg, max_arg; - Name name = Function.ParseHead (node, out min_arg, out max_arg); - Function func = new Function (name, min_arg, max_arg); + termtypes[name] = new TermType (name, parser); + } - functions[name] = func; - return func; + public void DefSubr (Builtin builtin, string str, bool setvar, + int min_arg, int max_arg, params string[] aliases) + { + Symbol name = str; + Function func = new Function.Subroutine (builtin, name, setvar, + min_arg, max_arg); + functions[name] = func; + foreach (string a in aliases) + functions[(Symbol) a] = func; } - internal Function Defun (XmlNode node) + public void DefSpecial (Builtin builtin, string str, + int min_arg, int max_arg, + params string[] aliases) + { + Symbol name = str; + Function func = new Function.SpecialForm (builtin, name, + min_arg, max_arg); + functions[name] = func; + foreach (string a in aliases) + functions[(Symbol) a] = func; + } + + public void DefAlias (string alias, string str) + { + functions[(Symbol) alias] = functions[(Symbol) str]; + } + + public void Defun (Symbol name, bool args_evalled, + Symbol[] args, Term[] body, bool prototype) { - Name name = node.Attributes[Nfname].Value; Function func; - if (! functions.TryGetValue (name, out func)) - func = RegisterFunction (node); - func.Setup (node, this); - return func; + if (prototype || ! functions.TryGetValue (name, out func)) + { + func = new Function.Lambda (this, name, args_evalled, args); + functions[name] = func; + } + if (! prototype) + ((Function.Lambda) func).SetBody (body); + } + + public void Defun (XmlNode node, bool prototype) + { + Symbol name = node.Attributes[Qfname].Value; + Function func; + + if (prototype || ! functions.TryGetValue (name, out func)) + { + func = new Function.Lambda (this, node); + functions[name] = func; + } + if (! prototype) + ((Function.Lambda) func).SetBody (this, node); + } + + public void Defun (Function func) + { + functions[func.name] = func; } - public void Defvar (Name name, XmlNode node) + public Variable Defvar (XmlNode node) { + Symbol name = node.Attributes[0].Value; + String desc; Variable vari; - if (node.Name == Ndescription) - node = node.NextSibling; - if (node.Name == Nconst) + node = node.FirstChild; + if (node != null && node.Name == Qdescription) + { + desc = node.InnerText; + node = node.NextSibling; + } + else + desc = null; + if (node != null) { - Name type = (Name) node.Attributes[Ntype].Value; - string val = node.Value; + Symbol type = node.Name; XmlNodeList range_list = null; int nranges = 0; + string val = node.InnerText; node = node.NextSibling; - if (node.Name == Npossible_value) + if (node != null) { range_list = node.ChildNodes; nranges = range_list.Count; } - if (type == Ninteger) + if (type == Qinteger) { - VarInt vi = new VarInt (name, parse_integer (val)); + int intval = parse_integer (val); + int[] range = null; if (range_list != null) { - vi.ranges = new VarInt.Range[nranges]; - + range = new int[nranges * 2]; for (int i = 0; i < nranges; i++) { XmlNode n = range_list[i]; - - if (n.Name == Nconst) + if (n.Name == Qrange) { - int num = parse_integer (n.Value); - vi.ranges[i].from = vi.ranges[i].to = num; + range[i * 2] + = parse_integer (n.FirstChild.InnerText); + range[i * 2 + 1] + = parse_integer (n.LastChild.InnerText); } - else // range_list[i].Name == "range" + else { - vi.ranges[i].from = - parse_integer (n.FirstChild.Value); - vi.ranges[i].to = - parse_integer (n.LastChild.Value); + range[i * 2] + = range[i * 2 + 1] + = parse_integer (n.FirstChild.InnerText); } } } - vari = vi; + + if (variables.TryGetValue (name, out vari)) + { + if (! (vari is Variable.Int)) + throw new Exception ("Inalid value"); + vari = (Variable) vari.Clone (); + Term v = new Term (intval); + vari.Value = v; + vari.DefaultValue = v; + if (range != null) + vari.Range = range; + } + else + vari = new Variable.Int (name, desc, intval, range); } - else if (type == Nstring) + else if (type == Qstring) { - VarStr vs = new VarStr (name, val); + string[] range = null; if (range_list != null) - vs.ranges = new string[nranges]; - for (int i = 0; i < nranges; i++) - vs.ranges[i] = range_list[i].Value; - vari = vs; + { + range = new string[nranges]; + for (int i = 0; i < nranges; i++) + range[i] = range_list[i].FirstChild.InnerText; + } + + if (variables.TryGetValue (name, out vari)) + { + if (! (vari is Variable.Str)) + throw new Exception ("Invalid value"); + vari = (Variable) vari.Clone (); + Term v = new Term (val); + vari.Value = v; + vari.DefaultValue = v; + if (range != null) + vari.Range = range; + } + else + vari = new Variable.Str (name, desc, val, range); } - else if (type == Nboolean) + else if (type == Qsymbol) { - vari = new VarBool (name, val == "true"); + Symbol[] range = null; + if (range_list != null) + { + range = new Symbol[nranges]; + for (int i = 0; i < nranges; i++) + range[i] = range_list[i].FirstChild.InnerText; + } + + if (variables.TryGetValue (name, out vari)) + { + if (! (vari is Variable.Sym)) + throw new Exception ("Invalid value"); + vari = (Variable) vari.Clone (); + Term v = new Term (val); + vari.Value = v; + vari.DefaultValue = v; + if (range != null) + vari.Range = range; + } + else + vari = new Variable.Sym (name, desc, val, range); } else throw new Exception ("Unknown type: " + type); } else - vari = new VarMisc (name, null); + { + if (variables.TryGetValue (name, out vari)) + vari = (Variable) vari.Clone (); + else + vari = new Variable (name, Zero); + } + variables[name] = vari; + return vari; + } + + public Variable Defvar (Variable vari) + { + variables[vari.name] = vari; + return vari; + } + + internal Variable Defvar (Symbol name) + { + Variable vari = new Variable (name, Zero); variables[name] = vari; + return vari; } - internal Function GetFunc (Name name) + internal Function GetFunc (Symbol name) { Function func; @@ -574,7 +913,7 @@ namespace System.Xml.Expression return func; } - public bool CopyFunc (Domain domain, Name name) + public bool CopyFunc (Domain domain, Symbol name) { Function func = GetFunc (name); @@ -584,33 +923,30 @@ namespace System.Xml.Expression public void CopyFunc (Domain domain) { - foreach (KeyValuePair kv in functions) + foreach (KeyValuePair kv in functions) domain.functions[kv.Key] = kv.Value; } - internal Variable GetVar (Name name) + public Variable GetVar (Symbol name, bool create) { Variable vari; if (! variables.TryGetValue (name, out vari)) - variables[name] = vari = new VarMisc (name, null); + { + if (! create) + return null; + variables[name] = vari = new Variable (name, Zero); + } return vari; } - internal Variable GetVar (Xex e) - { - if (! (e.val is Name)) - throw new Exception ("Not a symbol" + e.val); - return GetVar ((Name) e.val); - } - public override string ToString () { string str = "<(functions"; - foreach (KeyValuePair kv in functions) + foreach (KeyValuePair kv in functions) str += " " + kv.Key; str += ") (variabls"; - foreach (KeyValuePair kv in variables) + foreach (KeyValuePair kv in variables) str += " " + kv.Key; str += ")"; if (bindings != null) @@ -620,414 +956,899 @@ namespace System.Xml.Expression str += ">"; return str; } - } - public delegate object Builtin (Xex[] args, Domain domain); - - private static Domain basic = new Domain (); + internal void DebugWrite (bool head, string fmt, params string[] arg) + { + if (debug_level > depth) + { + if (head) + { + Console.WriteLine (); + for (int i = 0; i < depth; i++) + Console.Write (" "); + } + Console.Write (fmt, arg); + } + } - internal static Function Fprogn; + public object SaveValues () + { + Dictionary values = new Dictionary (); + + foreach (KeyValuePair kv in variables) + values[kv.Value] = kv.Value.val.Clone (); + return values; + } - static Xex () + public void RestoreValues (object values) + { + foreach (KeyValuePair kv + in (Dictionary) values) + kv.Key.val = kv.Value; + } + } + + public delegate Term Builtin (Domain domain, Variable vari, Term[] args); + + private static Domain basic = new Domain (); + + static Xexpression () { - basic.Defun ("set", set_value, 2, 2, false); - basic.Defun ("=", set_value, 2, 2, false); - basic.Defun ("and", and, 1, -1, false); - basic.Defun ("&&", and, 1, -1, false); - basic.Defun ("or", or, 1, -1, false); - basic.Defun ("||", or, 1, -1, false); - basic.Defun ("not", not, 1, 1, false); - basic.Defun ("!", not, 1, 1, false); - basic.Defun ("add", add, 2, -1, false); - basic.Defun ("+", add, 2, -1, false); - basic.Defun ("mul", mul, 2, -1, false); - basic.Defun ("*", mul, 2, -1, false); - basic.Defun ("sub", sub, 1, -1, false); - basic.Defun ("-", sub, 1, -1, false); - basic.Defun ("div", div, 2, -1, false); - basic.Defun ("/", div, 2, -1, false); - basic.Defun ("mod", mod, 2, 2, false); - basic.Defun ("%", mod, 2, 2, false); - basic.Defun ("logior", logior, 2, -1, false); - basic.Defun ("|", logior, 2, -1, false); - basic.Defun ("logand", logand, 2, -1, false); - basic.Defun ("&", logand, 2, -1, false); - basic.Defun ("add-set", add_set, 2, -1, true); - basic.Defun ("+=", add_set, 2, -1, true); - basic.Defun ("mul-set", mul_set, 2, -1, true); - basic.Defun ("*=", mul_set, 2, -1, true); - basic.Defun ("sub-set", sub_set, 2, -1, true); - basic.Defun ("-=", sub_set, 2, -1, true); - basic.Defun ("div-set", div_set, 2, -1, true); - basic.Defun ("/=", div_set, 2, -1, true); - basic.Defun ("mod-set", mod_set, 2, 2, true); - basic.Defun ("%=", mod_set, 2, 2, true); - basic.Defun ("logior-set", logior_set, 2, -1, true); - basic.Defun ("|=", logior_set, 2, -1, true); - basic.Defun ("logand-set", logand_set, 2, -1, true); - basic.Defun ("&=", logand_set, 2, -1, true); - basic.Defun ("lsh", lsh, 2, 2, false); - basic.Defun ("<<", lsh, 2, 2, false); - basic.Defun ("rsh", rsh, 2, 2, false); - basic.Defun (">>", rsh, 2, 2, false); - basic.Defun ("lsh-set", lsh_set, 2, 2, true); - basic.Defun ("<<=", lsh_set, 2, 2, true); - basic.Defun ("rsh-set", rsh_set, 2, 2, true); - basic.Defun (">>=", rsh_set, 2, 2, true); - basic.Defun ("eq", eq, 2, -1, false); - basic.Defun ("==", eq, 2, -1, false); - basic.Defun ("noteq", noteq, 2, 2, false); - basic.Defun ("!=", noteq, 2, 2, false); - basic.Defun ("lt", less_than, 2, -1, false); - basic.Defun ("<", less_than, 2, -1, false); - basic.Defun ("le", less_eq, 2, -1, false); - basic.Defun ("<=", less_eq, 2, -1, false); - basic.Defun ("gt", greater_than, 2, -1, false); - basic.Defun (">", greater_than, 2, -1, false); - basic.Defun ("ge", greater_eq, 2, -1, false); - basic.Defun (">=", greater_eq, 2, -1, false); - basic.Defun ("eval", eval_clause, 1, 1, true); - basic.Defun ("progn", progn_clause, 0, -1, true); - basic.Defun ("expr", progn_clause, 0, -1, true); - basic.Defun ("if", if_clause, 2, -1, true); - basic.Defun ("when", when_clause, 1, -1, true); - basic.Defun ("while", while_clause, 1, -1, true); - - Fprogn = basic.GetFunc (Nprogn); + basic.DefTerm ("funcall", Funcall.parser); + + basic.DefSubr (Fset, "set", true, 1, 1, "="); + basic.DefSubr (Fnot, "not", false, 1, 1, "!"); + basic.DefSubr (Fadd, "add", true, 1, -1, "+"); + basic.DefSubr (Fmul, "mul", true, 1, -1, "*"); + basic.DefSubr (Fsub, "sub", true, 1, -1, "-"); + basic.DefSubr (Fdiv, "div", true, 1, -1, "/"); + basic.DefSubr (Fmod, "mod", true, 1, 2, "%"); + basic.DefSubr (Flogior, "logior", true, 1, -1, "|"); + basic.DefSubr (Flogand, "logand", true, 1, -1, "&"); + basic.DefSubr (Flsh, "lsh", true, 1, 2, "<<"); + basic.DefSubr (Frsh, "rsh", true, 1, 2, ">>"); + basic.DefSubr (Feq, "eq", false, 2, -1, "=="); + basic.DefSubr (Fnoteq, "noteq", false, 2, 2, "!="); + basic.DefSubr (Flt, "lt", false, 2, -1, "<"); + basic.DefSubr (Fle, "le", false, 2, -1, "<="); + basic.DefSubr (Fgt, "gt", false, 2, -1, ">"); + basic.DefSubr (Fge, "ge", false, 2, -1, ">="); + basic.DefSubr (Fappend, "append", true, 0, -1); + basic.DefSubr (Fconcat, "concat", true, 0, -1); + basic.DefSubr (Fnth, "nth", false, 2, 2); + basic.DefSubr (Fcopy, "copy", false, 1, 1); + basic.DefSubr (Fins, "ins", true, 2, 2); + basic.DefSubr (Fdel, "del", true, 2, 2); + basic.DefSubr (Feval, "eval", false, 1, 1); + basic.DefSubr (Fbreak, "break", false, 0, 1); + basic.DefSubr (Freturn, "return", false, 0, 1); + + basic.DefSpecial (Fand, "and", 1, -1, "&&"); + basic.DefSpecial (For, "or", 1, -1, "||"); + basic.DefSpecial (Fprogn, "progn", 0, -1, "expr"); + basic.DefSpecial (Fif, "if", 2, 3); + basic.DefSpecial (Fwhen, "when", 1, -1); + basic.DefSpecial (Floop, "loop", 1, -1); + basic.DefSpecial (Fwhile, "while", 1, -1); + basic.DefSpecial (Fcond, "cond", 1, -1); + basic.DefSpecial (Fforeach, "foreach", 2, -1); + basic.DefSpecial (Fquote, "quote", 1, 1); + basic.DefSpecial (Ftype, "type", 1, 1); + basic.DefSpecial (Fcatch, "catch", 2, 2); + basic.DefSpecial (Fthrow, "throw", 1, 2); } - private static bool is_true (object val) + private static Term Fset (Domain domain, Variable vari, Term[] args) { - return (val is bool ? (bool) val - : val is int ? (int) val == 0 - : true); + vari.Value = args[0]; + return vari.val; } - private static object set_value (Xex[] args, Domain domain) + private static Term Fnot (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); + return args[0].IsTrue ? Zero : One; + } - vari.Value = args[1].val; + private static Term Fadd (Domain domain, Variable vari, Term[] args) + { + int n = vari == null ? 0 : vari.val.Intval; + + foreach (Term arg in args) + n += arg.Intval; + if (vari == null) + return new Term (n); + vari.val.intval = n; return vari.val; } - private static object and (Xex[] args, Domain domain) + private static Term Fmul (Domain domain, Variable vari, Term[] args) { - foreach (Xex arg in args) - if (! is_true (arg.val)) - return false; - return true; + int n = vari == null ? 1 : vari.val.Intval; + foreach (Term arg in args) + n *= arg.Intval; + if (vari == null) + return new Term (n); + vari.val.intval = n; + return vari.val; } - private static object or (Xex[] args, Domain domain) + private static Term Fsub (Domain domain, Variable vari, Term[] args) { - foreach (Xex arg in args) - if (is_true (arg.val)) - return true; - return false; + int n, i; + + if (vari == null) + { + n = args[0].Intval; + i = 1; + } + else + { + n = vari.val.Intval; + i = 0; + } + while (i < args.Length) + n -= args[i++].Intval; + if (vari == null) + return new Term (n); + vari.val.intval = n; + return vari.val; } - private static object not (Xex[] args, Domain domain) + private static Term Fdiv (Domain domain, Variable vari, Term[] args) { - return ! is_true (args[0].val); + int n, i; + + if (vari == null) + { + n = args[0].Intval; + i = 1; + } + else + { + n = vari.val.Intval; + i = 0; + } + while (i < args.Length) + n /= args[i++].Intval; + if (vari == null) + return new Term (n); + vari.val.intval = n; + return vari.val; } - private static object add (Xex[] args, Domain domain) + private static Term Fmod (Domain domain, Variable vari, Term[] args) { - int n = 0; - foreach (Xex e in args) - n += (int) e.val; - return n; + if (vari == null) + return new Term (args[0].Intval % args[1].Intval); + vari.val.intval = vari.val.Intval % args[0].Intval; + return vari.val; } - private static object mul (Xex[] args, Domain domain) + private static Term Flogior (Domain domain, Variable vari, Term[] args) { - int n = 1; - foreach (Xex e in args) - n *= (int) e.val; - return n; + int n = vari == null ? 0 : vari.val.Intval; + foreach (Term arg in args) + n |= arg.Intval; + if (vari == null) + return new Term (n); + vari.val.intval = n; + return vari.val; } - private static object sub (Xex[] args, Domain domain) + private static Term Flogand (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - if (args.Length == 1) - return - n; - for (int i = 1; i < args.Length; i++) - n -= (int) args[i].val; - return n; + int n, i; + + if (vari == null) + { + n = args[0].Intval; + i = 1; + } + else + { + n = vari.val.Intval; + i = 0; + } + while (i < args.Length) + n &= args[i++].Intval; + if (vari == null) + return new Term (n); + vari.val.intval = n; + return vari.val; } - private static object div (Xex[] args, Domain domain) + private static Term Flsh (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - for (int i = 1; i < args.Length; i++) - n /= (int) args[i].val; - return n; + if (vari == null) + return new Term (args[0].Intval << args[1].Intval); + vari.val.intval = vari.val.Intval << args[0].Intval; + return vari.val; } - private static object mod (Xex[] args, Domain domain) + private static Term Frsh (Domain domain, Variable vari, Term[] args) { - return ((int) args[0].val % (int) args[1].val); + if (vari == null) + return new Term (args[0].Intval >> args[1].Intval); + vari.val.intval = vari.val.Intval >> args[0].Intval; + return vari.val; } - private static object logior (Xex[] args, Domain domain) + private static Term Feq (Domain domain, Variable vari, Term[] args) { - int n = 0; - foreach (Xex e in args) - n |= (int) e.val; - return n; + Term o = args[0]; + + if (o.objval == null) + { + for (int i = 1; i < args.Length; i++) + if (args[i].objval != null || args[i].intval != o.intval) + return Zero; + } + else + { + for (int i = 1; i < args.Length; i++) + if (o.objval.Equals (args[i].objval)) + return Zero; + } + return One; } - private static object logand (Xex[] args, Domain domain) + private static Term Fnoteq (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - for (int i = 1; i < args.Length; i++) - n &= (int) args[i].val; - return n; + return Feq (domain, vari, args); } - private static object add_set (Xex[] args, Domain domain) + private static Term Flt (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; + int n = args[0].Intval; for (int i = 1; i < args.Length; i++) - n += (int) args[i].val; - vari.val = n; - return n; + { + int n1 = args[i].Intval; + if (n >= n1) + return Zero; + n = n1; + } + return One; } - private static object mul_set (Xex[] args, Domain domain) + private static Term Fle (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; - + int n = args[0].Intval; for (int i = 1; i < args.Length; i++) - n *= (int) args[i].val; - vari.val = n; - return n; + { + int n1 = args[i].Intval; + if (n > n1) + return Zero; + n = n1; + } + return One; } - private static object sub_set (Xex[] args, Domain domain) + private static Term Fgt (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; - + int n = args[0].Intval; for (int i = 1; i < args.Length; i++) - n -= (int) args[i].val; - vari.val = n; - return n; + { + int n1 = args[i].Intval; + if (n <= n1) + return Zero; + n = n1; + } + return One; } - private static object div_set (Xex[] args, Domain domain) + private static Term Fge (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; - + int n = args[0].Intval; for (int i = 1; i < args.Length; i++) - n /= (int) args[i].val; - vari.val = n; - return n; + { + int n1 = args[i].Intval; + if (n < n1) + return Zero; + n = n1; + } + return One; } - private static object mod_set (Xex[] args, Domain domain) + private static Term Fappend (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; + List list; - for (int i = 1; i < args.Length; i++) - n %= (int) args[i].val; - vari.val = n; - return n; + if (vari == null) + list = new List (); + else + list = vari.val.Listval; + + foreach (Term arg in args) + { + if (arg.IsList) + list.AddRange ((List) arg.objval); + else + list.Add (arg); + } + if (vari == null) + { + Term result; + result.intval = 0; + result.objval = list; + return result; + } + return vari.val; } - private static object logior_set (Xex[] args, Domain domain) + private static Term Fconcat (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; + string str; - for (int i = 1; i < args.Length; i++) - n |= (int) args[i].val; - vari.val = n; - return n; + if (vari == null) + str = ""; + else + str = vari.val.Strval; + + foreach (Term arg in args) + { + if (arg.IsStr) + str += (string) arg.objval; + else if (arg.IsList) + foreach (Term term in (List) arg.objval) + str += (char) term.Intval; + else + str += (char) arg.Intval; + } + if (vari == null) + { + Term result; + result.intval = 0; + result.objval = str; + return result; + } + vari.val.objval = str; + return vari.val; } - private static object logand_set (Xex[] args, Domain domain) + private static Term Fnth (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; + Term result; - for (int i = 1; i < args.Length; i++) - n &= (int) args[i].val; - vari.val = n; - return n; + if (args[1].IsStr) + { + result.intval = ((string) args[1].objval)[args[0].Intval]; + result.objval = null; + } + else if (args[1].IsList) + { + result = ((List) args[1].objval)[args[0].Intval]; + } + else + throw new Exception ("Term is not enumelable: " + args[1]); + return result; } - private static object lsh (Xex[] args, Domain domain) + private static Term Fcopy (Domain domain, Variable vari, Term[] args) { - return (int) args[0].val << (int) args[1].val; + Term result; + + result.intval = 0; + result.objval = new List (args[0].Listval); + return result; } - private static object lsh_set (Xex[] args, Domain domain) + private static Term Fins (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; + if (vari.val.IsStr) + vari.val.objval + = vari.val.Strval.Insert (args[0].Intval, args[1].Strval); + else if (vari.val.IsList) + vari.val.Listval.InsertRange (args[0].Intval, args[1].Listval); + else + throw new Exception ("term is not collection: " + vari.val); + return vari.val; + } - n <<= (int) args[1].val; - vari.val = n; - return n; + private static Term Fdel (Domain domain, Variable vari, Term[] args) + { + if (vari.val.IsStr) + vari.val.objval + = vari.val.Strval.Remove (args[0].Intval, + args[1].Intval - args[0].Intval); + + else if (vari.val.IsList) + vari.val.Listval.RemoveRange (args[0].Intval, + args[1].Intval - args[0].Intval); + else + throw new Exception ("term is not collection: " + vari.val); + return vari.val; } - private static object rsh (Xex[] args, Domain domain) + private static Term Fand (Domain domain, Variable vari, Term[] args) { - return (int) args[0].val >> (int) args[1].val; + foreach (Term arg in args) + if (! arg.Eval (domain).IsTrue) + return Zero; + return One; } - private static object rsh_set (Xex[] args, Domain domain) + private static Term For (Domain domain, Variable vari, Term[] args) { - Variable vari = domain.GetVar (args[0]); - int n = (int) vari.val; + foreach (Term arg in args) + if (arg.Eval (domain).IsTrue) + return One; + return Zero; + } - n >>= (int) args[1].val; - vari.val = n; - return n; + private static Term Feval (Domain domain, Variable vari, Term[] args) + { + return (args[0].Eval (domain)); } - private static object eq (Xex[] args, Domain domain) + private static Term Fprogn (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; + Term result = One; - for (int i = 1; i < args.Length; i++) - if (n != (int) args[i].val) - return false; - return true; + foreach (Term arg in args) + result = arg.Eval (domain); + return result; } - private static object noteq (Xex[] args, Domain domain) + private static Term Fif (Domain domain, Variable vari, Term[] args) { - return ((int) args[0].val != (int) args[1].val); + if (args[0].Eval (domain).IsTrue) + return args[1].Eval (domain); + if (args.Length == 2) + return Zero; + return args[2].Eval (domain); } - private static object less_than (Xex[] args, Domain domain) + private static Term Fwhen (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - + if (! args[0].Eval (domain).IsTrue) + return Zero; + Term result = One; for (int i = 1; i < args.Length; i++) - { - int n1 = (int) args[i].val; - if (n >= n1) - return false; - n = n1; - } - return true; + result = args[i].Eval (domain); + return result; } - private static object less_eq (Xex[] args, Domain domain) + private static Term Freturn (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - for (int i = 1; i < args.Length; i++) - { - int n1 = (int) args[i].val; - if (n > n1) - return false; - n = n1; - } - return true; + domain.ThrowReturn (); + return args.Length == 0 ? Zero : args[0]; + } + + private static Term Fbreak (Domain domain, Variable vari, Term[] args) + { + domain.ThrowBreak (); + return args.Length == 0 ? Zero : args[0]; + } + + private static Term Floop (Domain domain, Variable vari, Term[] args) + { + Term result = Zero; + try { + domain.Catch (CatchTag.Break); + while (! domain.Thrown) + foreach (Term arg in args) + { + result = arg.Eval (domain); + if (domain.Thrown) + return result; + } + } finally { + domain.Uncatch (); + } + return result; } - private static object greater_than (Xex[] args, Domain domain) + private static Term Fwhile (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - for (int i = 1; i < args.Length; i++) - { - int n1 = (int) args[i].val; - if (n <= n1) - return false; - n = n1; - } - return true; + Term result = Zero; + try { + domain.Catch (CatchTag.Break); + while (! domain.Thrown && args[0].Eval (domain).IsTrue) + for (int i = 1; i < args.Length; i++) + { + result = args[i].Eval (domain); + if (domain.Thrown) + return result; + } + } finally { + domain.Uncatch (); + } + return result; } - private static object greater_eq (Xex[] args, Domain domain) + private static Term Fcond (Domain domain, Variable vari, Term[] args) { - int n = (int) args[0].val; - for (int i = 1; i < args.Length; i++) + foreach (Term arg in args) { - int n1 = (int) args[i].val; - if (n < n1) - return false; - n = n1; + List list = arg.Listval; + Term result = list[0].Eval (domain); + + if (result.IsTrue) + { + for (int i = 1; i < list.Count; i++) + result = list[i].Eval (domain); + return result; + } } - return true; + return Zero; } - private static object eval_clause (Xex[] args, Domain domain) + private static Term Fforeach (Domain domain, Variable vari, + Term[] args) { - return args[0].Eval (domain); + Term result = args[0].Eval (domain); + if (domain.Thrown) + return result; + List list = result.Listval; + Bindings current = domain.bindings; + + try { + domain.Catch (CatchTag.Break); + foreach (Term term in list) + { + domain.Bind (vari, term); + try { + for (int i = 1; i < args.Length; i++) + { + result = args[i].Eval (domain); + if (domain.Thrown) + return result; + } + } finally { + domain.UnboundTo (current); + } + } + } finally { + domain.Uncatch (); + } + return result; } - private static object progn_clause (Xex[] args, Domain domain) + private static Term Fquote (Domain domain, Variable vari, Term[] args) { - object result = true; - - foreach (Xex e in args) - result = e.Eval (domain); - return result; + return new Term (args[0]); } - private static object if_clause (Xex[] args, Domain domain) + private static Term Ftype (Domain domain, Variable vari, Term[] args) { - object result; + if (args[0].IsInt) + return TermInt; + if (args[0].IsStr) + return TermStr; + if (args[0].IsSymbol) + return TermSymbol; + if (args[0].IsList) + return TermList; + return TermTerm; + } - if (is_true (args[0].Eval (domain))) + public static Term Fcatch (Domain domain, Variable vari, Term[] args) + { + Term result = Zero; + try { + domain.Catch (new CatchTag (args[0].Symval)); result = args[1].Eval (domain); - else - { - result = false; - for (int i = 2; i < args.Length; i++) - result = args[i].Eval (domain); - } + } finally { + domain.Uncatch (); + } return result; } - private static object when_clause (Xex[] args, Domain domain) + public static Term Fthrow (Domain domain, Variable vari, Term[] args) { - if (! is_true (args[0].Eval (domain))) - return false; + domain.ThrowTag (new CatchTag (args[0].Symval)); + return (args.Length == 1 ? Zero : args[1]); + } - object result = true; - for (int i = 1; i < args.Length; i++) - result = args[i].Eval (domain); - return result; + public delegate TermValue TermParser (Domain domain, XmlNode node); + + public class TermType + { + public readonly Symbol type; + internal readonly TermParser parser; + + public TermType (Symbol type, TermParser parser) + { + this.type = type; + this.parser = parser; + } } - private static object while_clause (Xex[] args, Domain domain) + public abstract class TermValue { - while (is_true (args[0].Eval (domain))) - for (int i = 1; i < args.Length; i++) - args[i].Eval (domain); - return false; + public virtual Term Eval (Domain domain) { return new Term (this); } + public abstract TermValue Clone (); } - // FUNCALL: function != null - // VARREF: function == null, args[0] = DIRECT-SYMBOL - // DIRECT: function == null, args == null + private class Funcall : TermValue + { + internal Function func; + internal Variable vari; + internal Term[] args; - private Function function; - private Xex[] args; - private object val; + private Funcall (Function func, Variable vari, Term[] args) + { + this.func = func; + this.vari = vari; + this.args = args; + } - public Xex[] Args { get { return args; } } - public object Val { get { return val; } } + public Funcall (Domain domain, Symbol fname, Term[] args) + { + func = domain.GetFunc (fname); + if (args != null) + { + int nargs = args.Length; + if (nargs < func.min_arg + || (func.max_arg >= 0 && nargs > func.max_arg)) + throw new Exception ("Invalid number of arguments to: " + + fname + " " + nargs); + } + this.args = args; + } + + public Funcall (Domain domain, Symbol fname, Symbol vname, Term[] args) + { + func = domain.GetFunc (fname); + if (args != null) + { + int nargs = args.Length; + if (nargs < func.min_arg + || (func.max_arg >= 0 && nargs > func.max_arg)) + throw new Exception ("Invalid number of arguments to: " + + fname + " " + nargs); + } + this.args = args; + if (vname != Qnull) + vari = domain.GetVar (vname, true); + } + + internal static TermValue parser (Domain domain, XmlNode node) + { + Symbol fname = node.Name; + Symbol vname = Qnull; + XmlAttribute attr; - private Xex () { } + if (fname == Qfuncall) + fname = node.Attributes[Qfname].Value; + attr = node.Attributes[Qvname]; + if (attr != null) + vname = attr.Value; + + XmlNodeList nlist = node.ChildNodes; + int nargs = nlist.Count; + Term[] args = new Term[nargs]; + for (int i = 0; i < nargs; i++) + args[i] = new Term (domain, nlist[i]); + return new Funcall (domain, fname, vname, args); + } - private Xex (object val) + public override Term Eval (Domain domain) + { + domain.DebugWrite (true, "(({0}", func.name); + for (int i = 0; i < args.Length; i++) + domain.DebugWrite (false, " {0}", args[i].ToString ()); + domain.DebugWrite (false, ")"); + domain.depth++; + Term result = func.Call (domain, vari, args); + domain.depth--; + domain.DebugWrite (true, " ==> {0})", result.ToString ()); + return result; + } + + public override TermValue Clone () + { + return new Funcall (func, vari, args); + } + + public override string ToString () + { + string str = "<" + func.name; + if (vari != null) + str += " \"vname=" + vari.name + "\""; + if (args == null) + return str + "/>"; + str += ">"; + foreach (Term e in args) + str += e; + return (str + ""); + } + } + + public struct Term { - this.val = val; + public int intval; + public object objval; + + // ... + public Term (int i) { intval = i; objval = null; } + // ... + public Term (Symbol name) { intval = 0; objval = name; } + // ... + public Term (string str) { intval = 0; objval = str; } + // ... + public Term (List list) { intval = 0; objval = list; } + + public Term (Term term) { intval = term.intval; objval = term.objval; } + public Term (TermValue obj) { intval = 0; objval = obj; } + + public Term (Domain domain, XmlNode node) + { + Symbol name = node.Name; + + if (name == Qinteger) + { + intval = parse_integer (node.InnerText); + objval = null; + } + else + { + intval = 0; + if (name == Qsymbol) + objval = (Symbol) node.InnerText; + else if (name == Qstring) + objval = node.InnerText.Clone (); + else if (name == Qvarref) + objval = domain.GetVar ((Symbol) node.Attributes[0].Value, true); + else if (name == Qlist) + { + List list = new List (); + for (node = node.FirstChild; node != null; + node = node.NextSibling) + list.Add (new Term (domain, node)); + objval = list; + } + else + { + TermType term_type; + + if (domain.termtypes.TryGetValue (name, out term_type)) + objval = term_type.parser (domain, node); + else + objval = Funcall.parser (domain, node); + } + } + } + + // + public Term (Domain domain, Symbol vname) + { + intval = 0; + objval = domain.GetVar (vname, true); + } + + // ... + public Term (Domain domain, Symbol fname, Term[] args) + { + intval = 0; + objval = new Funcall (domain, fname, args); + } + + // ... + public Term (Domain domain, Symbol fname, Symbol vname, Term[] args) + { + intval = 0; + objval = new Funcall (domain, fname, vname, args); + } + + public object Objval { + get { + if (objval == null) + throw new Exception ("term is an integer: " + this); + return objval; + } + } + + public int Intval { + get { + if (objval != null) + throw new Exception ("term is not integer: " + this); + return intval; + } + } + + public string Strval { + get { + if (! IsStr) + throw new Exception ("term is not string: " + this); + return (string) objval; + } + } + + public string Symval { + get { + if (! IsSymbol) + throw new Exception ("term is not symbol: " + this); + return (Symbol) objval; + } + } + + public List Listval { + get { + if (! IsList) + throw new Exception ("term is not list: " + this); + return (List) objval; + } + } + + public bool IsTrue { + get { + return (objval == null + ? (intval != 0) + : objval is List + ? (((List) objval).Count != 0) + : true); + } + } + public bool IsInt { get { return (objval == null); } } + public bool IsStr { get { return (objval is string); } } + public bool IsSymbol { get { return (objval is Symbol); } } + public bool IsList { get { return (objval is List); } } + + public bool IsType (Type type) + { + return (objval == null ? type == typeof (int) + : type == objval.GetType ()); + } + + public Term Eval (Domain domain) + { + if (objval == null || objval is Symbol || objval is string) + return this; + if (objval is List) + return new Term ((List) objval); + return ((TermValue) objval).Eval (domain); + } + + public Term Clone () + { + if (objval == null || objval is Symbol || objval is string) + return this; + if (objval is List) + { + List list = new List (); + list.InsertRange (0, ((List) objval)); + return new Term (list); + } + return new Term (((TermValue) objval).Clone ()); + } + + public override string ToString () + { + string str; + + if (objval == null) + str = "" + intval + ""; + else if (objval is Symbol) + str = "" + objval + ""; + else if (objval is string) + str = "" + objval + ""; + else if (objval is List) + { + str = ""; + foreach (Term e in (List) objval) + str += e; + str += ""; + } + else if (objval is Term) + str = "" + objval + ""; + else if (objval is TermValue) + str = ((TermValue) objval).ToString (); + else + throw new Exception ("invalid Term object: " + objval); + return str; + } } + static private Term Zero = new Term (0); + static private Term One = new Term (1); + static private Term TermInt = new Term (Qinteger); + static private Term TermStr = new Term (Qstring); + static private Term TermSymbol = new Term (Qsymbol); + static private Term TermList = new Term (Qlist); + static private Term TermTerm = new Term ((Symbol) "term"); + internal static int parse_integer (string str) { int len = str.Length; @@ -1039,7 +1860,9 @@ namespace System.Xml.Expression int c = str[0]; int i; - if (c == '0' && str[1] == 'x') + if (c == '?') + return str[1]; + if ((c == '0' || c == '#') && str[1] == 'x') { i = 0; for (int idx = 2; idx < len; idx++) @@ -1075,153 +1898,95 @@ namespace System.Xml.Expression return negative ? - i : i; } - private int pre_parse (XmlNodeList nlist, Domain domain) - { - int len = 0; - foreach (XmlNode node in nlist) - { - if (node.Name == Ndefun) - domain.RegisterFunction (node); - else if (node.Name == Ndefvar) - domain.Defvar ((Name) node.Attributes[0].Value, node.FirstChild); - else - len++; - } - return len; - } + private Term[] terms; - private void post_parse (XmlNodeList nlist, Domain domain) + public static Term[] ParseTerms (Domain domain, XmlNode node) { - for (int i = 0, j = 0; i < nlist.Count; i++) - { - XmlNode node = nlist[i]; - - if (node.Name == Ndefun) - domain.Defun (node); - else if (node.Name != Ndefvar) - args[j++] = new Xex (node, domain); - } + int nterms = 0; + for (XmlNode n = node; n != null; n = n.NextSibling) + if (n.NodeType == XmlNodeType.Element) + { + if (n.Name == Qdefun) + domain.Defun (n, true); + else if (n.Name == Qdefvar) + domain.Defvar (n); + else + nterms++; + } + Term[] terms = new Term[nterms]; + int i = 0; + for (XmlNode n = node; n != null; n = n.NextSibling) + if (n.NodeType == XmlNodeType.Element) + { + if (n.Name == Qdefun) + domain.Defun (n, false); + else if (n.Name != Qdefvar) + terms[i++]= new Term (domain, n); + } + return terms; } - private void Setup (XmlNode node, Domain domain) + public static Term Eval (Domain domain, Term[] terms) { - Name name = node.Name; - - if (name == Nconst) - { - Name type = node.Attributes[Ntype].Value; - - if (type == Ninteger) - val = parse_integer (node.InnerText); - else if (type == Nstring) - val = node.InnerText; - else if (type == Nsymbol) - val = (Name) node.InnerText; - else if (type == Nboolean) - val = node.InnerText == "true"; - else if (type == Nlist) - { - List list = new List (); - for (XmlNode n = node.FirstChild; n != null; n = n.NextSibling) - list.Add (new Xex (n, domain)); - val = list; - } - else - throw new Exception ("Unknown type: " + type); - } - else if (name == Nvariable) + Term result = new Term (0); + foreach (Term term in terms) { - args = new Xex[1]; - args[0] = new Xex ((Name) node.Attributes[0].Value); + result = term; + if (result.Objval is Funcall) + while ((result = result.Eval (domain)).Objval is Funcall); } - else - { - if (name == Nfuncall) - name = node.Attributes[0].Value; - function = domain.GetFunc (name); + return result; + } - XmlNodeList nlist = node.ChildNodes; - int nargs = nlist.Count; - if (nargs < function.min_arg - || (function.max_arg >= 0 && nargs > function.max_arg)) - throw new Exception ("Invalid number of arguments to: " - + name + " " + nargs); - nargs = pre_parse (nlist, domain); - args = new Xex[nargs]; - post_parse (nlist, domain); - } + public Xexpression (Domain domain, XmlNode node) + { + terms = ParseTerms (domain, node); } - public Xex (string url, Domain domain) + public Xexpression (Domain domain, string url) { - XmlDocument doc = new XmlDocument (Name.Table); + XmlDocument doc = new XmlDocument (Symbol.Table); XmlNode node; - using (XmlTextReader reader = new XmlTextReader (url, Name.Table)) + using (XmlTextReader reader = new XmlTextReader (url, Symbol.Table)) { do { reader.Read (); } while (reader.NodeType != XmlNodeType.None && (reader.NodeType != XmlNodeType.Element - || Nexpr != reader.Name)); + || reader.Name != Qexpr)); if (reader.NodeType == XmlNodeType.None) throw new Exception ("Node not found"); node = doc.ReadNode (reader); } - - Setup (node, domain); + terms = ParseTerms (domain, node.FirstChild); } - // EXPR = SYMBOL | MTEXT | INTEGER | FUNCALL | PROGN - // FUNCALL = '(' SYMBOL EXPR* ')' - // PROGN = '(' EXPR * ')' - public Xex (XmlNode node, Domain domain) + public Term Eval (Domain domain) { - Setup (node, domain); - } + Term result = Zero; - public object Eval (Domain domain) - { - if (function == null) - { - if (args != null) - { - Variable vari = domain.GetVar ((Name) args[0].val); - val = vari.val; - } - return val; - } - else - val = function.Call (args, domain); - return val; + domain.depth = 0; + try { + domain.Catch (CatchTag.Return); + foreach (Term term in terms) + { + result = term.Eval (domain); + if (domain.Thrown) + return result; + } + } finally { + domain.Uncatch (); + } + return result; } public override string ToString () { - string str; - - if (function != null) - { - str = "(" + function.name; - if (args != null) - foreach (Xex e in args) - str += " " + e.ToString (); - str += ")"; - } - else if (args != null) - { - str = (Name) args[0].val; - } - else if (val != null) - { - if (val is string) - str = "\"" + ((string) val) + "\""; - else - str = val.ToString (); - } - else - str = "()"; + string str = ""; + for (int i = 0; i < terms.Length; i++) + str += terms[i]; return str; } }