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;