File r30/cmacro.red artifact c46d5f52d1 part of check-in d9e362f11e


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;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]