1:- module(distfix).			% SEPIA header
2
3:- lib(rdtok).
4:- import read_tokens/2 from rdtok.
5
6:- dynamic is_distprefix_op/5, is_distinfix_op/5.
7
8:- local display/1.
9display(X) :- write(error,X).
10ttyput(X) :- put(error, X).
11ttynl :- nl(error).
12
13%   File   : DISTFI.PL
14%   Author : R.A.O'Keefe
15%   Updated: 10 May 1984
16%   Purpose: Read Prolog terms (with extended syntax).
17
18/*  Modified by Alan Mycroft to regularise the functor modes.
19    This is both easier to understand (there are no more '?'s),
20    and also fixes bugs concerning the curious interaction of cut with
21    the state of parameter instantiation.
22
23    Since this file doesn't provide "metaread", it is considerably
24    simplified.  The token list format has been changed somewhat, see
25    the comments in the RDTOK file.
26
27    I have added the rule X(...) -> apply(X,[...]) for Alan Mycroft.
28
29    Distfix operators have finally been added.  They are declared by
30	distfixop(Priority, Type, Pattern, Term)
31    where Priority is as usual, Type is currently only fx or fy (if
32    the Pattern doesn't specify a right argument one of the types must
33    still be specified but it doesn't matter which), Term is what the
34    reader is to return when it sees something matching the pattern,
35    and the Pattern is a list of atoms and variables whose first
36    elements is an atom, and in which no two variables appear side by
37    side without an intervening atom.  To avoid ambiguities, the first
38    atom following each variable should NOT be an infix or postfix
39    operator, but the code below does not check for that, as you could
40    declare such an operator after declaring the distfix form.
41    Examples:
42	distfixop(950, fy, [for,each,X,show,that,Y], forall(X,Y))
43	distfixop(1105, fx, [try,Goal,reverting,to,Alternative,on,failure],
44				(Goal;Alternative))
45	distfixop(999, fy, [there,is,a,clause,with,head,H,and,body,B],
46				clause(H,B))
47	distfixop(999, fy, [there,is,a,clause,with,head,H], clause(H,_))
48    Infix forms are also available.  These have the side effect of
49    declaring the head keyword as an infix operator; anything that did
50    not do this would be significantly harder to patch into the old parser.
51    Examples:
52	distfixop(700, xfy, [S,is,the,set,of,X,such,that,P], setof(X,P,S))
53	distfixop(700, xfy, [B,is,the,bag,of,X,such,that,P], bagof(X,P,S)),
54	distfixop(700, xfy, [X,is,to,Y,as,A,is,to,B], X*B =:= A*Y),
55	distfixop(700, xfx, [X,had,N,variables], numbervars(X,0,N))
56*/
57
58:- export
59	distfixop/4,
60	read/2.
61
62:- mode
63	after_prefix_op(+, +, +, +, +, -, -),
64	ambigop(+, -, -, -, -, -),
65	cant_follow_expr(+, -),
66	distfixop(?, ?, ?, ?),
67	distfix_head(+, +, +, -, -),
68	distfix_head(+, +, +, +, -, -),
69	distfix_keys(+, ?, ?),
70	distfix_pass(+, +, -),
71	distfix_pattern(+, +, -),
72	distfix_read(+, +, -),
73	expect(+, +, -),
74	exprtl(+, +, +, +, -, -),
75	exprtl0(+, +, +, -, -),
76	infixop(+, -, -, -),
77	postfixop(+, -, -),
78	prefixop(+, -, -),
79	prefix_is_atom(+, +),
80	read(?, ?),
81	read(+, +, -, -),
82	read(+, +, +, -, -),
83	read_args(+, -, -),
84	read_list(+, -, -),
85	syntax_error(+),
86	syntax_error(+, +).
87
88
89%   read(?Answer, ?Variables)
90%   reads a term from the current input stream and unifies it with
91%   Answer.  Variables is bound to a list of [Atom=Variable] pairs.
92
93read(Answer, Variables) :-
94	repeat,
95	    read_tokens(Tokens, Variables),
96	    (   read(Tokens, 1200, Term, Leftover), all_read(Leftover)
97	    ;   syntax_error(Tokens)
98	    ),
99	!,
100	Answer = Term.
101
102
103%   all_read(+Tokens)
104%   checks that there are no unparsed tokens left over.
105
106all_read([]) :- !.
107all_read(S) :-
108	syntax_error([operator,expected,after,expression], S).
109
110
111%   expect(Token, TokensIn, TokensOut)
112%   reads the next token, checking that it is the one expected, and
113%   giving an error message if it is not.  It is used to look for
114%   right brackets of various sorts, as they're all we can be sure of.
115
116expect(Token, [Token|Rest], Rest) :- !.
117expect(Token, S0, _) :-
118	syntax_error([Token,or,operator,expected], S0).
119
120
121%   I want to experiment with having the operator information held as
122%   ordinary Prolog facts.  For the moment the following predicates
123%   remain as interfaces to current_op.
124%   prefixop(O -> Self, Rarg)
125%   postfixop(O -> Larg, Self)
126%   infixop(O -> Larg, Self, Rarg)
127
128
129prefixop(Op, Prec, Prec) :-
130	current_op(Prec, fy, Op), !.
131prefixop(Op, Prec, Less) :-
132	current_op(Prec, fx, Op), !,
133	Less is Prec-1.
134
135
136postfixop(Op, Prec, Prec) :-
137	current_op(Prec, yf, Op), !.
138postfixop(Op, Less, Prec) :-
139	current_op(Prec, xf, Op), !, Less is Prec-1.
140
141
142infixop(Op, Less, Prec, Less) :-
143	current_op(Prec, xfx, Op), !, Less is Prec-1.
144infixop(Op, Less, Prec, Prec) :-
145	current_op(Prec, xfy, Op), !, Less is Prec-1.
146infixop(Op, Prec, Prec, Less) :-
147	current_op(Prec, yfx, Op), !, Less is Prec-1.
148
149
150ambigop(F, L1, O1, R1, L2, O2) :-
151	postfixop(F, L2, O2),
152	infixop(F, L1, O1, R1), !.
153
154
155%   read(+TokenList, +Precedence, -Term, -LeftOver)
156%   parses a Token List in a context of given Precedence,
157%   returning a Term and the unread Left Over tokens.
158
159read([Token|RestTokens], Precedence, Term, LeftOver) :-
160	read(Token, RestTokens, Precedence, Term, LeftOver).
161read([], _, _, _) :-
162	syntax_error([expression,expected], []).
163
164
165%   read(+Token, +RestTokens, +Precedence, -Term, -LeftOver)
166
167read(var(Variable,_), ['('|S1], Precedence, Answer, S) :- !,
168	read(S1, 999, Arg1, S2),
169	read_args(S2, RestArgs, S3), !,
170	exprtl0(S3, apply(Variable,[Arg1|RestArgs]), Precedence, Answer, S).
171
172read(var(Variable,_), S0, Precedence, Answer, S) :- !,
173	exprtl0(S0, Variable, Precedence, Answer, S).
174
175read(atom(-), [integer(Integer)|S1], Precedence, Answer, S) :-
176	Negative is -Integer, !,
177	exprtl0(S1, Negative, Precedence, Answer, S).
178
179read(atom(Functor), ['('|S1], Precedence, Answer, S) :- !,
180	read(S1, 999, Arg1, S2),
181	read_args(S2, RestArgs, S3),
182	Term =.. [Functor,Arg1|RestArgs], !,
183	exprtl0(S3, Term, Precedence, Answer, S).
184
185read(atom(Keyword), S0, Precedence, Answer, S) :-
186	is_distprefix_op(Keyword, Prec, Keys, Pattern, Term),
187	Precedence >= Prec,
188	distfix_pass(Keys, S0, S1),
189	distfix_read(Pattern, S1, S2),
190	!,
191	exprtl(S2, Prec, Term, Precedence, Answer, S).
192
193read(atom(Functor), S0, Precedence, Answer, S) :-
194	prefixop(Functor, Prec, Right), !,
195	after_prefix_op(Functor, Prec, Right, S0, Precedence, Answer, S).
196
197read(atom(Atom), S0, Precedence, Answer, S) :- !,
198	exprtl0(S0, Atom, Precedence, Answer, S).
199
200read(integer(Integer), S0, Precedence, Answer, S) :- !,
201	exprtl0(S0, Integer, Precedence, Answer, S).
202
203read('[', [']'|S1], Precedence, Answer, S) :- !,
204	exprtl0(S1, [], Precedence, Answer, S).
205
206read('[', S1, Precedence, Answer, S) :- !,
207	read(S1, 999, Arg1, S2),
208	read_list(S2, RestArgs, S3), !,
209	exprtl0(S3, [Arg1|RestArgs], Precedence, Answer, S).
210
211read('(', S1, Precedence, Answer, S) :- !,
212	read(S1, 1200, Term, S2),
213	expect(')', S2, S3), !,
214	exprtl0(S3, Term, Precedence, Answer, S).
215
216read(' (', S1, Precedence, Answer, S) :- !,
217	read(S1, 1200, Term, S2),
218	expect(')', S2, S3), !,
219	exprtl0(S3, Term, Precedence, Answer, S).
220
221read('{', ['}'|S1], Precedence, Answer, S) :- !,
222	exprtl0(S1, '{}', Precedence, Answer, S).
223
224read('{', S1, Precedence, Answer, S) :- !,
225	read(S1, 1200, Term, S2),
226	expect('}', S2, S3), !,
227	exprtl0(S3, '{}'(Term), Precedence, Answer, S).
228
229read(string(List), S0, Precedence, Answer, S) :- !,
230	exprtl0(S0, List, Precedence, Answer, S).
231
232read(Token, S0, _, _, _) :-
233	syntax_error([Token,cannot,start,an,expression], S0).
234
235
236%   read_args(+Tokens, -TermList, -LeftOver)
237%   parses {',' expr(999)} ')' and returns a list of terms.
238
239read_args([','|S1], [Term|Rest], S) :- !,
240	read(S1, 999, Term, S2), !,
241	read_args(S2, Rest, S).
242read_args([')'|S], [], S) :- !.
243read_args(S, _, _) :-
244	syntax_error([', or )',expected,in,arguments], S).
245
246
247%   read_list(+Tokens, -TermList, -LeftOver)
248%   parses {',' expr(999)} ['|' expr(999)] ']' and returns a list of terms.
249
250read_list([','|S1], [Term|Rest], S) :- !,
251	read(S1, 999, Term, S2), !,
252	read_list(S2, Rest, S).
253read_list(['|'|S1], Rest, S) :- !,
254	read(S1, 999, Rest, S2), !,
255	expect(']', S2, S).
256read_list([']'|S], [], S) :- !.
257read_list(S, _, _) :-
258	syntax_error([', | or ]',expected,in,list], S).
259
260
261%   after_prefix_op(+Op, +Prec, +ArgPrec, +Rest, +Precedence, -Ans, -LeftOver)
262
263after_prefix_op(Op, Oprec, _, S0, Precedence, _, _) :-
264	Precedence < Oprec, !,
265	syntax_error([prefix,operator,Op,in,context,
266		with,precedence,Precedence], S0).
267
268after_prefix_op(Op, Oprec, _, S0, Precedence, Answer, S) :-
269	peepop(S0, S1),
270	prefix_is_atom(S1, Oprec), % can't cut but would like to
271	exprtl(S1, Oprec, Op, Precedence, Answer, S).
272
273after_prefix_op(Op, Oprec, Aprec, S1, Precedence, Answer, S) :-
274	read(S1, Aprec, Arg, S2),
275	Term =.. [Op,Arg], !,
276	exprtl(S2, Oprec, Term, Precedence, Answer, S).
277
278
279%   The next clause fixes a bug concerning "mop dop(1,2)" where
280%   mop is monadic and dop dyadic with higher Prolog priority.
281
282peepop([atom(F),'('|S1], [atom(F),'('|S1]) :- !.
283peepop([atom(F)|S1], [infixop(F,L,P,R)|S1]) :- infixop(F, L, P, R).
284peepop([atom(F)|S1], [postfixop(F,L,P)|S1]) :- postfixop(F, L, P).
285peepop(S0, S0).
286
287
288%   prefix_is_atom(+TokenList, +Precedence)
289%   is true when the right context TokenList of a prefix operator
290%   of result precedence Precedence forces it to be treated as an
291%   atom, e.g. (- = X), p(-), [+], and so on.
292
293prefix_is_atom([Token|_], Precedence) :-
294	prefix_is_atom(Token, Precedence).
295
296prefix_is_atom(infixop(_,L,_,_), P) :- L >= P.
297prefix_is_atom(postfixop(_,L,_), P) :- L >= P.
298prefix_is_atom(')', _).
299prefix_is_atom(']', _).
300prefix_is_atom('}', _).
301prefix_is_atom('|', P) :- 1100 >= P.
302prefix_is_atom(',', P) :- 1000 >= P.
303prefix_is_atom([],  _).
304
305
306%   exprtl0(+Tokens, +Term, +Prec, -Answer, -LeftOver)
307%   is called by read/4 after it has read a primary (the Term).
308%   It checks for following postfix or infix operators.
309
310exprtl0([atom(F)|S1], Term, Precedence, Answer, S) :-
311	ambigop(F, L1, O1, R1, L2, O2), !,
312	(   exprtl([infixop(F,L1,O1,R1)|S1], 0, Term, Precedence, Answer, S)
313	;   exprtl([postfixop(F,L2,O2) |S1], 0, Term, Precedence, Answer, S)
314	).
315exprtl0([atom(F)|S1], Term, Precedence, Answer, S) :-
316	infixop(F, L1, O1, R1), !,
317	exprtl([infixop(F,L1,O1,R1)|S1], 0, Term, Precedence, Answer, S).
318exprtl0([atom(F)|S1], Term, Precedence, Answer, S) :-
319	postfixop(F, L2, O2), !,
320	exprtl([postfixop(F,L2,O2) |S1], 0, Term, Precedence, Answer, S).
321
322exprtl0([','|S1], Term, Precedence, Answer, S) :-
323	Precedence >= 1000, !,
324	read(S1, 1000, Next, S2), !,
325	exprtl(S2, 1000, (Term,Next), Precedence, Answer, S).
326
327exprtl0(['|'|S1], Term, Precedence, Answer, S) :-
328	Precedence >= 1100, !,
329	read(S1, 1100, Next, S2), !,
330	exprtl(S2, 1100, (Term;Next), Precedence, Answer, S).
331
332exprtl0([Thing|S1], _, _, _, _) :-
333	cant_follow_expr(Thing, Culprit), !,
334	syntax_error([Culprit,follows,expression], [Thing|S1]).
335
336exprtl0(S, Term, _, Term, S).
337
338
339cant_follow_expr(atom(_),	atom).
340cant_follow_expr(var(_,_),	variable).
341cant_follow_expr(integer(_),	integer).
342cant_follow_expr(string(_),	string).
343cant_follow_expr(' (',		bracket).
344cant_follow_expr('(',		bracket).
345cant_follow_expr('[',		bracket).
346cant_follow_expr('{',		bracket).
347
348
349
350exprtl([infixop(F,L,O,_)|S1], C, Term, Precedence, Answer, S) :-
351	Precedence >= 0, C =< L,
352	is_distinfix_op(F, Keys, Term, Pattern, Expr),
353	distfix_pass(Keys, S1, S2),
354	distfix_read(Pattern, S2, S3),
355	!,	% do we want this?
356	exprtl(S3, O, Expr, Precedence, Answer, S).
357
358exprtl([infixop(F,L,O,R)|S1], C, Term, Precedence, Answer, S) :-
359	Precedence >= O, C =< L, !,
360	read(S1, R, Other, S2),
361	Expr =.. [F,Term,Other], /*!,*/
362	exprtl(S2, O, Expr, Precedence, Answer, S).
363
364exprtl([postfixop(F,L,O)|S1], C, Term, Precedence, Answer, S) :-
365	Precedence >= O, C =< L, !,
366	Expr =.. [F,Term],
367	peepop(S1, S2),
368	exprtl(S2, O, Expr, Precedence, Answer, S).
369
370exprtl([','|S1], C, Term, Precedence, Answer, S) :-
371	Precedence >= 1000, C < 1000, !,
372	read(S1, 1000, Next, S2), /*!,*/
373	exprtl(S2, 1000, (Term,Next), Precedence, Answer, S).
374
375exprtl(['|'|S1], C, Term, Precedence, Answer, S) :-
376	Precedence >= 1100, C < 1100, !,
377	read(S1, 1100, Next, S2), /*!,*/
378	exprtl(S2, 1100, (Term;Next), Precedence, Answer, S).
379
380exprtl(S, _, Term, _, Term, S).
381
382
383%   This business of syntax errors is tricky.  When an error is detected,
384%   we have to write out a message.  We also have to note how far it was
385%   to the end of the input, and for this we are obliged to use the data-
386%   base.  Then we fail all the way back to read(), and that prints the
387%   input list with a marker where the error was noticed.  If subgoal_of
388%   were available in compiled code we could use that to find the input
389%   list without hacking the data base.  The really hairy thing is that
390%   the original code noted a possible error and backtracked on, so that
391%   what looked at first sight like an error sometimes turned out to be
392%   a wrong decision by the parser.  This version of the parser makes
393%   fewer wrong decisions, and my goal was to get it to do no backtracking
394%   at all.  This goal has not yet been met, and it will still occasionally
395%   report an error message and then decide that it is happy with the input
396%   after all.  Sorry about that.
397
398
399syntax_error(Message, List) :-
400	ttynl, display('**'),
401	display_list(Message),
402	length(List, Length),
403	recorda(syntax_error, length(Length), _), !,
404	fail.
405
406display_list([Head|Tail]) :-
407	ttyput(32),
408	display_token(Head), !,
409	display_list(Tail).
410display_list([]) :-
411	ttynl.
412
413syntax_error(List) :-
414	recorded(syntax_error, length(AfterError), Ref),
415	erase(Ref),
416	length(List, Length),
417	BeforeError is Length-AfterError,
418	display_list(List, BeforeError), !,
419	fail.
420
421display_list(X, 0) :-
422	display('<<here>> '), !,
423	display_list(X, 99999).
424display_list([Head|Tail], BeforeError) :-
425	display_token(Head),
426	ttyput(32),
427	Left is BeforeError-1, !,
428	display_list(Tail, Left).
429display_list([], _) :-
430	ttynl.
431
432display_token(atom(X))	  :- !,	display(X).
433display_token(var(_,X))	  :- !,	display(X).
434display_token(integer(X)) :- !,	display(X).
435display_token(string(X))  :- !,	display(X).
436display_token(X)	  :-	display(X).
437
438%  From here down is new stuff to handle distfix operators.
439
440distfixop(Priority, Type, Pattern, Template) :-
441	integer(Priority),
442	Priority > 0,
443	Priority =< 1200,
444	atom(Type),
445	(   (   Type = fx,	Right is Priority-1
446	    ;   Type = fy,	Right = Priority
447	    ),
448	    distfix_keys(Pattern, [Atom|Keys], RestPattern),
449	    distfix_pattern(RestPattern, Right, P_form),
450	    !,
451	    assert(is_distprefix_op(Atom, Priority, Keys, P_form, Template))
452	;   (	Type = xfx,	Right is Priority-1
453	    ;	Type = xfy,	Right = Priority
454	    ;	Type = yfx,	Right is Priority-1
455	    ),
456	    distfix_pattern(Pattern, Right, P_form_0),
457	    P_form_0 = p(Lhs,[Atom|Keys],P_form),
458	    !,
459	    op(Priority, Type, Atom),
460	    assert(is_distinfix_op(Atom, Keys, Lhs, P_form, Template))
461	).
462distfixop(P, T, Pn, Te) :-
463	nl(error), write(error, '! error: '),
464	write(error, distfixop(P,T,Pn,Te)), nl(error),
465	fail.
466
467/*  A distfix pattern is one of
468	p		  -- standing for the end of the pattern
469	p(Var,Prio)	  -- standing for a right argument of that priority
470	p(Var,Keys,Rest)  -- standing for Var Keyword... Restofpattern
471    e.g. p(X,[by],p(Y,[giving,quotient],p(Q,[and,remainder],p(R,99)))).
472    distfix_pattern(List, Prio, P_form) turns a human-readable list into
473    this compact form.
474*/
475
476distfix_pattern([], _, p) :- !.
477distfix_pattern([Var], Prio, p(Var,Prio)) :- !,
478	var(Var).		%
479distfix_pattern([Var|List], Prio, p(Var,Keys,Rest)) :-
480	var(Var),
481	distfix_keys(List, Keys, RestList),
482	Keys \== [], !,
483	distfix_pattern(RestList, Prio, Rest).
484
485/*  distfix_keys picks off all the atoms at the front of the list.
486*/
487distfix_keys([Key|List], [Key|Keys], RestList) :-
488	atom(Key), !,
489	distfix_keys(List, Keys, RestList).
490distfix_keys(List, [], List).
491
492
493distfix_read(p, S0, S) :-
494	peepop(S0, S).
495distfix_read(p(Variable,Priority), S0, S) :-
496	read(S0, Priority, Variable, S).
497distfix_read(p(Variable,Keywords,RestPattern), S0, S) :-
498	distfix_head(S0, [], Keywords, Tokens, S1),
499	%  This may backtrack over ever longer Token lists
500	read(Tokens, 1200, Variable, T),
501	T = [],
502	!,	%  not sure if I want this cut or not
503	distfix_read(RestPattern, S1, S).
504
505
506/*  Distfix_pass(Keys, S0, S)
507    is basically append(Keys, S, S0), but Keys is a list of atoms,
508    and the prefix of S0 must be atom(K1),...,atom(Kn)
509*/
510distfix_pass([], S, S) :- !.
511distfix_pass([Key|Keys], [atom(Key)|S0], S) :-
512	distfix_pass(Keys, S0, S).
513
514/*  Distfix_head(S0, Stack, Keys, Tokens, S)
515    matches S0 against Tokens & Keys & S, where Tokens is balanced
516    with respect to () [] {}.  It uses the Stack to keep track of
517    what brackets need balancing.
518*/
519
520distfix_head(S0, [], Keys, [], S) :-
521	distfix_pass(Keys, S0, S).
522distfix_head([Token|S0], Stack, Keys, [Token|Tokens], S) :-
523	distfix_head(Token, Stack, S0, Keys, Tokens, S).
524
525distfix_head('(', Stack, S0, Keys, Tokens, S) :- !,
526	distfix_head(S0, [')'|Stack], Keys, Tokens, S).
527distfix_head(' (',Stack, S0, Keys, Tokens, S) :- !,
528	distfix_head(S0, [')'|Stack], Keys, Tokens, S).
529distfix_head('[', Stack, S0, Keys, Tokens, S) :- !,
530	distfix_head(S0, [']'|Stack], Keys, Tokens, S).
531distfix_head('{', Stack, S0, Keys, Tokens, S) :- !,
532	distfix_head(S0, ['}'|Stack], Keys, Tokens, S).
533distfix_head(Token, [Token|Stack], S0, Keys, Tokens, S) :- !,
534	distfix_head(S0, Stack, Keys, Tokens, S).
535distfix_head(Token, _, _, _, _, _) :-
536	atom(Token),
537	(Token = ')' ; Token = ']' ; Token = '}'),
538	!, fail.
539distfix_head(_, Stack, S0, Keys, Tokens, S) :-
540	distfix_head(S0, Stack, Keys, Tokens, S).
541
542