Artifact 87fc4bc34b4d59e6b83e80677e9e0990f3d5f3b1cb826f4818922afed4094215:
- File
r30/rend2.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5771) [annotate] [blame] [check-ins using] [more...]
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;