cmacro.red 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410
  1. COMMENT DECSYSTEM 10 AND 20 COMPILER MACRO MODULE;
  2. PUT('COMPLR,'IMPORTS,'(LAP));
  3. COMMENT fixups for PDP-10 assembly;
  4. FLAG('(NCONS XCONS),'LOSE);
  5. FLAG('(LIST2 LIST3 LIST4 LIST5),'LOSE);
  6. REMFLAG('(XN),'LOSE);
  7. COMMENT Global variable and flag values for PDP-10 version;
  8. GLOBAL '(MAXNARGS !*NOLINKE !*ORD !*PLAP !*R2I);
  9. MAXNARGS := 14;
  10. !*NOLINKE := NIL;
  11. !*ORD := NIL;
  12. !*PLAP := NIL;
  13. !*R2I := T;
  14. %We also need;
  15. FLUID '(REGS);
  16. COMMENT general functions;
  17. SYMBOLIC PROCEDURE !&MKFUNC FN; MKQUOTE FN;
  18. COMMENT c-macros for PDP-10 Implementation;
  19. SYMBOLIC PROCEDURE !*ALLOC N;
  20. IF N=0 THEN NIL
  21. ELSE IF N=1 THEN LIST '(PUSH P 1)
  22. ELSE LIST(LIST('ADD,'P,LIST('C,0,0,N,N)),'(213 P 85 16));
  23. SYMBOLIC PROCEDURE !*DEALLOC N;
  24. IF N>0 THEN LIST LIST('SUB,'P,LIST('C,0,0,N,N)) ELSE NIL;
  25. COMMENT !*ENTRY is handled by the loader;
  26. SYMBOLIC PROCEDURE !*EXIT; LIST '(POPJ P);
  27. SYMBOLIC PROCEDURE !*STORE(REG,FLOC); % Uses R as extra reg;
  28. BEGIN SCALAR OP,PQ;
  29. IF NUMBERP FLOC
  30. THEN (IF FLOC>5 THEN FLOC := 'EXARG . (FLOC - 6)
  31. ELSE IF FLOC<1 THEN PQ := '(P))
  32. ELSE IF EQCAR(FLOC,'GLOBAL) THEN FLOC := 'FLUID . CDR FLOC;
  33. IF NUMBERP REG AND REG>5
  34. THEN RETURN IF IDP FLOC OR NUMBERP FLOC AND FLOC>0
  35. THEN !*LOAD(FLOC,REG)
  36. ELSE NCONC(!*LOAD('R,REG),
  37. LIST ('MOVEM . ('R . (FLOC . PQ))));
  38. OP := IF REG THEN 'MOVEM ELSE <<REG := 0; 'SETZM>>;
  39. RETURN LIST (OP . (REG . (FLOC . PQ)))
  40. END;
  41. SYMBOLIC PROCEDURE !*JUMP ADR; LIST LIST('JRST,0,ADR);
  42. SYMBOLIC PROCEDURE !*JUMPNIL ADR; LIST LIST('JUMPE,1,ADR);
  43. SYMBOLIC PROCEDURE !*JUMPT ADR; LIST LIST('JUMPN,1,ADR);
  44. SYMBOLIC PROCEDURE !*JUMPE(ADR,EXP);
  45. NCONC(!*LOADEXP(1,EXP,'(CAMN . CAIN)),LIST LIST('JRST,0,ADR));
  46. SYMBOLIC PROCEDURE !*JUMPN(ADR,EXP);
  47. NCONC(!*LOADEXP(1,EXP,'(CAME . CAIE)),LIST LIST('JRST,0,ADR));
  48. SYMBOLIC PROCEDURE !*LBL ADR; LIST ADR;
  49. SYMBOLIC PROCEDURE !*LAMBIND(REGS,ALST);
  50. %produces the parameter list for binding;
  51. BEGIN SCALAR X,Y;
  52. ALST := REVERSE ALST;
  53. REGS := REVERSE REGS;
  54. WHILE ALST DO
  55. <<IF NULL REGS THEN X := 0
  56. ELSE <<X := CAR REGS; REGS := CDR REGS>>;
  57. Y := LIST(0,X,LIST('FLUID,CAAR ALST)) . Y;
  58. ALST := CDR ALST>>;
  59. RETURN '(CALL 0 (E !*LAMBIND!*)) . Y
  60. END;
  61. SYMBOLIC PROCEDURE !*PROGBIND ALST; !*LAMBIND(NIL,ALST);
  62. SYMBOLIC PROCEDURE !*FREERSTR ALST; '((CALL 0 (E !*SPECRSTR!*)));
  63. SYMBOLIC PROCEDURE !*LOAD(REG,EXP); % Uses R as extra reg;
  64. IF REG=EXP THEN NIL
  65. ELSE IF NUMBERP REG AND REG>5
  66. THEN IF IDP EXP OR NUMBERP EXP AND EXP>0 THEN !*STORE(EXP,REG)
  67. ELSE IF EXP='(QUOTE NIL) THEN !*STORE(NIL,REG)
  68. ELSE NCONC(!*LOAD('R,EXP),!*STORE('R,REG))
  69. ELSE !*LOADEXP(REG,EXP,'(MOVE . MOVEI));
  70. SYMBOLIC PROCEDURE !*LINK(FN,TYPE,NARGS);
  71. !*MKLINK(FN,TYPE,NARGS,-1,'CALL);
  72. SYMBOLIC PROCEDURE !*LINKE(FN,TYPE,NARGS,N);
  73. !*MKLINK(FN,TYPE,NARGS,N,'JCALL);
  74. COMMENT Auxiliary functions used by the c-macros;
  75. SYMBOLIC PROCEDURE !*OPEN U;
  76. IF CAR U EQ 'LAMBDA THEN SUBPLIS(U,'(1 1)) ELSE U;
  77. SYMBOLIC PROCEDURE SUBPLIS(X,Y); SUBLIS(PAIR(CADR X,Y),CADDR X);
  78. SYMBOLIC PROCEDURE !*LOADEXP(REG,U,OPS);
  79. %OPS=(direct . immediate). When not MOVE, uses D as extra reg;
  80. %REG is always an actual machine register;
  81. IF ATOM U
  82. THEN IF IDP U OR U>0 AND U<6 THEN LIST LIST(CAR OPS,REG,U)
  83. ELSE IF U>5 THEN LIST LIST(CAR OPS,REG,'EXARG . (U - 6))
  84. ELSE LIST LIST(CAR OPS,REG,U,'P)
  85. ELSE IF CAR U EQ 'QUOTE THEN LIST LIST(CDR OPS,REG,U)
  86. ELSE IF CAR U EQ 'GLOBAL THEN LIST LIST(CAR OPS,REG,'FLUID . CDR U)
  87. ELSE IF CAR U EQ 'FLUID THEN LIST LIST(CAR OPS,REG,U)
  88. ELSE IF NOT CAR OPS EQ 'MOVE
  89. THEN NCONC(!*LOAD('D,U),LIST LIST(CAR OPS,REG,'D))
  90. ELSE BEGIN SCALAR X,Y,Z;
  91. X := 'ANYREG;
  92. IF ATOM (Y := CADR U)
  93. THEN IF IDP Y THEN X := 'OPEN
  94. ELSE IF Y<1 THEN Y := Y . '(P)
  95. ELSE IF Y>5 THEN Y := LIST ('EXARG . (Y - 6))
  96. ELSE X := 'OPEN
  97. ELSE IF CAR Y EQ 'GLOBAL THEN Y := LIST ('FLUID . CDR Y)
  98. ELSE IF CAR Y EQ 'FLUID THEN Y := LIST Y
  99. ELSE <<X := 'OPEN; Z := !*LOAD(REG,Y); Y := REG>>;
  100. IF NOT (X := GET(CAR U,X))
  101. THEN LPRIE LIST("Incomplete macro definition for",
  102. CAR U);
  103. RETURN NCONC(Z,SUBPLIS(X,LIST(REG,Y)))
  104. END;
  105. SYMBOLIC PROCEDURE !*MKLINK(FN,TYPE,NARGS,N,CALL);
  106. BEGIN SCALAR B,Y;
  107. B := N<0;
  108. IF (Y := GET(FN,'OPEN)) AND (B OR NOT FLAGP(FN,'NOPENR))
  109. THEN <<Y := !*OPEN Y;
  110. IF NOT B
  111. THEN Y :=
  112. APPEND(Y,LIST(LIST('!*DEALLOC,N),'(!*EXIT)))>>
  113. ELSE <<Y :=
  114. LIST LIST(CALL,
  115. IF TYPE EQ 'FEXPR THEN 15 ELSE NARGS,
  116. LIST('E,FN));
  117. IF N>0 THEN Y := LIST('!*DEALLOC,N) . Y>>;
  118. RETURN Y
  119. END;
  120. COMMENT Peep-hole optimization tables;
  121. SYMBOLIC PROCEDURE !&STOPT U;
  122. %this has to use fact that LLNGTH is offset during code generation;
  123. IF CDAR U='(1 0) AND CADR U='(!*ALLOC 0)
  124. THEN <<RPLACA(U,'(PUSH P 1)); RPLACD(U,NIL)>>
  125. ELSE IF CDAR U='(2 -1)
  126. AND CADR U='(!*STORE 1 0)
  127. AND CADDR U='(!*ALLOC -1)
  128. THEN <<RPLACA(U,'(PUSH P 1));
  129. RPLACA(CDR U,'(PUSH P 2));
  130. RPLACD(CDR U,NIL)>>;
  131. PUT('!*STORE,'OPTFN,'!&STOPT);
  132. COMMENT Some PDP-10 dependent optimizations;
  133. SYMBOLIC PROCEDURE !&PAEQUAL(U,VARS);
  134. (LAMBDA(X,Y);
  135. IF !&EQVP X OR !&EQVP Y THEN 'EQ
  136. ELSE IF NUMBERP X OR NUMBERP Y THEN 'EQN
  137. ELSE 'EQUAL)
  138. (CADR U,CADDR U)
  139. . !&PALIS(CDR U,VARS);
  140. PUT('EQUAL,'PA1FN,'!&PAEQUAL);
  141. SYMBOLIC PROCEDURE !&EQP U;
  142. %!&EQP is true if U is an object for which EQ can replace EQUAL;
  143. INUMP U OR IDP U;
  144. SYMBOLIC PROCEDURE !&EQVP U;
  145. %!&EQVP is true if EVAL U is an object for which EQ can
  146. %replace EQUAL;
  147. INUMP U OR EQCAR(U,'QUOTE) AND !&EQP CADR U;
  148. SYMBOLIC PROCEDURE !&PAMEMBER(U,VARS);
  149. (LAMBDA(X,Y);
  150. IF !&EQVP X THEN 'MEMQ
  151. ELSE IF NOT EQCAR(Y,'QUOTE) THEN 'MEMBER
  152. ELSE BEGIN SCALAR A;
  153. A := (Y := CADR Y);
  154. WHILE Y AND A DO <<A := !&EQP CAR Y; Y := CDR Y>>;
  155. RETURN IF A THEN 'MEMQ ELSE 'MEMBER
  156. END)
  157. (CADR U,CADDR U)
  158. . !&PALIS(CDR U,VARS);
  159. PUT('MEMBER,'PA1FN,'!&PAMEMBER);
  160. SYMBOLIC PROCEDURE !&PAASSOC(U,VARS);
  161. (LAMBDA(X,Y);
  162. IF !&EQVP X THEN 'ATSOC
  163. ELSE IF NOT EQCAR(Y,'QUOTE) THEN 'ASSOC
  164. ELSE BEGIN SCALAR A;
  165. A := T;
  166. Y := CADR Y;
  167. WHILE Y AND A DO <<A := !&EQP CAAR Y; Y := CDR Y>>;
  168. RETURN IF A THEN 'ATSOC ELSE 'ASSOC
  169. END)
  170. (CADR U,CADDR U)
  171. . !&PALIS(CDR U,VARS);
  172. PUT('ASSOC,'PA1FN,'!&PAASSOC);
  173. SYMBOLIC PROCEDURE !&COMAPPLY(EXP,STATUS); % Look for LIST;
  174. BEGIN INTEGER N,NN; SCALAR FN,ARGS;
  175. EXP := CDR EXP;
  176. FN := CAR EXP;
  177. ARGS := CDR EXP;
  178. IF !&CFNTYPE FN EQ 'FEXPR
  179. THEN LPRIE LIST(FN,"IS NOT AN EXPR FOR APPLY");
  180. IF NULL ARGS
  181. OR CDR ARGS
  182. OR NOT EQCAR(CAR ARGS,'LIST)
  183. OR (NN := (N := LENGTH CDAR ARGS))>MAXNARGS
  184. THEN RETURN !&CALL('APPLY,EXP,STATUS);
  185. ARGS := REVERSE (FN . REVERSE CDAR ARGS);
  186. ARGS := !&COMLIS ARGS;
  187. !&STORE1();
  188. FN := CAR ARGS;
  189. ARGS := CDR ARGS;
  190. IF STATUS>0 THEN !&CLRREGS();
  191. WHILE N>0 DO
  192. <<!&LREG(N,CAR ARGS,CDR ARGS,STATUS);
  193. ARGS := CDR ARGS;
  194. N := N - 1>>;
  195. !&ATTACH ('!*LINKF . (NN . !&LOCATE FN));
  196. REGS := LIST (1 . NIL)
  197. END;
  198. %PUT('APPLY,'COMPFN,'!&COMAPPLY); %Only works for compiled functions;
  199. SYMBOLIC PROCEDURE !&COMRPLAC(EXP,STATUS);
  200. BEGIN SCALAR FN,X,Y;
  201. FN := IF CAR EXP EQ 'RPLACA THEN '!*RPLACA ELSE '!*RPLACD;
  202. EXP := !&COMLIS CDR EXP;
  203. Y := IF CAR EXP = '(QUOTE NIL) THEN NIL
  204. ELSE IF Y := !&RASSOC(CAR EXP,REGS) THEN CAR Y
  205. ELSE <<!&LREG('TT,CAR EXP,CDR EXP,STATUS); 'TT>>;
  206. IF STATUS<2
  207. THEN <<IF Y=1 THEN !&LREG(Y := 'TT,CAR EXP,CDR EXP,STATUS);
  208. !&LREG1(CADR EXP,STATUS)>>;
  209. !&ATTACH (FN . (Y . !&LOCATE CADR EXP))
  210. END;
  211. PUT('RPLACA,'COMPFN,'!&COMRPLAC);
  212. PUT('RPLACD,'COMPFN,'!&COMRPLAC);
  213. COMMENT Additional c-macros defined in PDP-10 implementation;
  214. SYMBOLIC PROCEDURE !*LINKF(NARGS,FNEXP);
  215. !*LOADEXP(NARGS,FNEXP,'(CALLF!@ . CALLF));
  216. SYMBOLIC PROCEDURE !*RPLACA(REG,EXP);
  217. !*LOADEXP!*(REG,EXP,'((RPLCA!@ . RPLCA) . (HRRZS!@ . HRRZS)));
  218. SYMBOLIC PROCEDURE !*RPLACD(REG,EXP);
  219. !*LOADEXP!*(REG,EXP,'((RPLCD!@ . RPLCD) . (HLLZS!@ . HLLZS)));
  220. SYMBOLIC PROCEDURE !*LOADEXP!*(REG,EXP,OPS);
  221. IF REG
  222. THEN IF NUMBERP REG AND REG>5
  223. THEN NCONC(!*LOAD('R,REG),!*LOADEXP('R,EXP,CAR OPS))
  224. ELSE !*LOADEXP(REG,EXP,CAR OPS)
  225. ELSE !*LOADEXP(0,EXP,CDR OPS);
  226. FLAG('(!*LINKF !*RPLACA !*RPLACD),'MC);
  227. FLAG('(LINKF),'UNKNOWNUSE);
  228. COMMENT Open coded functions in this version;
  229. PUT('CAR,'OPEN,'(LAMBDA (X Y) ((HLRZ X 0 Y))));
  230. PUT('CDR,'OPEN,'(LAMBDA (X Y) ((HRRZ X 0 Y))));
  231. FLAG('(RPLACA RPLACD),'NOPENR);
  232. PUT('CAR,'ANYREG,'(LAMBDA (X Y) ((HLRZ!@ X . Y))));
  233. PUT('CDR,'ANYREG,'(LAMBDA (X Y) ((HRRZ!@ X . Y))));
  234. COMMENT PDP-10 interpreter function register use;
  235. FLAG( '(
  236. CAR CDR RPLACA RPLACD
  237. ATOM CLOSE CODEP CONSTANTP EJECT EQ FIXP FLOATP GET IDP LINELENGTH
  238. LPOSN NCONS NOT NUMBERP NULL PAGELENGTH PAIRP POSN REMPROP REVERSE
  239. STRINGP TERPRI VECTORP XCONS UPBV
  240. !*LAMBIND!* !*PROGBIND!* !*SPECRSTR!* BIGP INUMP RECLAIM TYO UNTYI
  241. ),'ONEREG);
  242. FLAG('(
  243. ABS ATSOC CONS FIX FLOAT GETD GETV LENGTH PRINC PUTV PUT REMD
  244. !*BOX ASCII BINI BINO DELIMITER EXAMINE EXCISE FILEP GCTIME IGNORE
  245. LETTER MKCODE NUMVAL RDSLSH SCANSET SETPCHAR
  246. SPEAK TIME
  247. ),'TWOREG);
  248. COMMENT Code for counting macro execution use;
  249. FLUID '(MCPROCS !*COUNTMC);
  250. SYMBOLIC PROCEDURE RESETMC U;
  251. BEGIN SCALAR L;
  252. !*COUNTMC := U;
  253. FOR EACH L IN MCPROCS DO <<SET(L,CDR (131072 + 1));
  254. % FWD of a fresh FIXNUM;
  255. DEPOSIT(!*BOX EVAL L,0);
  256. % FWD = numeric 0 now;
  257. PUT(L,'MCCOUNT,0)>>
  258. END;
  259. SYMBOLIC PROCEDURE COUNTMC L; LIST LIST(118800,0,LIST('FLUID,L));
  260. SYMBOLIC PROCEDURE PRINTMC;
  261. BEGIN SCALAR SM;
  262. SM := 0;
  263. PRIN2 "DYNAMIC COUNT:";
  264. TERPRI();
  265. FOR EACH L IN MCPROCS DO <<PRIN2 L;
  266. PRIN2 " ";
  267. SM :=
  268. PRINT (CAR 131072 . EVAL L) + SM>>;
  269. PRIN2 "DYNAMIC TOTAL: ";
  270. PRINT SM;
  271. TERPRI();
  272. PRIN2 "STATIC COUNT:";
  273. TERPRI();
  274. SM := 0;
  275. FOR EACH L IN MCPROCS DO <<PRIN2 L;
  276. PRIN2 " ";
  277. SM := PRINT GET(L,'MCCOUNT) + SM>>;
  278. PRIN2 "STATIC TOTAL: ";
  279. PRINT SM
  280. END;
  281. MCPROCS :=
  282. '(!*ALLOC
  283. !*DEALLOC
  284. !*ENTRY
  285. !*EXIT
  286. !*LOAD
  287. !*STORE
  288. !*JUMP
  289. !*JUMPE
  290. !*JUMPN
  291. !*JUMPT
  292. !*JUMPNIL
  293. !*LBL
  294. !*LAMBIND
  295. !*PROGBIND
  296. !*FREERSTR
  297. !*LINK
  298. !*LINKF
  299. !*LINKE
  300. !*RPLACA
  301. !*RPLACD);
  302. RESETMC NIL;
  303. SYMBOLIC PROCEDURE LAPPRI U;
  304. BEGIN
  305. A: IF NULL U THEN RETURN NIL;
  306. PRIN1 CAR U;
  307. U := CDR U;
  308. IF NULL U THEN RETURN NIL;
  309. SPACES2 24;
  310. PRIN1 CAR U;
  311. U := CDR U;
  312. IF NULL U THEN RETURN NIL;
  313. SPACES2 48;
  314. PRIN1 CAR U;
  315. TERPRI();
  316. U := CDR U;
  317. GO TO A
  318. END;
  319. SYMBOLIC PROCEDURE SPACES2 N;
  320. <<IF POSN()>N THEN TERPRI(); SPACES(N-POSN())>>;
  321. END;