Artifact c46d5f52d1dc6bb5d1acf8378100cde6a966015068e38c26ca751529b9b885c5:
- File
r30/cmacro.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: 11801) [annotate] [blame] [check-ins using] [more...]
COMMENT DECSYSTEM 10 AND 20 COMPILER MACRO MODULE; PUT('COMPLR,'IMPORTS,'(LAP)); COMMENT fixups for PDP-10 assembly; FLAG('(NCONS XCONS),'LOSE); FLAG('(LIST2 LIST3 LIST4 LIST5),'LOSE); REMFLAG('(XN),'LOSE); COMMENT Global variable and flag values for PDP-10 version; GLOBAL '(MAXNARGS !*NOLINKE !*ORD !*PLAP !*R2I); MAXNARGS := 14; !*NOLINKE := NIL; !*ORD := NIL; !*PLAP := NIL; !*R2I := T; %We also need; FLUID '(REGS); COMMENT general functions; SYMBOLIC PROCEDURE !&MKFUNC FN; MKQUOTE FN; COMMENT c-macros for PDP-10 Implementation; SYMBOLIC PROCEDURE !*ALLOC N; IF N=0 THEN NIL ELSE IF N=1 THEN LIST '(PUSH P 1) ELSE LIST(LIST('ADD,'P,LIST('C,0,0,N,N)),'(213 P 85 16)); SYMBOLIC PROCEDURE !*DEALLOC N; IF N>0 THEN LIST LIST('SUB,'P,LIST('C,0,0,N,N)) ELSE NIL; COMMENT !*ENTRY is handled by the loader; SYMBOLIC PROCEDURE !*EXIT; LIST '(POPJ P); SYMBOLIC PROCEDURE !*STORE(REG,FLOC); % Uses R as extra reg; BEGIN SCALAR OP,PQ; IF NUMBERP FLOC THEN (IF FLOC>5 THEN FLOC := 'EXARG . (FLOC - 6) ELSE IF FLOC<1 THEN PQ := '(P)) ELSE IF EQCAR(FLOC,'GLOBAL) THEN FLOC := 'FLUID . CDR FLOC; IF NUMBERP REG AND REG>5 THEN RETURN IF IDP FLOC OR NUMBERP FLOC AND FLOC>0 THEN !*LOAD(FLOC,REG) ELSE NCONC(!*LOAD('R,REG), LIST ('MOVEM . ('R . (FLOC . PQ)))); OP := IF REG THEN 'MOVEM ELSE <<REG := 0; 'SETZM>>; RETURN LIST (OP . (REG . (FLOC . PQ))) END; SYMBOLIC PROCEDURE !*JUMP ADR; LIST LIST('JRST,0,ADR); SYMBOLIC PROCEDURE !*JUMPNIL ADR; LIST LIST('JUMPE,1,ADR); SYMBOLIC PROCEDURE !*JUMPT ADR; LIST LIST('JUMPN,1,ADR); SYMBOLIC PROCEDURE !*JUMPE(ADR,EXP); NCONC(!*LOADEXP(1,EXP,'(CAMN . CAIN)),LIST LIST('JRST,0,ADR)); SYMBOLIC PROCEDURE !*JUMPN(ADR,EXP); NCONC(!*LOADEXP(1,EXP,'(CAME . CAIE)),LIST LIST('JRST,0,ADR)); SYMBOLIC PROCEDURE !*LBL ADR; LIST ADR; SYMBOLIC PROCEDURE !*LAMBIND(REGS,ALST); %produces the parameter list for binding; BEGIN SCALAR X,Y; ALST := REVERSE ALST; REGS := REVERSE REGS; WHILE ALST DO <<IF NULL REGS THEN X := 0 ELSE <<X := CAR REGS; REGS := CDR REGS>>; Y := LIST(0,X,LIST('FLUID,CAAR ALST)) . Y; ALST := CDR ALST>>; RETURN '(CALL 0 (E !*LAMBIND!*)) . Y END; SYMBOLIC PROCEDURE !*PROGBIND ALST; !*LAMBIND(NIL,ALST); SYMBOLIC PROCEDURE !*FREERSTR ALST; '((CALL 0 (E !*SPECRSTR!*))); SYMBOLIC PROCEDURE !*LOAD(REG,EXP); % Uses R as extra reg; IF REG=EXP THEN NIL ELSE IF NUMBERP REG AND REG>5 THEN IF IDP EXP OR NUMBERP EXP AND EXP>0 THEN !*STORE(EXP,REG) ELSE IF EXP='(QUOTE NIL) THEN !*STORE(NIL,REG) ELSE NCONC(!*LOAD('R,EXP),!*STORE('R,REG)) ELSE !*LOADEXP(REG,EXP,'(MOVE . MOVEI)); SYMBOLIC PROCEDURE !*LINK(FN,TYPE,NARGS); !*MKLINK(FN,TYPE,NARGS,-1,'CALL); SYMBOLIC PROCEDURE !*LINKE(FN,TYPE,NARGS,N); !*MKLINK(FN,TYPE,NARGS,N,'JCALL); COMMENT Auxiliary functions used by the c-macros; SYMBOLIC PROCEDURE !*OPEN U; IF CAR U EQ 'LAMBDA THEN SUBPLIS(U,'(1 1)) ELSE U; SYMBOLIC PROCEDURE SUBPLIS(X,Y); SUBLIS(PAIR(CADR X,Y),CADDR X); SYMBOLIC PROCEDURE !*LOADEXP(REG,U,OPS); %OPS=(direct . immediate). When not MOVE, uses D as extra reg; %REG is always an actual machine register; IF ATOM U THEN IF IDP U OR U>0 AND U<6 THEN LIST LIST(CAR OPS,REG,U) ELSE IF U>5 THEN LIST LIST(CAR OPS,REG,'EXARG . (U - 6)) ELSE LIST LIST(CAR OPS,REG,U,'P) ELSE IF CAR U EQ 'QUOTE THEN LIST LIST(CDR OPS,REG,U) ELSE IF CAR U EQ 'GLOBAL THEN LIST LIST(CAR OPS,REG,'FLUID . CDR U) ELSE IF CAR U EQ 'FLUID THEN LIST LIST(CAR OPS,REG,U) ELSE IF NOT CAR OPS EQ 'MOVE THEN NCONC(!*LOAD('D,U),LIST LIST(CAR OPS,REG,'D)) ELSE BEGIN SCALAR X,Y,Z; X := 'ANYREG; IF ATOM (Y := CADR U) THEN IF IDP Y THEN X := 'OPEN ELSE IF Y<1 THEN Y := Y . '(P) ELSE IF Y>5 THEN Y := LIST ('EXARG . (Y - 6)) ELSE X := 'OPEN ELSE IF CAR Y EQ 'GLOBAL THEN Y := LIST ('FLUID . CDR Y) ELSE IF CAR Y EQ 'FLUID THEN Y := LIST Y ELSE <<X := 'OPEN; Z := !*LOAD(REG,Y); Y := REG>>; IF NOT (X := GET(CAR U,X)) THEN LPRIE LIST("Incomplete macro definition for", CAR U); RETURN NCONC(Z,SUBPLIS(X,LIST(REG,Y))) END; SYMBOLIC PROCEDURE !*MKLINK(FN,TYPE,NARGS,N,CALL); BEGIN SCALAR B,Y; B := N<0; IF (Y := GET(FN,'OPEN)) AND (B OR NOT FLAGP(FN,'NOPENR)) THEN <<Y := !*OPEN Y; IF NOT B THEN Y := APPEND(Y,LIST(LIST('!*DEALLOC,N),'(!*EXIT)))>> ELSE <<Y := LIST LIST(CALL, IF TYPE EQ 'FEXPR THEN 15 ELSE NARGS, LIST('E,FN)); IF N>0 THEN Y := LIST('!*DEALLOC,N) . Y>>; RETURN Y END; COMMENT Peep-hole optimization tables; SYMBOLIC PROCEDURE !&STOPT U; %this has to use fact that LLNGTH is offset during code generation; IF CDAR U='(1 0) AND CADR U='(!*ALLOC 0) THEN <<RPLACA(U,'(PUSH P 1)); RPLACD(U,NIL)>> ELSE IF CDAR U='(2 -1) AND CADR U='(!*STORE 1 0) AND CADDR U='(!*ALLOC -1) THEN <<RPLACA(U,'(PUSH P 1)); RPLACA(CDR U,'(PUSH P 2)); RPLACD(CDR U,NIL)>>; PUT('!*STORE,'OPTFN,'!&STOPT); COMMENT Some PDP-10 dependent optimizations; SYMBOLIC PROCEDURE !&PAEQUAL(U,VARS); (LAMBDA(X,Y); IF !&EQVP X OR !&EQVP Y THEN 'EQ ELSE IF NUMBERP X OR NUMBERP Y THEN 'EQN ELSE 'EQUAL) (CADR U,CADDR U) . !&PALIS(CDR U,VARS); PUT('EQUAL,'PA1FN,'!&PAEQUAL); SYMBOLIC PROCEDURE !&EQP U; %!&EQP is true if U is an object for which EQ can replace EQUAL; INUMP U OR IDP U; SYMBOLIC PROCEDURE !&EQVP U; %!&EQVP is true if EVAL U is an object for which EQ can %replace EQUAL; INUMP U OR EQCAR(U,'QUOTE) AND !&EQP CADR U; SYMBOLIC PROCEDURE !&PAMEMBER(U,VARS); (LAMBDA(X,Y); IF !&EQVP X THEN 'MEMQ ELSE IF NOT EQCAR(Y,'QUOTE) THEN 'MEMBER ELSE BEGIN SCALAR A; A := (Y := CADR Y); WHILE Y AND A DO <<A := !&EQP CAR Y; Y := CDR Y>>; RETURN IF A THEN 'MEMQ ELSE 'MEMBER END) (CADR U,CADDR U) . !&PALIS(CDR U,VARS); PUT('MEMBER,'PA1FN,'!&PAMEMBER); SYMBOLIC PROCEDURE !&PAASSOC(U,VARS); (LAMBDA(X,Y); IF !&EQVP X THEN 'ATSOC ELSE IF NOT EQCAR(Y,'QUOTE) THEN 'ASSOC ELSE BEGIN SCALAR A; A := T; Y := CADR Y; WHILE Y AND A DO <<A := !&EQP CAAR Y; Y := CDR Y>>; RETURN IF A THEN 'ATSOC ELSE 'ASSOC END) (CADR U,CADDR U) . !&PALIS(CDR U,VARS); PUT('ASSOC,'PA1FN,'!&PAASSOC); SYMBOLIC PROCEDURE !&COMAPPLY(EXP,STATUS); % Look for LIST; BEGIN INTEGER N,NN; SCALAR FN,ARGS; EXP := CDR EXP; FN := CAR EXP; ARGS := CDR EXP; IF !&CFNTYPE FN EQ 'FEXPR THEN LPRIE LIST(FN,"IS NOT AN EXPR FOR APPLY"); IF NULL ARGS OR CDR ARGS OR NOT EQCAR(CAR ARGS,'LIST) OR (NN := (N := LENGTH CDAR ARGS))>MAXNARGS THEN RETURN !&CALL('APPLY,EXP,STATUS); ARGS := REVERSE (FN . REVERSE CDAR ARGS); ARGS := !&COMLIS ARGS; !&STORE1(); FN := CAR ARGS; ARGS := CDR ARGS; IF STATUS>0 THEN !&CLRREGS(); WHILE N>0 DO <<!&LREG(N,CAR ARGS,CDR ARGS,STATUS); ARGS := CDR ARGS; N := N - 1>>; !&ATTACH ('!*LINKF . (NN . !&LOCATE FN)); REGS := LIST (1 . NIL) END; %PUT('APPLY,'COMPFN,'!&COMAPPLY); %Only works for compiled functions; SYMBOLIC PROCEDURE !&COMRPLAC(EXP,STATUS); BEGIN SCALAR FN,X,Y; FN := IF CAR EXP EQ 'RPLACA THEN '!*RPLACA ELSE '!*RPLACD; EXP := !&COMLIS CDR EXP; Y := IF CAR EXP = '(QUOTE NIL) THEN NIL ELSE IF Y := !&RASSOC(CAR EXP,REGS) THEN CAR Y ELSE <<!&LREG('TT,CAR EXP,CDR EXP,STATUS); 'TT>>; IF STATUS<2 THEN <<IF Y=1 THEN !&LREG(Y := 'TT,CAR EXP,CDR EXP,STATUS); !&LREG1(CADR EXP,STATUS)>>; !&ATTACH (FN . (Y . !&LOCATE CADR EXP)) END; PUT('RPLACA,'COMPFN,'!&COMRPLAC); PUT('RPLACD,'COMPFN,'!&COMRPLAC); COMMENT Additional c-macros defined in PDP-10 implementation; SYMBOLIC PROCEDURE !*LINKF(NARGS,FNEXP); !*LOADEXP(NARGS,FNEXP,'(CALLF!@ . CALLF)); SYMBOLIC PROCEDURE !*RPLACA(REG,EXP); !*LOADEXP!*(REG,EXP,'((RPLCA!@ . RPLCA) . (HRRZS!@ . HRRZS))); SYMBOLIC PROCEDURE !*RPLACD(REG,EXP); !*LOADEXP!*(REG,EXP,'((RPLCD!@ . RPLCD) . (HLLZS!@ . HLLZS))); SYMBOLIC PROCEDURE !*LOADEXP!*(REG,EXP,OPS); IF REG THEN IF NUMBERP REG AND REG>5 THEN NCONC(!*LOAD('R,REG),!*LOADEXP('R,EXP,CAR OPS)) ELSE !*LOADEXP(REG,EXP,CAR OPS) ELSE !*LOADEXP(0,EXP,CDR OPS); FLAG('(!*LINKF !*RPLACA !*RPLACD),'MC); FLAG('(LINKF),'UNKNOWNUSE); COMMENT Open coded functions in this version; PUT('CAR,'OPEN,'(LAMBDA (X Y) ((HLRZ X 0 Y)))); PUT('CDR,'OPEN,'(LAMBDA (X Y) ((HRRZ X 0 Y)))); FLAG('(RPLACA RPLACD),'NOPENR); PUT('CAR,'ANYREG,'(LAMBDA (X Y) ((HLRZ!@ X . Y)))); PUT('CDR,'ANYREG,'(LAMBDA (X Y) ((HRRZ!@ X . Y)))); COMMENT PDP-10 interpreter function register use; FLAG( '( CAR CDR RPLACA RPLACD ATOM CLOSE CODEP CONSTANTP EJECT EQ FIXP FLOATP GET IDP LINELENGTH LPOSN NCONS NOT NUMBERP NULL PAGELENGTH PAIRP POSN REMPROP REVERSE STRINGP TERPRI VECTORP XCONS UPBV !*LAMBIND!* !*PROGBIND!* !*SPECRSTR!* BIGP INUMP RECLAIM TYO UNTYI ),'ONEREG); FLAG('( ABS ATSOC CONS FIX FLOAT GETD GETV LENGTH PRINC PUTV PUT REMD !*BOX ASCII BINI BINO DELIMITER EXAMINE EXCISE FILEP GCTIME IGNORE LETTER MKCODE NUMVAL RDSLSH SCANSET SETPCHAR SPEAK TIME ),'TWOREG); COMMENT Code for counting macro execution use; FLUID '(MCPROCS !*COUNTMC); SYMBOLIC PROCEDURE RESETMC U; BEGIN SCALAR L; !*COUNTMC := U; FOR EACH L IN MCPROCS DO <<SET(L,CDR (131072 + 1)); % FWD of a fresh FIXNUM; DEPOSIT(!*BOX EVAL L,0); % FWD = numeric 0 now; PUT(L,'MCCOUNT,0)>> END; SYMBOLIC PROCEDURE COUNTMC L; LIST LIST(118800,0,LIST('FLUID,L)); SYMBOLIC PROCEDURE PRINTMC; BEGIN SCALAR SM; SM := 0; PRIN2 "DYNAMIC COUNT:"; TERPRI(); FOR EACH L IN MCPROCS DO <<PRIN2 L; PRIN2 " "; SM := PRINT (CAR 131072 . EVAL L) + SM>>; PRIN2 "DYNAMIC TOTAL: "; PRINT SM; TERPRI(); PRIN2 "STATIC COUNT:"; TERPRI(); SM := 0; FOR EACH L IN MCPROCS DO <<PRIN2 L; PRIN2 " "; SM := PRINT GET(L,'MCCOUNT) + SM>>; PRIN2 "STATIC TOTAL: "; PRINT SM END; MCPROCS := '(!*ALLOC !*DEALLOC !*ENTRY !*EXIT !*LOAD !*STORE !*JUMP !*JUMPE !*JUMPN !*JUMPT !*JUMPNIL !*LBL !*LAMBIND !*PROGBIND !*FREERSTR !*LINK !*LINKF !*LINKE !*RPLACA !*RPLACD); RESETMC NIL; SYMBOLIC PROCEDURE LAPPRI U; BEGIN A: IF NULL U THEN RETURN NIL; PRIN1 CAR U; U := CDR U; IF NULL U THEN RETURN NIL; SPACES2 24; PRIN1 CAR U; U := CDR U; IF NULL U THEN RETURN NIL; SPACES2 48; PRIN1 CAR U; TERPRI(); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE SPACES2 N; <<IF POSN()>N THEN TERPRI(); SPACES(N-POSN())>>; END;