reduce-historical/r30/rend2.red

COMMENT The 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;

COMMENT Introduction of Infix Character Strings Peculiar to the PDP-10;

PUT(INTERN ASCII 27,'NEWNAM,'!$);
PUT(INTERN ASCII 125,'NEWNAM,'!$);
PUT('!^,'NEWNAM,'EXPT);


COMMENT REDUCE Functions defined in front end for greater efficiency;

COMMENT The following routine is used by DETQ;

LAP '((TWOMEM EXPR 2)
	(MOVE C B)
	(CALL 1 (E NUMVAL))
	(EXCH A C)
	(CALL 1 (E NUMVAL))
	(133120 A C)
	(JUMPE A TAG)
	(MOVEI A (QUOTE T))
  TAG	(POPJ P));

FLAG('(TWOMEM),'LOSE);

GLOBAL '(TTYPE!* SCNVAL);

REMFLAG('(TOKEN),'LOSE);

SYMBOLIC PROCEDURE TOKEN;
   IF NULL IFL!* AND !*INT THEN TOKEN1()
    ELSE IF (TTYPE!*:=!%SCAN()) = 0 THEN INTERN SCNVAL
    ELSE IF SCNVAL EQ '!' THEN LIST('QUOTE,RREAD())
    ELSE SCNVAL;

FLAG('(TOKEN),'LOSE);

COMMENT Redefinition of REDUCE IO functions for greater flexibility;

%SYMBOLIC PROCEDURE SLREADFN;
%   BEGIN SCALAR !*MODE,!*SLIN;
%      !*MODE := 'SYMBOLIC;
%      !*SLIN := T;
%      BEGIN1();
%      RESETPARSER();   %since SCANSET seems to get set to NIL
%   END;

%PUT('SL,'ACTION,'SLREADFN);

PUT('LOAD,'STAT,'RLIS);   %to make available as a command;

FLAG('(LOAD),'NOFORM);

PUT('TR,'STAT,'RLIS);

PUT('TRST,'STAT,'RLIS);

FLAG('(TR TRST UNTR UNTRST),'IGNORE);


COMMENT SIMPFG properties for various flags;

PUT('CREF,'SIMPFG,'((T (PROG NIL (FISLM (QUOTE RCREF)) (CREFON)))
		    (NIL (CREFOFF))));


COMMENT Declarations needed for FAP building;

%ALG1:

FLAG('(CDIF CMINUS CMOD CPLUS CTIMES SETMOD),'LOSE);

% FACTOR:

FLUID '(LARGEST!-SMALL!-MODULUS);

LARGEST!-SMALL!-MODULUS := 2**32;

SYMBOLIC PROCEDURE LOGAND2(M,N); BOOLE(1,M,N);

SYMBOLIC PROCEDURE LOGOR2(M,N); BOOLE(7,M,N);

SYMBOLIC PROCEDURE LOGXOR2(M,N); BOOLE(6,M,N);

SYMBOLIC SMACRO PROCEDURE LEFTSHIFT(U,N); LSH(U,N);

%RLISP:

FLAG('(TOKEN COMMAND ATSOC PRINTPROMPT RESETPARSER),'LOSE);


COMMENT redefining COMMAND;

GLOBAL '(EDIT!* !*DEMO !*PRET);

REMFLAG('(COMMAND),'LOSE);

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
	  <<!%NEXTTYI(); 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 <<SCAN();
		CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL;
		KEY!* := CURSYM!*; X := XREAD1 NIL>>;
	IF !*PRET THEN PROGN(TERPRI(),RPRINT X);
%	IF IFL!*='(DSK!: (INPUT . TMP)) AND 
%	   (Y:= PGLINE()) NEQ '(1 . 0)
%	  THEN LPL!*:= Y;	%use of IN(noargs);
    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;
	IF NULL !*SLIN THEN X := FORM 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!*);
	RETURN X 
   END;

FLAG('(COMMAND),'LOSE);

FLUID '(TSLIN!* !*SLIN);

SYMBOLIC PROCEDURE RDFNEV(X,Y,Z,U);
 <<IF (X EQ !*SLIN OR X AND !*SLIN) AND Y EQ LREADFN!* THEN Z:=NIL
    ELSE <<IF U THEN TSLIN!* := (!*SLIN . LREADFN!*);
	   !*SLIN := X;
	   LREADFN!* := Y>>;
   IF U THEN EVAL CAR U ELSE Z>>;

REMFLAG('(SLISP RLISP),'GO);

FEXPR PROCEDURE SLISP U;
 RDFNEV(T,NIL,"Standard Lisp parsing . . .",U);

FEXPR PROCEDURE RLISP U;
 RDFNEV(NIL,NIL,"Rlisp parsing . . .",U);

PUTD('LISP,'FEXPR,CDR GETD 'RLISP);

GLOBAL '(!*BACKTRACE);

SYMBOLIC PROCEDURE RMOSTAT;
 BEGIN SCALAR TMODE,X,Y;
  IF NOT(KEY!* EQ (X:=CURSYM!*)) THEN SYMERR("SYNTAX ERROR",NIL)
   ELSE IF FLAGP(SCAN(),'DELIM)
    THEN <<!*MODE:='SYMBOLIC; RETURN LIST X>>;
  KEY!* := CURSYM!*;
  TMODE := !*MODE;
  !*MODE := 'SYMBOLIC;
  Y := ERRORSET('(XREAD1 NIL),NIL,!*BACKTRACE);
  !*MODE := TMODE;
  IF ATOM Y OR CDR Y THEN ERROR(10,NIL);
  RETURN X . CAR Y
 END;

PUT('RLISP,'STAT,'RMOSTAT);

PUT('SLISP,'STAT,'RMOSTAT);

FLAG('(SLISP RLISP),'GO);

FLAG('(SLISP RLISP),'EVAL);

FLAG('(SLISP RLISP),'IGNORE);

REMFLAG('(RESETPARSER),'LOSE);

SYMBOLIC PROCEDURE RESETPARSER;
 IF !*SLIN THEN <<RDSLSH NIL; SCANSET T>> ELSE COMM1 T;

FLAG('(RESETPARSER),'LOSE);

REMFLAG('(OFF),'EVAL);


COMMENT fixups for build of REDUCE;

%MAPOBL FUNCTION LAMBDA J;
%   <<REMFLAG(LIST J,'LOSE); REMFLAG(LIST J,'FLUID)>>;

FLAG('(!*S!* !*S1!* !*PI!*),'FLUID);

REMPROP('U,'VALUE);
REMPROP('W,'VALUE);
REMPROP('X,'VALUE);
REMPROP('Y,'VALUE);

IF SYSTEM!*=-1 THEN PUTD('SETSITE,'EXPR,'(LAMBDA NIL NIL));

FLAG('(CORE),'OPFN);


COMMENT some global variable initializations;

INITFN!* := 'BEGIN;
!*GCGAG := NIL;
!*INT := T;
!*NOUUO := NIL;
!*RAISE := T;

KLIST := NIL;
TMODE!* := NIL;
TSLIN!* := NIL;
!*BEGIN := NIL;
!*COMP := NIL;
!*FSLOUT := NIL;

COMMENT Some additional constructs for TOPS-10;

IF SYSTEM!* EQ 0 THEN <<FLAG('(EXCORE),'OPFN);
		FISLSIZE := 1500;   %big enough for factor;
		PUT('BFLOAT,'FAPSIZE,7);
		PUT('COMPLR,'FAPSIZE,6);
		PUT('FACTOR,'FAPSIZE,27);
		PUT('FAP,'FAPSIZE,3);
		PUT('HEPHYS,'FAPSIZE,3);
		PUT('INT,'FAPSIZE,11);
		PUT('MATR,'FAPSIZE,2);
		PUT('RCREF,'FAPSIZE,3);
		PUT('RPRINT,'FAPSIZE,2);
		PUT('SOLVE,'FAPSIZE,4)>>;


COMMENT The following two functions are only needed for TENEX;

IF SYSTEM!* EQ 1 THEN BEGIN
	PUTD('STDIR,'EXPR,'(LAMBDA (U)
	     (PROG (A)
		(SETQ A (ERRORSET (LIST 'JSYS 32 0 (MKQUOTE U) 0 1)
			 NIL NIL))
		(RETURN (COND ((ATOM A) 0)
				(T (BOOLE 1 (CAR A) 262143)))))));
	PUTD('SETSYS!:,'EXPR,'(LAMBDA (U) (SETSYS (STDIR U))))
   END;


END;