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;