home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / LF / SETUP2.LF < prev    next >
Text File  |  1996-05-27  |  23KB  |  881 lines
  1. % Copyright 1991 Digital Equipment Corporation.
  2. % All Rights Reserved.
  3. %
  4. % The BUILT_IN module
  5. %
  6. % This file should not be modified by the user.
  7. %
  8. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  9.  
  10. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  11. %
  12. % Declarations
  13. %
  14. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  15.  
  16. %%% public built_ins
  17.  
  18. public(trace_input, query, declaration, error, abort, aborthook,abs, append,
  19.        apply, asc, assert, asserta, bagof, beep, begin_raw, bool,
  20.        bool_pred,bi_load_path, call_once,
  21.        call_handler, ceiling, children, chr, clause,
  22.        close, cond, cons, copy_pointer, copy_rules, copy_term, cos, cpu_time,
  23.        current_module, delay_check, disj, display_module_status,
  24.        display_modules, dynamic, end_raw, eval, evalin, exists_file,
  25.        exists_choice, exp, fail, false, features, floor, fx, fy, gc, genint,
  26.        get, get_choice, get_raw, glb, halt, has_feature, implies, in_raw,
  27.        inherited_modules, init, initrandom, input_file, int, int2str,
  28.        is_function, is_number, is_predicate, is_sort, is_value, least_sorts,
  29.        length,life_ext, list, listing, load, load_module,
  30.        load_path,load_suffixes, loaded_file, local_time, log, lub, map, maprel,
  31.        max, maxint, member, min, module, mresiduate, nil, nl, nl_err,
  32.        non_strict, nonvar, op, open, open_in, open_modules, open_out, ops,
  33.        % not, PVR 10.2.94
  34.        page_width, parents, parse, pause, pretty_write, pretty_writeq,
  35.        print_codes, print_depth, print_variables, private, project,
  36.        psi2str, public, put, put_err, put_raw, random, read, read_token, real,
  37.        real_time, reduce, repeat, reset_window_flag, residuate, retract, rlist,
  38.        root_sort, run, set_choice, set_input, set_output, setq, simple_load,
  39.        sin, sqrt, static, statistics, step, str, str2psi, strcon, string,
  40.        strip, strlen, strval, subsort, substr, succeed,system, tan,
  41.        time, tprove, trace, true, undo, var, verbose, window_flag,
  42.        write, write_canonical, write_err, writeq, writeq_err, import,
  43.        % xor, PVR 10.2.94
  44.        substitute,is_persistent, global, persistent, display_persistent, alias,
  45.        bestof, % RM: Apr 15 1993
  46.        private_feature, % RM: Mar 11 1993
  47.        split_double,     % RM: Jun 29 1993
  48.        string_address,    % RM: Jul 6 1993
  49.        deref_length,     % RM: Jul 15 1993
  50.        argv,             % RM: Sep 20 1993  PVR 11.2.94
  51.        public_symbols,    % RM: Jan 28 1994
  52.        chdir,         % RM: Feb 10 1994
  53.        getenv,         % RM: Feb 10 1994
  54.        module_name,    % RM: Feb 16 1994
  55.        combined_name,    % RM: Feb 16 1994
  56.        quiet,           % BD: Feb 17 1994
  57.        feature_values
  58.       )?
  59.  
  60. %%% These are considered private:
  61. %%% '*** ERROR ***', '<NULL PSI TERM>',
  62. %%% bottom,comment,constant,variable,init
  63.  
  64. private(c_op)? % RM: Feb 24 1993
  65.  
  66.  
  67. %%% Operators
  68.  
  69. c_op(300,yfx,mod)? %% PVR 24.2.94
  70.  
  71.  
  72. %%% Built-in sorts.
  73.  
  74. cons <| list.
  75. nil <| list.
  76. list <| built_in.
  77.  
  78. string <| built_in.
  79.  
  80. real <| built_in.
  81. int <| real.
  82.  
  83. bool <| built_in.
  84. true <| bool.
  85. false <| bool.
  86.  
  87.  
  88. %%% non strict declarations
  89.  
  90. non_strict(non_strict)?
  91. non_strict(dynamic)?
  92. non_strict(static)?
  93. non_strict(delay_check)?
  94. non_strict(listing)?
  95. non_strict(evalin)?
  96. non_strict(eval)?
  97. non_strict(global) ?           %% BD 3.3.94
  98. non_strict(persistent) ?       %% BD 3.3.94
  99.  
  100. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  101.  
  102. %%%  For correct operation of the interpreter, nothing before this line should
  103. %%%  be modified.  What comes after is used for definition of built-ins and can
  104. %%%  be edited (albeit very carefully).
  105.  
  106. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  107.  
  108.  
  109. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  110. %
  111. % System built-ins
  112. %
  113. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  114.  
  115.  
  116. %%% A more useful listing predicate from the c_listing built-in.
  117.  
  118. non_strict(listing)?
  119. X:listing :-
  120.     %%    trace(T,U),   % RM: Dec  9 1992 
  121.     listing_2(features(X), X).
  122.     %%    trace(T,U).
  123.  
  124. listing_2([],    _) :- !.
  125. listing_2([F],   X) :- !, nl, listing_3(F, X).
  126. listing_2([F|L], X) :- nl, listing_3(F, X), listing_2(L, X).
  127.  
  128. listing_3(F, X) :- P=X.F, c_listing(P), listing_4(P).
  129.  
  130. listing_4(P) :- var(P), !,
  131.         write("% '@' is the top sort."), nl.
  132. %% listing_4(P:int)    :- !, listing_4a(int).
  133. %% listing_4(P:real)   :- !, listing_4a(real).
  134. %% listing_4(P:string) :- !, listing_4a(string).
  135. listing_4(P) :- listing_4a(P).
  136.  
  137. listing_4a(P) :- is_sort(P), is_value(P)=false, !, 
  138.     listing_5(parents(P), P),
  139.         listing_6(children(P), P).
  140.     % write("% Parents: "),writeq(parents(P)), nl,
  141.     % write("% Children: "),writeq(children(P)), nl.
  142.  
  143.  
  144. listing_4a(_).
  145.  
  146. listing_5([], _) :- !.
  147. listing_5([X|Xs], Y) :-
  148.     writeq(Y), write(" <| "), writeq(X), write("."), nl,
  149.     listing_5(Xs, Y).
  150.  
  151. listing_6([], _) :- !.
  152. listing_6([X|Xs], Y) :-
  153.     writeq(X), write(" <| "), writeq(Y), write("."), nl,
  154.     listing_6(Xs, Y).
  155.  
  156.  
  157. %%% An op predicate that handles any pattern of arguments. 
  158.  
  159. non_strict(op)?
  160. op(P,K,F,precedence=>P,kind=>K,functor=>F) :-
  161.     trace(T,U),
  162.     ( op_2(P,K,F), trace(T,U)
  163.     ; trace(T,U), fail
  164.     ).
  165.  
  166. op_2(P,K,F) :- nonvar(P), nonvar(K), nonvar(F), F=list, !, op_3(F,P,K).
  167. op_2(P,K,F) :- nonvar(F), F=list, !,
  168.     write_err("*** Error: invalid operator declaration."),
  169.     nl_err.
  170. op_2(P,K,F) :- nonvar(P), nonvar(K), nonvar(F), !, c_op(P,K,F).
  171. op_2(P,K,F) :- member(op(P,K,F),ops).
  172.  
  173. % List of operators.
  174. op_3([]) :- !.
  175. op_3([H|T],P,K) :- op_2(P,K,H),op_3(T,P,K).
  176.  
  177.  
  178. %%% Default call handler.
  179. %%% This is called for predicates that have no definition.
  180. %%% More sophisticated call handlers can be written to do auto-loading
  181. %%% of undefined predicates.
  182.  
  183. call_handler(P) :- is_sort(P), !,
  184.     write_err("*** Error: the sort '"),writeq_err(P),
  185.         write_err("' occurs where a predicate or function is expected."),
  186.     nl_err, abort.
  187. call_handler(P) :- !,
  188.     write_err("*** Error: '"),writeq_err(P),
  189.         write_err("' is not a predicate or a function."), nl_err,
  190.     abort.
  191.  
  192.  
  193. %%% Pause for N seconds.
  194. pause(N) :-
  195.     S=real_time,
  196.     repeat,
  197.     real_time-S>N,
  198.     !.
  199.  
  200. %%% Time a goal (whether it succeeds or fails).
  201. run(G) :-
  202.     S=cpu_time,
  203.     (G;succeed),
  204.     !,
  205.     write("Time = ",cpu_time-S," sec"),
  206.     nl.
  207.  
  208.  
  209. %%% Personal customizing.
  210.  
  211. init :-
  212.     exists_file("wild"),
  213.     simple_load("wild"),
  214.     quiet_write("Loaded customizing file from current directory."),
  215.     !.
  216.  
  217. init :-
  218.     exists_file("~wild"),
  219.     simple_load("~wild"),
  220.     quiet_write("Loaded customizing file from home directory."),
  221.     !.
  222.  
  223. init :-
  224.     quiet_write("No customizing file loaded."),
  225.     !.
  226.  
  227. %% init :-                                        %% was in .set_up
  228. %%     exists_file("+SETUPDIR+/.wild_life"),
  229. %%     simple_load("+SETUPDIR+/.wild_life"),
  230. %%     write("Loaded default customizing file."), nl
  231. %%     !.
  232.  
  233. init :-
  234.     write_err("*** Warning: couldn't access any customizing file."),
  235.     nl_err.
  236.  
  237.  
  238. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  239. %
  240. % Input-Output
  241. %
  242. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  243.  
  244. %%% Newline
  245.  
  246. nl :- write("
  247. ").
  248.  
  249. nl_err :- write_err("
  250. ").
  251.  
  252.  
  253. %%% Beep
  254.  
  255. beep :- put(7).
  256.  
  257.  
  258. %%% Quiet writing for support of '-q' option
  259. %%% This built-in doesn't write anything if the '-q' option is enabled.
  260. %%% 21.1 & RM: Feb 17 1993 
  261.  
  262. quiet_write :- quiet, !.
  263. S:quiet_write :- quiet_write_loop(features(S),S), nl.
  264.  
  265. quiet_write_loop([]) :- !.
  266. quiet_write_loop([X|L], S) :-
  267.     write(S.X),
  268.     quiet_write_loop(L, S).
  269.  
  270.  
  271.  
  272. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  273. %
  274. % Loading Files
  275. %
  276. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  277.  
  278. %%% A very useful load that searches a path, does suffix completion,
  279. %%% and remembers if a file has already been loaded.
  280. %%% The default path may be extended by an optional user-defined function
  281. %%% load_path that gives a disjunction of directories to search in.
  282. %%% The set of default suffixes may be extended by an optional user-defined
  283. %%% function load_suffixes that gives a disjunction of suffixes.
  284. %%% This predicate accepts an arbitrary number of arguments.
  285.  
  286. persistent(load_option,top_load,loading) ?
  287. load_option <<- false ?
  288. loading <<- false ?
  289.  
  290. non_strict(load)?
  291. X:load :-
  292.     CM = current_module,
  293.     F = features(X),
  294.     (
  295.         loading,!,
  296.         load_2(F,X)
  297.     ;
  298.         loading <<- true,
  299.         top_load <<- get_choice,
  300.         load_2(F,X),!,loading <<- false
  301.     ;
  302.         open_out("stdout",_),
  303.         open_in("stdin",_),
  304.         set_module(CM),
  305.         loading <<- false,
  306.         fail
  307.     ).
  308.  
  309. load_2([F|L],X) :-
  310.     (
  311.         find_file(X.F,CF),!,
  312.         (
  313.         has_feature(CF,consulted,Bool),!,
  314.         quiet_write("*** File """,CF,""" is already loaded.")
  315.         ;
  316.         quiet_write("*** Loading File """,CF,""""),
  317.         first_load(CF)
  318.         ),
  319.         load_2(L,X)
  320.     ;
  321.         set_choice(top_load),fail
  322.     ).
  323. load_2([]).
  324.  
  325. first_load(CF) :-
  326.     (
  327.         load_option,!,
  328.         consulted.CF <<- true,
  329.         simple_exp_load(CF)
  330.     ;
  331.         consulted.CF <<- false,
  332.         simple_load(CF)
  333.     ).
  334.  
  335. find_file(F:string,CF) :-
  336.     !,
  337.         (
  338.         CF=strcon(bi_load_path,
  339.               strcon(F,
  340.                  life_ext)),
  341.         exists_file(CF), !
  342.     ;
  343.         write_err("*** File """,F,""" not found."),nl_err,
  344.         fail 
  345.     ).
  346. find_file(F) :-
  347.     write_err("*** Error: File name "),
  348.     writeq_err(F),
  349.     write_err(" should be a string."),
  350.     nl_err,
  351.     fail.
  352.  
  353. bi_load_path ->  {
  354.              ""
  355.                  ;
  356.              strcon((load_path | is_function(`load_path)),
  357.                 %% {"";"/"}
  358.                 "/"
  359.                )
  360.          ;
  361.              lib_dir
  362.          ;
  363.              tools_dir
  364.                  ; %% "+SETUPDIR+/Examples/"   % BD June 10 1993
  365.              examples_dir
  366.          ;
  367.              superlint_dir
  368.                  }.
  369.  
  370. %%% The user may define a function load_suffixes that returns a
  371. %%% disjunction of other suffixes to be used.
  372. life_ext -> { ".lf"
  373.             ; ""
  374.         ; (load_suffixes | is_function(`load_suffixes))
  375.         ; ".life"
  376.         }.
  377.  
  378.  
  379. %%% reconsult facility
  380.  
  381. public(reconsult) ?
  382.  
  383. non_strict(reconsult)?
  384.  
  385. X:reconsult :-
  386.     CM = current_module,
  387.     F = features(X),
  388.     (
  389.         loading,!,
  390.         reconsult_2(F,X)
  391.     ;
  392.         loading <<- true,
  393.         top_load <<- get_choice,
  394.         reconsult_2(F,X),!,loading <<- false
  395.     ;
  396.         open_out("stdout",_),
  397.         open_in("stdin",_),
  398.         set_module(CM),
  399.         loading <<- false,
  400.         fail
  401.     ).
  402.  
  403. reconsult_2([F|L],X) :-
  404.     find_file(X.F,CF),!,
  405.     (
  406.         has_feature(CF,consulted,Bool),!,
  407.         (
  408.         Bool,!,
  409.         reload(CF,Bool)
  410.         ;
  411.         write_err("*** File """,CF,""" cannot be reconsulted."),
  412.         nl_err
  413.         )
  414.     ;
  415.         quiet_write("*** Loading File """,CF,""""),
  416.         first_load(CF)
  417.     ),
  418.     reconsult_2(L,X).
  419. reconsult_2([]).
  420.  
  421.  
  422. reload(CF,Bool) :-
  423.     retract_file(Bool),
  424.     quiet_write("*** Reconsulting File """,CF,""""),
  425.     quiet_write(" "),
  426.     quiet_write("*** Warning: sort,public,non_strict and operators ",
  427.             "declarations are not undone."),
  428.     quiet_write("***          Rules added using queries in the ",
  429.             "file are not retracted."),
  430.     quiet_write(" "),
  431.     first_load(CF).
  432.  
  433.  
  434. retract_file(B) :-
  435.     X = current_module,
  436.     retract_modules(features(B),B),
  437.     set_module(X).
  438.  
  439. retract_modules([M1|Ms],B) :- !,
  440.     M = psi2str(M1),
  441.     %% set_module(M),
  442.     retract_functions(features(B.M1.functions,M),B.M1.functions), 
  443.     retract_predicates(features(B.M1.preds,M),B.M1.preds).
  444. retract_modules([]).
  445.  
  446. retract_functions([F|Fs]) :- !,
  447.     (
  448.         retract_all_f(F)
  449.     ;
  450.         retract_functions(Fs)
  451.     ).
  452. retract_functions([]).
  453. retract_predicates([F|Fs]) :- !,
  454.     (
  455.         retract_all_p(F)
  456.     ;
  457.         retract_predicates(Fs)
  458.     ).
  459. retract_predicates([]).
  460.  
  461.  
  462. retract_all_f(F) :-
  463.     retract((F -> @)),
  464.     retract_all_f(F).
  465. retract_all_p(F) :-
  466.     retract((F :- @)),
  467.     retract_all_p(F).
  468.  
  469.  
  470.  
  471. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  472. %
  473. % Meta features
  474. %
  475. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  476.  
  477. %%% Negation
  478.  
  479. \+ X :- X,!,fail.
  480. (\+) .
  481.  
  482. %%% Quote
  483.  
  484. non_strict(`)?
  485. `X -> X.
  486.  
  487.  
  488. %%% Definition of bagof using non-backtrackable destructive assignment.
  489. %%% bagof(X,G) -> R:[]:cond(call_once((G,R<<-[X|R],fail)),R,R). % (19.8)
  490. %%% This version does not allow non-residuating functions in G &
  491. %%% "leaks" the evaluation of G into X on the outside:
  492. %%% bagof(X,G) -> R:[] | (G,R<<-[X|R],fail ; true).
  493.  
  494. %%% This version seems to be completely clean:
  495. %%% non_strict(bagof)?
  496. %%% bagof(X,G) -> R:[] | (evalin(G),R<<-[evalin(X)|R],fail ; R<-copy_term(R)).
  497.  
  498. %%% New version using persistent terms:     RM: Feb 16 1993 
  499. %%% The old version had a complexity of O(n2), now down to O(n).
  500.  
  501. non_strict(bagof)?
  502. bagof(X,G) -> N |
  503.         L<<-[],
  504.         ((evalin(G),                         % Prove G
  505.           L<<-[evalin(X)|copy_pointer(L)],   % Record the binding of X
  506.           fail)                              % Force back-tracking on G
  507.         ;
  508.          (N<-copy_term(L))).                 % Copy the resulting global term
  509.                                              % back onto the stack.
  510.  
  511.  
  512. %%% Best solution to a goal by some relation:
  513.  
  514. non_strict(bestof)?
  515. bestof(X,R,G) -> N |
  516.        L<<-first_value,
  517.        (evalin(G),                         % Prove G
  518.     cond(L:==first_value,              % Record the binding of X
  519.          L<<-evalin(X),
  520.          cond(R(X,L),                  % Compare to last value
  521.           L<<-evalin(X),
  522.           succeed)),
  523.     fail                               % Force back-tracking on G
  524.     ;
  525.         N<-copy_term(L)).                  % Copy the resulting global term
  526.                                            % back onto the stack.
  527.  
  528.  
  529. % Reducing a monoidal binary operator over a list:
  530. reduce(F,E,[H|T]) -> F(H,reduce(F,E,T)).
  531. reduce(F,E,[]) -> E.
  532.  
  533. % Mapping a function over a list:
  534. map(F,[])->[].
  535. map(F,[H|T])->[F(H)|map(F,T)].
  536.  
  537. % Mapping a unary relation over a list:
  538. maprel(P,[H|T]) :- !,root_sort(P) & @(H),maprel(P,T).
  539. maprel(P,[]).
  540.  
  541.  
  542.  
  543. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  544. %
  545. % Basic Lists Manipulation
  546. %
  547. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  548.  
  549. append([],L:list)->L.
  550. append([H|T],L:list)->[H|append(T,L)].
  551.  
  552. length([])->0.
  553. length([H|T])->1+length(T).
  554.  
  555. member(X,[X|_]).
  556. member(X,[_|L]) :- member(X,L).
  557.  
  558. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  559. %
  560. % Arithmetic
  561. %
  562. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  563.  
  564. A^N:int -> cond(N<0,1/pwr(A,-N),pwr(A,N)).
  565.  
  566. pwr(A,0) -> 1.
  567. pwr(A,1) -> A.
  568. % PVR 24.2.94
  569. pwr(A,N) -> cond((N /\ 1)=:=0, X*X, X*X*A) | X=pwr(A,N>>1).
  570. % pwr(A,N) -> A*pwr(A,(N-1)).
  571.  
  572. abs(R) -> cond(R<0,-R,R).
  573. max(A,B) -> cond(A>B,A,B).
  574. min(A,B) -> cond(A>B,B,A).
  575.  
  576.  
  577. % Generate a unique integer for each call to genint
  578. persistent(genint_counter)?
  579. genint_counter<<-0?
  580. genint -> copy_term(genint_counter) | genint_counter<<-genint_counter+1.
  581.  
  582.  
  583. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  584. %
  585. % String Manipulation
  586. %
  587. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  588.  
  589. "" $== "" -> true.
  590. S1:string $== S2:string ->
  591.     (asc(S1)=:=asc(S2)) and
  592.     lenstreq(substr(S1,2,L1:strlen(S1)),substr(S2,2,L2:strlen(S2)),L1,L2).
  593.  
  594. lenstreq("","",_,_) -> true.
  595. lenstreq(S1,S2,L1,L2) ->
  596.     L1=:=L2 and L1>0 and (asc(S1)=:=asc(S2)) and
  597.     lenstreq(substr(S1,2,LL1:(L1-1)),substr(S2,2,LL2:(L2-1)),LL1,LL2).
  598.  
  599. "" $=< string -> true.
  600. string $=< "" -> false.
  601. S1:string $=< S2:string ->
  602.     (C1:asc(S1)<C2:asc(S2))
  603.     or
  604.     (C1=:=C2 and lenstrle(substr(S1,2,L1:strlen(S1)),
  605.                               substr(S2,2,L2:strlen(S2)),
  606.                               L1,L2)).
  607.  
  608. lenstrle("",string,_,_) -> true.
  609. lenstrle(string,"",_,_) -> false.
  610. lenstrle(S1,S2,L1,L2) ->
  611.     (C1:asc(S1) < C2:asc(S2))
  612.     or
  613.     (C1=:=C2 and lenstrle(substr(S1,2,LL1:(L1-1)),
  614.                               substr(S2,2,LL2:(L2-1)),
  615.                               LL1,LL2)).
  616.  
  617. S1:string $< S2:string -> S1$=<S2 and not(S1$==S2).
  618. S1:string $> S2:string -> not(S1$=<S2).
  619. S1:string $>= S2:string -> not(S1$=<S2) or S1$==S2.
  620. S1:string $\== S2:string -> not(S1$==S2).
  621.  
  622. %%% Convert "any" psi-term to a string.
  623. %%% This converts strings to themselves, integers to a string giving their
  624. %%% value, and other psi-terms to a string giving their print name.
  625.  
  626. str(X) -> cond(is_value(X),strval(X),psi2str(X)).
  627.  
  628. strval(S:string) -> S.
  629. strval(N:int) -> int2str(N).
  630.  
  631.  
  632. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  633. %
  634. %  Declarations of support of modules      RM: Jan  6 1993
  635. %
  636. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  637.  
  638. module(N) :-
  639.     N:<string,
  640.         !,
  641.     set_module(N),
  642.     setq(open_modules,[]),
  643.     setq(inherited_modules,[]),
  644.     open("syntax"),
  645.     open("built_ins"),
  646.     open("x").
  647.                         
  648. module(N) :-                                     % PVR 13.9.93
  649.     write_err("*** Error: module name '"),writeq_err(N),
  650.     write_err("' should be a string"),
  651.     nl_err.
  652.  
  653. X:open :- open_list(features(X), X).
  654.  
  655. open_list([]) :- !.
  656. open_list([F|FL], X) :- open_one(X.F), open_list(FL, X).
  657.  
  658. open_one(N:string) :- !,
  659.     open_module(N),
  660.     setq(open_modules,[N|open_modules]).
  661.  
  662. open_one(N) :-                                   % PVR 13.9.93
  663.     write_err("*** Error: module argument '"),writeq_err(N),
  664.     write_err("' of open should be a string"),
  665.     nl_err.
  666.  
  667.  
  668. display_module_status :-
  669.     write("%%%%%%%%%%%%%%%%%%%%"),nl,
  670.     write("%%% current module: ",current_module),nl,
  671.     write("%%% open modules: ",open_modules),nl,
  672.     write("%%% inherited modules: ",inherited_modules),nl,
  673.     write("%%%%%%%%%%%%%%%%%%%%"),nl.
  674.  
  675.  
  676. public(import_clauses)?
  677. non_strict(import_clauses)?
  678.  
  679. import_clauses(for => Sort,
  680.                replacing => RepList) :-
  681.  
  682.     (
  683.         is_function(Sort),
  684.         (Connect = ->) ;
  685.         
  686.         is_predicate(Sort),
  687.         (Connect = :-) ;
  688.         
  689.         write_err("*** Import: ",Sort," is not a predicate or function"),
  690.         nl_err,
  691.         fail
  692.         ),
  693.     ! ,
  694.     get_and_replace(Sort,Connect,RepList);
  695.     succeed.
  696.  
  697.  
  698. get_and_replace(Sort,Connect,RepList) :-
  699.     Connect=@(Sort,Body),
  700.     clause(Connect),
  701.     %%    write("Importing clause:"),
  702.     %%    nl,
  703.     %%    writeq(Connect),
  704.     %%    nl,
  705.     replace(Connect,RepList),
  706.     %%    write("as clause:"),
  707.     %%    nl,
  708.     %%    writeq(Connect),
  709.     %%    nl,
  710.     %%    nl,
  711.     R=root_sort(Connect.1),
  712.     dynamic(R),
  713.     assert(Connect),
  714.     fail.
  715.  
  716.  
  717. replace(Connect,[]) :- ! .
  718. replace(Connect,[(A,B)|T]) :-
  719.     substitute(A,B,Connect),
  720.     replace(Connect,T).
  721.  
  722.  
  723. %%% PVR 13.9.93
  724. non_strict(import)?
  725. X:import :-
  726.     load&strip(X),
  727.     import_list(features(X), X).
  728.  
  729. import_list([]) :- !.
  730. import_list([F|FL], X) :- import_one(X.F), import_list(FL,X).
  731.  
  732. import_one(X) :-
  733.     Module =remove_path(X),
  734.     (open(Module),!;succeed).
  735.  
  736. remove_path(File) -> remove_path_loop(File,strlen(File)).
  737.  
  738. remove_path_loop(File,0) -> File.
  739. remove_path_loop(File,L) -> cond(L<1,
  740.                  File,
  741.                  cond(substr(File,L,1) $== "/",
  742.                       substr(File,L+1,strlen(File)-L),
  743.                       remove_path_loop(File,L-1))).
  744.  
  745. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  746. %
  747. %  Compatibility with older versions 
  748. %
  749. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  750.  
  751. project(A,B) -> B.A.
  752.  
  753.  
  754. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  755. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  756. %%
  757. %% Obsolete
  758. %%
  759. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  760. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  761.  
  762. %%%public('\+','$==','$=<', c_op,append_file, built_in, day, encode,
  763. %%%       freeze,functor,genint_counter, hour, inf_loop, kind, lenstreq,
  764. %%%       lenstrle,c_listing,  minute, month, precedence, second, stream,
  765. %%%       warning, 
  766. %%%       weekday, where, set_module, open_module,xf, xfx, xfy, yf, yfx,
  767. %%%       new_block, block_struct, block_valueintset,block_valuerealset,
  768. %%%       block_valueintget,block_valuerealget,block_subblockset,
  769. %%%       block_subblockget,is_block,same_block, block_privateintget,
  770. %%%       block_privateintset,block_privaterealget,block_privaterealset,
  771. %%%       block_wake,
  772. %%%       c_xareallzero, c_xareallpos, c_xareallneg,
  773. %%%       c_xelm, c_xadd_basic, c_xclean_linear, c_xobjective,
  774. %%%       syntax
  775. %%%      ) ?
  776.  
  777. %%%c_op(1200,fx,block_struct)?    % RM 20 Jan 93
  778.  
  779.  
  780. %%%% To force a type encoding.
  781. %%%encode?
  782.  
  783. %%% non_strict(global)?  %% RM: Apr  8 1993 
  784.  
  785. %%%non_strict(assert)?  %% 17.9
  786. %%%non_strict(asserta)?  %% 17.9
  787. %%%non_strict(clause)?  %% 17.9
  788. %%%non_strict(retract)?  %% 17.9
  789. %%%non_strict(cond)? %% 24.8
  790.  
  791. %%%A ## B -> A.B.
  792.  
  793.  
  794. %%%A poor man's global variable update:
  795. %%%set(X,V) :- retract((X->@)), !, assert((X->V)).
  796. %%%set(X,V) :- dynamic(X), assert((X->V)).
  797.  
  798. %%%This has become a C built-in:
  799. %%%non_strict(setq)?
  800. %%%setq(X,V) :- Value = eval(V), retract((X->@)), !, assert((X->Value)).
  801. %%%setq(X,V) :- dynamic(X), Value = eval(V), assert((X->Value)).
  802.  
  803.  
  804. %%%These are removed since their functionality is subsumed by that of
  805. %%%unification.
  806. %%%Lisp pseudo-compatibility.
  807. %%%nil -> [].
  808. %%%cons(H,T) -> [H|T].
  809. %%%car([H|T]) -> H.
  810. %%%cdr([H|T]) -> T.
  811.  
  812. %%%Repeat.
  813. %%%repeat.
  814. %%%repeat :- repeat.
  815.  
  816. %%%Handy for functional programming.
  817. %%%where -> @.
  818.  
  819. %%%Logic functions (some are C built-ins).
  820.  
  821. %%%and(false,bool) -> false.
  822. %%%and(bool,false) -> false.
  823. %%%and(true,true) -> true.
  824.  
  825. %%%or(true,bool) -> true.
  826. %%%or(bool,true) -> true.
  827. %%%or(false,false) -> false.
  828.  
  829. % PVR 10.2.94
  830. %%%not(true) -> false.
  831. %%%not(false) -> true.
  832. %%%xor(true,false) -> true.
  833. %%%xor(false,true) -> true.
  834. %%%xor(bool,bool) -> false.
  835.  
  836. %%%dynamic(genint_counter)?
  837. %%%genint_counter -> 0.
  838. %%%genint -> N:genint_counter | setq(genint_counter,N+1).
  839.  
  840. %%%This works but results in several genints in the same expression
  841. %%%all getting the same resulting value:
  842. %%%persistent(genint_counter)?
  843. %%%genint_counter<<-0?
  844. %%%genint -> N:genint_counter | genint_counter<<-N+1.
  845.  
  846. %%%This is now a C built-in:
  847. %%%int2str(N:int) -> cond(N<0,
  848. %%%                       strcon("-",num(-N)),
  849. %%%                       num(N)).
  850.  
  851. %%%num(N) -> cond(N<10,
  852. %%%                   psi2str(chr(N+48)),
  853. %%%                   strcon(num(Q:floor(N/10)),num(N-Q*10))).
  854.  
  855. %%%This is the same speed:
  856. %%%num2str(0) -> "0".
  857. %%%num2str(1) -> "1".
  858. %%%num2str(2) -> "2".
  859. %%%num2str(3) -> "3".
  860. %%%num2str(4) -> "4".
  861. %%%num2str(5) -> "5".
  862. %%%num2str(6) -> "6".
  863. %%%num2str(7) -> "7".
  864. %%%num2str(8) -> "8".
  865. %%%num2str(9) -> "9".
  866. %%%num2str(N:int) ->
  867. %%%        cond(N<0,
  868. %%%             strcon("-",num2str(-N)),
  869. %%%             strcon(num2str(Q:floor(N/10)),num2str(N-Q*10))).
  870.  
  871. %%% nl :- put(10).
  872. %%% nl_err :- put_err(10).
  873. %%% Infinite loop.
  874. %%% inf_loop -> inf_loop.
  875.  
  876. %%%copy_rules(Symbol,SourceModule,NewName) :-
  877. %%%    load_module(SourceModule),
  878. %%%    var(NewName),
  879. %%%    copy_rules(Symbol,SourceModule,NewName).
  880. load_path->'~lib' | '~tools'.
  881.