/** * Warranty & Liability * To the extent permitted by applicable law and unless explicitly * otherwise agreed upon, XLOG Technologies AG makes no warranties * regarding the provided information. XLOG Technologies AG assumes * no liability that any problems might be solved with the information * provided by XLOG Technologies AG. * * Rights & License * All industrial property rights regarding the information - copyright * and patent rights in particular - are the sole property of XLOG * Technologies AG. If the company was not the originator of some * excerpts, XLOG Technologies AG has at least obtained the right to * reproduce, change and translate the information. * * Reproduction is restricted to the whole unaltered document. Reproduction * of the information is only allowed for non-commercial uses. Selling, * giving away or letting of the execution of the library is prohibited. * The library can be distributed as part of your applications and libraries * for execution provided this comment remains unchanged. * * Restrictions * Only to be distributed with programs that add significant and primary * functionality to the library. Not to be distributed with additional * software intended to replace any components of the library. * * Trademarks * Jekejeke is a registered trademark of XLOG Technologies AG. */ /***************************************************************/ /* Operators Modes */ /***************************************************************/ % sys_is_infix(-Atom, -Integer, -Imteger) sys_is_infix(xfx, 1, 1). sys_is_infix(yfx, 0, 1). sys_is_infix(xfy, 1, 0). % sys_is_prefix(-Atom, -Integer) sys_is_prefix(fx, 1). sys_is_prefix(fy, 0). % sys_is_postfix(-Atom, -Integer) sys_is_postfix(xf, 1). sys_is_postfix(yf, 0). /***************************************************************/ /* Syntax Operators */ /***************************************************************/ /** * The fourth argument are the printing flags. * 1: Suppresse left operator space. * 2: Suppresse right operator space. * 4: Formatting of (,)/2 and (:-)/2 like operators. * 8: Formatting of (;)/2 and (:-)/2 like operators. */ % sys_op(-Atom, -Atom, -Integer, -Integer, -Atom) :- dynamic(sys_op/5). /** * current_op(L, M, O): [ISO 8.14.4] * The predicate succeeds for every operator O with mode M and level L. */ % current_op(-Integer, -Atom, -Atom) current_op(L, M, O) :- sys_op(O, M, L, _, _). /** * op(L, M, O): [ISO 8.14.3] * The predicate succeeds. As a side effect, a new operator O with * mode M and level L is assserted. */ % op(+Integer, +Atom, +Atom) op(L, M, O) :- must_be(integer, L), must_be(atom, M), must_be(atom, O), sys_check_priority(L), sys_op_retract(O, M), sys_op_assert(O, M, L). % sys_check_priority(+Integer) sys_check_priority(L) :- L < 0, throw(error(domain_error(not_less_than_zero, L), _)). sys_check_priority(L) :- L > 1200, throw(error(domain_error(operator_priority, L), _)). sys_check_priority(_). % sys_op_retract(+Atom, +Atom) sys_op_retract(O, M) :- sys_is_prefix(M, _), !, (sys_op(O, N, R, _, _), sys_is_prefix(N, _), retract(sys_op(O, N, R, _, _)), fail; true). sys_op_retract(O, M) :- sys_is_postfix(M, _), !, (sys_op(O, N, R, _, _), sys_is_postfix(N, _), retract(sys_op(O, N, R, _, _)), fail; true). sys_op_retract(O, M) :- sys_is_infix(M, _, _), !, (sys_op(O, N, R, _, _), sys_is_infix(N, _, _), retract(sys_op(O, N, R, _, _)), fail; true). sys_op_retract(_, M) :- throw(error(domain_error(operator_specifier, M),_)). % sys_op_assert(+Atom, +Atom, +Integer) sys_op_assert(_, _, 0) :- !. sys_op_assert(O, M, _) :- sys_is_infix(M, _, _), sys_op(O, N, _, _, _), sys_is_postfix(N, _), throw(error(permission_error(create,operator, O),_)). sys_op_assert(O, M, _) :- sys_is_postfix(M, _), sys_op(O, N, _, _, _), sys_is_infix(N, _, _), throw(error(permission_error(create,operator, O),_)). sys_op_assert(O, M, L) :- sys_op_punct(O, E), sys_op_space(M, L, F), sys_op_format(M, L, G), H is E \/ F \/ G, dg_get_partition(S), assertz(sys_op(O, M, L, H, S)). % sys_op_punct(+Atom, -Integer) sys_op_punct(; , 2) :- !. sys_op_punct(',', 2) :- !. sys_op_punct(_ , 0). % sys_op_space(+Atom, +Integer, -Integer) sys_op_space(_, L, 0) :- L > 699, !. sys_op_space(M, _, 1) :- sys_is_prefix(M, _), !. sys_op_space(M, _, 2) :- sys_is_postfix(M, _), !. sys_op_space(_, _, 3). % sys_op_format(+Atom, +Integer, -Integer) sys_op_format(M, L, F) :- sys_is_infix(M, _, _), !, sys_op_format2(L, F). sys_op_format(M, L, F) :- sys_is_prefix(M, _), !, sys_op_format3(L, F). sys_op_format(_, _, 0). % sys_op_format2(+Integer, -Integer) sys_op_format2(L, 12) :- L > 1149, !. sys_op_format2(L, 8) :- L > 1049, !. sys_op_format2(L, 4) :- L > 949, !. sys_op_format2(_, 0). % sys_op_format3(Integer, -Integer) sys_op_format3(L, 12) :- L > 1149, !. sys_op_format3(_, 0). /***************************************************************/ /* Predefind Operators */ /***************************************************************/ :- op(1200, fx, :-). :- op(1200, xfx, :-). :- op(1200, fx, ?-). :- op(1200, xfx, -->). :- op(1100, xfy, ;). :- op(1050, xfy, ->). :- op(1000, xfy, ','). :- op(900, fy, \+). :- op(700, xfx, is). :- op(700, xfx, =). :- op(700, xfx, \=). :- op(700, xfx, =..). :- op(700, xfx, <). :- op(700, xfx, =<). :- op(700, xfx, =\=). :- op(700, xfx, >=). :- op(700, xfx, >). :- op(700, xfx, =:=). :- op(700, xfx, @<). :- op(700, xfx, @=<). :- op(700, xfx, \==). :- op(700, xfx, @>=). :- op(700, xfx, @>). :- op(700, xfx, ==). :- op(600, xfy, :). :- op(500, yfx, +). :- op(500, yfx, -). :- op(500, yfx, /\). :- op(500, yfx, \/). :- op(400, yfx, *). :- op(400, yfx, /). :- op(400, yfx, //). :- op(400, yfx, rem). :- op(400, yfx, div). :- op(400, yfx, mod). :- op(400, yfx, xor). :- op(400, yfx, >>). :- op(400, yfx, <<). :- op(200, fy, -). :- op(200, fy, \). :- op(200, xfx, **). :- op(200, xfy, ^). /********************************************************************/ /* initialization/1 */ /********************************************************************/ :- dynamic(sys_init_goal/1). /** * initialization(G): * The goal G is scheduled for later execution. */ % initialization(+Goal) initialization(G) :- assertz(sys_init_goal(G)). % sys_init_goals sys_init_goals :- retract(sys_init_goal(G)), catch(sys_must(G), Error, sys_print_error(Error)), fail. sys_init_goals. % sys_must(+Goal) sys_must(X) :- X, !. sys_must(_) :- throw(error(syntax_error(directive_failed),_)). /********************************************************/ /* Prolog Baseline */ /********************************************************/ /** * sys_baseline: * The predicate processes the option arguments. * Runtime Library incarnation. */ % sys_baseline sys_baseline :- current_prolog_flag(argv, L), sys_baseline(L). % sys_baseline(+List) sys_baseline(['-h'|_]) :- !, current_output(Stream), put_message(Stream, command(runtime)), nl. sys_baseline([H|_]) :- sub_atom(H, 0, _, _, '-'), throw(error(system_error(option_command), _)). sys_baseline(_). /*************************************************************/ /* Prolog Launch */ /*************************************************************/ /** * sys_launch(R): * The predicate launches the remainder arguments. */ % sys_launch sys_launch :- current_prolog_flag(argv, L), sys_launch(L). % sys_launch(+List) sys_launch(['-h'|_]) :- !. sys_launch([]) :- ensure_loaded(library(tester/session)), version, prolog. sys_launch([H|_]) :- ensure_loaded(H), sys_init_goals. /*********************************************************************/ /* Net Dedection */ /*********************************************************************/ % sys_net_request(+Atom) sys_net_request(P) :- sys_net_path(P). sys_net_request(_) :- current_prolog_flag(base_url, B), sys_net_path(B). % sys_net_path(+Atom) sys_net_path(P) :- sub_atom(P, 0, _, _, 'http:'). sys_net_path(P) :- sub_atom(P, 0, _, _, 'https:'). /*********************************************************************/ /* File Open */ /*********************************************************************/ /** * open(P, M, S): [ISO 8.11.5.4] * open(P, M, S, O): [ISO 8.11.5.4] * The built-in succeeds in S with a new stream for the path P and the * mode M. The quaternary predicate allows specifying open options O. */ % open(+Atom, +Atom, -Stream) open(P, M, S) :- open(P, M, S, []). % open(+Atom, +Atom, -Stream, +List) open(P, M, S, List) :- sys_net_request(P), !, ir_object_new(Map), sys_open_opts(List, Map), sys_open_http(P, M, Map, S), sys_open_results(List, Map). open(P, M, S, List) :- ir_object_new(Map), sys_stream_opts(List, Map), sys_open_file(P, M, Map, S). % sys_open_file(+Atom, +Atom, +Map, -Stream) sys_open_file(P, read, Map, S) :- current_prolog_flag(read_async, on), !, os_open_promise(P, Map, S, Q), '$YIELD'(Q). sys_open_file(P, M, Map, S) :- os_open_sync(P, M, Map, S). % sys_open_http(+Atom, +Atom, +Map, -Stream) sys_open_http(P, read, Map, S) :- current_prolog_flag(read_async, on), !, net_open_promise(P, Map, S, Q), '$YIELD'(Q). sys_open_http(P, M, Map, S) :- net_open_sync(P, M, Map, S). /** * close(S): [ISO 8.11.6] * The built-in succeeds. As a side effect, the stream S is closed. */ % close(+Stream) close(S) :- ir_object_current(S, 'flags', F), F /\ 2 =\= 0, !, os_close_promise(S, P), '$YIELD'(P). close(S) :- os_close_sync(S). /***************************************************************/ /* Newline, Flush and Tab */ /***************************************************************/ /** * nl: [ISO 8.12.3] * nl(S): [ISO 8.12.3] * The predicate succeeds. As a side effect, a newline is written. * The unary predicate allows specifying an output stream S. */ % nl nl :- current_output(Stream), put_atom(Stream, '\n'), flush_output(Stream). % nl(+Stream) nl(Stream) :- ir_object_current(Stream, 'flags', F), F /\ 16 =\= 0, !, put_atom(Stream, '\n'), flush_output(Stream). nl(Stream) :- put_atom(Stream, '\n'). /** * flush_output: [ISO 8.11.7] * flush_output(S): [ISO 8.11.7] * The predicate succeeds. As a side effect, the current * output is flushed. The unary predicate allows specifying * an output stream S. */ % flush_output flush_output :- current_output(S), flush_output(S). % flush_output(+Stream) % defined as special /***********************************************************************/ /* Code I/O */ /***********************************************************************/ /** * put_code(C): [ISO 8.12.3] * put_code(S, C): [ISO 8.12.3] * The unary predicate writes the code C to the standard output. * The binary predicate takes an additional output stream S as argument. */ % put_code(+Code) put_code(Code) :- current_output(Stream), char_code(Atom, Code), put_atom(Stream, Atom). % put_code(+Stream, +Code) put_code(Stream, Code) :- char_code(Atom, Code), put_atom(Stream, Atom). /** * get_code(C): [ISO 8.12.1] * get_code(S, C): [ISO 8.12.1] * The predicate reads a code from the standard input. The predicate * succeeds when C unifies with the read code or the integer -1 when the * end of the stream has been reached. The binary predicate takes an additional * input stream S as argument. */ % get_code(-Code) get_code(Code) :- current_input(Stream), get_code(Stream, Code). % get_code(+Stream, -Code) get_code(S, C) :- os_get_code(S, H), !, H = C. get_code(S, C) :- sys_read_buffer(S), os_get_code(S, H), !, H = C. get_code(_, C) :- -1 = C. /** * peek_code(C): [ISO 8.12.2] * peek_code(T, C): [ISO 8.12.2] * The predicate reads a code from the standard input and puts it back. The * predicate succeeds when C unifies with the read code or the integer -1 when * the end of the stream has been reached. The binary predicate takes an * additional input stream S as argument. */ % peek_code(-Code) peek_code(Code) :- current_input(Stream), peek_code(Stream, Code). % peek_code(+Stream, -Code) peek_code(S, C) :- os_peek_code(S, H), !, H = C. peek_code(S, C) :- sys_read_buffer(S), os_peek_code(S, H), !, H = C. peek_code(_, C) :- -1 = C. % sys_read_buffer(+Stream) sys_read_buffer(S) :- ir_object_current(S, 'flags', F), F /\ 2 =\= 0, !, os_read_promise(S, P), '$YIELD'(P). sys_read_buffer(S) :- os_read_sync(S). /***************************************************************/ /* Atom I/O */ /***************************************************************/ /** * put_atom(S): * put_atom(S, A): * The built-in succeeds. As a side effect, it adds the atom * A to the output stream. The binary predicate allows * specifying an output stream S. */ % put_atom(+Atom) put_atom(A) :- current_output(S), put_atom(S, A). % put_atom(+Stream, +Atom) % defined as special /** * get_atom(A, O): * get_atom(S, A, O): * The built-in succeeds in A with the atom from the input * stream up to the atom options O. The ternary predicate * allows specifying an input stream S. */ % get_atom(-Atom, +List) get_atom(A, O) :- current_input(S), get_atom(S, A, O). % get_atom(+Stream, -Atom, +List) get_atom(S, A, O) :- sys_atom_opts(O, v(0'\n,1,0), v(D,F,M)), sys_get_code(S, H, F), sys_get_code_list(H, D, M, S, L, F), atom_codes(A, L). % sys_get_code_list(+Integer, +Integer, +Integer, +Stream, -List, +Integer) sys_get_code_list(-1, _, _, _, [], _) :- !. sys_get_code_list(H, H, _, _, [H], _) :- !. sys_get_code_list(H, _, 1, _, [H], _) :- !. sys_get_code_list(H, D, 0, S, [H|L], F) :- !, sys_get_code(S, J, F), sys_get_code_list(J, D, 0, S, L, F). sys_get_code_list(H, D, M, S, [H|L], F) :- sys_get_code(S, J, F), N is M-1, sys_get_code_list(J, D, N, S, L, F). /** * sys_get_code(S, C, F): * Like get_code/2 but compresses line terminators '\n', * '\r' and '\r\n' into a single '\n' in case the flag F * has bit 0x00000001 set. */ % sys_get_code(+Stream, -Integer, +Integer) sys_get_code(S, C, F) :- F /\ 1 =:= 0, !, get_code(S, C). sys_get_code(S, C, G) :- ir_object_current(S, 'flags', F), get_code(S, H), sys_get_code_more(H, F, S, C, G). % sys_get_code_more(+Integer, +Integer, +Stream, -Integer, +Integer) sys_get_code_more(13, _, _, 10, _) :- !. sys_get_code_more(10, F, S, C, G) :- F /\ 1 =\= 0, !, sys_get_code(S, C, G). sys_get_code_more(H, _, _, H, _). /***************************************************************/ /* Decode Atom Options */ /***************************************************************/ % sys_atom_opts(+List, +Triple, -Triple) sys_atom_opts(V, _, _) :- var(V), throw(error(instantiation_error,_)). sys_atom_opts([X|L], I, O) :- !, sys_atom_opt(X, I, H), sys_atom_opts(L, H, O). sys_atom_opts([], H, H) :- !. sys_atom_opts(L, _, _) :- throw(error(type_error(list,L),_)). % sys_atom_opt(+Option, +Triple, -Triple) sys_atom_opt(V, _, _) :- var(V), throw(error(instantiation_error,_)). sys_atom_opt(stop(D), v(_,F,M), v(D,F,M)) :- !. sys_atom_opt(compress(B), v(D,F,M), v(D,G,M)) :- !, sys_opt_boolean(B, 1, F, G). sys_atom_opt(max(M), v(D,F,_), v(D,F,M)) :- !. sys_atom_opt(O, _, _) :- throw(error(domain_error(atom_option,O),_)). /***************************************************************/ /* Write Convenience */ /***************************************************************/ /** * write(T): [ISO 8.14.2] * write(S, T): [ISO 8.14.2] * The predicate succeeds. As a side effect the term T is written. * The binary predicate allows specifying an output stream S. */ % write(+Term) write(Term) :- current_output(Stream), write_term(Stream, Term, [numbervars(true)]). % write(+Stream, +Term) write(Stream, Term) :- write_term(Stream, Term, [numbervars(true)]). /** * writeq(T): [ISO 8.14.2] * writeq(S, T): [ISO 8.14.2] * The predicate succeeds. As a side effect the term T is written * with quoted strings. The binary predicate allows specifying an * output stream S. */ % writeq(+Term) writeq(Term) :- current_output(Stream), write_term(Stream, Term, [numbervars(true), quoted(true)]). % writeq(+Stream, +Term) writeq(Stream, Term) :- write_term(Stream, Term, [numbervars(true), quoted(true)]). /** * write_canonical(T): [ISO 8.14.2] * write_canonical(S, T): [ISO 8.14.2] * The predicate succeeds. As a side effect the term T is written * with quoted strings and ignored operators. The binary predicate * allows specifying an output stream S. */ % write_canonical(+Term) write_canonical(Term) :- current_output(Stream), write_term(Stream, Term, [quoted(true), ignore_ops(true)]). % write_canonical(+Stream, +Term) write_canonical(Stream, Term) :- write_term(Stream, Term, [quoted(true), ignore_ops(true)]). /** * write_term(T, O): [ISO 8.14.2] * write_term(S, T, O): [ISO 8.14.2] * The predicate succeeds. As a side effect the term T is written with * options O. The ternary predicate allows specifying an output stream S. * For the available options see the documentation. */ % write_term(+Term, +List) write_term(Term, Opts) :- current_output(Stream), write_term(Stream, Term, Opts). /****************************************************************/ /* Error Printing */ /****************************************************************/ /** * sys_print_error(E): * sys_print_error(S, E): * The predicate succeeds. As a side effect it prints the * error E to the error stream. The binary predicate allows * specifying the destination stream. */ % sys_print_error(+Error) sys_print_error(Error) :- current_error(Stream), sys_print_error(Stream, Error). % sys_print_error(+Stream, +Error) sys_print_error(Stream, Error) :- ir_object_current(Stream, 'flags', F), F /\ 12 =\= 0, !, sys_fancy_problem(Error, Stream). sys_print_error(Stream, Error) :- sys_print_problem(Error, Stream). % sys_print_problem(+Error, +Stream) sys_print_problem(Error, Stream) :- var(Error), !, put_message(Stream, exception(unknown, Error), Stream), nl(Stream). sys_print_problem(cause(Primary, Secondary), Stream) :- !, sys_print_problem(Primary, Stream), sys_print_problem(Secondary, Stream). sys_print_problem(error(Message, Trace), Stream) :- !, put_message(Stream, exception(error)), put_message(Stream, Message), nl(Stream), sys_print_trace(Trace, Stream). sys_print_problem(warning(Message, Trace), Stream) :- !, put_message(Stream, exception(warning)), put_message(Stream, Message), nl(Stream), sys_print_trace(Trace, Stream). sys_print_problem(Error, Stream) :- put_message(Stream, exception(unknown, Error)), nl(Stream). % sys_print_trace(+List, +Stream) sys_print_trace(Trace, Stream) :- var(Trace), !, put_message(Stream, exception(context, Trace)), nl(Stream). sys_print_trace([Frame|Trace], Stream) :- !, sys_print_frame(Frame, Stream), nl(Stream), sys_print_trace(Trace, Stream). sys_print_trace([], _) :- !. sys_print_trace(Trace, Stream) :- put_message(Stream, exception(context, Trace)), nl(Stream). % sys_print_frame(+Term, +Stream) sys_print_frame(sys_including(File, Include), Stream) :- atom(File), !, file_base_name(File, Name), ir_object_current(Include, 'lineno', Line), put_message(Stream, file_line(Name, Line)). sys_print_frame(Frame, Stream) :- put_message(Stream, Frame). /***************************************************************/ /* Read Convenience */ /***************************************************************/ /** * read(E): [ISO 8.14.1] * read(S, E): [ISO 8.14.1] * The predicate succeeds in E with the read term or end_of_file. * As a side effect, the input position is advanced. The binary * predicate allows specifying an input stream S. */ % read(-Term) read(Term) :- current_input(Stream), get_code(Stream, Code), sys_read_term(Code, Stream, [], Term). % read(+Stream, -Term) read(Stream, Term) :- get_code(Stream, Code), sys_read_term(Code, Stream, [], Term). /** * read_term(E, O): [ISO 8.14.1] * read_term(S, E, O): [ISO 8.14.1] * The predicate succeeds in E with the read term or end_of_file * and in O with the options. As a side effect, the input position * is advanced. The ternary predicate allows specifying an input * stream. For the available options see the documentation. */ % read_term(-Term, -List) read_term(Term, Opt) :- current_input(Stream), get_code(Stream, Code), sys_read_term(Code, Stream, Opt, Term). % read_term(+Stream, -Term, -List) read_term(Stream, Term, Opt) :- get_code(Stream, Code), sys_read_term(Code, Stream, Opt, Term). /****************************************************************/ /* File Properties */ /****************************************************************/ /** * file_property(F, P): * The predicate succeeds in P with the properties of the file F. */ % file_property(+Atom, -Term) file_property(P, Prop) :- var(Prop), !, sys_prop_map(P, Map), ir_object_keys(Map, Keys), member(Key, Keys), ir_object_current(Map, Key, Value), Prop =.. [Key,Value]. file_property(P, Prop) :- Prop =.. [Key,Value2], sys_prop_map(P, Map), ir_object_current(Map, Key, Value), !, Value2 = Value. file_property(_, Prop) :- Prop =.. [Key,_], throw(error(domain_error(prolog_flag, Key),_)). % sys_prop_map(+Atom, -Map) sys_prop_map(P, Map) :- sys_net_request(P), !, sys_prop_http(P, Map). sys_prop_map(P, Map) :- sys_prop_file(P, Map). % sys_prop_file(+Atom, -Map) sys_prop_file(P, Map) :- current_prolog_flag(prop_async, on), !, os_prop_promise(P, Map, Prom), '$YIELD'(Prom). sys_prop_file(P, Map) :- os_prop_sync(P, Map). % sys_prop_http(+Atom, -Map) sys_prop_http(P, Map) :- current_prolog_flag(prop_async, on), !, net_prop_promise(P, Map, Prom), '$YIELD'(Prom). sys_prop_http(P, Map) :- net_prop_sync(P, Map). /** * set_file_property(F, P): * The predicate assigns the property P to the file F. */ % set_file_property(+Atom, +Term) set_file_property(P, Q) :- sys_net_request(P), !, net_cntrl_sync(P, Q). set_file_property(P, Q) :- os_cntrl_sync(P, Q). /** * file_directory_name(F, G): * The predicate succeeds in G with the directory name of the file name F. * The trailing file separator is included in the directory name. */ % file_directory_name(+Atom, -Atom) file_directory_name(Path, Dir) :- (last_sub_atom(Path, Pos1, _, _, '/') -> true; Pos1 = -1), (last_sub_atom(Path, Pos2, _, _, '\\') -> true; Pos2 = -1), Pos is max(Pos1, Pos2), Pos3 is Pos+1, sub_atom(Path, 0, Pos3, _, Dir). /** * file_base_name(F, G): * The predicate succeeds in G with the base name of the file name F. * File names with trailing file separator return empty base name. */ % file_base_name(+Atom, -Atom) file_base_name(Path, Name) :- atom_length(Path, Len), (last_sub_atom(Path, _, _, Pos1, '/') -> true; Pos1 = Len), (last_sub_atom(Path, _, _, Pos2, '\\') -> true; Pos2 = Len), Pos is min(Pos1, Pos2), sub_atom(Path, _, Pos, 0, Name). /***************************************************************/ /* Path Utilities */ /***************************************************************/ /** * absolute_file_name(F, G): * absolute_file_name(F, G, L): * The predicate succeeds in G with the absolute file name of F. * If F is already an absolute file name, then F is returned unchanged, * otherwise the F is resolved against the Prolog flag base_url. The * ternary predicate allows specifying absolute file options. */ % absolute_file_name(+Atom, +Atom) absolute_file_name(Path, Path2) :- absolute_file_name(Path, Path2, []). % absolute_file_name(+Atom, +Atom, +List) absolute_file_name(Path, Path3, Opts) :- current_prolog_flag(base_url, Base), sys_absolute_opts(Opts, v('',Base), v(Ext,Base2)), sys_file_complete(Ext, Path, Path2), sys_file_combine(Base2, Path2, Path3). % sys_absolute_opts(+List, +Pair, -Pair) sys_absolute_opts(V, _, _) :- var(V), throw(error(instantiation_error,_)). sys_absolute_opts([X|L], F, G) :- !, sys_absolute_opt(X, F, H), sys_absolute_opts(L, H, G). sys_absolute_opts([], F, F) :- !. sys_absolute_opts(L, _, _) :- throw(error(type_error(list,L),_)). % sys_absolute_opt(+Term, +Pair, -Pair) sys_absolute_opt(V, _, _) :- var(V), throw(error(instantiation_error,_)). sys_absolute_opt(relative_to(R), v(E,_), v(E,R)) :- !. sys_absolute_opt(extension(E), v(_,R), v(E,R)) :- !. sys_absolute_opt(O, _, _) :- throw(error(domain_error(absolute_option,O),_)). % sys_file_complete(+Atom, +Atom, -Atom) sys_file_complete('', Path, Path) :- !. sys_file_complete(_, Path, Path) :- file_base_name(Path, Name), sub_atom(Name, _, _, _, '.'), !. sys_file_complete(Ext, Path, Path2) :- atom_concat(Path, Ext, Path2). % sys_file_combine(+Atom, +Atom, -Atom) sys_file_combine(_, Path, Path2) :- is_absolute_file_name(Path), !, Path = Path2. sys_file_combine(Base, Path, Path3) :- (sub_atom(Path, 0, _, _, '../'); sub_atom(Path, 0, _, _, '..\\')), !, sub_atom(Path, 3, _, 0, Path2), file_directory_name(Base, Dir), sub_atom(Dir, 0, _, 1, Base2), sys_file_combine(Base2, Path2, Path3). sys_file_combine(Base, Path, Path2) :- file_directory_name(Base, Dir), atom_concat(Dir, Path, Path2). /** * is_absolute_file_name(F): * The predicate succeeds if F is an absolute file name. A file name is * considered absolute if it starts with a file separator or if it contains * a protocol separator before the first file separator or in itself. */ % is_absolute_file_name(+Atom) is_absolute_file_name(Path) :- atom_length(Path, Len), (sub_atom(Path, Pos1, _, _, '/') -> true; Pos1 = Len), (sub_atom(Path, Pos2, _, _, '\\') -> true; Pos2 = Len), Pos is min(Pos1, Pos2), (Pos == 0 -> Pos < Len; sub_atom(Path, Pos3, _, _, ':') -> Pos3 < Pos; fail). /*************************************************************/ /* Relative Utility */ /*************************************************************/ % sys_file_relative(+Term, -Atom) sys_file_relative(V, _) :- var(V), throw(error(instantiation_error, _)). sys_file_relative(library(Path), Path2) :- !, sys_file_compound(Path, 'liblet', '.p', Path2). sys_file_relative(foreign(Path), Path2) :- !, current_prolog_flag(foreign_ext, Ext), sys_file_compound(Path, 'doglet', Ext, Path2). sys_file_relative(Path, Path2) :- sys_file_including(Base), !, absolute_file_name(Path, Path2, [relative_to(Base),extension('.p')]). sys_file_relative(Path, Path2) :- absolute_file_name(Path, Path2, [extension('.p')]). % sys_file_compound(+Path, +Atom, +Atom, -Atom) sys_file_compound(Path, Dir, Ext, Path2) :- sys_file_struct(Path, Path4), atom_join([Dir, '/', Path4, Ext], Path3), current_prolog_flag(system_url, Base), sys_file_combine(Base, Path3, Path2). % sys_file_including(-Atom) sys_file_including(Base) :- current_task(Task), sys_including(Base, Task, _), !, Base \== user. % sys_file_struct(+Term, -Atom) sys_file_struct(V, _) :- var(V), throw(error(instantiation_error, _)). sys_file_struct(Path/Path2, Path3) :- !, sys_file_struct(Path, Path4), atom_join([Path4, '/', Path2], Path3). sys_file_struct(Path, Path2) :- atom(Path), !, Path = Path2. sys_file_struct(Path, _) :- throw(error(type_error(atom, Path),_)). /****************************************************************/ /* Other Texts */ /****************************************************************/ % strings(+Atom, +Atom, -Atom) :- multifile(strings/3). strings('exception.unknown', de, 'Ausnahme unbekannt: ~q'). strings('exception.error', de, 'Fehler: '). strings('exception.warning', de, 'Warnung: '). strings('exception.template', de, 'Vorlage unbekannt: ~q'). strings('exception.context', de, ' Kontext unbekannt: ~q'). strings('file_line', de, ' ~q auf ~q'). strings('command.runtime', de, 'Benutzung: opt_1 .. opt_m [text arg_1 .. arg_n]\n\ Falls kein text spezifiziert ist, wird Banner gezeigt und dann\n\ Top-Level ausgeführt, andernfalls wird text ausgeführt.\n\ -h Diesen Hilfetext anzeigen und Vorgang beenden'). strings('system_error.option_command', de, 'Ungültige Befehlzeilenoption, -h für weitere Informationen.'). strings('exception.unknown', '', 'Unknown exception: ~q'). strings('exception.error', '', 'Error: '). strings('exception.warning', '', 'Warning: '). strings('exception.template', '', 'Unknown template: ~q'). strings('exception.context', '', ' Unknown context: ~q'). strings('file_line', '', ' ~q at ~q'). strings('command.runtime', '', 'Usage: opt_1 ... opt_m [text arg_1 ... arg_n]\n\ If no text is specified, banner is shown and then top-level\n\ is executed, otherwise text is executed.\n\ -h Display this help and exit.'). strings('system_error.option_command', '', 'Invalid command line option, -h for more information.'). /****************************************************************/ /* Error Texts */ /****************************************************************/ strings('evaluation_error.float_overflow', de, 'Die Funktion überschreitet hier den Gleitpunktzahlbereich.'). strings('evaluation_error.undefined', de, 'Die Funktion ist hier undefiniert.'). strings('evaluation_error.zero_divisor', de, 'Nulldivision.'). strings('resource_error.not_supported', de, 'Nicht unterstützte Operation.'). strings('resource_error.interrupted_exception', de, 'Unerwartet unterbrochene Operation.'). strings('representation_error.int', de, 'Unerlaubte Ganzzahl (nicht zwischen - 2^31 und 2^31-1).'). strings('representation_error.long', de, 'Unerlaubte Ganzzahl (nicht zwischen - 2^63 und 2^63-1).'). strings('representation_error.max_arity', de, 'Unerlaubte Stelligkeit (nicht kleiner oder gleich 2^31-1).'). strings('domain_error.prolog_flag', de, 'Flag erwartet, gefunden ~q.'). strings('domain_error.not_less_than_zero', de, 'Positiv oder 0 erwartet, gefunden ~q.'). strings('domain_error.operator_priority', de, 'Operatorlevel (kleiner oder gleich 1200) erwartet, gefunden ~q.'). strings('domain_error.operator_specifier', de, 'Operatormode (fx, fy, xfx, yfx, xfy, xf, yf) erwartet, gefunden ~q.'). strings('domain_error.time_format', de, 'Zeitformat erwartet, gefunden ~q.'). strings('domain_error.atom_option', de, 'Atomoption erwartet, gefunden ~q.'). strings('domain_error.absolute_option', de, 'Absolutoption erwartet, gefunden ~q.'). strings('type_error.atom', de, 'Atom erwartet, gefunden ~q.'). strings('type_error.number', de, 'Zahl erwartet, gefunden ~q.'). strings('type_error.integer', de, 'Ganzzahl erwartet, gefunden ~q.'). strings('type_error.callable', de, 'Argument sollte aufrufbar sein (Atom oder Verbund), gefunden ~q.'). strings('type_error.atomic', de, 'Argument sollte atomar sein, gefunden ~q.'). strings('type_error.list', de, 'Liste ([] oder [_|_]) erwartet, gefunden ~q.'). strings('type_error.evaluable', de, 'Berechenbaren Funktion erwartet, gefunden ~q.'). strings('type_error.character', de, 'Zeichen erwartet, gefunden ~q.'). strings('type_error.pair', de, 'Paar (_-_) erwartet, gefunden ~q.'). strings('type_error.predicate_indicator', de, 'Prädikatindikator (_/_) erwartet, gefunden ~q.'). strings('type_error.maybe', de, 'Option (nothing oder just(_)) erwartet, gefunden ~q.'). strings('permission_error.modify.flag', de, 'Kann schreibgeschütztes Flag ~q nicht aktualisieren.'). strings('evaluation_error.float_overflow', '', 'The function overflows the float range here.'). strings('evaluation_error.undefined', '', 'The function is undefined here.'). strings('evaluation_error.zero_divisor', '', 'Division by zero.'). strings('resource_error.not_supported', '', 'Operation not supported.'). strings('resource_error.interrupted_exception', '', 'Operation terminated unexpectedly.'). strings('representation_error.int', '', 'Illegal integer (not between - 2^31 and 2^31-1).'). strings('representation_error.long', '', 'Illegal integer (not between - 2^63 and 2^63-1).'). strings('representation_error.max_arity', '', 'Illegal arity (not less or equal 2^31-1).'). strings('domain_error.prolog_flag', '', 'Flag expected, found ~q.'). strings('domain_error.not_less_than_zero', '', 'Positive or 0 expected, found ~q.'). strings('domain_error.operator_priority', '', 'Operator level (less or equal 1200) expected, found ~q.'). strings('domain_error.operator_specifier', '', 'Operator mode (fx, fy, xfx, yfx, xfy, xf, yf) expected, found ~q.'). strings('domain_error.time_format', '', 'Time format expected, found ~q.'). strings('domain_error.atom_option', '', 'Atom option expected, found ~q.'). strings('domain_error.absolute_option', '', 'Absolute option expected, found ~q.'). strings('type_error.atom', '', 'Atom expected, found ~q.'). strings('type_error.number', '', 'Number expected, found ~q.'). strings('type_error.integer', '', 'Integer expected, found ~q.'). strings('type_error.callable', '', 'Argument should be callable (atom or compound), found ~q.'). strings('type_error.atomic', '', 'Argument should be an atomic, found ~q.'). strings('type_error.list', '', 'List ([] or [_|_]) expected, found ~q.'). strings('type_error.evaluable', '', 'Evaluable functor expected, found ~q.'). strings('type_error.character', '', 'Character expected, found ~q.'). strings('type_error.pair', '', 'Pair (_-_) expected, found ~q.'). strings('type_error.predicate_indicator', '', 'Predicate indicator (_/_) expected, found ~q.'). strings('type_error.maybe', '', 'Maybe (nothing or just(_)) expected, found ~q.'). strings('permission_error.modify.flag', '', 'Can\'t modify read-only flag ~q.').