123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410 |
- 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;
|