292 lines
8.6 KiB
Prolog
292 lines
8.6 KiB
Prolog
:- use_module(library(lists)).
|
|
:- use_module(library(si)).
|
|
|
|
:- module('$toplevel', ['$repl'/1, consult/1, use_module/1, use_module/2]).
|
|
|
|
'$repl'(ListOfModules) :-
|
|
maplist('$use_list_of_modules', ListOfModules),
|
|
false.
|
|
'$repl'(_) :- '$repl'.
|
|
|
|
'$use_list_of_modules'(Module) :-
|
|
catch(use_module(Module), E, '$print_exception'(E)).
|
|
|
|
'$repl' :-
|
|
catch('$read_and_match', E, '$print_exception'(E)),
|
|
false. %% this is for GC, until we get actual GC.
|
|
'$repl' :- '$repl'.
|
|
|
|
'$read_and_match' :-
|
|
'$read_query_term'(Term, VarList),
|
|
'$instruction_match'(Term, VarList).
|
|
|
|
% make '$compile_batch', a system routine, callable.
|
|
'$$compile_batch' :- '$compile_batch'.
|
|
|
|
'$instruction_match'([Item], []) :-
|
|
( atom(Item) -> !,
|
|
( Item == user ->
|
|
catch('$$compile_batch', E, '$print_exception_with_check'(E))
|
|
; consult(Item)
|
|
)
|
|
; !,
|
|
catch(throw(error(type_error(atom, Item), repl/0)),
|
|
E,
|
|
'$print_exception_with_check'(E))
|
|
).
|
|
'$instruction_match'(Term, VarList) :-
|
|
'$submit_query_and_print_results'(Term, VarList),
|
|
!.
|
|
|
|
'$submit_query_and_print_results'(Term0, VarList) :-
|
|
( expand_goals(Term0, Term) -> true
|
|
; Term = Term0
|
|
),
|
|
( '$get_b_value'(B), call(Term), '$write_eqs_and_read_input'(B, VarList),
|
|
!
|
|
% clear attribute goal lists, which may be populated by
|
|
% copy_term/3 prior to failure.
|
|
; '$clear_attribute_goals', write('false.'), nl
|
|
).
|
|
|
|
'$needs_bracketing'(Value, Op) :-
|
|
catch((functor(Value, F, _),
|
|
current_op(EqPrec, EqSpec, Op),
|
|
current_op(FPrec, _, F)),
|
|
_,
|
|
false),
|
|
( EqPrec < FPrec -> true
|
|
; EqPrec == FPrec,
|
|
memberchk(EqSpec, [fx,xfx,yfx])
|
|
).
|
|
|
|
'$write_goal'(G, VarList) :-
|
|
( G = (Var = Value) ->
|
|
write(Var),
|
|
write(' = '),
|
|
( '$needs_bracketing'(Value, (=)) ->
|
|
write('('),
|
|
write_term(Value, [quoted(true), variable_names(VarList)]),
|
|
write(')')
|
|
; write_term(Value, [quoted(true), variable_names(VarList)])
|
|
)
|
|
; G == [] ->
|
|
write('true')
|
|
; write_term(G, [quoted(true), variable_names(VarList)])
|
|
).
|
|
|
|
'$write_last_goal'(G, VarList) :-
|
|
( G = (Var = Value) ->
|
|
write(Var),
|
|
write(' = '),
|
|
( '$needs_bracketing'(Value, (=)) ->
|
|
write('('),
|
|
write_term(Value, [quoted(true), variable_names(VarList)]),
|
|
write(')')
|
|
; write_term(Value, [quoted(true), variable_names(VarList)]),
|
|
( '$trailing_period_is_ambiguous'(Value) ->
|
|
write(' ')
|
|
; true
|
|
)
|
|
)
|
|
; G == [] ->
|
|
write('true')
|
|
; write_term(G, [quoted(true), variable_names(VarList)])
|
|
).
|
|
|
|
'$write_eq'((G1, G2), VarList) :-
|
|
!,
|
|
'$write_goal'(G1, VarList),
|
|
write(', '),
|
|
'$write_eq'(G2, VarList).
|
|
'$write_eq'(G, VarList) :-
|
|
'$write_last_goal'(G, VarList).
|
|
|
|
'$graphic_token_char'(C) :-
|
|
memberchk(C, ['#', '$', '&', '*', '+', '-', '.', ('/'), ':',
|
|
'<', '=', '>', '?', '@', '^', '~', ('\\')]).
|
|
|
|
'$list_last_item'([C], C) :- !.
|
|
'$list_last_item'([_|Cs], D) :-
|
|
'$list_last_item'(Cs, D).
|
|
|
|
'$trailing_period_is_ambiguous'(Value) :-
|
|
atom(Value),
|
|
atom_chars(Value, ValueChars),
|
|
'$list_last_item'(ValueChars, Char),
|
|
'$graphic_token_char'(Char).
|
|
|
|
'$write_eqs_and_read_input'(B, VarList) :-
|
|
sort(VarList, SortedVarList),
|
|
'$get_b_value'(B0),
|
|
'$gather_goals'(SortedVarList, VarList, Goals),
|
|
( B0 == B ->
|
|
( Goals == [] ->
|
|
write('true.'), nl
|
|
; thread_goals(Goals, ThreadedGoals, (',')),
|
|
'$write_eq'(ThreadedGoals, VarList),
|
|
write('.'),
|
|
nl
|
|
)
|
|
; thread_goals(Goals, ThreadedGoals, (',')),
|
|
'$write_eq'(ThreadedGoals, VarList),
|
|
'$raw_input_read_char'(C),
|
|
( C == (';'), !,
|
|
write(' ;'), nl, false
|
|
; C == ('.'), !,
|
|
write(' ...'), nl
|
|
)
|
|
).
|
|
|
|
'$gather_query_vars'([_ = Var | Vars], QueryVars) :-
|
|
( var(Var) ->
|
|
QueryVars = [Var | QueryVars1],
|
|
'$gather_query_vars'(Vars, QueryVars1)
|
|
; '$gather_query_vars'(Vars, QueryVars)
|
|
).
|
|
'$gather_query_vars'([], []).
|
|
|
|
'$is_a_different_variable'([_ = Binding | Pairs], Value) :-
|
|
( Value == Binding, !
|
|
; '$is_a_different_variable'(Pairs, Value)
|
|
).
|
|
|
|
'$gather_goals'([], VarList, Goals) :-
|
|
'$get_attr_var_queue_beyond'(0, AttrVars),
|
|
'$gather_query_vars'(VarList, QueryVars),
|
|
'$call_attribute_goals'(QueryVars, AttrVars),
|
|
'$fetch_attribute_goals'(Goals).
|
|
'$gather_goals'([Var = Value | Pairs], VarList, Goals) :-
|
|
( ( nonvar(Value)
|
|
; '$is_a_different_variable'(Pairs, Value)
|
|
) ->
|
|
Goals = [Var = Value | Goals0],
|
|
'$gather_goals'(Pairs, VarList, Goals0)
|
|
; '$gather_goals'(Pairs, VarList, Goals)
|
|
).
|
|
|
|
'$print_exception'(E) :-
|
|
write_term('caught: ', [quoted(false)]),
|
|
writeq(E),
|
|
nl.
|
|
|
|
'$print_exception_with_check'(E) :-
|
|
( E = error(_, _:_) -> true % if the error source contains a line
|
|
% number, a GNU-style error message
|
|
% is expected to be printed instead.
|
|
; '$print_exception'(E)
|
|
).
|
|
|
|
'$module_export'(Source, PI) :-
|
|
( nonvar(PI) ->
|
|
( PI = Name / Arity ->
|
|
( var(Name) -> throw(error(instantiation_error, Source))
|
|
; integer(Arity) ->
|
|
( \+ atom(Name) -> throw(error(type_error(atom, Name), Source))
|
|
; Arity < 0 -> throw(error(domain_error(not_less_than_zero, Arity), Source))
|
|
; true
|
|
)
|
|
; throw(error(type_error(integer, Arity), Source))
|
|
)
|
|
; PI = op(Prec, Spec, Name) ->
|
|
( integer(Prec) ->
|
|
( \+ atom(Name) ->
|
|
throw(error(type_error(atom, Name), Source))
|
|
; Prec < 0 ->
|
|
throw(error(domain_error(not_less_than_zero, Prec), Source))
|
|
; Prec > 1200 ->
|
|
throw(error(domain_error(operator_precision, Prec), Source))
|
|
; memberchk(Spec, [xfy, yfx, xfx, fx, fy, yf, xf])
|
|
; throw(error(domain_error(operator_specification, Spec), Source))
|
|
)
|
|
; throw(error(type_error(integer, Prec), Source))
|
|
)
|
|
; throw(error(type_error(module_export, PI), Source))
|
|
)
|
|
; throw(error(instantiation_error, Source))
|
|
).
|
|
|
|
consult(Item) :-
|
|
( atom(Item) -> use_module(Item)
|
|
; throw(error(type_error(atom, Item), consult/1))
|
|
).
|
|
|
|
use_module(Module) :-
|
|
( nonvar(Module) ->
|
|
( Module = library(Filename) -> '$use_module'(Filename)
|
|
; atom(Module) -> '$use_module_from_file'(Module)
|
|
; throw(error(invalid_module_specifier, use_module/1))
|
|
)
|
|
; throw(error(instantiation_error, use_module/1))
|
|
).
|
|
|
|
use_module(Module, QualifiedExports) :-
|
|
( nonvar(Module) ->
|
|
( list_si(QualifiedExports) ->
|
|
maplist('$module_export'(use_module/2), QualifiedExports) ->
|
|
( Module = library(Filename) ->
|
|
'$use_qualified_module'(Filename, QualifiedExports)
|
|
; atom(Module) ->
|
|
'$use_qualified_module_from_file'(Module, QualifiedExports)
|
|
; throw(error(invalid_module_specifier, use_module/2))
|
|
)
|
|
; throw(error(type_error(list, QualifiedExports), use_module/2))
|
|
)
|
|
; throw(error(instantiation_error, use_module/2))
|
|
).
|
|
|
|
% expand goals in initialization directives.
|
|
user:term_expansion(Term0, (:- initialization(ExpandedGoals))) :-
|
|
nonvar(Term0),
|
|
Term0 = (:- initialization(Goals)),
|
|
expand_goals(Goals, ExpandedGoals),
|
|
Goals \== ExpandedGoals.
|
|
|
|
expand_goals(UnexpandedGoals, ExpandedGoals) :-
|
|
nonvar(UnexpandedGoals),
|
|
var(ExpandedGoals),
|
|
( expand_goal(UnexpandedGoals, Goals) -> true
|
|
; Goals = UnexpandedGoals
|
|
),
|
|
( Goals = (Goal0, Goals0) ->
|
|
( expand_goal(Goal0, Goal1) ->
|
|
Expanded = true,
|
|
expand_goals(Goals0, Goals1),
|
|
thread_goals(Goal1, ExpandedGoals, Goals1, (','))
|
|
; expand_goals(Goals0, Goals1),
|
|
ExpandedGoals = (Goal0, Goals1)
|
|
)
|
|
; Goals = (Goals0 -> Goals1) ->
|
|
expand_goals(Goals0, ExpandedGoals0),
|
|
expand_goals(Goals1, ExpandedGoals1),
|
|
ExpandedGoals = (ExpandedGoals0 -> ExpandedGoals1)
|
|
; Goals = (Goals0 ; Goals1) ->
|
|
expand_goals(Goals0, ExpandedGoals0),
|
|
expand_goals(Goals1, ExpandedGoals1),
|
|
ExpandedGoals = (ExpandedGoals0 ; ExpandedGoals1)
|
|
; thread_goals(Goals, ExpandedGoals, (','))
|
|
; Goals = ExpandedGoals
|
|
).
|
|
|
|
thread_goals(Goals0, Goals1, Hole, Functor) :-
|
|
nonvar(Goals0),
|
|
( Goals0 = [G | Gs] ->
|
|
( Gs == [] ->
|
|
Goals1 =.. [Functor, G, Hole]
|
|
; Goals1 =.. [Functor, G, Goals2],
|
|
thread_goals(Gs, Goals2, Hole, Functor)
|
|
)
|
|
; Goals1 =.. [Functor, Goals0, Hole]
|
|
).
|
|
|
|
thread_goals(Goals0, Goals1, Functor) :-
|
|
nonvar(Goals0),
|
|
( Goals0 = [G | Gs] ->
|
|
( Gs = [] ->
|
|
Goals1 = G
|
|
; Goals1 =.. [Functor, G, Goals2],
|
|
thread_goals(Gs, Goals2, Functor)
|
|
)
|
|
; Goals1 = Goals0
|
|
).
|