Add op/3 and current_op/3

3 files changed, 134 insertions, 2 deletions

diff --git a/builtins.c b/builtins.c
index 9699de1..1cddcdd 100644
--- a/builtins.c
+++ b/builtins.c
@@ -66,6 +66,8 @@ BuiltinProto(builtinloadmodulefromfile);
 BuiltinProto(builtinflushoutput);
 BuiltinProto(builtinstreamproperties);
 BuiltinProto(builtinsetstreamposition);
+BuiltinProto(builtinop);
+BuiltinProto(builtincurrentops);
 
 int compareterms(Term *, Term *);
 
@@ -187,6 +189,10 @@ findbuiltin(Term *goal)
 		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 @@ builtinsetstreamposition(Term *goal, Binding **bindings, Module *module)
 
 	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
diff --git a/parser.c b/parser.c
index 0e7c967..8c4f0e9 100644
--- a/parser.c
+++ b/parser.c
@@ -281,7 +281,7 @@ parseoperators(Term *list)
 		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");
 		}
diff --git a/stdlib.pl b/stdlib.pl
index c6b395f..bbefa41 100644
--- a/stdlib.pl
+++ b/stdlib.pl
@@ -354,6 +354,8 @@ is_list_or_partial_list(T) :- (list(T) ; partial_list(T)), ! ; type_error(list,
 
 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(debug, [on, off]).
 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