reduce-historical/r38/packages/rlisp/superv.red

module superv; % REDUCE supervisory functions.

% Author: Anthony C. Hearn.

% Modified by: Jed B. Marti, Francis J. Wright.

% Copyright (c) 1998 Anthony C. Hearn.  All rights reserved.

fluid '(!*debug
	!*defn
	!*demo
	!*echo
	!*errcont
	!*int
	!*lisp!_hook
	!*mode
	!*output
	!*pret
	!*reduce4
	!*slin
	!*time
	dfprint!*
	errmsg!*
	lispsystem!*
	loopdelimslist!*
	lreadfn!*
	newrule!*
	semic!*
	tslin!*);

global '(!$eof!$
	 !*byeflag!*
	 !*extraecho
	 !*lessspace
	 !*micro!-version
	 !*nosave!*
	 !*strind
	 !*struct
	 cloc!*
	 cmsg!*
	 crbuf!*
	 crbuflis!*
	 crbuf1!*
	 curline!*
	 cursym!*
	 eof!*
	 erfg!*
	 forkeywords!*
	 ifl!*
	 ipl!*
	 initl!*
	 inputbuflis!*
	 key!*
	 ofl!*
	 opl!*
	 ogctime!*
	 otime!*
	 program!*
	 programl!*
	 promptexp!*
	 repeatkeywords!*
	 resultbuflis!*
	 st!*
	 statcounter
	 symchar!*
	 tok!*
	 ttype!*
	 whilekeywords!*
	 ws);

!*output := t;
eof!* := 0;
initl!* := '(fname!* outl!*);
statcounter := 0;

% The true REDUCE supervisory function is BEGIN, again defined in the
% system dependent part of this program.  However, most of the work is
% done by BEGIN1, which is called by BEGIN for every file encountered
% on input;

symbolic procedure errorp u;
   %returns true if U is an ERRORSET error format;
   atom u or cdr u;

symbolic procedure printprompt u;
   %Prints the prompt expression for input;
   progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*);

symbolic procedure setcloc!*;
   % Used to set for file input a global variable CLOC!* to dotted pair
   % of file name and dotted pair of line and page being read.
   % Currently a place holder for system specific function, since not
   % supported in Standard LISP.  CLOC!* is used in the INTER and RCREF
   % modules.
   cloc!* := if null ifl!* then nil else car ifl!* . (1 . curline!*);

symbolic procedure commdemo;
   begin scalar echo,x,y,z,!*demo;
      echo := !*echo;
      !*echo := nil;
      x := ifl!*;
      terpri();
      rds nil;
      y:=readch();
      if null seprp y then
	     % Read command line from terminal.
	  begin scalar crbuf,crbuf1,crchar,ifl;
		crbuf := crbuf!*;
		crbuf!* := nil;
		crbuf1 := crbuf1!*;
		crbuf1!* := list y;
		crchar := crchar!*;
		crchar!* := '! ;
		ifl := ifl!*;
		ifl!* := nil;
		z := errorset!*('(command),t);
		z := if errorp z then '(algebraic(aeval 0))
		     else car z;
		     % eat rest of line quietly.
	     q: y  := readch();
		if y neq !$eol!$ then go to q;
		rds cadr x;
		crbuf!* := crbuf;
		crbuf1!* := crbuf1;
		crchar!* := crchar;
		ifl!* := ifl;
		!*echo := echo;
	  end
       else
	     % Read command from current input.
	  progn(rds cadr x, !*echo := echo, z := command());
       return z
   end;

symbolic procedure command1;
   % Innermost part of COMMAND. Can be used as hook to editor if needed.
   begin
      scan();
      setcloc!*();
      key!* := cursym!*;
      return xread1 nil
   end;

symbolic procedure command;
   begin scalar errmsg!*,loopdelimslist!*,mode,x,y;
      if !*demo and ifl!* then return commdemo()
       else if null !*slin or !*reduce4 then go to a;
      % Note key!* not set in this case.
      setcloc!*();
      y := if lreadfn!* then lispapply(lreadfn!*,nil) else read();
      go to b;
   a: crchar!* := readch1();  % Initialize crchar!*.
      if crchar!* = !$eol!$ then go to a;
      % Parse input.
      y := command1();
   b: if !*reduce4 then go to c
       else if !*struct then y := structchk y;
      if !*pret and (atom y or null (car y memq '(in out shut)))
	then if null y and cursym!* eq 'end then rprint 'end
	      else progn(rprint y,terpri());
      if !*slin then return list('symbolic,y);
      x := form y;
      % Determine target mode.
      if flagp(key!*,'modefn) then mode := key!*
       else if null atom x % and null !*micro!-version
	 and null(car x eq 'quote)
	 and (null(idp car x
		 and (flagp(car x,'nochange)
		       or flagp(car x,'intfn)
		       or car x eq 'list))
	   or car x memq '(setq setel setf)
		   and eqcar(caddr x,'quote))
	then mode := 'symbolic
       else mode := !*mode;
      return list(mode,convertmode1(x,nil,'symbolic,mode));
   c: if !*debug then progn(prin2 "Parse: ",prettyprint y);
    % Mode analyze input.
      if key!* eq '!*semicol!* then go to a;  % Should be a comment.
      if null !*reduce4 then y := form y else y := n!_form y;
%     y := n!_form y;
      if !*debug then progn(terpri(),prin2 "Form: ",prettyprint y);
      return y
   end;

symbolic procedure update!_prompt;
   begin
      statcounter := statcounter + 1;
      promptexp!* :=
	 compress('!! . append(explode statcounter,
		     explode if null symchar!* or !*mode eq 'algebraic
			       then '!:!  else '!*! ));
      setpchar promptexp!*
   end;

symbolic procedure begin1;
   begin scalar parserr,result,x;
      otime!* := time();
      % The next line is that way for bootstrapping purposes.
      if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0;
      cursym!* := '!*semicol!*;
  a:  if terminalp()
	then progn((if !*nosave!* or statcounter=0 then nil
		     else add2buflis()),
		   update!_prompt());
      !*nosave!* := nil;
      !*strind := 0;     % Used by some versions of input editor.
      parserr := nil;
      if !*time then lispeval '(showtime);   % Since a STAT.
      if !*output and null ofl!* and terminalp() and null !*defn
	 and null !*lessspace
	then terpri();
      if tslin!*
	then progn(!*slin := car tslin!*,
		   lreadfn!* := cdr tslin!*,
		   tslin!* := nil);
      x := initl!*;
 b:   if x then progn(sinitl car x, x := cdr x, go to b);
      remflag(forkeywords!*,'delim);
      remflag(repeatkeywords!*,'delim);
      remflag( whilekeywords!*,'delim);
      if !*int then erfg!* := nil;   % To make editing work properly.
      if cursym!* eq 'end then progn(comm1 'end, return nil)
       % Note that key* was set from *previous* command in following.
       else if terminalp() and null(key!* eq 'ed)
	then printprompt promptexp!*;
      x := errorset!*('(command),t);
      condterpri();
      if errorp x then go to err1;
      x := car x;
      if car x eq 'symbolic and eqcar(cadr x,'xmodule)
	then result := xmodloop eval cadr x
       else result := begin11 x;
      if null result then go to a
       else if result eq 'end then return nil
       else if result eq 'err2 then go to err2
       else if result eq 'err3 then go to err3;
  c:  if crbuf1!* then
	progn(lprim "Closing object improperly removed. Redo edit.",
		crbuf1!* := nil, return nil)
	else if eof!*>4
	 then progn(lprim "End-of-file read", return lispeval '(bye))
       else if terminalp()
	then progn(crbuf!* := nil,!*nosave!* := t,go to a)
       else return nil;
  err1:
      if eofcheck() or eof!*>0 then go to c
       else if x="BEGIN invalid" then go to a;
      parserr := t;
  err2:
      resetparser();  % In case parser needs to be modified.
  err3:
      erfg!* := t;
      if null !*int and null !*errcont
	then progn(!*defn := t,
		   !*echo := t,
		   (if null cmsg!*
		      then lprie "Continuing with parsing only ..."),
		   cmsg!* := t)
       else if null !*errcont
	then progn(result := pause1 parserr,
		   (if result then return null lispeval result),
		   erfg!* := nil)
       else erfg!* := nil;
      go to a
   end;

% Newrule!* is initialized in the following function, since it is not
% always reinitialized by the rule code.

symbolic procedure begin11 x;
   begin scalar errmsg!*,mode,result,newrule!*;
      if cursym!* eq 'end
	 then if terminalp() and null !*lisp!_hook
		then progn(cursym!* := '!*semicol!*, !*nosave!* := t,
			   return nil)
	       else progn(comm1 'end, return 'end)
       else if eqcar((if !*reduce4 then x else cadr x),'retry)
	then if programl!* then x := programl!*
	      else progn(lprim "No previous expression",return nil);
      if null !*reduce4 then progn(mode := car x,x := cadr x);
      program!* := x;    % Keep it around for debugging purposes.
      if eofcheck() then return 'c else eof!* := 0;
      add2inputbuf(x,if !*reduce4 then nil else mode);
      if null atom x
	  and car x memq '(bye quit)
	then if getd 'bye
	       then progn(lispeval x, !*nosave!* := t, return nil)
	      else progn(!*byeflag!* := t, return nil)
       else if null !*reduce4 and eqcar(x,'ed)
	then progn((if getd 'cedit and terminalp()
		      then cedit cdr x
		     else lprim "ED not supported"),
		   !*nosave!* := t, return nil)
       else if !*defn
	then if erfg!* then return nil
	      else if null flagp(key!*,'ignore)
		and null eqcar(x,'quote)
	       then progn((if x then dfprint x else nil),
			  if null flagp(key!*,'eval) then return nil);
      if !*output and ifl!* and !*echo and null !*lessspace
	then terpri();
      result := errorset!*(x,t);
      if errorp result or erfg!*
	then progn(programl!* := list(mode,x),return 'err2)
       else if !*defn then return nil;
      if null !*reduce4
	then if null(mode eq 'symbolic) then x := getsetvars x else nil
       else progn(result := car result,
		  (if null result then result := mkobject(nil,'noval)),
		  mode := type result,
		  result := value result);
      add2resultbuf((if null !*reduce4 then car result else result),
		    mode);
      if null !*output then return nil
       else if null(semic!* eq '!$)
	then if !*reduce4 then (begin
		   terpri();
		   if mode eq 'noval then return nil
		    else if !*debug then prin2t "Value:";
		   rapply1('print,list list(mode,result))
		 end)
       else if mode eq 'symbolic
	      then if null car result and null(!*mode eq 'symbolic)
		     then nil
	      else begin
		  terpri();
		  result:=
		       errorset!*(list('print,mkquote car result),t)
		    end
       else if car result
	then result := errorset!*(list('assgnpri,mkquote car result,
				       (if x then 'list . x else nil),
				       mkquote 'only),
				  t);
      if null !*reduce4
	then return if errorp result then 'err3 else nil
       else if null(!*mode eq 'noval) % and !*debug
	then progn(terpri(), prin2 "of type: ", print mode);
      return nil
   end;

symbolic procedure getsetvarlis u;
   if null u then nil
    else if atom u then errach list("getsetvarlis",u)
    else if atom car u then car u . getsetvarlis cdr u
    else if caar u memq '(setel setk)   % setk0.
     then getsetvarlis cadar u . getsetvarlis cdr u
    else if caar u eq 'setq then mkquote cadar u . getsetvarlis cdr u
    else car u . getsetvarlis cdr u;

symbolic procedure getsetvars u;
   if atom u then nil
    else if car u memq '(setel setk)   % setk0.
     then getsetvarlis cadr u . getsetvars caddr u
    else if car u eq 'setq then mkquote cadr u . getsetvars caddr u
    else nil;

flag ('(deflist flag fluid global remflag remprop unfluid),'eval);

symbolic procedure close!-input!-files;
   % Close all input files currently open;
   begin
      if ifl!* then progn(rds nil,ifl!* := nil);
  aa: if null ipl!* then return nil;
      close cadar ipl!*;
      ipl!* := cdr ipl!*;
      go to aa
   end;

symbolic procedure close!-output!-files;
   % Close all output files currently open;
   begin
      if ofl!* then progn(wrs nil,ofl!* := nil);
  aa: if null opl!* then return nil;
      close cdar opl!*;
      opl!* := cdr opl!*;
      go to aa
   end;

symbolic procedure add2buflis;
   begin
      if null crbuf!* then return nil;
      crbuf!* := reversip crbuf!*;   %put in right order;
   a: if crbuf!* and seprp car crbuf!*
	then progn(crbuf!* := cdr crbuf!*, go to a);
      crbuflis!* := (statcounter . crbuf!*) . crbuflis!*;
      crbuf!* := nil
   end;

symbolic procedure add2inputbuf(u,mode);
   begin
      if null terminalp() or !*nosave!* then return nil;
      inputbuflis!* := list(statcounter,mode,u) . inputbuflis!*
   end;

symbolic procedure add2resultbuf(u,mode);
   begin
      if mode eq 'symbolic
       or (null u and (null !*reduce4 or null(mode eq 'empty!_list)))
       or !*nosave!* then return nil;
      if !*reduce4 then putobject('ws,u,mode) else ws := u;
      if terminalp()
	then resultbuflis!* := (statcounter . u) . resultbuflis!*
   end;

symbolic procedure condterpri;
   !*output and !*echo and !*extraecho and (null !*int or ifl!*)
	and null !*defn and null !*demo and terpri();

symbolic procedure eofcheck;
   % true if an end-of-file has been read in current input sequence;
   program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1);

symbolic procedure resetparser;
   %resets the parser after an error;
   if null !*slin then comm1 t;

symbolic procedure terminalp;
   %true if input is coming from an interactive terminal;
   !*int and null ifl!*;

symbolic procedure dfprint u;
   % Looks for special action on a form, otherwise prettyprints it.
   if dfprint!* then lispapply(dfprint!*,list u)
    else if cmsg!* then nil
    else if null eqcar(u,'progn) then prettyprint u
    else begin
	    a:  u := cdr u;
		if null u then return nil;
		dfprint car u;
		go to a
	 end;

remprop('showtime,'lose);  % Temporary.

symbolic procedure showtime;
   begin scalar x,y;
      x := otime!*;
      otime!* := time();
      x := otime!* - x;
      y := ogctime!*;
      ogctime!* := gctime();
      y := ogctime!* - y;
      if 'psl memq lispsystem!* then x := x - y;
      terpri();
      prin2 "Time: "; prin2 x; prin2 " ms";
      if null(y=0)
	then progn(prin2 "  plus GC time: ", prin2 y, prin2 " ms");
      terpri();
      return if !*reduce4 then mknovalobj() else nil
   end;

symbolic procedure sinitl u;
   set(u,eval get(u,'initl));

symbolic procedure read!-init!-file name;
  % Read a resource file in REDUCE syntax. Quiet input.
  % Algebraic mode is used unless rlisp88 is on.
  % Look for file in home directory. If no home directory
  % is defined, use the current directory.
  begin scalar !*errcont,!*int,base,fname,oldmode,x,y;
   base := getenv "home" or getenv "HOME" or
	   ((x := getenv "HOMEDRIVE") and (y := getenv "HOMEPATH")
	      and concat2(x,y)) or ".";
   if not(car reversip explode2 base eq '!/)
     then base := concat2(base,"/"); % FJW
   fname := if filep(x := concat2(base,concat2(".", % FJW
						concat2(name,"rc"))))
	       then x
	     else if filep(x := concat2(base,concat2(name,".rc"))) % FJW
	      then x
	     else if filep
		     (x := concat2(getenv "HOME",concat2(name,".INI")))
	       then x; % for (Open) VMS
   if null fname then return nil
    else if !*mode neq 'algebraic and null !*rlisp88
     then progn(oldmode := !*mode, !*mode := 'algebraic);
   x := errorset(list('in!_list1,fname,nil),nil,nil);
   if errorp x or erfg!* then
     progn(terpri(),
	   prin2 "***** Error processing resource file ",
	   prin2t fname);
   close!-input!-files();
   erfg!*:= cmsg!* := !*defn := nil;
   if oldmode then !*mode := oldmode;
   terpri();
   statcounter := 0
  end;

endmodule;

end;