Artifact 701a501d8aaf1d6c9df5f25829af1a44a02d05fe512c453221a11c2de21ca626:
- Executable file
r38/packages/rlisp/superv.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 15237) [annotate] [blame] [check-ins using] [more...]
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;