shithub: pprolog

--- a/builtins.c

+++ b/builtins.c

@@ -135,7 +135,7 @@

 		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 @@

 	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 @@

 	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,9 +848,54 @@

 		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);

--- a/fns.h

+++ b/fns.h

@@ -59,7 +59,7 @@

 int isoutputstream(Term *);

 int istextstream(Term *);

 int isbinarystream(Term *);

-int readterm(Term *, Term *, Term **);

+int readterm(Term *, Term **);

 void writeterm(Term *, Term *, Term *);

 /* module.c */

--- a/stdlib.pl

+++ b/stdlib.pl

@@ -97,7 +97,25 @@

 	throw(error(syntax_error(Error), _)).

 % Input and output

+parse_read_option(variables(Vs), options(variables, Vs)).

+parse_read_option(variable_names(VNames), option(variable_names, VNames)).

+parse_read_option(singletons(S), options(singletons, S)).

+parse_read_options([], []).

+parse_read_options([Op|Rest], [OpParsed|RestParsed]) :-

+	is_nonvar(Op),

+	parse_read_options(Rest, RestParsed),

+	( parse_read_option(Op, OpParsed)

+	-> true

+	; domain_error(read_option, Op)

+	).

+read_term(S, Term, Options) :-

+	is_nonvar(Options),

+	is_list(Options),

+	parse_read_options(Options, ParsedOptions),

+	'$read_term'(S, Term, ParsedOptions).

 read_term(Term, Options) :-

 	current_input(S),

 	read_term(S, Term, Options).

@@ -106,6 +124,9 @@

 	current_input(S),

 	read_term(S, Term, []).

+read(S, Term) :-

+	read_term(S, Term, []).

 write_term(Term, Options) :-

 	current_output(S),

 	write_term(S, Term, Options).

@@ -128,6 +149,10 @@

 write_canonical(S, Term) :-

 	write_term(S, Term, [quoted(true), ignore_ops(true)]).

+nl :-

+	write_term('

+', []).

 % Arithmetic comparisons defined in terms of >=. This is not the most effective way,

 % but it is fine for now.

@@ -240,6 +265,8 @@

 is_list_or_partial_list(T) :- (list(T) ; partial_list(T)), ! ; type_error(list, T).

+is_list(T) :- list(T), ! ; type_error(list, T).

 % All solutions

 findall(Template, Goal, Instances) :-

@@ -405,4 +432,4 @@

 	atom_codes(A1, Codes1),

 	atom_codes(A2, Codes2).

 atom_concat(A1, A2, A3) :-

-	instantiation_error.

\ No newline at end of file

+	instantiation_error.

--- a/streams.c

+++ b/streams.c

@@ -192,16 +192,13 @@

int

-readterm(Term *stream, Term *options, Term **term)

+readterm(Term *stream, Term **term)

-	USED(options);

 	Stream *s = getstream(stream);

 	if(s == nil){

 		*term = existenceerror(L"stream", stream);

 		return 1;

-	print(": ");

 	*term = parse(0, s->bio, 1);

 	return 0;