From 2a77288e28f2725b5621c239d2393d49f61993e8 Mon Sep 17 00:00:00 2001
From: Peter Mikkelsen <peter@pmikkelsen.com>
Date: Thu, 15 Jul 2021 22:04:03 +0000
Subject: Make read_term understand the three read options:

	variables(Vars),
	variable_names(VarNames),
	singletons(Singles)

as required per the ISO standard
---
 builtins.c | 117 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 113 insertions(+), 4 deletions(-)

(limited to 'builtins.c')

diff --git a/builtins.c b/builtins.c
index 913de1e..224750a 100644
--- a/builtins.c
+++ b/builtins.c
@@ -135,7 +135,7 @@ findbuiltin(Term *goal)
 		return builtinsetinput;
 	if(Match(L"set_output", 1))
 		return builtinsetoutput;
-	if(Match(L"read_term", 3))
+	if(Match(L"$read_term", 3))
 		return builtinreadterm;
 	if(Match(L"write_term", 3))
 		return builtinwriteterm;
@@ -760,6 +760,72 @@ builtinsetoutput(Term *goal, Binding **bindings, Module *module)
 	return 1;
 }
 
+Term *
+readtermvars(Term *t)
+{
+	Term *vars;
+	switch(t->tag){
+	case VariableTerm:
+		vars = copyterm(t, nil);
+		break;
+	case CompoundTerm:
+		vars = nil;
+		int n = t->arity;
+		for(t = t->children; n > 0; t = t->next, n--){
+			Term *childvars = readtermvars(t);
+			while(childvars){
+				Term *childvarscopy = copyterm(childvars, nil);
+				vars = appendterm(vars, childvarscopy);
+				childvars = childvars->next;
+			}
+		}
+		break;
+	default:
+		vars = nil;
+	}
+	return vars;
+}
+
+Term *
+varsandnames(Term *vars)
+{
+	Term *varsnames = nil;
+	Term *var;
+	for(var = vars; var != nil; var = var->next){
+		if(runestrcmp(var->text, L"_") == 0)
+			continue;
+		Term *varname = mkatom(var->text);
+		varname->next = copyterm(var, nil);
+		Term *pair = mkcompound(L"=", 2, varname);
+		varsnames = appendterm(varsnames, pair);
+	}
+	return varsnames;
+}
+
+Term *
+singletons(Term *vars)
+{
+	Term *var;
+	Term *varsnames = varsandnames(vars);
+	Term *singles = nil;
+
+	for(var = varsnames; var != nil; var = var->next){
+		Term *tmp;
+		int duplicate = 0;
+		for(tmp = varsnames; tmp != nil ; tmp = tmp->next){
+			if(tmp == var)
+				continue;
+			if(runestrcmp(var->children->text, tmp->children->text) == 0){
+				duplicate = 1;
+				break;
+			}
+		}
+		if(!duplicate)
+			singles = appendterm(singles, copyterm(var, nil));
+	}
+	return singles;
+}
+
 int
 builtinreadterm(Term *goal, Binding **bindings, Module *module)
 {
@@ -772,8 +838,6 @@ builtinreadterm(Term *goal, Binding **bindings, Module *module)
 
 	if(stream->tag == VariableTerm)
 		Throw(instantiationerror());
-	if(options->tag != AtomTerm || runestrcmp(options->text, L"[]") != 0)
-		Throw(typeerror(L"empty_list", options));
 	if(stream->tag != IntegerTerm && stream->tag != AtomTerm)
 		Throw(domainerror(L"stream_or_alias", stream));
 	if(!isopenstream(stream))
@@ -784,10 +848,55 @@ builtinreadterm(Term *goal, Binding **bindings, Module *module)
 		Throw(permissionerror(L"input", L"binary_stream", stream));
 
 	Term *realterm;
-	int error = readterm(stream, options, &realterm);
+	int error = readterm(stream, &realterm);
 	if(error)
 		Throw(realterm);
 
+	Term *singlevars = nil;
+	Term *uniquevars = nil;
+	Term *varsnames = nil;
+	if(options->tag == CompoundTerm){
+		Term *allvars = readtermvars(realterm);
+		Term *tmp1;
+		for(tmp1 = allvars; tmp1 != nil; tmp1 = tmp1->next){
+			Term *tmp2;
+			int duplicate = 0;
+			for(tmp2 = uniquevars; tmp2 != nil; tmp2 = tmp2->next){
+				if(runestrcmp(tmp2->text, tmp1->text) == 0){
+					duplicate = 1;
+					break;
+				}
+			}
+			if(!duplicate){
+				Term *v = copyterm(tmp1, nil);
+				uniquevars = appendterm(uniquevars, v);
+			}
+		}
+
+		varsnames = varsandnames(uniquevars);
+		singlevars = singletons(allvars);
+	}
+	
+	Term *op;
+	for(op = options; op->tag == CompoundTerm; op = op->children->next){
+		Term *opkey = op->children->children;
+		Term *opval = opkey->next;
+
+		if(runestrcmp(opkey->text, L"variables") == 0){
+			Term *variablelist = mklist(uniquevars);
+			if(unify(opval, variablelist, bindings) == 0)
+				return 0;
+		}else if(runestrcmp(opkey->text, L"variable_names") == 0){
+			Term *list = mklist(varsnames);
+			if(unify(opval, list, bindings) == 0)
+				return 0;
+		}else if(runestrcmp(opkey->text, L"singletons") == 0){
+			Term *list = mklist(singlevars);
+			if(unify(opval, list, bindings) == 0)
+				return 0;
+		}
+	}
+
 	return unify(term, realterm, bindings);
 }
 
-- 
cgit v1.2.3