reduce-historical/r38/packages/redlog/rlcont.red

% ----------------------------------------------------------------------
% $Id: rlcont.red,v 1.5 1999/03/23 09:23:56 dolzmann Exp $
% ----------------------------------------------------------------------
% Copyright (c) 1995-1999 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% $Log: rlcont.red,v $
% Revision 1.5  1999/03/23 09:23:56  dolzmann
% Changed copyright information.
%
% Revision 1.4  1999/03/22 12:41:42  dolzmann
% Reimplemented procedure rl_set for calling the exit functions of the
% context before calling the enter function of the new context. The old
% version could not handle the calling sequence rlset(dvfsf,5);
% rlset(dvfsf) correctly.
%
% Revision 1.3  1996/10/07 12:03:55  sturm
% Added fluids for CVS and copyright information.
%
% Revision 1.2  1996/09/05 11:16:59  dolzmann
% Added procedures rl_serviadd and rl_bbiadd.
%
% Revision 1.1  1996/03/22 12:18:29  sturm
% Moved and split.
%
% ----------------------------------------------------------------------
lisp <<
   fluid '(rl_cont_rcsid!* rl_cont_copyright!*);
   rl_cont_rcsid!* :=
      "$Id: rlcont.red,v 1.5 1999/03/23 09:23:56 dolzmann Exp $";
   rl_cont_copyright!* := "Copyright (c) 1995-1999 by A. Dolzmann and T. Sturm"
>>;

module rlcont;
% Reduce logic component context selection. Submodule of [redlog].

put('rlset,'psopfn,'rl_set!$);

procedure rl_set!$(argl);
   begin scalar w;
      if argl then <<
      	 w := reval car argl;
      	 if eqcar(w,'list) then <<
	    if cdr argl then rederr "too many arguments";
	    argl := cdr w
      	 >> else
	    argl := w . for each x in cdr argl collect reval x
      >>;
      return 'list . rl_set argl
   end;

procedure rl_set(argl);
   begin scalar cntxt,w;
      cntxt := if rl_cid!* then rl_cid!* . rl_argl!* else nil;
      if null argl then return cntxt;
      if rl_cid!* then rl_exit();
      w := rl_enter(argl);
      if w then <<
	 if cntxt then rl_enter(cntxt);
	 rederr w
      >>;
      return cntxt;
   end;

procedure rl_exit();
   begin scalar w;
      w := for each pair in get(rl_cid!*,'rl_cswitches) collect
	 car pair . rl_onp car pair;
      put(rl_cid!*,'rl_cswitches,w);
      for each pair in rl_ocswitches!* do
	 rl_vonoff(car pair,cdr pair);
      if (w := get(rl_cid!*,'rl_exit)) then
	 apply(w,nil);
   end;

procedure rl_enter(argl);
   begin scalar w,enter,cid;
      cid := car argl;
      argl := cdr argl;
      w := errorset({'load!-package,mkquote(cid)},nil,!*backtrace)
	 where !*msg=nil;
      if errorp w then
	 return {"switching to context",cid,"failed"};
      if not flagp(cid,'rl_package) then
	 return {cid,"is not an rl package"};
      enter := get(cid,'rl_enter);
      if null enter and argl then <<
	 lprim {"extra",ioto_cplu("argument",cddr argl),"ignored"};
	 argl := nil;
      >>;
      if enter then <<
      	 w := apply(enter,{argl});
      	 if not car w then
	    return cdr w
      	 else
	    argl := cdr w
      >>;
      rl_cid!* := cid;
      rl_argl!* := argl;
      rl_ocswitches!* := nil;
      for each pair in get(rl_cid!*,'rl_cswitches) do <<
	 rl_ocswitches!* := (car pair . rl_onp car pair) . rl_ocswitches!*;
	 rl_vonoff(car pair,cdr pair)
      >>;
      rl_ocswitches!* := reversip rl_ocswitches!*;
      rl_updcache();
      rmsubs();
      return nil
   end;

procedure rl_onp(s);
   eval intern compress append(explode '!*,explode s);

procedure rl_vonoff(sw,v);
   % Verbose [onoff]. [sw] is a switch; [v] is Bool.
   if v neq rl_onp sw then <<
      lprim {"turned",if rl_onp sw then "off" else "on","switch",sw};
      onoff(sw,v)
   >>;

procedure rl_updcache();
   % Update cache.
   <<
      for each bbv in rl_bbl!* do
	 set(bbv,nil);
      for each x in get(rl_cid!*,'rl_params) do
      	 set(car x,cdr x);
      for each sv in rl_servl!* do
	 set(sv,nil);
      for each x in get(rl_cid!*,'rl_services) do
      	 set(car x,cdr x)
   >>;

procedure rl_serviadd(tag,name,value);
   rl_sbiadd(tag,'rl_services,name,value);

procedure rl_bbiadd(tag,name,value);
   rl_sbiadd(tag,'rl_params,name,value);

procedure rl_sbiadd(tag,prp,name,value);
   begin scalar w,al,old;
      if not flagp(tag,'rl_package) then
	 rederr {tag,"is not a context identifier"};
      al := get(tag,prp);
      w := atsoc(name,al);
      if null w then <<
	 al := (name . value) . al;
      	 put(tag,prp,al);
	 return nil
      >>;
      old := cdr w;
      cdr w := value;
      lprim {"Changed definition of",name};
      put(tag,prp,al);
      return old
   end;

(if w then
   rl_deflang!* := {intern compress reversip cdr reversip cdr explode w})
      where w=getenv("RLDEFLANG");
if rl_deflang!* then rl_set rl_deflang!*;

endmodule;  % [rlcont]

end;  % of file