reduce-historical/psl-1983/util/rlisp-support.red

%  <PSL.UTIL>RLISP-SUPPORT.RED.8, 13-Oct-82 10:21:02, Edit by BENSON
%  !*INT is globally T
%  <PSL.UTIL>RLISP-SUPPORT.RED.5,  5-Oct-82 11:05:30, Edit by BENSON
%  Changed SaveSystem to 3 arguments
%  <PSL.UTIL>RLISP-SUPPORT.RED.3, 20-Sep-82 11:57:21, Edit by BENSON
%  Added Begin1 and BeginRlisp to IgnoredInBacktrace!*

CompileTime REMPROP('SHOWTIME,'STAT);
                  
%*********************************************************************
%	RLISP and REDUCE Support Code for NEW-RLISP / On PSL
%********************************************************************;


GLOBAL '(FLG!*);

GLOBAL '(BLOCKP!* CMSG!* ERFG!* INITL!* LETL!*
	PRECLIS!* VARS!* !*FORCE
	CLOC!*
        !*DEMO
	!*QUIET
        OTIME!* !*SLIN LREADFN!* TSLIN!*
	!*NAT NAT!*!* CRCHAR!* IFL!* IPL!* KEY!* KEY1!*
	OFL!* OPL!* PROGRAM!* PROGRAML!* SEMIC!*
	!*OUTPUT EOF!* TECHO!* !*INT !*MODE
	!*CREF !*MSG !*PRET !*EXTRAECHO);

FLUID '(!*DEFN !*ECHO DFPRINT!* !*TIME !*BACKTRACE CURSYM!*);

%	These global variables divide into two classes. The first
%class are those which must be initialized at the top level of the
%program. These are as follows;

BLOCKP!* := NIL;	%keeps track of which block is active;
CMSG!* := NIL;		%shows that continuation msg has been printed;
EOF!* := NIL;		%flag indicating an end-of-file;
ERFG!* := NIL;		%indicates that an input error has occurred;
INITL!* := '(BLOCKP!* VARS!*);
			%list of variables initialized in BEGIN1;
KEY!* := 'SYMBOLIC;	%stores first word read in command;
LETL!* := NIL;		%used in algebraic mode for special delimiters;
LREADFN!* := NIL;	%used to define special reading function;
%OUTL!* := NIL;		%storage for output of input line;
PRECLIS!*:= '(OR AND NOT MEMBER MEMQ EQUAL NEQ EQ GEQ GREATERP LEQ
	      LESSP PLUS DIFFERENCE TIMES QUOTIENT EXPT CONS);
			%precedence list of infix operators;
TECHO!* := NIL; 	%terminal echo status;
VARS!* := NIL;		%list of current bound variables during parse;
!*BACKTRACE := NIL;	%if ON, prints a LISP backtrace;
!*CREF := NIL;		%used by cross-reference program;
!*DEMO := NIL;		% causes a PAUSE (READCH) in COMMAND loop
!*ECHO := NIL;		%indicates echoing of input;
!*FORCE := NIL; 	%causes all macros to expand;
!*INT := T;		% system is interactive
%!*LOSE := T;		%determines whether a function flagged LOSE
			%is defined;
%!*MSG:=NIL;		%flag to indicate whether messages should be
			%printed;
!*NAT := NIL;		%used in algebraic mode to denote 'natural'
			%output. Must be on in symbolic mode to
			%ensure input echoing;
NAT!*!* := NIL; 	%temporary variable used in algebraic mode;
!*OUTPUT := T;		%used to suppress output;
!*SLIN := NIL;		%indicates that LISP code should be read;
!*TIME := NIL;		%used to indicate timing should be printed;

%	 The second class are those global variables which are
%initialized within some function, although they do not appear in that
%function's variable list. These are;

% CRCHAR!*		next character in input line
% CURSYM!*		current symbol (i. e. identifier, parenthesis,
%			delimiter, e.t.c,) in input line
% FNAME!*		name of a procedure being read
% FTYPES!*		list of regular procedure types
% IFL!* 		input file/channel pair - set in BEGIN to NIL
% IPL!* 		input file list- set in BEGIN to NIL
% KEY1!*		current key-word being analyzed - set in RLIS1;
% NXTSYM!*		next symbol read in TOKEN
% OFL!* 		output file/channel pair - set in BEGIN to NIL
% OPL!* 		output file list- set in BEGIN to NIL
% PROGRAM!*		current input program
% PROGRAML!*		stores input program when error occurs for a
%			later restart
% SEMIC!*		current delimiter character (used to decide
%			whether to print result of calculation)
% TTYPE!*		current token type;
% WS 			used in algebraic mode to store top level value
% !*FORT		used in algebraic mode to denote FORTRAN output
% !*INT 		indicates interactive system use
% !*MODE		current mode of calculation
% !*PRET		indicates REDUCE prettyprinting of input;


fluid '(IgnoredInBacktrace!*);
IgnoredInBacktrace!* := Append(IgnoredInBacktrace!*, '(Begin1 BeginRlisp));

CompileTime flag('(FlagP!*!* CondTerPri
		   LispFileNameP MkFil SetLispScanTable SetRlispScanTable
		   ProgVr),
		'InternalFunction);

CompileTime <<
macro procedure PgLine U;		% needed for LOCN
    ''(1 . 1);
>>;

%*********************************************************************
%			   REDUCE SUPERVISOR
%********************************************************************;

% 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 FLAGP!*!*(U,V);
  IDP U AND FLAGP(U,V);

FLUID '(PROMPTSTRING!*);

fluid '(STATCOUNTER!*);
STATCOUNTER!* := 0;

lisp procedure RlispPrompt();
    BldMsg("[%w] ", StatCounter!*);

put('Symbolic, 'PromptFn, 'RlispPrompt);

SYMBOLIC PROCEDURE BEGIN1;
   BEGIN SCALAR MODE,PARSERR,RESULT,PROMPT,WRKSP,MODEPRINT,PROMPTFN,RESULTL,
	PROMPTSTRING!*;
    A0: CURSYM!* := '!*SEMICOL!*;
	OTIME!* := TIME();
	GO TO A1;
    A:	%IF NULL IFL!* AND !*INT
	 % THEN <<%/CRBUFLIS!* := (STATCOUNTER!* . CRBUF!*) . CRBUFLIS!*;
		% CRBUF!* := NIL>>;
    A1: IF NULL IFL!* AND !*INT THEN STATCOUNTER!* := STATCOUNTER!* + 1;
	IF PROMPTFN := GET(!*MODE,'PROMPTFN) THEN
	  PROMPTSTRING!* := APPLY(PROMPTFN,NIL);
    A2: PARSERR := NIL;
%	IF !*OUTPUT AND !*INT AND NULL IFL!* AND NULL OFL!*
%	    AND NULL !*DEFN
%	  THEN TERPRI();
	IF !*TIME THEN SHOWTIME();
	IF TSLIN!*
	  THEN PROGN(!*SLIN := CAR TSLIN!*,
		     LREADFN!* := CDR TSLIN!*,
		     TSLIN!* := NIL);
	MAPC(INITL!*,FUNCTION SINITL);
	IF !*INT THEN ERFG!* := NIL;	%to make editing work properly;
	IF CURSYM!* EQ 'END THEN GO TO ND0;
	PROGRAM!* := ERRORSET('(COMMAND),T,!*BACKTRACE);
	CONDTERPRI();
	IF ATOM PROGRAM!* OR CDR PROGRAM!* THEN GO TO ERR1;
	PROGRAM!* := CAR PROGRAM!*;
	IF PROGRAM!* EQ !$EOF!$ THEN GO TO ND1
	 ELSE IF EQCAR(PROGRAM!*,'!*COMMA!*) THEN GO TO ER
	 ELSE IF CURSYM!* EQ 'END THEN GO TO ND0
	 ELSE IF EQCAR(PROGRAM!*,'RETRY) THEN PROGRAM!* := PROGRAML!*
;%	 ELSE IF PROGRAM!* EQ 'ED 
%	   THEN PROGN(CEDIT NIL,GO TO A2)
%	 ELSE IF EQCAR(PROGRAM!*,'ED)
%	   THEN PROGN(CEDIT CDR PROGRAM!*,GO TO A2);
	IF !*DEFN THEN GO TO D;
    B:	%IF !*OUTPUT AND IFL!* AND !*ECHO THEN TERPRI();
	RESULTL := ERRORSET(PROGRAM!*,T,!*BACKTRACE);
	IF ATOM RESULTL OR CDR RESULTL OR ERFG!* THEN GO TO ERR2
	 ELSE IF !*DEFN THEN GO TO A;
	RESULT := CAR RESULTL;
	IF IDP KEY!* AND GET(KEY!*,'STAT) EQ 'MODESTAT
	  THEN MODE := KEY!*
	 ELSE MODE := !*MODE;
	IF NULL !*OUTPUT OR IFL!* AND !*QUIET THEN GO TO C;
	IF SEMIC!* EQ '!; THEN <<
	  MODEPRINT := GET(MODE,'MODEPRINFN) OR 'PrintWithFreshLine;
%	  IF NOT FLAGP(MODE,'NOTERPRI) THEN
%	    TERPRI();
	    APPLY(MODEPRINT,RESULTL) >>;
    C:	IF WRKSP := GET(MODE,'WORKSPACE) THEN
	  SET(WRKSP,RESULT);
	GO TO A;
    D:	IF ERFG!* THEN GO TO A
	 ELSE IF FLAGP!*!*(KEY!*,'IGNORE) OR EQCAR(PROGRAM!*,'QUOTE)
	  THEN GO TO B;
	IF PROGRAM!* THEN DFPRINT PROGRAM!*;
	IF FLAGP!*!*(KEY!*,'EVAL) THEN GO TO B ELSE GO TO A;
    ND0:COMM1 'END;
    ND1: EOF!* := NIL;
	IF NULL IPL!*	%terminal END;
	  THEN BEGIN
		IF OFL!* THEN WRS NIL;
	    AA: IF NULL OPL!* THEN RETURN(OFL!* := NIL);
		CLOSE CDAR OPL!*;
		OPL!* := CDR OPL!*;
		GO TO AA
	      END;
	RETURN NIL;
    ERR1:
	IF EOF!* OR PROGRAM!* EQ !$EOF!$ THEN GO TO ND1
	 ELSE IF PROGRAM!* EQ 'EXTRA! BEGIN THEN GO TO A
%	 ELSE IF PROGRAM!* EQ !*!*ESC THEN GO TO A0
	 ELSE GO TO ER1;
    ER: LPRIE IF NULL ATOM CADR PROGRAM!*
		  THEN LIST(CAADR PROGRAM!*,"UNDEFINED")
		 ELSE "SYNTAX ERROR";
    ER1:
	PARSERR := T;
	GO TO ERR3;
    ERR2:
	PROGRAML!* := PROGRAM!*;
    ERR3:
	RESETPARSER();
%	IF NULL ERFG!* OR ERFG!* EQ 'HOLD
%	 THEN LPRIE "ERROR TERMINATION *****";
	ERFG!* := T;
	IF NULL !*INT THEN GO TO E;
	RESULT := PAUSE1 PARSERR;
	IF RESULT THEN RETURN NULL EVAL RESULT;
	ERFG!* := NIL;
	GO TO A;
    E:	!*DEFN := T;	%continue syntax analyzing but not evaluation;
	!*ECHO := T;
	IF NULL CMSG!* THEN LPRIE "CONTINUING WITH PARSING ONLY ...";
	CMSG!* := T;
	GO TO A
   END;

SYMBOLIC PROCEDURE CONDTERPRI;
   !*OUTPUT AND !*ECHO AND !*EXTRAECHO AND (NULL !*INT OR IFL!*)
	AND NULL !*DEFN AND POSN() > 0 AND TERPRI();

CommentOutCode <<
SYMBOLIC PROCEDURE ASSGNL U;
   IF ATOM U OR NULL (CAR U MEMQ '(SETK SETQ SETEL))
     THEN NIL
    ELSE IF ATOM CADR U THEN MKQUOTE CADR U . ASSGNL CADDR U
    ELSE CADR U . ASSGNL CADDR U;
>>;

SYMBOLIC PROCEDURE DFPRINT U;
   %Looks for special action on a form, otherwise prettyprints it;
   IF DFPRINT!* THEN APPLY(DFPRINT!*,LIST U)
%    ELSE IF CMSG!* THEN NIL
    ELSE IF NULL EQCAR(U,'PROGN) THEN
    <<  PRINTF "%f";
	PRETTYPRINT U >>
    ELSE BEGIN
	    A:	U := CDR U;
		IF NULL U THEN RETURN NIL;
		DFPRINT CAR U;
		GO TO A
	 END;

SYMBOLIC PROCEDURE SHOWTIME;
   BEGIN SCALAR X;
      X := OTIME!*;
      OTIME!* := TIME();
      X := OTIME!*-X;
%      TERPRI();
      PRIN2 "TIME: "; PRIN2 X; PRIN2T " MS";
   END;

SYMBOLIC PROCEDURE SINITL U;
   SET(U,GET(U,'INITL));

FLAG ('(IN OUT ON OFF SHUT),'IGNORE);


%*********************************************************************
%	       IDENTIFIER AND RESERVED CHARACTER READING
%********************************************************************;

%	 The function TOKEN defined below is used for reading
%identifiers and reserved characters (such as parentheses and infix
%operators). It is called by the function SCAN, which translates
%reserved characters into their internal name, and sets up the output
%of the input line. The following definitions of TOKEN and SCAN are
%quite general, but also inefficient. THE READING PROCESS CAN OFTEN
%BE SPEEDED UP BY A FACTOR OF AS MUCH AS FIVE IF THESE FUNCTIONS
%(ESPECIALLY TOKEN) ARE CODED IN ASSEMBLY LANGUAGE;

CommentOutCode <<
SYMBOLIC PROCEDURE PRIN2X U;
  OUTL!*:=U . OUTL!*;

SYMBOLIC PROCEDURE PTOKEN;
   BEGIN SCALAR X;
	X := TOKEN();
	IF X EQ '!) AND EQCAR(OUTL!*,'! ) THEN OUTL!*:= CDR OUTL!*;
	   %an explicit reference to OUTL!* used here;
	PRIN2X X;
	IF NULL ((X EQ '!() OR (X EQ '!))) THEN PRIN2X '! ;
	RETURN X
   END;
>>;

SYMBOLIC PROCEDURE MKEX U;
   IF NOT(!*MODE EQ 'ALGEBRAIC) OR EQCAR(U,'AEVAL) THEN U
    ELSE NIL;%APROC(U,'AEVAL);

SYMBOLIC PROCEDURE MKSETQ(U,V);
   LIST('SETQ,U,V);

SYMBOLIC PROCEDURE MKVAR(U,V); U;

SYMBOLIC PROCEDURE RPLCDX(U,V); IF CDR U=V THEN U ELSE RPLACD(U,V);

SYMBOLIC PROCEDURE REFORM U;
   IF ATOM U OR CAR U EQ 'QUOTE THEN U
   ELSE IF CAR U EQ 'COND THEN 'COND . REFORM CDR U
   ELSE IF CAR U EQ 'PROG
    THEN PROGN(RPLCDX(CDR U,MAPCAR(CDDR U,FUNCTION REFORM)),U)
    ELSE IF CAR U EQ 'LAMBDA
     THEN PROGN(RPLACA(CDDR U,REFORM CADDR U),U)
    ELSE IF CAR U EQ 'FUNCTION AND ATOM CADR U
     THEN BEGIN SCALAR X;
	IF NULL !*CREF AND (X:= GET(CADR U,'SMACRO))
	  THEN RETURN LIST('FUNCTION,X)
	 ELSE IF GET(CADR U,'NMACRO) OR MACROP CADR U
	  THEN REDERR "MACRO USED AS FUNCTION"
	 ELSE RETURN U END
%    ELSE IF CAR U EQ 'MAT THEN RPLCDX(U,MAPC2(CDR U,FUNCTION REFORM))
    ELSE IF ATOM CAR U
     THEN BEGIN SCALAR X,Y;
	 IF (Y := GETD CAR U) AND CAR Y EQ 'MACRO
		AND EXPANDQ CAR U
	  THEN RETURN REFORM APPLY(CDR Y,LIST U);
	X := REFORMLIS CDR U;
	IF NULL IDP CAR U THEN RETURN(CAR U . X)
	 ELSE IF (NULL !*CREF OR EXPANDQ CAR U)
		 AND (Y:= GET(CAR U,'NMACRO))
	  THEN RETURN
		APPLY(Y,IF FLAGP(CAR U,'NOSPREAD) THEN LIST X ELSE X)
	 ELSE IF (NULL !*CREF OR EXPANDQ CAR U)
		   AND (Y:= GET(CAR U,'SMACRO))
	  THEN RETURN SUBLIS(PAIR(CADR Y,X),CADDR Y)
	   %we could use an atom SUBLIS here (eg, SUBLA);
	 ELSE RETURN PROGN(RPLCDX(U,X),U)
      END
    ELSE REFORM CAR U . REFORMLIS CDR U;

SYMBOLIC PROCEDURE REFORMLIS U;
    IF ATOM U THEN U ELSE REFORM CAR U . REFORMLIS CDR U;

SYMBOLIC PROCEDURE EXPANDQ U;
   %determines if macro U should be expanded in REFORM;
   FLAGP(U,'EXPAND) OR !*FORCE AND NULL FLAGP(U,'NOEXPAND);

CommentOutCode <<
SYMBOLIC PROCEDURE ARRAYP U;
   GET(U,'ARRAY);

SYMBOLIC PROCEDURE GETTYPE U;
   %it might be better to use a table here for more generality;
   IF NULL ATOM U THEN 'FORM
    ELSE IF NUMBERP U THEN 'NUMBER
    ELSE IF ARRAYP U THEN 'ARRAY
    ELSE IF GETD U THEN 'PROCEDURE
    ELSE IF GLOBALP U THEN 'GLOBAL
    ELSE IF FLUIDP U THEN 'FLUID
    ELSE IF GET(U,'MATRIX) THEN 'MATRIX
    ELSE IF GET(U,'SIMPFN) OR GET(U,'MSIMPFN) THEN 'OPERATOR
    ELSE IF FLAGP(U,'PARM) THEN 'PARAMETER
    ELSE NIL;

SYMBOLIC PROCEDURE GETELS U;
   GETEL(CAR U . EVLIS(CDR U));

SYMBOLIC PROCEDURE SETELS(U,V);
   SETEL(CAR U . EVLIS(CDR U),V);
>>;

%. Top Level Entry Function
%. --- Special Flags -----
% !*DEMO -

SYMBOLIC PROCEDURE COMMAND;
   BEGIN SCALAR X,Y;
	IF !*DEMO AND (X := IFL!*)
	  THEN PROGN(TERPRI(),RDS NIL,READCH(),RDS CDR X);
%	IF EDIT!* THEN EDITLINE() ELSE IF FLG!* THEN GO TO A;
	IF !*SLIN THEN
	  <<KEY!* := SEMIC!* := '!;;
	    CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL;
	    X := IF LREADFN!* THEN APPLY(LREADFN!*,NIL) ELSE READ();
	    IF KEY!* EQ '!; THEN KEY!* := IF ATOM X THEN X ELSE CAR X>>
	 ELSE <<SetRlispScanTable(); MakeInputAvailable(); SCAN();
		CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL;
		KEY!* := CURSYM!*; X := XREAD1 NIL>>;
	IF !*PRET THEN PROGN(TERPRI(),RPRINT X);
	X := REFORM X;
	IF CLOC!* AND NOT ATOM X AND CAR X MEMQ '(DE DF DM)
	  THEN PUT(CADR X,'LOCN,CLOC!*)
	ELSE IF CLOC!* AND EQCAR(X,'PROGN)
	      AND CDDR X AND NOT ATOM CADDR X
	      AND CAADDR X MEMQ '(DE DF DM)
	  THEN PUT(CADR CADDR X,'LOCN,CLOC!*);
%	IF IFL!*='(DSK!: (INPUT . TMP)) AND 
%	   (Y:= PGLINE()) NEQ '(1 . 0)
%	  THEN LPL!*:= Y;	%use of IN(noargs);
	IF NULL IDP KEY!* OR NULL(GET(KEY!*,'STAT) EQ 'MODESTAT)
		AND NULL(KEY!* EQ 'ED)
	  THEN X := MKEX X;
    A:	IF FLG!* AND IFL!* THEN BEGIN
		CLOSE CDR IFL!*;
		IPL!* := DELETE(IFL!*,IPL!*);
		IF IPL!* THEN RDS CDAR IPL!* ELSE RDS NIL;
		IFL!* := NIL END;
	FLG!* := NIL;
	RETURN X 
   END;

OFF R2I;

SYMBOLIC PROCEDURE RPRINT U;		% Autoloading stub
<<  LOAD RPRINT;
    RPRINT U >>;

ON R2I;

%*********************************************************************
%			   GENERAL FUNCTIONS
%********************************************************************;


%SYMBOLIC PROCEDURE MAPC2(U,V);
%   %this very conservative definition is to allow for systems with
%   %poor handling of functional arguments, and because of bootstrap-
%   %ping difficulties;
%   BEGIN SCALAR X,Y,Z;
%   A: IF NULL U THEN RETURN REVERSIP Z;
%      X := CAR U;
%      Y := NIL;
%   B: IF NULL X THEN GO TO C;
%      Y := APPLY(V,LIST CAR X) . Y;
%      X := CDR X;
%      GO TO B;
%   C: U := CDR U;
%      Z := REVERSIP Y . Z:
%      GO TO A
%   END;



%*********************************************************************
%	 FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES
%********************************************************************;

SYMBOLIC PROCEDURE LPRIE U;
<<  ERRORPRINTF("***** %L", U);
    ERFG!* := T >>;

SYMBOLIC PROCEDURE LPRIM U; 
    !*MSG AND ERRORPRINTF("*** %L", U);

SYMBOLIC PROCEDURE REDERR U;
   BEGIN %TERPRI(); 
     LPRIE U; ERROR(99,NIL) END;


SYMBOLIC PROCEDURE PROGVR VAR;
   IF NOT ATOM VAR THEN NIL
    ELSE IF NUMBERP VAR OR FLAGP(VAR,'SHARE)
	OR NOT(!*MODE EQ 'ALGEBRAIC) AND FLUIDP VAR THEN T
    ELSE BEGIN SCALAR X;
	IF X := GET(VAR,'DATATYPE) THEN RETURN CAR X END;

SYMBOLIC PROCEDURE MKARG U;
   IF NULL U THEN NIL
    ELSE IF ATOM U THEN IF PROGVR U THEN U ELSE MKQUOTE U
    ELSE IF CAR U EQ 'QUOTE THEN MKQUOTE U
    ELSE IF FLAGP!*!*(CAR U,'NOCHANGE) AND NOT FLAGP(KEY1!*,'QUOTE)
     THEN U
    ELSE 'LIST . MAPCAR(U,FUNCTION MKARG);


SYMBOLIC PROCEDURE MKPROG(U,V);
   'PROG . (U . V);

CommentOutCode <<
SYMBOLIC PROCEDURE SETDIFF(U,V);
   IF NULL V THEN U ELSE SETDIFF(DELETE(CAR V,U),CDR V);

SYMBOLIC PROCEDURE REMTYPE VARLIS;
   BEGIN SCALAR X,Y;
	VARS!* := SETDIFF(VARS!*,VARLIS);
    A:	IF NULL VARLIS THEN RETURN NIL;
	X := CAR VARLIS;
	Y := CDR GET(X,'DATATYPE);
	IF Y THEN PUT(X,'DATATYPE,Y)
	 ELSE PROGN(REMPROP(X,'DATATYPE),REMFLAG(LIST X,'PARM));
	VARLIS := CDR VARLIS;
	GO TO A
   END;
>>;

DEFLIST('((LISP SYMBOLIC)),'NEWNAM);

FLAG('(FOR),'NOCHANGE);

FLAG('(REPEAT),'NOCHANGE);

FLAG('(WHILE),'NOCHANGE);

CommentOutCode <<
COMMENT LISP arrays built with computed index into a vector;
% FLUID '(U V X Y N); %/ Fix for MAPC closed compile

SYMBOLIC PROCEDURE ARRAY U;
   FOR EACH X IN U DO
      BEGIN INTEGER Y;
	IF NULL CDR X OR NOT IDP CAR X
	  THEN REDERR LIST(X,"CANNOT BECOME AN ARRAY");
	Y:=1;
	FOR EACH V IN CDR X DO Y:=Y*(V+1);
	PUT(CAR X,'ARRAY,MKVECT(Y-1));
	PUT(CAR X,'DIMENSION,ADD1LIS CDR X);
   END;

SYMBOLIC PROCEDURE CINDX!* U;
   BEGIN SCALAR V; INTEGER N;
	N:=0;
	IF NULL(V:=DIMENSION CAR U)
	  THEN REDERR LIST(CAR U,"NOT AN ARRAY");
	FOR EACH Y IN CDR U DO
	 <<IF NULL V THEN REDERR LIST(U,"TOO MANY INDICES");
	   IF Y<0 OR Y>CAR V-1
	     THEN REDERR LIST(U,"INDEX OUT OF RANGE");
	   N:=Y+N*CAR V;
	   V:=CDR V>>;
	IF V THEN REDERR LIST(U,"TOO FEW INDICES");
	RETURN N
   END;
%UNFLUID '(U V X Y N); %/ Fix for MAPC closed compile

SYMBOLIC PROCEDURE GETEL U;
 GETV(ARRAYP CAR U,CINDX!* U);

SYMBOLIC PROCEDURE SETEL(U,V);
 PUTV(ARRAYP CAR U,CINDX!* U,V);

SYMBOLIC PROCEDURE DIMENSION U;
 GET(U,'DIMENSION);


COMMENT further support for REDUCE arrays;

SYMBOLIC PROCEDURE TYPECHK(U,V);
   BEGIN SCALAR X;
      IF (X := GETTYPE U) EQ V OR X EQ 'PARAMETER
	THEN LPRIM LIST(U,"ALREADY DEFINED AS",V)
       ELSE IF X THEN REDERR LIST(X,U,"INVALID AS",V)
   END;

SYMBOLIC PROCEDURE NUMLIS U;
   NULL U OR (NUMBERP CAR U AND NUMLIS CDR U);

CompileTime REMPROP('ARRAY,'STAT);	 %for bootstrapping purposes;

SYMBOLIC PROCEDURE ARRAYFN U;
   BEGIN SCALAR X,Y;
    A:	IF NULL U THEN RETURN;
	X := CAR U;
	IF ATOM X THEN REDERR "SYNTAX ERROR"
	 ELSE IF TYPECHK(CAR X,'ARRAY) THEN GO TO B;
	Y := IF NOT(!*MODE EQ 'ALGEBRAIC) THEN !*EVLIS CDR X
		ELSE REVLIS CDR X;
	IF NOT NUMLIS Y
	  THEN LPRIE LIST("INCORRECT ARRAY ARGUMENTS FOR",CAR X);
	ARRAY LIST (CAR X . Y);
    B:	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE ADD1LIS U;
   IF NULL U THEN NIL ELSE (CAR U+1) . ADD1LIS CDR U;

>>;
%*********************************************************************
%*********************************************************************
%	REDUCE FUNCTIONS FOR HANDLING INPUT AND OUTPUT OF FILES
%*********************************************************************
%********************************************************************;

GLOBAL '(CONTL!*);

MACRO PROCEDURE IN U;
    LIST('EVIN, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVIN U;
   BEGIN SCALAR CHAN,ECHO,ECHOP,EXTN,OSLIN,OLRDFN,OTSLIN;
    ECHOP := SEMIC!* EQ '!;;
    ECHO := !*ECHO;
    IF NULL IFL!* THEN TECHO!* := !*ECHO;	%terminal echo status;
    OSLIN := !*SLIN;
    OLRDFN := LREADFN!*;
    OTSLIN := TSLIN!*;
    TSLIN!* := NIL;
    FOR EACH FL IN U DO
      <<CHAN := OPEN(FL,'INPUT); IFL!* := FL . CHAN;
	IPL!* := IFL!* . IPL!*;
	RDS (IF IFL!* THEN CDR IFL!* ELSE NIL);
	!*ECHO := ECHOP;
	!*SLIN := T;
	 IF LISPFILENAMEP FL THEN LREADFN!* := NIL
	 ELSE !*SLIN := OSLIN;
	BEGIN1();
	IF !*SLIN THEN RESETPARSER();
	IF CHAN THEN CLOSE CHAN;
	LREADFN!* := OLRDFN;
	!*SLIN := OSLIN;
	IF FL EQ CAAR IPL!* THEN IPL!* := CDR IPL!*
	 ELSE REDERR LIST("FILE STACK CONFUSION",FL,IPL!*)>>;
    !*ECHO := ECHO;   %restore echo status;
    TSLIN!* := OTSLIN;
    IF IPL!* AND NULL CONTL!* THEN IFL!* := CAR IPL!*
     ELSE IFL!* := NIL;
    RDS(IF IFL!* THEN CDR IFL!* ELSE NIL);
    RETURN NIL
   END;

CommentOutCode <<
lisp procedure RedIN F;
begin scalar !*Echo, !*Output, !*SLIN, Chan;
   IPL!* := (IFL!* := (F . (Chan := Open(F, 'Input)))) . IPL!*;
   RDS Chan;
   Begin1();
   IPL!* := cdr IPL!*;
   RDS(if not null IPL!* then cdr first IPL!* else NIL);
end;
>>;

SYMBOLIC PROCEDURE LISPFILENAMEP S;	%. Look for ".SL" or ".LSP"
BEGIN SCALAR C, I, SS;
    SS := SIZE S;
    IF SS < 3 THEN RETURN NIL;
    I := SS;
LOOP:
    IF I < 0 THEN RETURN NIL;
    IF INDX(S, I) = CHAR '!. THEN GOTO LOOPEND;
    I := I - 1;
    GOTO LOOP;
LOOPEND:
    I := I + 1;
    C := SS - I;
    IF NOT (C MEMBER '(1 2)) THEN RETURN NIL;
    C := SUBSEQ(S, I, SS + 1);
    RETURN IF C MEMBER '("SL" "sl" "LSP" "lsp" "Sl" "Lsp") THEN T ELSE NIL;
END;

MACRO PROCEDURE OUT U;
    LIST('EVOUT, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVOUT U;
   %U is a list of one file;
   BEGIN SCALAR CHAN,FL,X;
	IF NULL U THEN RETURN NIL
	 ELSE IF CAR U EQ 'T THEN RETURN <<WRS(OFL!* := NIL); NIL>>;
	FL := MKFIL CAR U;
	IF NOT (X := ASSOC(FL,OPL!*))
	  THEN <<CHAN := OPEN(FL,'OUTPUT);
		 OFL!* := FL . CHAN;
		 OPL!* := OFL!* . OPL!*>>
	 ELSE OFL!* := X;
	WRS CDR OFL!*
   END;

MACRO PROCEDURE SHUT U;
    LIST('EVSHUT, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVSHUT U;
   %U is a list of names of files to be shut;
   BEGIN SCALAR FL,FL1;
    A:	IF NULL U THEN RETURN NIL
	 ELSE IF FL1 := ASSOC((FL := MKFIL CAR U),OPL!*) THEN GO TO B
	 ELSE IF NOT (FL1 := ASSOC(FL,IPL!*))
	  THEN REDERR LIST(FL,"NOT OPEN");
	IF FL1 NEQ IFL!*
	  THEN <<CLOSE CDR FL1; IPL!* := DELETE(FL1,IPL!*)>>
	  ELSE REDERR LIST("CANNOT CLOSE CURRENT INPUT FILE",CAR FL);
	GO TO C;
    B:	OPL!* := DELETE(FL1,OPL!*);
	IF FL1=OFL!* THEN <<OFL!* := NIL; WRS NIL>>;
	CLOSE CDR FL1;
    C:	U := CDR U;
	GO TO A
   END;

%/ removed STAT property

%*********************************************************************
%		FUNCTIONS HANDLING INTERACTIVE FEATURES
%********************************************************************;

%GLOBAL Variables referenced in this Section;

CONTL!* := NIL;

SYMBOLIC PROCEDURE PAUSE;
   PAUSE1 NIL;

SYMBOLIC PROCEDURE PAUSE1 BOOL;
   BEGIN
%      IF BOOL THEN
%	IF NULL IFL!*
%	 THEN RETURN IF !*INT AND GETD 'CEDIT AND YESP 'EDIT!?
%		       THEN CEDIT() ELSE
%		       NIL
%	 ELSE IF GETD 'EDIT1 AND ERFG!* AND CLOC!* AND YESP 'EDIT!?
%	  THEN RETURN <<CONTL!* := NIL;
%	   IF OFL!* THEN <<LPRIM LIST(CAR OFL!*,'SHUT);
%			   CLOSE CDR OFL!*;
%			   OPL!* := DELETE(OFL!*,OPL!*);
%			   OFL!* := NIL>>;
%	   EDIT1(CLOC!*,NIL)>>
%	 ELSE IF FLG!* THEN RETURN (EDIT!* := NIL);
      IF NULL IFL!* OR YESP 'CONT!? THEN RETURN NIL;
      CONTL!* := IFL!* . !*ECHO . CONTL!*;
      RDS (IFL!* := NIL);
      !*ECHO := TECHO!*
   END;

SYMBOLIC PROCEDURE CONT;
   BEGIN SCALAR FL,TECHO;
	IF IFL!* THEN RETURN NIL   %CONT only active from terminal;
	 ELSE IF NULL CONTL!* THEN REDERR "NO FILE OPEN";
	FL := CAR CONTL!*;
	TECHO := CADR CONTL!*;
	CONTL!* := CDDR CONTL!*;
	IF FL=CAR IPL!* THEN <<IFL!* := FL;
			       RDS IF FL THEN CDR FL ELSE NIL;
			       !*ECHO := TECHO>>
	 ELSE <<EOF!* :=T; LPRIM LIST(FL,"NOT OPEN"); ERROR(99,NIL)>>
   END;

%/DEFLIST ('((PAUSE ENDSTAT) (CONT ENDSTAT) (RETRY ENDSTAT)),'STAT);

%/PUT('RETRY,'STAT,'ENDSTAT);

FLAG ('(CONT),'IGNORE);


%******** "rend" fixups

GLOBAL '(!*INT CONTL!* DATE!* !*MODE
	 IMODE!* CRCHAR!* !*SLIN LREADFN!*);

REMFLAG('(BEGINRLISP),'GO);

%---- Merge into XREAD1 in command ----
% Shouldnt USE Scan in COMMAND, since need change Parser first

FLUID '(!*PECHO);

Symbolic Procedure XREAD1 x;           %. With Catches
 Begin scalar Form!*;
     Form!*:=PARSE0(0, NIL);
     If !*PECHO then PRIN2T LIST("parse>",Form!*);
     Return Form!*   
 end;

lisp procedure Xread X;
 Begin scalar Form!*;
     MakeInputAvailable();
     Form!*:=PARSE0(0, T);
     If !*PECHO then PRIN2T LIST("parse>",Form!*);
     Return Form!*   
 end;

!*PECHO:=NIL;

SYMBOLIC PROCEDURE BEGINRLISP;
   BEGIN SCALAR A,B,PROMPTSTRING!*;
%/	!*BAKGAG := NIL;
	!*INT := T;
	!*ECHO := NIL;
	A := !*SLIN;
	!*SLIN := LREADFN!* := NIL;
	CONTL!* := IFL!* := IPL!* := OFL!* := OPL!* := NIL;
	!*MODE := IMODE!*;
	CRCHAR!* := '! ;
%/	RDSLSH NIL;
%/	SETPCHAR '!*;
	SetRlispScanTable();
%	IF SYSTEM!* NEQ 0 THEN CHKLEN();
	IF DATE!* EQ NIL
	  THEN IF A THEN <<PRIN2 "Entering RLISP..."; GO TO B>>
		ELSE GO TO A;
%/	IF FILEP '((REDUCE . INI)) THEN <<IN REDUCE.INI; TERPRI()>>;
%/	ERRORSET(QUOTE LAPIN "PSL.INI", NIL, NIL);	% no error if not there
	PRIN2 DATE!*;
	DATE!* := NIL;
%	IF SYSTEM!* NEQ 1 THEN GO TO A;
%	IF !*HELP THEN PRIN2 "For help, type HELP()";
  B:    TERPRI();
  A:    BEGIN1();
%	TERPRI();
	!*SLIN := T;
%/        RDSLSH NIL;
        SetLispScanTable();
	PRIN2T "Entering LISP..."
   END;

FLAG('(BEGINRLISP),'GO);

PUTD('BEGIN,'EXPR, CDR GETD 'BEGINRLISP);

SYMBOLIC PROCEDURE MKFIL U;
   %converts file descriptor U into valid system filename;
   U;

SYMBOLIC PROCEDURE NEWMKFIL U;
   %converts file descriptor U into valid system filename;
   U;

lisp procedure SetPChar C;		%. Set prompt, return old one
begin scalar OldPrompt;
    OldPrompt := PromptString!*;
    PromptString!* := if StringP C then C
		      else if IDP C then CopyString ID2String C
		      else BldMsg("%w", C);
    return OldPrompt;
end;

COMMENT Some Global Variables required by REDUCE;

%GLOBAL '(!*!*ESC);
%
%!*!*ESC := 'ESC!.NOT!.NEEDED!.NOW;   %to make it user settable (used to be a NEWNAM);


COMMENT The remaining material in this file introduces extensions
	or redefinitions of code in the REDUCE source files, and
	is not really necessary to run a basic system;


lisp procedure SetRlispScanTable();
<<  CurrentReadMacroIndicator!* :='RLispReadMacro;
    CurrentScanTable!* := RLispScanTable!* >>;

lisp procedure SetLispScanTable();
<<  CurrentReadMacroIndicator!* :='LispReadMacro;
    CurrentScanTable!* := LispScanTable!* >>;

PutD('LispSaveSystem, 'EXPR, cdr GetD 'SaveSystem);

lisp procedure SaveSystem(S, F, I);		%. Set up for saving EXE file
<<  StatCounter!* := 0;
    RemD 'Main;
    Copyd('Main, 'RlispMain);
    Date!* := BldMsg("%w, %w", S, Date());
    LispSaveSystem("PSL", F, I) >>;

lisp procedure RlispMain();
<<  BeginRlisp();
    StandardLisp() >>;

lisp procedure Rlisp();			% Uses new top loop
<<  SetRlispScanTable();
    TopLoop('ReformXRead, 'PrintWithFreshLine, 'Eval, "rlisp", "PSL Rlisp") >>;

lisp procedure ReformXRead();
    Reform XRead T;

!*RAISE := T;

%IF GETD 'ADDSQ THEN IMODE!* := 'ALGEBRAIC ELSE IMODE!* := 'SYMBOLIC;
IMODE!* := 'SYMBOLIC;

TSLIN!* := NIL;
!*MSG := T;

END;