File psl-1983/3-1/util/20/exec.red artifact afdb90b3c5 part of check-in 955d0a90a7


%
% EXEC.RED -   Simple TOPS20 Interfaces, "EXEC Fork", etc
% 
% Author:      Martin L. Griss and Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        8 March 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.UTIL.20>EXEC.RED.6, 25-Mar-83 14:32:06, Edit by BARBOUR
%  Updated clocktimedate  to return the string with nulls stripped off
% Edit by Cris Perdue, 23 Mar 1983 1453-PST
% Changed from clocktime to ClockTimeDate
% Edit by Cris Perdue, 21 Mar 1983 1003-PST
% Added Kessler's clocktime and getloadaverage from CLOCKTIME.RED
%  <PERDUE>EXEC.RED.2, 21-Mar-83 11:02:46, Edit by PERDUE
%  Put JSYS names in const(<name>) form to match current JSYS module
%  <PSL.UTIL>EXEC.RED.5, 24-May-82 13:01:50, Edit by BENSON
%  Changed <EDITORS> and <SUBSYS> to SYS: in filenames
%/ Changed FILNAM->FileName, due to GLOBAL conflict
%/ Changed JSYS calls, so LIST(..) rather than '(..) used
%/ Changed for V3:JSYS
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Simple JSYS interfaces

CompileTime load(Syslisp, Jsys, Monsym);
imports '(JSYS);

GLOBAL '(ForkNAMES!* EXECFork EMacsFork MMFork);

Lisp procedure GetOLDJfn FileName; %. test If file OLD and return Jfn
   Begin scalar Jfn; 
      If NULL StringP FileName then return NIL; 
      Jfn := JSYS1(Bits(2,3,17),FileName,0,0,const(jsGTJfn)); 
	 % OLD!MSG!SHORT
      If Jfn<0 then return NIL; 
      return Jfn
   END;

Lisp procedure GetNEWJfn FileName; 	 %. test If file NEW and return Jfn
   Begin scalar Jfn; 
      If NULL StringP FileName then return NIL; 
      Jfn := JSYS1(Bits(0,1,3,17),FileName,0,0,const(jsGTJfn)); 
	% GEN!NEW!MSG!SHORT
      If Jfn<0 then return NIL; 
      return Jfn
   END;

Lisp procedure RELJfn Jfn;	 %. return Jfn to system
 JSYS0(Jfn,0,0,0,const(jsRLJfn));

Lisp procedure OPENOLDJfn Jfn;	 %. OPEN to READ
 JSYS0(Jfn,Bits( (7 . 5),19),0,0,const(jsOPENF));

Lisp procedure OPENNEWJfn Jfn;	 %. Open to WRITE
 JSYS0(Jfn,Bits( (7 . 5),20),0,0,const(jsOPENF));

Lisp procedure GetFork Jfn; 	 %. Create Fork, READ File on Jfn
   Begin scalar FH; 
      FH := JSYS1(Bits(1),0,0,0,const(jsCFork)); 
      JSYS0(Xword(FH ,Jfn),0,0,0,const(jsGet)); 
      return FH
   END;

Lisp procedure STARTFork FH;	 %. Start (Restart) a Fork
  JSYS0(FH, 0,0,0,const(jsSFRKV));

Lisp procedure WAITFork FH;	 %. Wait for completion
 JSYS0(FH,0,0,0,const(jsWFork));

Lisp procedure RUNFork FH;	 %. Normal use, to run a Fork
 <<STARTFork FH; WAITFork FH>>;

Lisp procedure KILLFork FH;	 %. Kill a Fork
   JSYS0(FH,0,0,0,const(jsKFork));

Lisp procedure SETPRIMARYJfnS(FH,INJfn,OUTJfn);
   JSYS0(FH,Xword(INJfn , OUTJfn),0,0,const(JSSPJfn));  %. Change PRIMARY Jfns (BAD?)

Lisp procedure OPENFork FileName; 	 %. Get a File into a Fork
   Begin scalar FH,Jfn; 
      If NULL FileP FileName then StdError CONCAT("Cant find File ",FileName); 
      Jfn := GetOLDJfn FileName; 
      FH := GetFork Jfn; 
      return FH
   END;

Lisp procedure RUN FileName;	 %. Run A File
   Begin scalar FH; FH := OPENFork FileName; RUNFork FH; KILLFork FH END;

Lisp Procedure ForkP FH;         %. test if Valid Fork Handle
  FixP FH and not Zerop FH; %/Kludge

Lisp procedure EXEC; 
  <<If Not ForkP EXECFork then EXECFork := OPENFork "SYSTEM:EXEC.EXE"; 
    RUNFork EXECFork>>;

Lisp procedure EMACS; 
  <<If Not ForkP EMacsFork then EMACSFork := OPENFork "SYS:EMACS.EXE"; 
    RUNFork EMACSFork>>;

Lisp procedure MM; 
  <<If Not ForkP MMFork then  MMFork := OPENFork "SYS:MM.EXE";
    RUNFork MMFork>>;

Lisp procedure GetUNAME; 	 %. USER name
 Begin Scalar S;
   S:=Mkstring 80;
   JSYS0(s,JSYS1(0,0,0,0,const(JSGJINF)),0,0,const(JSDIRST));
   Return RecopyStringToNULL S
 End;

Lisp procedure GetCDIR;	 %. Connected DIRECTORY
  Begin scalar s;
   S:=Mkstring 80;
   JSYS0(S,JSYS2(0,0,0,0,const(jsGJINF)),0,0,const(jsDIRST));
   return RecopyStringToNULL S
 end;

%   Determine the current time or date or both and  stripped off trailing 
% nulls, with ONE blank Char concatenated on the end of the returned string.
%
%                  RETURNS STRING FORMS ARE SHOWN BELOW:
%    1     -> Returns Date & Time          ..  Day Date First & 24 hr format
%    2     -> Returns Date & Time          ..  Day Date First & 12 hr format
%    3     -> Returns Date & Time          ..  Month first & 24 hr format
%    4     -> Returns Date & Time          ..  Month first & 12 hr format
%    5     -> Returns Weekday,Date, & Time ..  Month first & 24 hr format
%    6     -> Returns Weekday,Date, & Time ..  Month first & 12 hr format
%    7     -> Returns Weekday,Date, & Time ..  Month first & 12 hr format
%                                              day-3 letters and no seconds
%    8     -> Returns time only     ...  hh:mm:ss  12 hr format
%Otherwise -> Returns time only     ...  hh:mm:ss  24 hr format
%
%
 PROCEDURE ClockTimeDate (Time_Selector);       % old ClockTime 
  BEGIN SCALAR Ret_String ;
   Ret_String := MKSTRING 30;
   CASE Time_Selector OF
     1:       <<  JSYS1( Ret_String,-1,bits(2),0,const jsODTIM) ;
                  Ret_String := SUB(Ret_String, 0, 17 )                    >>;
     2:       <<  JSYS1(Ret_String, -1,bits(2,11),0, const jsODTIM) ;
                  Ret_String := SUB(Ret_String, 0, 19 )                    >> ;
     3:       <<  JSYS1(Ret_String, -1,bits(6),0, const jsODTIM) ; 
                  Ret_String := SUB(Ret_String, 0, 17 )                    >> ;
     4:       <<  JSYS1(Ret_String, -1,bits(6,11),0, const jsODTIM) ; 
                  Ret_String := SUB(Ret_String, 0, 19 )                    >> ;
     5:       <<  JSYS1(Ret_String, -1,bits(1,2,6),0, const jsODTIM) ; 
                  Ret_String := SUB(Ret_String, 0, 27 )                    >> ;
     6:       <<  JSYS1(Ret_String, -1,bits(1,2,6,11),0, const jsODTIM) ;
                  Ret_String := SUB(Ret_String, 0, 29 )                    >> ;
     7:       <<  JSYS1(Ret_String, -1,bits(1,6,10,11),0, const jsODTIM) ;
                  Ret_String := SUB(Ret_String, 0, 20 )                    >> ;
     8:       <<  JSYS1(Ret_String, -1,bits(0,11),0, const jsODTIM) ;
                  Ret_String := SUB(Ret_String, 0, 9 )                     >> ;
  Otherwise:  <<  JSYS1(Ret_String, -1,bits(0),0, const jsODTIM) ;
                  Ret_String := SUB(Ret_String, 0, 7 )                     >> ;
    END ; %end for case
    Ret_String := ConCat( Ret_String, " ") ;
    RETURN Ret_String ;
 END;

% Determine the current 1 minute load average and return as a string.
procedure GetLoadAverage;
begin scalar s;
 s:=mkstring 6;
 jsys1(s,Jsys1(8#000014000014, 0, 0, 0, const jsGETAB),8#024037020200,
       0, const jsFLOUT);
 return s
end;

Lisp procedure PSOUT S;	 %. Print String
 JSYS0(S,0,0,0,const(jsPSOUT));

Lisp procedure GTJfn L;	 %. Get a Jfn
 JSYS1(L,0,0,0,const(jsGTJFN));

Lisp procedure NAMEFROMJfn J;	 %. name of File on a Jfn
  Begin scalar S;
       s:=Mkstring 100;
       JSYS0(S,J,0,0,const(JSJfnS));
  return RecopyStringToNULL S;
 end;

Fexpr Procedure InFile(U);   %. INPUT FILE, (prompt for name too?)
 If StringP U then DskIn EVAL CAR U
  else
    Begin scalar Jfn,Fname;
      PSOUT "Input file:";
	Jfn:=Jsys1(BITS(2,3,4,16,17),Xword(8#100,8#101),0,0,const(jsGTJFN));
	Fname:= NAMEFROMJFN JFN;
	RELJFN JFN;
        PRINTF("reading file %r %n", FNAME);
        DSKIN Fname;
    end;

%-- Command string processor and take

Lisp procedure  PutRescan(S);	%. Enter String
 <<JSYS0(S,0,0,0,const(jsRSCAN));
   JSYS0(0,0,0,0,const(jsRSCAN))>>;

On SYSLISP;

syslsp procedure  GetRescan();	%. Return as String
 Begin scalar N,S;
   XJSYS1(0,0,0,0,const(jsRSCAN));      % Announce to Get
   N:=XJSYS1(1,0,0,0,const(jsRSCAN)); % How Many
   IF N=0 then return 'Nil;
   S:=GtStr N-1;   % To Drop Trailing EOL
   For I:=0:N-2 do
	StrByt(S,I):=XJsys1(0,0,0,0,const(JsPBIN));
   Return MkSTR S; % Will include Program name
 end;


OFF SYSLISP;

Global '(CRLF BL);

CRLF :=STRING(8#15,8#12);	%. CR-LF
BL :=STRING(8#40);		%. Blank

Lisp procedure  CONCATS (L);			%. Combine list of strings
 If PAIRP L then CONCAT(CAR L,CONCATS CDR L)
   else CRLF;

Lisp Fexpr Procedure CMDS (!%L);            %. user COMMAND submit
  DOCMDS EVLIS !%L;

Lisp procedure  DOCMDS (L);                  %. Submit via PutRescan
 <<PutRescan CONCATS L;		% Add CR, plant in RSCAN
   EXEC()>>;			% Run 'em

%. -------- Sample Commands

Lisp procedure  VDIR (L);
 DOCMDS LIST("VDIR ",L,CRLF,"POP");

Lisp procedure HelpDir();
 DOCMDS  LIST("DIR PH:*.HLP",CRLF,"POP");

Lisp procedure Take (FileName);
  If FileP FileName then DOCMDS LIST("Take ",FileName,CRLF,"POP");

Lisp procedure  SYS (L);
  DOCMDS LIST("SYS ", L, CRLF, "POP");

Lisp procedure  TALK (L);
  DOCMDS LIST("TALK ",L,CRLF);

Lisp procedure  TYPE (L);
  DOCMDS LIST("TYPE ",L,CRLF,"POP");

END;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]