ref: e6ce8b1d6da2434232b86c7c115d7ed4961e7f5c
parent: 1c840d5c5ab6326492542886297d5bafa2877c4d
author: Peter Mikkelsen <peter@pmikkelsen.com>
date: Tue Jul 20 14:05:21 EDT 2021
Add op/3 and current_op/3
--- a/builtins.c
+++ b/builtins.c
@@ -66,6 +66,8 @@
BuiltinProto(builtinflushoutput);
BuiltinProto(builtinstreamproperties);
BuiltinProto(builtinsetstreamposition);
+BuiltinProto(builtinop);
+BuiltinProto(builtincurrentops);
int compareterms(Term *, Term *);
@@ -187,6 +189,10 @@
return builtinstreamproperties;
if(Match(L"set_stream_position", 2))
return builtinsetstreamposition;
+ if(Match(L"$op", 3))
+ return builtinop;
+ if(Match(L"current_ops", 1))
+ return builtincurrentops;
return nil;
}
@@ -1508,4 +1514,81 @@
reposition(s, pos->ival);
return 1;
+}
+
+int
+builtinop(Term *goal, Binding **bindings, Module *module)
+{+ USED(bindings);
+ Term *priority = goal->children;
+ Term *specifier = priority->next;
+ Term *operator = specifier->next;
+
+ if(runestrcmp(operator->text, L",") == 0)
+ Throw(permissionerror(L"modify", L"operator", operator));
+
+ int type = 0;
+ if(runestrcmp(specifier->text, L"xf") == 0)
+ type = Xf;
+ else if(runestrcmp(specifier->text, L"yf") == 0)
+ type = Yf;
+ else if(runestrcmp(specifier->text, L"xfx") == 0)
+ type = Xfx;
+ else if(runestrcmp(specifier->text, L"xfy") == 0)
+ type = Xfy;
+ else if(runestrcmp(specifier->text, L"yfx") == 0)
+ type = Yfx;
+ else if(runestrcmp(specifier->text, L"fy") == 0)
+ type = Fy;
+ else if(runestrcmp(specifier->text, L"fx") == 0)
+ type = Fx;
+
+ addoperator(priority->ival, type, operator->text, module);
+ return 1;
+}
+
+int
+builtincurrentops(Term *goal, Binding **bindings, Module *module)
+{+ Term *ops = goal->children;
+ Term *oplist = nil;
+
+ int level;
+ for(level = 0; level < PrecedenceLevels; level++){+ Operator *o;
+ for(o = module->operators[level]; o != nil; o = o->next){+ int type = o->type;
+ while(type != 0){+ Term *args = mkinteger(o->level);
+ if(type & Xf){+ args->next = mkatom(L"xf");
+ type = type^Xf;
+ }else if(type & Yf){+ args->next = mkatom(L"yf");
+ type = type^Yf;
+ }else if(type & Xfx){+ args->next = mkatom(L"xfx");
+ type = type^Xfx;
+ }else if(type & Xfy){+ args->next = mkatom(L"xfy");
+ type = type^Xfy;
+ }else if(type & Yfx){+ args->next = mkatom(L"yfx");
+ type = type^Yfx;
+ }else if(type & Fx){+ args->next = mkatom(L"fx");
+ type = type^Fx;
+ }else if(type & Fy){+ args->next = mkatom(L"fy");
+ type = type^Fy;
+ }
+ args->next->next = mkatom(o->spelling);
+ Term *op = mkcompound(L"op", 3, args);
+ oplist = appendterm(oplist, op);
+ }
+ }
+ }
+
+ Term *realops = mklist(oplist);
+ return unify(ops, realops, bindings);
}
\ No newline at end of file
--- a/parser.c
+++ b/parser.c
@@ -281,7 +281,7 @@
if(index == -1){ print("Can't parse, list of length %d contains no operators: ", length);for(i = 0; i < length; i++)
- print("%S(%d) ", prettyprint(terms[i], 0, 0, 0, currentmod), infos[i].level);+ print("%S(%d) ", prettyprint(terms[i], 0, 1, 0, currentmod), infos[i].level); print("\n"); syntaxerror_parser("parseoperators");}
--- a/stdlib.pl
+++ b/stdlib.pl
@@ -354,6 +354,8 @@
is_list(T) :- list(T), ! ; type_error(list, T).
+is_integer(T) :- integer(T), ! ; type_error(integer, T).
+
% All solutions
findall(Template, Goal, Instances) :-
@@ -628,4 +630,51 @@
appropriate_flag_values(max_arity, [Val]) :-
current_prolog_flag(max_arity).
appropriate_flag_values(unknown, [error, fail, warning]).
-appropriate_flag_values(double_quotes, [chars, codes, atom]).
\ No newline at end of file
+appropriate_flag_values(double_quotes, [chars, codes, atom]).
+
+% Operator table modification and inspection
+
+op(Priority, Op_specifier, Operator) :-
+ is_nonvar(Priority),
+ is_integer(Priority),
+ is_nonvar(Op_specifier),
+ is_atom(Op_specifier),
+ ( operator_priority(Priority), !
+ ; domain_error(operator_priority, Priority)
+ ),
+ ( operator_specifier(Op_specifier), !
+ ; domain_error(operator_specifier, Op_specifier)
+ ),
+ is_nonvar(Operator),
+ ( atom(Operator)
+ -> Ops = [Operator]
+ ; Ops = Operator
+ ),
+ is_list(Ops),
+ op_helper(Priority, Op_specifier, Ops).
+
+op_helper(Priority, Op_specifier, []).
+op_helper(Priority, Op_specifier, [Op|Ops]) :-
+ is_nonvar(Op),
+ is_atom(Op),
+ '$op'(Priority, Op_specifier, Op),
+ op_helper(Priority, Op_specifier, Ops).
+
+operator_priority(P) :-
+ integer(P),
+ P >= 0,
+ P =< 1200.
+
+operator_specifier(S) :-
+ member(S, [xf, yf, xfx, xfy, yfx, fx, fy]).
+
+current_op(Priority, Op_specifier, Operator) :-
+ ( (var(Priority) ; operator_priority(Priority)), !
+ ; domain_error(operator_priority, Priority)
+ ),
+ ( (var(Op_specifier) ; operator_specifier(Op_specifier)), !
+ ; domain_error(operator_specifier, Op_specifier)
+ ),
+ is_atom_or_var(Operator),
+ current_ops(Operators),
+ member(op(Priority, Op_specifier, Operator), Operators).
\ No newline at end of file