From c72c810b2f4b0832a87c4601614ae969bfdda663 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Wed, 18 Jan 2017 16:14:13 -0800 Subject: [PATCH] Updated to build compiler from source. Resolves #383. --- bin/comlap/cd_fas.40 | Bin 0 -> 20375 bytes build/build.tcl | 20 + src/comlap/cdmacs.40 | 228 +++ src/comlap/comaux.25 | 2379 ++++++++++++++++++++++++++++++++ src/comlap/complr.936 | 3061 +++++++++++++++++++++++++++++++++++++++++ src/comlap/faslap.392 | 860 ++++++++++++ src/comlap/initia.120 | 838 +++++++++++ src/comlap/maklap.80 | 1187 ++++++++++++++++ src/comlap/phas1.86 | 2573 ++++++++++++++++++++++++++++++++++ src/comlap/srctrn.20 | 287 ++++ 10 files changed, 11433 insertions(+) create mode 100755 bin/comlap/cd_fas.40 create mode 100755 src/comlap/cdmacs.40 create mode 100755 src/comlap/comaux.25 create mode 100755 src/comlap/complr.936 create mode 100755 src/comlap/faslap.392 create mode 100755 src/comlap/initia.120 create mode 100755 src/comlap/maklap.80 create mode 100755 src/comlap/phas1.86 create mode 100755 src/comlap/srctrn.20 diff --git a/bin/comlap/cd_fas.40 b/bin/comlap/cd_fas.40 new file mode 100755 index 0000000000000000000000000000000000000000..8de68201745794a2a0348fb4a8bd2dd78773e423 GIT binary patch literal 20375 zcmb_k4QyQ1m40^y+d<)H(j<*d_!%HTa5BMm_)Q4-dFG8hc;?N^yqVZeNO6D^0;LH* zhLr!Rs@SUSRtQy9)kRf>x>Z&6Z&6is5kja!sH&=}s=5`bP`6^cRjFFCl+fM&WzYAW z``&#s9;c~xjr=(G-gC}9fA`#T?|aVM|NPX>)$c@;-tNxm{?X1c&+|+iw0C=e^5sgy zFUNa=R@js#`^@f6vmFrc%CV#mgN773Dwcp8I}J4m^cc`HJ_bmiZG34g>-DTrt8fz5J~H|rd3Ykw`%Q~2m|<$X3Jk_ zMnPzsaU3+J>cU3J+ELv>^ zidxOcQdByPNNKBks+M*}RG(=!XLYu6s#duk_+clCqq@^v7{@^+naGsu!h2d35RJ-> zc)D7v2eD-pwiVNqn^V-*>L$ka>kuOks59T~O1Odyh5*&-e!JETOVzqRU2cYg8l&0v zX)1L}!b*^XRw-`#?SKrxKB~8R*@u+~a*0#|h0Uo{$gt90h^!wu+6m)oGTI9K3TIXO zwf$+;vf{V>Ol(wYadR$&jffXit1&s4pjj>jdy=Th1(pCG~>rJltu8`f#A_srFOG~ zaN%rKKUV)6Kv4$-Iv@^YR}oJmj%1NEq)8dc{l zl%MveOF^qOB}SgLLYwIzj9NjpHn04qs|#fdr6D@qoNCRoMb6XBYP0F4oNk7}1P5m7 zzS8DrI^paDR2Jta6V)m~*siq~XdBPeWWBb;Q!S30TB8~J>Dn^25C%|GF|1uy$QxW9xjHEJa3Y|k@%g!c{ z@BvEX$8ozP-sF_oKAB3%qLv1hCe?aP<*_-Ih5_C{!=Hs_l9&BXy)6r&y`aX%XkJHC z>vAIL>x5IyPN)Ig@S|X!QwkJMIe{AG`BJ;(m(_I!x~de499M!p2~?xEO{24SZ=J~w z0|Q|&SL(NJ)EZ$u+@t;l)ShXJ{m3tDibBp6VW(czO(g7K7lRJOYu5L))Ok&WiuOhE zLITMs^%bjYidC{`yj)g&1&U?6l>bN@jmv_uP+b>{iN@>oa)8iF2IAcoic&6-_T{5- zyUj^#SN5nF(L@9x#OIMDlW}??GbN%``6XG^L@mGFX29zJwu=-ZGeK!iCt(iG($u_b z@#0wR673PcWM+d!h_X9ws7CqSom#sjyMv^XrXX_^3rb~f1>6tVkcnEsv~>VAlBQ%M zfJzps(F9MnypU!~C(pM!k}(=Vsa|VHQYJ-rU&L8*v0tl~8j?;*;z_AB;BT+#lr1Y`x+M@dFhkjYc^tP zP7XQOR}0%xKtg=58t5G;Ra;sZq@&j{WKtr$mByz+F@vJX;2pu#B4%_K#o?4FWm zK!G14o3L%V$u+4ef}n_R(i(_PNs3)+B-^OfZOV^rDxC`AHufd`F=%T2ONts06#@e1 z)n-kageV`O)E_34vRQLZC^h-Cjy7ez5|UgOG8~O;XQ9^UqPSmnYDwUfq?nh@krd_f zSOV2WI_+yV>bgA%a-9{sRDI%KsmrZ0s5r%92}M;l5akCbQA=hGw3&pnhcZ<18%R>lXyEw3)Fj|B`5i!C9?%e=)83W` z51*%_Nd-CYAW+Uk-w>d)0a4X8fKEr>T0mz4S`WzJu^P<{fX)Ck0_b;uHUc^e(0PE) z26O?S0-y^4(M%TudJp<80kjs-Wq{TJx*X7YKwAL47f=b%20&K;8V1DJ9Rai*edhqW z3eZMC*8n;f&~<>$1GE#+`G9r-x&RRUR0Jdr7a;+0`CSBvY2{)-)AH+W0>o&&1Q4nh z?@~bY$z_1JgKP%0TYkOE0U_4CQ9vxWwg8$#-&R0e-z7l%(6lJxH=wK0cMqUz038N&Eueb=T?goXKsx{}0on=ZAwbsy z`VgR9fF1#K1E9wM-3aIjK$Czz42Z%15kOPu`zRo$ho=CsF8&yx0HYrVR0Z@&K+}Le z1!xA)(|~G#o&j_dpicvu1@sv}EXF z7XZDlAP=Ivh~_OAcoC16&|C!cGN1#1z6mn3ca12pfz=nnyH!{bgge+1|dpdSOe3(!vh-3{m~c>ENzt(RZ#Ry;nC z=9kw9q3@ow?`LV>2h+aS)4sz%zO^6^Ca9mM14mNiU!;BarhRXuefOn(zfAk?Py2qA z_C1jH{TeE~%6ZY32eg!q{wAe(kPt*$4HPa!X2RFd{2d<5W|siE8jnMG+=vHvT?X85 z(R>I~z6Dl8faqko_p_<=zc9cZ;zJmvK#S<3Nq#SY{oyDcl>T8r$1(H>^+59vXg*qy z2WkHY&BxN_pU`|9cz+=Uns1?bLVk^xa4`l=laLt-^f>x*M8SaWDMZ0T2L#ZhioM4S zq@$E&BSt;;$^Q*ehS(Hj758~S8QMf3n#7zYgSz3WXrNt{T%YDq0%tBwfor7VV9|{R znvJR2wCta;ZAv{}3oF5VrVyN}g=M{+D0f;dDfZ={K%vrRO7EFUr7f+9+=RV0mAN#9 zxV3;vg_(u7UOF!%b(e3v+|p|VSC7i6T5oMlHLh3ddS-+Qasf1@cctKkW+!fuEt+*d zmb)~WmNJ`qr5ZMfC&w;V6$_pm5n6uTN}e=Da#ynniWLFsOYyJr;F3hHdPHkIo*Ge4 z?m){{1jEx@Vv+PPmQ3X6$h1=xJt?0Yw}L7yo7y0+XRh>CiFl)G<776}<#GqcgeXEz z)thn=7*4l&vuLJ-f6x+-S`Rks^`I>Gv2qGa7--O7X0m6qR>dWj{LnMFM9bO*C@?_= zMS`efLkgo|Ff9kvlmYIe#)+-hn9`icH0zes%OMoQHm(E3z}Z_lxwF9qp{)YNTX7o~ zUsb<7Bo@hni3!sx#kK$R11}^LHw8zK-&SG1L!J18v&tIHrJqua@Sl32<5KX z2?*t`*#+nVK-is35s(k5pdd>Ivjt5i{=pPlpF$U=5Y0|Q&?Gd|nFXO80INme%(BEV zCFs^8U53^4ao}MyFadyz*~EjJA1WL(Ee}uefWm@Xn~)&ShXAZ^?G6J9Y*FSkFgU#c zFntVQgTPO&DobrfUqv+JdYLN}qz1>+cxg*#6zjp%&_{NckO^pYXG}O5$yIi-5tsBu zzT*Hcn9R!mH54ud$`Cl^QhFiSUabZ7ie?FEUfJEeN}C`xvg}&k-rOpI@w4wVf%Xo{ zW8bP_fzFi2zT9T?$zvay$Ny2t_T~hVpF(~gXxX>*S{cA2hvvY$|MH|aGAgDwrLBUA z*~YzL@AiCgQ&CP_=)=!Q@w7YMdfYYNIb9NrYp$9+!y7xkD75c><4Nz59)A5;9a|in zJm44>^>TrF;~{L%xHqPQ>g22KHpm?y4_ z>LsxQb!TXgf(g_85a=1&pfd7G!CnK(mR0GiO7S9*ouQcb&hREEF=)rP&I<#l!12i^ zy}TPOZt~2QyqR3oJ|XZ%+^BG@+B+kGk(vg8+;T~oA@|af)R4Q5MYj*GrhUNV7Vbn( zJ)A4vu}O}!sS?A`X)JAySaptQ{NMJ+H{bjswk}!ocWy1ptJw>C)j0qudeniK`GlZX zlLNr#eT>sYy11c4EYMUZnM~*6nVnn91n1&IG%5V`pQ69MpaQ>F7A!K(RTLQWn_4^O z`@2lqIY?4W)@^#?s+>Zq20sWM+ri0+NxlIR5+RvECA5&x#kkw=)MDy+f zC{hX6-RGaV%SsrjgeZ*UY!;Nq$0C4BJ8oKyJDf}oyqZif=&UIiUS6qEIYGtrcQv4U zfYKu-2{4!uQ?Sf61w2zR*XF&;)><*|R57m=1d2JKVuFcVYKKV=6er=_(b7Bk_88Okkw*ZPRF)vmzH+U-Mb%G`d%x_ic4V4gG*O649jD%!7BXgT8pPb* zcuz%wJ}yaB0D0w%(XhJPB@(xxyz5CKBI7=}_X0;@O*X71+cCFgl6s4KVK|vF6MH)f z!mwY~A#UnZXSW@or{9M_%B^=ry9vTzF;gBUrNqj18AOhzfUwnq-p*v#7ldKIP$RAjHI|bgWv;s(5Vr(pJTT%F-_r(fFA^-aAsGMfQrXoIP1AX>AD&|byL_P<^ZRd4V!Z%xe6@dWimep%w*O_ zlDT{GR<4^$t%D*M#hh-ek3ixZFom-WT5{jg(62-B0^1fbE7f;f^6SosTor>$2$jSj zGw}1S$|*K46fd1vzeabIVY>-G3`!HU>hf(S zF5i}RbVlWrm(}ybqz9hUQ!wOMr&P;S{ICofA1K`_8hpFNAB6Q(khCzr{ay$r_6)zz z6v%u8ttn21$0blvqm+0+`KWYxA$8{i808fx%tsv_?D6N%92$F__W0A+z9uF8uq~J$ z0sVj&q!X3OxTh@Pr8@5?mxsYq1xzWw8S|i#?@zzXT2BeCsbEHDEwH31_>Ks-TztW2 zJ_hJE`Q?1oy*IV~aY65>Wt*P_)>{%}AfEof%_>A zU~mRdMiYipPoH4$nn%hhQSpZRFRKUECr4C8y#2zx`g|#5pf6pg#dk)rrwc#h$lb{6Kv2@ju54C*eWO9%|X)FR_B?c4_i+TjVG#sJOOk&^*1;JbMypK#;g9 zmF8J+Ypx*8g-$+XSqAr0;% z`q;+oN~JmBY;%rov3$cMF97GGu}sJaBlCqmfFz9ND9EJ;K2vj^b0uVWl zcy2KPH6~jt%sq)PdLlD?A7{e!i#4!y$>&QX1>0_ka*iN%6D>-$R-%&JA3EXC-{~V9nI{BRG*I#E(*g7qpg6hE zl0RLDswnUQMQ@3(Upq^7k8DE9QFiMV{!y0r@MQlN@4D zpnu(|QXDA`7NOp}>jS$U%Z%n0vj-b6`6da*@B#`1nbS$nkpSEm9Ct~v|2|-iC%NR9 zw~8-t6XSJ%wy zaZF8r&D@qw5#p!v3y3M4{NFBM6e!Ds7xE|33o6S0ZQ$Q5&5Zrgl4U4QLN^Ft-!`SM zJCEHyIC+p}2MX>6&3C%Jkcm-2G0&kS;p)9()4@k^AYB~m2~_xQzhmOKGe*Vlt22ky zofDpjh=!F7Cf#Pf=TeYspyro)Zs24!=KH-!xlnYcRY_BQs zjts(P>|upnRIl>%kqEmiAYbewEQCnpOjeZisY73cocI)nmIgId_Fyb;MYneIHyce)#aAhQwmM3%h2wrL(V?R|gUZ}n@MKi8)D9bj**wcNdW zy$6(@SX65*cke6Uc3U6!^6n9QdbTOr?(bJys+C1scbzL)Uk=XvoQIkqf6GMhpi5@2 z79be}SguLmg#Rk=Z(m6h`u+bSxlf#Ga;M+_o)__2p7g%dIM=5Bn_vm}9m+4urr-M; z)=C@?8*^EI58Mu}WUb^bw|93-a}Hme_hwUY(?r@oK}G8K4mFXJi7L|L_wTQyNkU*( ze5%R!p~?IEXp-}12K7TGV8rRZAp7*u%>6k0)L)Zihg-HUoGUvVBADeJb~yeqQzm$S zu#ytQO>-7ir#pTC5&2?u2&CK%{kDd-`8rfjnNifq_$%q_y4b&`A)0&wYC zHKlbC23P#dKwKnLsgFcXJ=Yxq^kazaT+~&1{GaXbr}|&}@WX4?I{i<<>d?)E3q0`;hgb{$^=n>)bds^~T?L>3uP1{m z)p85p1^SbV#Cb^hBSz|?KSc-7wHO#fMAP<*Y zE<5x3qr>UU!<%smhaz0o1H=XXJ@T-m-Ski1bk?LJKl%F39N5p38`@)XVE;Ym63gSC zLa;u|I88>)&k`XrPJ=YL3{~PYk}?_pOfbv`!QDB{t#r`$)I_wQt1N-h&n*Kkde=OA zze~Quo8{9K#8IzrPSGuD>Xi9APhR@k^Rz3zAShBADAUg^N=hrG^t*PpZoKdm{L)*g zoTs~DZU8g#QdV;V6mxam>zoWIJy`+wv6;jRDthB}a62r`zTS|M&MpREu=>dCMIhyu z0X(3;(|x@Lf*zabTkF&kC*C;xV(pYti0nHOlDP}X6W_DestYC7+}S)Lqvq!Y2qnK6 z{pUvQoqDc|)J7(#Xo;VL@(8AIafufH#fb?4G2BnXf|7 zt|J<59P zhXZm4tMp^4Ue|XOHO2t z$BOD~9P^`tebP-vC+jSmX{FW`DdZnwu>WEM1aqtMx11X&&SUQNmr|vgft0KAw_y1Y zBzB5{1;4uFlDn6D`M~R*4<5LFoqZ2+zD=~bGy qWY8Q1ij!vZ6^qiA9~B9Mnp6t{@h$2$5vif3y1*u|g}3o9^8GJf!2*r| literal 0 HcmV?d00001 diff --git a/build/build.tcl b/build/build.tcl index 0df98358..5f26b936 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -1218,6 +1218,26 @@ expect ":KILL" respond "*" ":midas sys2;ts xhost_sysen3;xhost\r" expect ":KILL" +# compile lisp compiler +respond "*" ":link comlap;cdmacs fasl,cd.fas >\r" +respond "*" "complr\013" +respond "_" ".temp.;_comlap;comaux\r" +respond "_" ".temp.;_comlap;complr\r" +respond "_" ".temp.;_comlap;faslap\r" +respond "_" ".temp.;_comlap;initia\r" +respond "_" ".temp.;_comlap;maklap\r" +respond "_" ".temp.;_comlap;phas1\r" +respond "_" ".temp.;_comlap;srctrn\r" +respond "_" "\032" +type ":kill\r" +respond "*" ":move .temp.;comaux fasl,comlap;cx.fas 25\r" +respond "*" ":move .temp.;complr fasl,comlap;cl.fas 936\r" +respond "*" ":move .temp.;faslap fasl,comlap;fl.fas 392\r" +respond "*" ":move .temp.;initia fasl,comlap;in.fas 120\r" +respond "*" ":move .temp.;maklap fasl,comlap;mk.fas 80\r" +respond "*" ":move .temp.;phas1 fasl,comlap;ph.fas 86\r" +respond "*" ":move .temp.;srctrn fasl,comlap;st.fas 20\r" + # ndskdmp tape respond "*" ":link kshack;good ram,.;ram ram\r" respond "*" ":link kshack;ddt bin,.;@ ddt\r" diff --git a/src/comlap/cdmacs.40 b/src/comlap/cdmacs.40 new file mode 100755 index 00000000..e4546335 --- /dev/null +++ b/src/comlap/cdmacs.40 @@ -0,0 +1,228 @@ +;;; CDMACS -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ** (Declarations and Macros for COMPLR) ******** +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + +(SETQ CDMACSVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/40))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + + +(COMMENT MACROS WHICH DO DECLARATIONS FOR COMPLR ITSELF) + +(EVAL-WHEN (COMPILE) (MACROS 'T)) + + +(DEFUN COMPDECLARE MACRO (L) + (SPECIAL + ACSMODE ARGLOC ARGNO ARITHP ARRAYOPEN ASSEMBLE ATPL ATPL1 BVARS + CAAGL CARCDR CCLOAD:INITIAL-PROPS CDMACSVERNO CDUMP CFVFL + CHOMPHOOK CL CLEANUPSPL CLOSED CLPROGN CMSGFILES CNT COBARRAY COMAL + COMAUXVERNO COMP COMPILATION-FLAGCONVERSION-TABLE COMPILER-STATE + COMPLRVERNO CONDP CONDPNOB CONDTYPE CONDUNSF CREADTABLE CTAG DATA + DISOWNED EFFS EOC-EVAL EOF-COMPILE-QUEUE EOF-SEEN ERRFL EXIT EXITN + EXLDL EXPAND-OUT-MACROS EXPR-HASH EXTEND-FILES-TO-LOAD FASL FASLPUSH + FBARP FILEPOSIBLE FILESCLOSEP FIXSW FLOSW FLPDL FXPDL GAG-ERRBREAKS + GENPREFIX GFYC GL GOBRKL GOFOO GONE2 HLAC HUNK2-TO-CONS IDENTITY + IGNOREVARS IMOSAR INFILE INITIALIZE INITIAVERNO INMLS INSTACK IOBARRAY + IREADTABLE KTYPE L-END-CNT LAP-INSIGNIF LAPLL LAPOF LDLST LERSTP+1 + LINEL LINEMODEP LMBP LOCVARS LOUT LOUT1 LPASST-FXP LPASST-P+1 LPRSL + MACROLIST MACROS MAKLAP-DEFAULTF-STYLE MAKLAPVERNO MAKUNBOUND MAPEX + MAPSB MCX-TRACE MODELIST MSDEV MSDIR MUZZLED NEW-EXTEND-FILES-TO-LOAD + NLNVS NLNVTHTBP NOLAP NULFU NUMACS OLVRL ONMLS OPSYS OPVRL + OUTFILES P1CCX P1CSQ P1GFY P1LL P1LLCEK P1LSQ P1PCX P1PSQ + P1SPECIALIZEDVS P2P PHAS1VERNO PKTYP PNOB PRATTSTACK PROGN PROGP + PROGTYPE PROGUNSF PRSSL PVR PVRL QSM QUIT-ON-ERROR READ RECOMPL REGACS + REGPDL RNL ROSENCEK RUNTIME-LIMIT RUNTIME-LIMITP + SAIL-MORE-SYSFUNS SAVED-ERRLIST SFLG SLOTX SOBARRAY + SPECIAL SPECIALS SPECVARS SPLDLST SPLITFILE-HOOK SQUID SREADTABLE STATE + STSL SWITCHLIST SWITCHTABLE SYMBOLS TAKENAC1 TOPFN TTYNOTES TYO UNDFUNS + UNFASLCOMMENTS UNSFLST UREAD USE-STRT7 USERATOMS-HOOKS + USERATOMS-INTERN USERATOMS-INTERN-FROB USER-STRING-MARK-IN-FASL + UWRITE VGO VGOL VL YESWARNTTY + ) + (*FEXPR + *EXPR *FEXPR *LEXPR ARRAY* CGOL EREAD EVAL-WHEN FIXNUM FLONUM + INITIALIZE MAKLAP NOTYPE SPECIAL UNSPECIAL + ) + (FIXNUM + AC ARGNO BASE BESTCNT BESTLOC CNT HLAC IBASE I II + LINEL M N NARGS NLARG NOACS P1CNT RSTNO TAKENAC1 VALAC + ) + (FIXNUM + (COM-AREF) (CC0) (CLLOC) (COML1) (COMLC) (COMARRAY) + (CONVNUMLOC FIXNUM) (FRAC) (FRAC1) (FRAC5) (FRACB) + (FREENUMAC0) (FREENUMAC1) (FREENUMAC) (FREEREGAC) + (LOADINREGAC) (LOADINSOMENUMAC) (LOADINNUMAC NOTYPE FIXNUM) + (OUTFUNCALL) (P1TRESS) (ZTYI) + ) + (*EXPR CARCDR CC0 CLEANUPSPL COMP COMPLRVERNO MCX-TRACE NARGS + P1GFY P1SPECIALIZEDVS SPECIALS UNSAFEP ELOAD UGREAT1 + ) + (*LEXPR PNAMECONC CDUMP EOPEN) + (APPLY 'ARRAY* (SUBST () () '((NOTYPE (BOLA 9 7) (STGET 10.) (CBA 16.) + (PVIA 3 17.) (A1S1A ? 4) + (AC-ADDRS 11.) (PDL-ADDRS 3 193.))))) + (FIXSW 'T) (CLOSED () ) (GENSYM 0) + (SETQ USE-STRT7 'T) + '(COMMENT COMPDECLARE)) + + + + + +(DEFUN FASLDECLARE MACRO (L) + (SPECIAL + ALLATOMS AMBIGSYMS ATOMINDEX BINCT CURRENTFN CURRENTFNSYMS DDTSYMP + DDTSYMS ENTRYNAMES EXPR FASLEVAL FASLPUSH FASLVERNO FILOC FSLFLD + IMOBFL IMOSAR IMOUSR LASTENTRY LDFNM LITCNT LITERALP LITERALS + LITLOC *LOC MAINSYMPDL MAKUNBOUND MESSIOC MSDIR SQUIDP SYMBOLSP + SYMPDL UFFIL UNDEFSYMS UNFASLCOMMENTS UNFASLSIGNIF + ) + (*EXPR + *DDTSYM ARGSINFO ATOMINDEX BLOBLENGTH BUFFERBIN COLLECTATOMS + FASLDEFSYM FASLDIFF FASLEVAL FASLINIT FASLMAIN FASLMINUS + FASLNEGLIS FASLPASS1 FASLPASS2 FASLPLUS FASLVERNO + INDENT-TO-INSTACK LAPCONST LISTOUT LREMPROP MAKEWORD MESOUT + MOBYSYMPOP MSOUT MUNGEABLE REMPROPL SUBMATCH + ) + (FIXNUM (BLOBLENGTH) (ATOMINDEX) (ARGSINFO) + (RECLITCOUNT) FILOC *LOC LITLOC LITCNT BINCT) + (ARRAY* (NOTYPE (LCA 16.) (BSAR 9.) (NUMBERTABLE 127.)) + (FIXNUM (BTAR 9.) (BXAR 9.))) + (MAPEX T) + '(COMMENT FASLDECLARE)) + + + +(COMMENT MACROS THAT COULD BE IN-LINEABLE-EXPRS) + +(DECLARE (MACROS () ) + (SETQ DEFMACRO-CHECK-ARGS () ) + (SETQ DEFMACRO-DISPLACE-CALL () ) + (SETQ DEFMACRO-FOR-COMPILING 'T)) + + +(DEFMACRO OUTFS (a1 a2 a3 &optional a4 a5) + (cond ((null a4) `(OUT3FIELDS ,a3 ,a2 ,a1)) + ((null a5) `(OUT4FIELDS ,a4 ,a3 ,a2 ,a1)) + ('t `(OUT5FIELDS ,a5 ,a4 ,a3 ,a2 ,a1)))) + + +(DEFMACRO NCDR (l n) `(NTHCDR ,n ,l)) +(DEFMACRO EQUIV (a1 a2) `(COND (,a1 ,a2) ((NULL ,a2)))) +(DEFMACRO /2^N-P (n) `(ZEROP (BOOLE 4 ,n (- ,n)))) +(DEFMACRO INVERSE-ASCII (char) `(GETCHARN ,char 1)) +(DEFMACRO |Oh, FOO!| () `(OUTPUT 'FOO)) +(DEFMACRO ITSP () `(EQ OPSYS 'ITS)) +(DEFMACRO SAILP () `(EQ OPSYS 'SAIL)) +(DEFMACRO DEC10P () `(EQ OPSYS 'DEC10)) +(DEFMACRO DEC20P () `(EQ OPSYS 'DEC20)) + + +(DEFMACRO BARF (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'BARF ,a1 ,a2)) +(DEFMACRO DBARF (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'DATA ,a1 ,a2)) +(DEFMACRO WARN (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'WARN ,a1 ,a2)) +(DEFMACRO PDERR (item msg) `(MSOUT ,item ',msg 'ERRFL 4 6)) + + +(DEFMACRO KNOW-ALL-TYPES (a1) + `(COND ((NULL ,a1) () ) + ((MEMQ ,a1 '(FIXNUM FLONUM))) + ((NOT (MEMQ '() ,a1))))) + +(DEFMACRO INITIALSLOTS () + `'((() () () () () ) ;REGACS + (() () () ) ;NUMACS + (() () () ) ;ACSMODE + () ;REGPDL + () ;FXPDL + () ;FLPDL + )) + + +(DEFMACRO ERL-SET () + `(OR (MEMBER '(COMPLRVERNO) (SETQ ERRLIST SAVED-ERRLIST)) + (PUSH '(COMPLRVERNO) ERRLIST))) +(DEFMACRO SETUP-CATCH-PDL-COUNTS () + `(SETQ LERSTP+1 13. LPASST-P+1 6. LPASST-FXP 11.)) + +(DEFMACRO CLEARALLACS () `(CLEARACS0 'T)) +(DEFMACRO NO-DELAYED-SPLDS () `(CSLD (SETQ CCSLD 'T) 'T ())) + +(DEFMACRO MAX-NPUSH () `'16.) +(DEFMACRO MAX-0PUSH () `'8) +(DEFMACRO MAX-0*0PUSH () `'8) + + + +(DEFMACRO NACS () `'5) +(DEFMACRO NUMVALAC () `'7) +(DEFMACRO NUMNACS () `'3) +(DEFMACRO NACS+1 () `'#.(1+ (NACS))) + +(DEFMACRO FXP0 () `'-2048.) ;2^11. Bit implies REGPDL +(DEFMACRO FLP0 () `'-4096.) ;2^12. Bit (with 2^11. off) implies FXPDL + +(DEFMACRO NPDL-ADDRS () `'192.) + +(DEFMACRO REGADP-N (n) `(LESSP #.(FXP0) ,n #.(NUMVALAC))) +(DEFMACRO REGACP (x) `(AND (SIGNP G ,x) (< ,x #.(NUMVALAC)))) +(DEFMACRO REGACP-N (n) `(LESSP 0 ,n #.(NUMVALAC))) +(DEFMACRO REGPDLP-N (n) `(LESSP #.(FXP0) ,n 1)) +(DEFMACRO REGPDLP (x) `(AND (SIGNP LE ,x) (> ,x #.(FXP0)))) + +(DEFMACRO PDLLOCP (x) `(SIGNP LE ,x)) +(DEFMACRO PDLLOCP-N (n) `(NOT (> ,n 0))) +(DEFMACRO ACLOCP (x) `(SIGNP G ,x)) +(DEFMACRO ACLOCP-N (n) `(> ,n 0)) + +(DEFMACRO NUMACP (x) `(AND (SIGNP G ,x) (NOT (< ,x #.(NUMVALAC))))) +(DEFMACRO NUMACP-N (n) `(NOT (< ,n #.(NUMVALAC)))) +(DEFMACRO NUMPDLP (x) `(AND (SIGNP LE ,x) (NOT (> ,x #.(FXP0))))) + +(DEFMACRO NUMPDLP-N (n) `(NOT (> ,n #.(FXP0)))) +(DEFMACRO FLPDLP-N (n) `(NOT (> ,n #.(FLP0)))) + +(DEFMACRO PDLAC (mode) + `(COND ((EQ ,mode 'FIXNUM) 'FXP) + ((NULL ,mode) 'P) + ('FLP))) +(DEFMACRO PDLGET (mode) + `(COND ((EQ ,mode 'FIXNUM) FXPDL) + ((NULL ,mode) REGPDL) + (FLPDL))) +(DEFMACRO ACSGET (mode) `(COND (,mode NUMACS) (REGACS))) +(DEFMACRO ACSSLOT (n) + `(COND ((= ,n #.(NUMVALAC)) NUMACS) + ((= ,n #.(1+ (NUMVALAC))) (CDR NUMACS)) + ('T (CDDR NUMACS)))) +(DEFMACRO ACSMODESLOT (n) + `(COND ((= ,n #.(NUMVALAC)) ACSMODE) + ((= ,n #.(1+ (NUMVALAC))) (CDR ACSMODE)) + ('T (CDDR ACSMODE)))) +(DEFMACRO NACSGET (mode) + `(COND ((NULL ,mode) #.(1+ (NACS))) + ('T #.(1+ (NUMNACS))))) +(DEFMACRO NULLIFY-NUMAC () + `(PROG2 (RPLACA NUMACS () ) () (RPLACA ACSMODE () ))) + + +(DEFMACRO ILOCREG (x acx) `(ILOCMODE ,x ,acx '(() FIXNUM FLONUM))) +(DEFMACRO ILOCNUM (x acx) `(ILOCMODE ,x ,acx '(FIXNUM FLONUM))) +(DEFMACRO ILOCF (x) `(ILOCMODE ,x 'FRACF '(() FIXNUM FLONUM))) +(DEFMACRO ILOCN (x) `(ILOCMODE ,x 'ARGNO '(() FIXNUM FLONUM))) +(DEFMACRO FREACB () `(FREEREGAC 'FRACB)) +(DEFMACRO FREAC () `(FREEREGAC 'FRAC)) diff --git a/src/comlap/comaux.25 b/src/comlap/comaux.25 new file mode 100755 index 00000000..edc1ec99 --- /dev/null +++ b/src/comlap/comaux.25 @@ -0,0 +1,2379 @@ +;;; COMAUX -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ***** LISP COMPILER (Auxilliary funs) ********** +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + +(SETQ COMAUXVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/25))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + + +(EVAL-WHEN (COMPILE) (COMPDECLARE) (GENPREFIX |/|ax-|)) + +(COMMENT AUXILIARY FUNCTIONS - alphabetical order) + + +(DEFUN 1FREE () (NOT (DVP1 REGACS 1))) + +(DEFUN 1INSP (VAR) + (COND (#%(NUMACP-N ARGNO)) ;Tries to figure out if a variable is LOADAC-able + (((LAMBDA (MODE) ; in only one instruction; rets CLPROGN if on NUMPDL + (COND ((NULL MODE) (OR CONDPNOB (NOT (MEMQ VAR UNSFLST)))) + ((NULL CONDPNOB) () ) + ((CLMEMBER VAR () #%(PDLGET MODE) 'EQ) CLPROGN))) + (VARMODE VAR))))) + +(DEFUN 6BSTR (X) + (AND (NOT (SYMBOLP X)) (SETQ X (MAKNAM (EXPLODEN X)))) + (DO ((I 1 (1+ I)) (N 0) (ZZ () (CONS N ZZ))) + ((ZEROP (SETQ N (GETCHARN X I))) (MAKNAM (NRECONC ZZ '(/!)))) + (COND ((OR (= N 35.) (= N 94.) (= N 33.)) (SETQ ZZ (CONS '/# ZZ))) ;CHECK FOR # ^ ! + ((LESSP 31. N 96.)) ;VALID SIXBIT + ('T (SETQ ZZ (CONS '/^ ZZ)) ;ELSE CONTROLIFY + (AND (= N 13.) (= (GETCHARN X (1+ I)) 10.) (SETQ I (1+ I))) + (SETQ N (BOOLE 6 N 64.)))))) + + +(DEFUN ACSMRGL (X) (ACMRG REGACS NUMACS ACSMODE (CAR X) (CADR X) (CADDR X) () )) +(DEFUN ACMRG (LL ZZ MM L Z M F) ;Merge ACCs off L onto LL if F = (), + (DO ((LL LL (CDR LL)) ; set LL from L if F = T + (L L (CDR L)) + (N #%(NACS) (SUB1 N))) + ((ZEROP N)) + (COND (F (RPLACA LL (CAR L))) + ((NULL (CAR LL))) + ((NOT (EQUAL (CAR LL) (CAR L))) (RPLACA LL () )))) + (DO ((A1 MM (CDR A1)) + (A2 M (CDR A2)) + (N #%(NUMNACS) (SUB1 N)) + (LL ZZ (CDR LL)) + (L Z (CDR L))) + ((ZEROP N)) + (COND (F (RPLACA LL (CAR L)) (RPLACA A1 (CAR A2))) + ((NULL (CAR LL))) + ((NOT (EQUAL (CAR LL) (CAR L))) + (RPLACA LL () ) + (RPLACA A1 () ))))) + +(DEFUN ADD (X Y) (COND ((MEMQ X Y) Y) ('T (CONS X Y)))) + +(DEFUN ADR (X) + (CDR (COND ((NULL X) '(() . () )) + ((ASSQ X GL)) + ('T '(() . () ))))) + +(DEFUN ASQSLT (X) (OR (ASSQ X REGACS) (ASSQ X REGPDL) (ASSQ X NUMACS) + (ASSQ X FXPDL) (ASSQ X FLPDL))) + +(DEFUN MEMASSQR (X Y) + (DO Y Y (CDR Y) (NULL Y) (COND ((EQ X (CDAR Y)) (RETURN Y))))) + + +(DEFUN BADTAGP (TAG) + ((LAMBDA (TEM) + (OR (NOT (EQ (L/.LE/. REGPDL (CAR TEM)) 'EQUAL)) + (NOT (EQ (L/.LE/. FXPDL (CADR TEM)) 'EQUAL)) + (NOT (EQ (L/.LE/. FLPDL (CADDR TEM)) 'EQUAL)))) + (CDDDR (LEVEL TAG)))) + + +(DEFUN BOOLOUT (TAG FL) + (COND ((NOT (LESSP 0 ARGNO #%(NUMVALAC))) + (WARN () |Predicate in numerical argument position|) + (OUTPUT (SUBST ARGNO 'ARGNO '(MOVEI ARGNO 0)))) + (((LAMBDA (TEM) + (OUTPUT TEM) + (AND TAG + (COND (FL (AND (OUTTAG TAG) + (NOT (EQ LOUT1 TEM)) + (BARF TAG |Lost in BOOLOUT|))) + ('T (OUTPUT TAG)))) + (OUTPUT (BOLA ARGNO 2)) + (|Oh, FOO!|)) + (BOLA ARGNO 1) )))) + + +(COMMENT BOOL1 BOOL2 and BOOL3) + +(DEFUN BOOL1 (EXP TAG F) ;Compile general boolean form, JRST to TAG when + (PROG (PROP) ; result matches F, otherwise drop through + (SETQ PROP (AND (SYMBOLP (CAR EXP)) ;Return non-null only when + + (GET (CAR EXP) 'P1BOOL1ABLE))) ;unconditional JRST taken + A (COND ((EQ PROP 'T) + (COND ((COND ((EQ (CAR EXP) 'AND) + (BOOL2 (CDR EXP) TAG F 'T) + 'T) + ((EQ (CAR EXP) 'OR) + (BOOL2 (CDR EXP) TAG (NOT F) () ) + 'T)) + (SETQ CNT (PLUS CNT 2))) + ((EQ (CAR EXP) 'NULL) (RETURN (BOOL1 (CADR EXP) TAG (NOT F)))) + ((EQ (CAR EXP) 'COND) (COMCOND (CDR EXP) TAG F () )) + ((EQ (CAR EXP) 'EQ) (COMEQ (CDR EXP) TAG F)) + ((EQ (CAR EXP) 'MEMQ) + (AND F (RETURN (BOOL3 EXP 'T TAG F))) ;CLOSE-CALL, AND JUMPN + #%(LET (X Y LX (ARGNO 1) (A1 0) (A2 0) EFFS (OEFFS EFFS)) + (DECLARE (FIXNUM A1 A2)) + (SETQ X (COMP0 (CADR EXP)) Y (COMP0 (CADDR EXP))) + (SETQ EFFS OEFFS) + (SETQ LX #%(ILOCF X)) + (SETQ A1 (LOADINREGAC Y () () )) + (CLEARVARS) + (CONT A1 '(NIL . TAKEN)) + (CONT (SETQ A2 #%(FREACB)) () ) + (OUTJ0 'JUMPE A1 TAG () A2) + (AND (NOT (REGADP LX)) + (DBARF EXP |Numeric 1st arg to MEMQ?| 4 6)) + (AND (NUMBERP LX) + (NOT (EQUAL X (CONTENTS LX))) + (SETQ LX (ILOC0 X () ))) + (REMOVEB X) + (OUT1 '(HLRZ) A2 A1) + (OUT1 '(HRRZ) A1 A1) + (OUT1 'CAME A2 LX) + (OUTPUT '(JUMPA 0 (* -4))) + (CONT A1 () ) + A1)) + ((EQ (CAR EXP) 'SIGNP) (COMSIGNP (CDR EXP) TAG F)) + ((BARF () |Lost dispatch in BOOL1|)))) + ((NULL PROP) + (COND ((AND (EQ (CAR EXP) 'PROG2) (NULL (CDDDR EXP))) + (COMPE (CADR EXP)) + (RST TAG) + (RETURN (BOOL1 (CADDR EXP) TAG F))) + ((RETURN (BOOL3 EXP 'T TAG F))))) + ((EQ PROP 'NUMBERP) + (COND ((COND (CLOSED (NOT (MEMQ (CADR EXP) '(FIXNUM FLONUM)))) + ('T (NOT #%(KNOW-ALL-TYPES (CADR EXP))))) + (RETURN (BOOL3 EXP 'T TAG F))) + ((MEMQ (CAR EXP) '(GREATERP LESSP)) (COMGRTLSP EXP TAG F)) + ((EQ (CAR EXP) 'EQUAL) (COMEQ (CDR EXP) TAG F)) + ((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP ODDP)) (COMZP EXP TAG F)) + ((BARF EXP |Is this really P1BOOL1ABLE?|)))) + ((NOT (ATOM PROP)) (COMTP EXP PROP TAG F () )) + ('T (SETQ PROP 'NUMBERP) (GO A))))) + + +(DEFUN BOOL1LCK (EXP TAG F) + #%(LET ((T1 (BADTAGP TAG))) + (COND (T1 (BOOL1 EXP (SETQ T1 (LEVELTAG)) (NOT F)) + (OJRST TAG () ) + (SLOTLISTSET (LEVEL T1)) + (OUTTAG0 T1)) + ('T (BOOL1 EXP TAG F))))) + +(DEFUN BOOL2 (EXP TAG F ANDFL) ;Compile AND or OR + (COND (F (COND ((CDR (SETQ EXP (L2F (CDDDDR EXP)))) + (BOOL2LOOP (CDR EXP) (SETQ F (LEVELTAG)) (NOT ANDFL))) + ('T (SETQ F () ))) + (BOOL1 (CAR EXP) TAG ANDFL) + (OUTTAG F)) + ('T (BOOL2LOOP (CDDDDR EXP) TAG (NOT ANDFL))))) + +(DEFUN BOOL2LOOP (EXP BTAG B2F) (MAPC '(LAMBDA (EXP) (BOOL1 EXP BTAG B2F)) EXP)) + +(DEFUN BOOL3 (EXP FLAG TAG F) + (PROG (Z LARG LARGSLOTP FL MODE) + (SETQ Z (COND (FLAG (COMPR EXP () 'T 'T)) (EXP))) + (SETQ LARG #%(ILOCF Z)) + (SETQ LARGSLOTP (NUMBERP LARG)) + (AND LARGSLOTP (SETQ MODE (GETMODE LARG))) + (COND ((AND (NOT LARGSLOTP) + (EQ (CAAR LARG) 'QUOTE) + (OR (ATOM (CADAR LARG)) + (NOT (EQ (CAADAR LARG) SQUID)))) + (REMOVE Z) + (COND (#%(EQUIV (CADAR LARG) F) + (CLEARVARS) + (OJRST TAG () ) + (RETURN 'T)) + ('T (RETURN () ))))) + (COND ((NOT (REGADP LARG)) (REMOVE Z) (CLEARVARS) + (RETURN (COND (F (OJRST TAG () ) 'T))))) + (SETQ FL (RST TAG)) + (REMOVE Z) + (AND (OR (CLEARVARS) FL) + LARGSLOTP + (NOT (PLUSP LARG)) + (SETQ LARG (ILOC0 Z MODE))) + (OUTJ0 (COND (F 'JUMPN) ('JUMPE)) LARG TAG () LARG) + (RETURN () ))) + + +(COMMENT CARCDR) + +(DEFUN CARCDR (ITEM ACORFUN) ;Computes a CARCDR + (PROG (AC T1 2LONG T2 LT2 ACP N MATCHP TEM FL) ;Compilation - returns SLOTLIST + (SETQ ACP (NUMBERP ACORFUN)) ; number of resultant + (SETQ LT2 #%(ILOCREG (SETQ T2 (CDDR ITEM)) ;Typical item is (G0025 (D A D D) X . 5) + (COND ((AND ACP ; for (CDDADR X) + (SETQ N ACORFUN) ;If item is (G0025 + #%(REGACP-N N)) ; (CARCDR-FREEZE A D A D . . .) X . 5), + ACORFUN) ; then no VL crossings may link to it + ((FRAC))))) + (REMOVE T2) + (SETQ N 0 T1 (CADR ITEM)) + (AND (EQ (CAR T1) 'CARCDR-FREEZE) (SETQ T1 (CDR T1))) + (COND ((AND (ATOM (CAR T2)) + (VARBP (CAR T2)) + (DO ((ZZ SPLDLST (CDR ZZ)) (2LONG-SETP)) ;Look for (GN (A . .) X.5) + ((NULL ZZ) MATCHP) + (AND (CAR ZZ) + (NOT (EQ ITEM (CAR ZZ))) + (NOT (ATOM (CDAR ZZ))) ; found (GM . .) + (EQ (CADDAR ZZ) (CAR T2)) ; found (GM . . X.7) + (EQ (CAADAR ZZ) (CAR T1)) ; found (GM (A . .) X.7) + (COND (2LONG-SETP) ;Setup the variable 2LONG + (ACP (SETQ 2LONG #%(NUMACP ACORFUN) + 2LONG-SETP 'T)) + ((SETQ 2LONG (COND ((EQ ACORFUN 'FREENUMAC)) + ((EQ ACORFUN 'ARGNO) + #%(NUMACP-N ARGNO))) + 2LONG-SETP 'T))) + (COND (2LONG (ASQSLT (CAAR ZZ))) ;2LONG is switch to tell + ((ASSQ (CAAR ZZ) REGACS)) ; whether or not to look + ((ASSQ (CAAR ZZ) REGPDL))) ; everywhere for possibilities + (EQUAL (ILOC0 (CDDAR ZZ) () ) LT2) ;X.5 can be used for X.7 + (PROG (L LL) + (SETQ L T1) ;T1- open string of ITEM + (SETQ LL (CADAR ZZ)) ;LL - open string of candidate + (AND (< (LENGTH LL) N) (RETURN () )) + A (COND ((NOT (EQ (CAR L) (CAR LL))) (RETURN () )) + ((SETQ LL (CDR LL)) + (COND ((SETQ L (CDR L)) (GO A)) + ((RETURN () ))))) + ;Candidate is an initial substring of ITEM + (SETQ MATCHP (CAR ZZ) N (LENGTH (CADR MATCHP))))))) + (COND ((EQUAL (CADR MATCHP) T1) + (PUSH (CONS (CAR MATCHP) (CAR ITEM)) VL) + (RETURN (ILOCMODE MATCHP () '(FIXNUM FLONUM)))) + ('T (SETQ T2 (LIST (GENSYM)) + T1 #%(NCDR T1 N) + LT2 (ILOCMODE MATCHP () '(FIXNUM FLONUM))) + (PUSH (CONS (CAR MATCHP) (CAR T2)) VL))))) + (SETQ 2LONG (CDDDR T1)) + (SETQ AC (COND ((NOT ACP) + (COND ((AND 2LONG (OR (EQUAL LT2 1) (1FREE))) + 1) + ('T ((LAMBDA (LDLST LL) + (COND (2LONG (CC0 (FRAC))) + ((EQ ACORFUN 'FRACF) (FRACF)) + ((EQ ACORFUN 'FREENUMAC) (FREENUMAC)) + ((EQ ACORFUN 'ARGNO) + (COND ((AND (NOT EFFS) + (= ARGNO 1) + (PROG2 (SETQ LDLST LL) + (DVP1 REGACS 1) + (SETQ LDLST TEM))) + (CC0 (FRAC))) + ((OR EFFS #%(NUMACP-N ARGNO)) (FRACF)) + (ARGNO))) + ((BARF ACORFUN |? fun - CARCDR|)))) + (SETQ TEM (CONS T2 LDLST)) LDLST)))) + ((OR (NOT 2LONG) (= ACORFUN 1)) ACORFUN) + ((OR (EQUAL LT2 1) (1FREE)) 1) + ((AND (CDDR 2LONG) (NOT (ZEROP (SETQ N (FRAC))))) (CC0 N)) + ('T ACORFUN))) + (SETQ TEM (COND ((AND #%(PDLLOCP LT2) (NOT #%(NUMACP-N AC))) + ;LT2 must always be a REGADP. Thus if it is a PLDLOCP, it is the REGPDL + ; and if AC is a REGAC, then a CPUSH might change the REGPDL + (SETQ FL 'T) + (AND (NULL TEM) (SETQ TEM (CONS T2 LDLST))) + ((LAMBDA (LDLST) (CPUSH AC)) TEM)) ;Ordinarily, a semipush would be needed + ('T (SETQ FL () ) (CPUSH AC)))) ; but the LDLST prevents trouble here +;;; Losing T2 may have moved around by CC0 or CPUSH + (COND ((OR (NOT ACP) (AND TEM FL)) + (SETQ LT2 (ILOC0 T2 () )))) + (SETQ FL () ACP #%(ACLOCP LT2) MATCHP () ) + B (COND ((AND ACP (= LT2 1) (= AC 1) (CDDR T1)) + ;ACP now applies to LT2, which is place to start [or continue] CARCDRing from + ;T1 contains D-A list of directions, and this clause is taken if 3 or more. + ;FL=T => We have a private copy of current portion of T1 + (AND (NULL FL) (SETQ FL (SETQ T1 (APPEND T1 () )))) + (COND ((CDDDDR T1) + (AND (NOT MATCHP) (SETQ MATCHP 'T) (CLEARNUMACS)) + ;If more than 4, then bite of a chunk of 4, feed TO CCOUT, and carry on + (CCOUT (PROG2 () T1 (RPLACD (SETQ T1 (CDDDR T1)) + (PROG2 (POP T1) () )))) + (GO B)) + ((CCOUT T1)))) + ('T (AND (AND (NOT ATPL) (NOT ATPL1)) + (EQ (CAR LOUT) 'MOVE) ;If LOUT = (MOVE AC 0 AC) + (MEMQ (CAR LOUT1) '(HRRZ HLRZ)) + (NUMBERP (CADR LOUT)) + (SIGNP E (CADDR LOUT)) ; and LOUT1 had just loaded AC + (NUMBERP (CADDDR LOUT)) + (= (CADR LOUT) AC) ; then flush LOUT + (= (CADDDR LOUT) AC) + (EQUAL (CADR LOUT1) AC) + (SETQ LOUT (SETQ ATPL 'FOO))) + (OUT1 (GET (CAR T1) 'INST) AC LT2) + (POP T1) + (COND (T1 (SETQ LT2 AC ACP 'T) (GO B))))) + (CONT (SETQ N AC) (LIST (CAR ITEM))) + (COND ((COND (#%(NUMACP-N AC)) + ((EQ ACORFUN 'FREENUMAC) + (SETQ TEM (CAR SLOTX) AC (FREENUMAC)) + (RPLACA SLOTX TEM) ;Quick way of (CONT N (CONTENTS AC)) + 'T)) + (SETMODE AC () ) + (OUT1 '(MOVE) AC N))) + (RETURN AC) )) + + + +(DEFUN CCOUT (X) ;(D A D D) => (CALL 1 'CDDADR) + ((LAMBDA (FUN) + #%(OUTFS 'JSP + 'T + (LIST 'CARCDR (CDDR (|carcdrp/|| FUN))) + 0 + FUN)) + (IMPLODE (CONS 'C (NRECONC X '(R)))))) + +(DEFUN CC0 (AC) +;;; Should be called only when (DVP (CONTENTS 1)) also, (FRAC) leaves SLOTX set + (COND ((ZEROP AC) (CPUSH1 1 () () )) + ((= AC 1)) + ((CCSWITCH AC 1)) ;If CCSWITCH is (), the SLOTX is undisturbed + ('T (RPLACA SLOTX (CAR REGACS)) ;(CONT AC (CONTENTS 1)) + (RPLACA REGACS ;(CONT 1 (CONS (CAAR (CONTENTS 1)) 'DUP)) + (CONS (CAAR REGACS) 'DUP)))) + 1) + + +(DEFUN CCSWITCH (A1 A2) ;A1 is always a REGAC address + (COND ((AND (NOT ATPL) + (MEMQ (CAR LOUT) '(MOVE HRRZ HLRZ MOVEI)) + (NUMBERP A2) + (NUMBERP (CADR LOUT)) + (= (CADR LOUT) A2)) + (OUTPUT (PROG2 () + (CONS (CAR LOUT) (CONS A1 (CDDR LOUT))) + (SETQ LOUT (SETQ ATPL 'FOO)))) + (SETQ A1 (FIND A1) A2 (FIND A2)) ;This might move CARCDRs ITEM + (RPLACA A1 (CAR A2)) ;(CONT A1 (CONTENTS A2)) + (RPLACA A2 () ) ;(CONT A2 () ) + 'T) + ('T (OUT1 'MOVE A1 A2) + () ))) + +;;; If first arg is null, then freez-out all carcdr-ings that are still around +;;; If second arg is null, then freeze-out all carcdr-ings over the variable +;;; indicated by the first arg. + +(DEFUN CARCDR-FREEZE (V ITEM) + ((LAMBDA (FL) + (MAP '(LAMBDA (LL) + (COND ((NULL (CAR LL)) (SETQ FL () )) + ((OR (ATOM (CDAR LL)) + (AND V (NOT (EQ (CADDAR LL) V))))) + ((OR (ASSQ (CAAR LL) LDLST) (DVP3 (CAAR LL) VL) (AND ITEM (EQ (CAAR LL) ITEM))) + (AND (NOT (EQ (CAADAR LL) 'CARCDR-FREEZE)) ;Modify the SPLDLST so that + (RPLACA LL (CONS (CAAR LL) ;no VL crossings can use this + (CONS (CONS 'CARCDR-FREEZE (CADAR LL)) + (CDDAR LL)))))) + ('T (CLOBBER-SLOT (CAR LL) REGACS) + (CLOBBER-SLOT (CAR LL) REGPDL) + (RPLACA LL (SETQ FL () ))))) ;Remove this loser from SPLDLST + SPLDLST) + (AND (NULL FL) (FLUSH-SPL-NILS))) + 'T)) + + +(COMMENT CLEAR) + +(DEFUN CLEAR (Y CLBFL) ;Clean up things possibly side-effected in a COND, PROG, LAMBDA, or LSUBR +; PROGN on Y ==> Unknown-function-application in form +; NULFU on Y ==> RPLACA-D in form +; GOFOO on Y ==> GO or RETURN in form +; Variable X ==> (SETQ X FOO) in form + (AND Y + (PROG (L MODE Z PDL) + (SETQ L (MAPCAN + '(LAMBDA (X) + (COND ((OR (EQ X GOFOO) (EQ X NULFU) (EQ X PROGN) (SPECIALP X)) + () ) + + ('T + (SETQ MODE (VARMODE X) PDL #%(PDLGET MODE)) + (COND ((AND MODE + (COND ((SETQ L (CLMEMBER X () REGPDL 'EQ)) + (SETQ Z (- (LENGTH L) (LENGTH REGPDL))) + 'T) + ((SETQ L (CLMEMBER X () REGACS 'EQ)) + (SETQ Z (- (1+ #%(NACS)) (LENGTH L))) + 'T))) +; Dont let local numvars be homed in the regworld + (OPUSH Z (CAR L) MODE) + (RPLACA L (CONS X CNT)) + (SETQ L PDL)) + ('T (SETQ L (CLMEMBER X () PDL 'EQ)))) + (COND ((OR (NULL L) (NULL (SETQ PDL (CLMEMBER X 'OHOME PDL 'EQ)))) + () ) + ('T (LIST (LIST X MODE L PDL))))))) + Y)) +; L is a list of losers that have both valid homes and ohomes on the PDL + A (COND ((NULL L) (GO C)) + ((OR (SETQ Z (CLCHK (SETQ PDL REGPDL) L)) + (SETQ Z (CLCHK (SETQ PDL FXPDL) L)) + (SETQ Z (CLCHK (SETQ PDL FLPDL) L))) + (SETQ L (DELQ Z L) MODE (CADR Z)) + (RPLACA (CADDDR Z) (CAR PDL)) + (OPOP (CLLOC (CADDDR Z) MODE) MODE) + (GO A))) + B (COND ((SETQ MODE (CADAR L)) (SETQ Z (FREENUMAC))) + ('T (SETQ Z (FRAC5)))) ;SLOTX left set by FREAC + (SETQ PDL (CADDAR L)) + (OUT1 'MOVE Z (CLLOC PDL MODE)) + (RPLACA SLOTX (CAR PDL)) + (RPLACA PDL () ) + (CPUSH1 Z () () ) ;SLOTX still set + (POP L) + (GO A) + C (COND ((MEMQ GOFOO Y) (SETQ CLBFL 'T) (CPVRL)) ;Make sure relevant PROG + ((AND PVRL (NULL LPRSL)) (CNPUSH (LAND PVRL Y) () ))) ;vars have a home +;;; Ditto for LAMBDA variables + (AND OLVRL (CNPUSH (LAND OLVRL Y) () )) +;;; Push out delayed SPECIALs or CARCDRs that might be clobbered + (AND LDLST + (COND ((MEMQ PROGN Y) (CSLD 'T 'T Y)) + ('T (CSLD () (MEMQ NULFU Y) Y)))))) +;;; Depending on input, we flush out the acs + (AND CLBFL (CLEARACS0 () ))) + +(COMMENT CLEARACS) + +(DEFUN CLEARACS (N CLBFL HOME) + (DECLARE (FIXNUM MODEFL)) + (PROG (I FL MODEFL) + A (COND ((MINUSP N) + (SETQ SLOTX NUMACS) (SETQ I #%(NUMVALAC)) + (SETQ MODEFL (SETQ N (- #%(NUMVALAC) 1 N)))) + ((SETQ SLOTX REGACS) (SETQ I 1) (SETQ MODEFL 0))) + B (COND ((EQ (CPUSH1 I HOME () ) 'PUSH) (SETQ FL 'T))) + (AND CLBFL (RPLACA SLOTX () )) + (COND ((GREATERP (SETQ I (ADD1 I)) N) + (AND (NOT (ZEROP MODEFL)) CLBFL (CLEARACSMODE MODEFL)) (RETURN FL)) + ((NULL (SETQ SLOTX (CDR SLOTX))) + (SETQ N (DIFFERENCE #%(NACS) N)) + (GO A)) + ((GO B))))) + +(DEFUN CLEARACS0 (CLBFL) (CLEARACS #.(+ (NACS) (NUMNACS)) CLBFL () )) + +(DEFUN CLEARACS1 (X HOME) + (CLEARACS (COND ((AND X (GET X 'ACS))) (#%(NACS))) 'T HOME) + (CLEARACS #.(- (NUMNACS)) 'T HOME)) + +(DEFUN CLEARVARS () (CLEARACS #.(+ (NACS) (NUMNACS)) () 'CLEARVARS)) + +(DEFUN CLEARNUMACS () (CLEARACS #.(- (NUMNACS)) 'T () )) + +(DEFUN CLEARACSMODE (N) + (RPLACA ACSMODE () ) + (COND ((> N #%(NUMVALAC)) + (RPLACA (CDR ACSMODE) () ) + (COND ((> N #.(1+ (NUMVALAC))) + (RPLACA (CDDR ACSMODE) () )))))) + + +(DEFUN CLEANUPSPL (CLBFL) +;;; Clean up the SPLDLST by tossing out worthless stuff +;;; CLBFL=() allows carcdrings still in the slotlist to stay around +;;; for possible future VL crossings + (PROG (FL TEM) + (SETQ FL 'T) + (MAP '(LAMBDA (LL) + (AND (NOT (COND ((ATOM (CDAR LL)) (CLMEMBER (CAAR LL) (CDAR LL) LDLST '=)) + ((ASSQ (CAAR LL) LDLST)) + ((NULL (SETQ TEM (ASQSLT (CAAR LL)))) () ) + ((NOT CLBFL) 'T) + ('T (SETQ TEM (OR (MEMBER TEM REGACS) + (MEMBER TEM NUMACS))) + ;; FOO, CHEAP WAY TO DO (CONT ? () ) + (AND TEM (RPLACA TEM () )) + () ))) + (RPLACA LL (SETQ FL () )))) + SPLDLST) + (AND (NULL FL) (FLUSH-SPL-NILS)))) + + +(DEFUN CLCHK (PDL L) (AND PDL (CAR PDL) (NULL (CDAR PDL)) (ASSQ (CAAR PDL) L))) + +(DEFUN CLLOC (Z MODE) (CONVNUMLOC (- (LENGTH Z) (LENGTH #%(PDLGET MODE))) MODE)) + + + +(DEFUN CLMEMBER (X Y L FUN) +;;; A QUICK WAY OF DOING (MEMBER ZZ L) WHERE X = (CAR ZZ) Y = (CDR ZZ) +;;; AND THE EXPECTATION IS THAT THE "MEMBER" WILL USUALLY FAIL + (DO Z L (CDR Z) (NULL Z) + (AND (CAR Z) + (EQ X (CAAR Z)) + (COND ((EQ FUN 'EQ) (EQ Y (CDAR Z))) + ((EQ FUN '=) (AND (NUMBERP (CDAR Z)) (= (CDAR Z) Y))) + ((EQ FUN 'EQUAL) (EQUAL Y (CDAR Z)))) + (RETURN Z)))) + +(DEFUN CLOBBER-SLOT (X L) + (AND (SETQ X (ASSQ (CAR X) L)) + (RPLACA (MEMQ X L) () )) + () ) + +;;; (FXP0) - Offset for FXPDL addresses, has 2^11. bit off +;;; (FLP0) - Offset for FLPDL addresses, has 2^12. bit off +(DEFUN CONVNUMLOC (AC MODE) + (COND ((NULL MODE) (COND ((> AC 0) (AC-ADDRS AC)) + ((> (SETQ AC (+ AC #%(NPDL-ADDRS))) 0) + (PDL-ADDRS 0 AC)) + ('T (- AC #%(NPDL-ADDRS))))) + (#%(ACLOCP-N AC) (AC-ADDRS (+ AC #.(1- (NUMVALAC))))) + ((PROG2 (SETQ AC (+ AC #%(NPDL-ADDRS))) + (EQ MODE 'FIXNUM)) + (COND ((> AC 0) (PDL-ADDRS 1 AC)) + ('T (+ AC #.(- (FXP0) (NPDL-ADDRS)))))) + ((EQ MODE 'FLONUM) + (COND ((> AC 0) (PDL-ADDRS 2 AC)) + ('T (+ AC #.(- (FLP0) (NPDL-ADDRS)))))))) + + +(DEFUN CONT (N Y) (RPLACA (FIND N) Y)) + +(DEFUN CONTENTS (N) (CAR (FIND N))) + + + +(COMMENT CPUSH) + +(DEFUN CPUSH (N) (FIND N) (CPUSH1 N () () )) + +(DEFUN CPUSH-DDLPDLP (N AD) + (FIND N) + (AND (DVP1 SLOTX N) ;Have I diddled with the PDl for which + (EQ (CPUSH1 N () AD) 'PUSH) ; the address AD is an offset thereof? + #%(PDLLOCP AD) + (EQ (GETMODE N) (GETMODE AD)))) + + +;;; Must preserve SLOTX. If SLOTX = (FIND N) , +;;; then CPUSH1 will compile a PUSH (or MOVE) to the PDL from N +;;; Returns either "PUSH", "T", or "()" depending on what happened. + +(DEFUN CPUSH1 (N HOME DONT) + (COND ((OR (NULL (CAR SLOTX)) + (EQ (CAAR SLOTX) 'QUOTE) + (EQ (CDAR SLOTX) 'DUP)) + () ) + ((EQ (CDAR SLOTX) 'TAKEN) (AND (NOT (EQ HOME 'CLEARVARS)) (CPUSH2 (GETMODE N) N))) + (((LAMBDA (VFL) + (COND ((NOT (DVP2 (CAR SLOTX) N VFL)) () ) ;If not DVP, then return () + ((NOT VFL) ;For GENSYM stuff, PUSH only + (AND (NOT (EQ HOME 'CLEARVARS)) ;If not restricted by home + (CPUSH2 (GETMODE N) N))) + ((EQ HOME 'GENSYM) () ) ;Vars not pushed if restricted + (((LAMBDA (MODE) + (COND ((CDAR SLOTX) + (OPUSH N (CAR SLOTX) MODE) + (RPLACA SLOTX () ) + 'PUSH) + ((CPUSHFOO N DONT MODE) 'MOVEM) ;Take existing home-slot on PDL + ((CPUSH2 MODE N)))) + (GETMODE N))))) ; or create PDL home for local var + (VARBP (CAAR SLOTX)))))) + +(DEFUN CPUSH2 (MODE N) + (OPUSH N (CAR SLOTX) MODE) + (RPLACA SLOTX (CONS (CAAR SLOTX) 'DUP)) + 'PUSH) + + + +(DEFUN CPUSHFOO (N DONT MODE) + ((LAMBDA (T1 T2 SL BESTCNT BESTLOC M) + (AND (NOT (FIXP DONT)) (SETQ DONT () )) + (DO ((Z #%(PDLGET MODE) (CDR Z)) + (I 0 (1- I))) + ((NULL Z)) + (AND (EQ (CAAR SLOTX) (CAAR Z)) + (PROG2 (SETQ T1 (CONVNUMLOC I MODE)) 'T) + (OR (NULL DONT) (NOT (= DONT T1))) + (COND ((AND (EQ (CDAR Z) 'OHOME) + (NOT (DVP4 (CAR Z) T1))) + (SETQ SL Z BESTLOC T1) + (RETURN () )) + ((NOT (DVP1 Z T1)))) + (PROG2 (SETQ T2 (COND ((NUMBERP (CDAR Z)) (CDAR Z)) (CNT))) + (> T2 BESTCNT)) + (SETQ SL Z BESTLOC T1 BESTCNT T2))) + (COND (SL (SETQ M (LENGTH #%(PDLGET MODE))) + (AND (REGADP N) + (NOT (REGADP BESTLOC)) + (SETQ SLOTX + (PROG2 () SLOTX + (SETQ N (LOADINSOMENUMAC + (CONS (CAR (CONTENTS N)) CNT)))))) + (SETQ BESTLOC (+ BESTLOC + (COND ((MINUSP (SETQ M (- M (LENGTH #%(PDLGET MODE))))) 1) + ((PLUSP M) -1) + (0)))) + (COND ((AND (= N 1) + (= BESTLOC 0) + (NULL MODE) + (AND (NOT ATPL) (NOT ATPL1)) + (MEMQ (CAR LOUT) '(CALL CALLF)) + (EQUAL LOUT1 '(PUSH P 1))) + (SETQ LOUT1 (SETQ ATPL1 'FOO)) + (OUTPUT '(PUSH P 1))) + ('T (OUT1 'MOVEM N BESTLOC))) + (RPLACA SL (PROG2 () + (CAR SLOTX) + (RPLACA SLOTX (CONS (CAAR SLOTX) 'DUP)))) + 'T))) + 0 0 () 0 0 0)) + +(COMMENT CSLD) + +;;; Apparently the value of CSLD is umimportant + +(DEFUN CSLD (VFL CCFL SETQLIST) + (PROG (L TEM T2 NLARG V) + (SETQ T2 0 NLARG 0) + (DO Z LDLST (CDR Z) (OR (NULL Z) (EQ Z EXLDL)) + (SETQ V (CAAR Z)) + (COND ((NULL (CDAR Z)) ; ITEM IS LIKE (G00001) + (AND CCFL + (SETQ TEM (ASSQ V SPLDLST)) + (NOT (ASQSLT V)) + (PUSH TEM L))) +;;; ### Does a "MEMQ" really work here? Is "MEMBER" or "CLMEMBER" necessary? + ((AND (OR (AND VFL (MEMQ (CAR Z) SPLDLST)) ;Loading up SPECIAL vars + (AND SETQLIST (MEMQ V SETQLIST))) ;Loading SETQ vars + (COND ((NOT (NUMBERP (SETQ TEM (ILOC2 'T (CAR Z) (VARMODE V)))))) + ((PROG2 (SETQ NLARG TEM) #%(PDLLOCP-N NLARG)) + (NULL (CDR (CONTENTS TEM)))) + ((AND #%(ACLOCP-N NLARG) + (MEMQ (CDR (CONTENTS TEM)) '(DUP () ))) + (AND (NOT (SPECIALP V)) (CPUSH TEM)) + #%(LET ((REGACS REGACS) (NUMACS NUMACS)) + (SETQ REGACS (APPEND REGACS () ) + NUMACS (APPEND NUMACS () )) + (MAP '(LAMBDA (SL) + (AND (CAR SL) + (EQ (CAAR SL) V) + (RPLACA SL () ))) + (APPEND NUMACS REGACS)) + (SETQ TEM (ILOC2 'T (CAR Z) (VARMODE V)))) + (OR (NOT (NUMBERP TEM)) (NULL (CDR (CONTENTS TEM))))) + (T))) + (PUSH (CAR Z) L)))) + ;;; At this point, L is the list of goodies to be loaded + (MAPC + '(LAMBDA (X) + (COND ((NOT (ATOM (CDR X))) ;Like (G0001 CAR X . 3) + + (COND ((NOT (EQ (PROG2 () VL (SETQ T2 (CARCDR X 1))) VL)) ;Did this carcdr add + (OPUSH T2 (LIST (CAR X)) () )) ; to the VL hackery? + ((CPUSH2 () T2)))) + ((AND (SETQ T2 (NUMBERP (SETQ TEM (ILOC0 X () )))) + (PROG2 (SETQ NLARG TEM) #%(PDLLOCP-N NLARG)) + (NOT (DVP TEM))) + (CONT TEM (CONS (CAR X) 'IDUP))) ;LIKE (X.N) + ((OPUSH TEM + (COND ((AND T2 (NUMBERP (CDR (SETQ T2 (CONTENTS TEM))))) T2) + ((CONS (CAR X) 'IDUP))) + () )))) + L))) + + + +(COMMENT CPVRL CNPUSH and DIDUP) + +(DEFUN CPVRL () + (COND (LPRSL) + ('T (SETQ LPRSL '(0 0 0)) + (CNPUSH PVRL 'T) + (SETQ PRSSL (SLOTLISTCOPY)) + (SETQ LPRSL (LIST (LENGTH REGPDL) (LENGTH FXPDL) (LENGTH FLPDL)))))) + +(DEFUN CNPUSH (L FL) + (AND L + (PROG (NN XN LN MODE LOC ITEM Z ZZ) + (DECLARE (FIXNUM NN XN LN)) + (SETQ NN 0 XN 0 LN 0) + A (SETQ MODE (VARMODE (CAR L))) + (SETQ LOC (ILOC1 'T (SETQ ITEM (CONS (CAR L) CNT)) MODE)) + (COND ((OR LOC (AND MODE (ASSQ (CAR L) REGACS) (SETQ LOC (ILOC1 'T ITEM () )))) + (AND FL #%(ACLOCP LOC) (PUSH LOC ZZ))) + ('T (RPLACD ITEM () ) + (COND ((NULL MODE) (PUSH ITEM REGPDL) (SETQ NN (1+ NN))) + ((EQ MODE 'FIXNUM) (PUSH ITEM FXPDL) (SETQ XN (1+ XN))) + ('T (PUSH ITEM FLPDL) (SETQ LN (1+ LN)))))) + (AND (SETQ L (CDR L)) (GO A)) + (AND (NOT (ZEROP NN)) (CNPUSH1 NN 0)) ;0 IS FOR P + (AND (NOT (ZEROP XN)) (CNPUSH1 XN 1)) ;1 IS FOR FXP + (AND (NOT (ZEROP LN)) (CNPUSH1 LN 2)) ;2 IS FOR FLP + (MAPC 'CPUSH ZZ) + (RETURN Z)))) + +(DEFUN CNPUSH1 (N PDL) + (DECLARE (FIXNUM N PDL MAX)) ;PDL IS THE NUMBER DESIGNATING + (PROG (MAX) ; WHICH PDL. N IS THE AMOUNT + (SETQ MAX (PVIA PDL 0)) ; TO BE PUSHED, AND MAX IS THE + A (COND ((> N MAX) ; MAX BITE IN ONE CHUNK + (OUTPUT (PVIA PDL MAX)) + (SETQ N (- N MAX)) + (GO A)) + ((> N 2) (OUTPUT (PVIA PDL N))) + ((> N 0) + (OUTPUT (PVIA PDL 1)) + (AND (= N 2) (OUTPUT (PVIA PDL 1))))))) + + + +(DEFUN DIDUP (L) + (COND (L (COND ((EQ L CLPROGN)) + ((MEMQ PROGN L) (SETQ L CLPROGN))) + (DIDU1 REGACS L) + (DIDU1 NUMACS L) + (DIDU1 REGPDL L) + (DIDU1 FXPDL L) + (DIDU1 FLPDL L)))) + +(DEFUN DIDU1 (SLOT L) + (AND SLOT + (DO ZZ (MEMASSQR 'IDUP SLOT) (MEMASSQR 'IDUP (CDR ZZ)) (NULL ZZ) + (AND (OR (EQ L CLPROGN) (MEMQ (CAAR ZZ) L)) + (RPLACA ZZ (CONS (CAAR ZZ) CNT)))))) + + +(COMMENT DVP) + +(DEFUN DVP (I) (DVP1 (FIND I) I)) + +(DEFUN DVP1 (SL I) + (COND ((OR (NULL (CAR SL)) ;Tells whether item must be saved (at this point). + (EQ (CAAR SL) 'QUOTE) ;Should not change SLOTX, eg by calling FIND + (EQ (CDAR SL) 'DUP)) + () ) + ((MEMQ (CDAR SL) '(TAKEN IDUP))) + ((DVP2 (CAR SL) I (VARBP (CAAR SL)))))) + +(DEFUN DVP2 (ITEM I VFL) ;VFL must be result of VARBP + (COND (VFL (COND ((AND (EQ VFL 'SPECIAL) + (MEMQ (CDR ITEM) '(DUP () ))) ;Current home of spec var + () ) + ((AND (NOT (EQ VFL 'SPECIAL)) ;Current home of local var + (OR (NULL (CDR ITEM)) (EQ (CDR ITEM) 'OHOME))) ; whose time has not yet + (SETQ VFL (ASSQ (CAR ITEM) LOCVARS)) + (OR (< CNT (CDR VFL)) (DVP4 ITEM I))) ; run out [or is still DVP4] + ((NOT (NUMBERP (CDR ITEM))) + (BARF (LIST I ITEM) |Whass happnin - DVP2|)) + (#%(ACLOCP I) + (SETQ VFL (GETMODE I)) ;Var in AC is not DVP if an + (SETQ VFL #%(PDLGET VFL)) ;IDUP or same-count copy is + (COND ((OR (CLMEMBER (CAR ITEM) 'IDUP VFL 'EQ) ; on PDL + (CLMEMBER (CAR ITEM) (CDR ITEM) VFL '=)) + () ) + ((DVP4 ITEM I)))) + ((DVP4 ITEM I)))) + ((ASSQ (CAR ITEM) LDLST)) ;Internal computation quantity on LDLST + (VL (DVP3 (CAR ITEM) VL)))) ;VarList crossings + +(DEFUN DVP3 (VAR L) + (AND L + (SETQ L (DO ZZ L (CDR ZZ) (NULL ZZ) ;Look for crossing for this var + (AND (EQ VAR (CAAR ZZ)) (RETURN ZZ)))) + ((LAMBDA (XTN LL) + (COND ((AND LL (NOT (ASQSLT XTN)))) ;A primary, needed crossing + ((NULL (CDR L)) () ) ;No more potential crossings + ((AND (NULL LL) (DVP3 XTN (CDR L)))) ;Look for "grandsons" + ((DVP3 VAR (CDR L))))) ;Look for more direct "sons" + (CDAR L) (ASSQ (CDAR L) LDLST)))) + +(DEFUN DVP4 (ITEM I) + (AND (ASSQ (CAR ITEM) LDLST) ;Basic var DVP utilizing LDLST + #%(LET ((MODE (VARMODE (CAR ITEM))) + (VAR (CAR ITEM)) + (PDLP (AND #%(PDLLOCP-N I) (NUMBERP (CDR ITEM)))) + (FL) (TEM) ) + (SETQ FL (AND MODE (ASSQ VAR REGACS))) + (DO ((Z LDLST (CDR Z))) ;If any item on LDLST needs + ((NULL Z)) ; the item of interest + (AND (EQ (CAAR Z) VAR) + (NUMBERP (SETQ TEM (COND (FL #%(ILOCNUM (CAR Z) () )) + ((ILOC1 'T (CAR Z) MODE))))) + (COND ((= I TEM)) ;Yup, this is the one! + ((< TEM 0) () ) + ((PROG2 (SETQ TEM (GCONTENTS TEM)) ;If (X.4) in both PDL and AC + PDLP) ; and LDLST wants either + (EQUAL ITEM TEM)) ; slot, then PDL slot is DVP + ((EQ (CDR TEM) 'DUP) ;Dont let DUPs mask out + (NULL (CDR (GCONTENTS I))))) ; a home slot. + (RETURN 'T)))) )) + + +(COMMENT EASYGO FIND and FLUSH-SPL-NIL) + +(DEFUN EASYGO () ;Should be nothing on LDLST except what was there + (AND (EQ PROGP LDLST) ; upon entry to the PROG + (NULL GOBRKL) ;Not be in LAMBDA requiring special unbind + (= (LENGTH REGPDL) (CAR LPRSL)) ; and not under CATCH or ERRSET + (= (LENGTH FXPDL) (CADR LPRSL)) ;SLOTLIST not need restore to PROG level + (= (LENGTH FLPDL) (CADDR LPRSL)))) + +(DEFUN FIND (N) + (SETQ SLOTX (COND ((PLUSP N) + (COND (#%(NUMACP-N N) (SETQ N (- N #%(NUMVALAC))) NUMACS) + ('T (SETQ N (1- N)) REGACS))) + ((NOT #%(NUMPDLP-N N)) (SETQ N (- N)) REGPDL) + (#%(FLPDLP-N N) (SETQ N (- #%(FLP0) N)) FLPDL) + ('T (SETQ N (- #%(FXP0) N)) FXPDL))) + (COND ((ZEROP N) SLOTX) + ((SETQ SLOTX #%(NCDR SLOTX N))))) + + +(DEFUN FLUSH-SPL-NILS () + (AND SPLDLST + (PROG (L OL) + A (AND (NULL (CAR SPLDLST)) (SETQ SPLDLST (CDR SPLDLST)) (GO A)) + (SETQ OL (SETQ L SPLDLST)) + B (AND (NULL (SETQ L (CDR L))) (RETURN SPLDLST)) + (COND ((NULL (CAR L)) (RPLACD OL (CDR L))) + ((SETQ OL L))) + (GO B)))) + + +(COMMENT FRACF etc to FREEREGAC) + +(DEFUN FRACF () + ((LAMBDA (N) + (COND ((ZEROP N) (SETQ SLOTX REGACS) (CPUSH1 1 () () ) 1) + (N))) + (FRAC))) + +(DEFUN FRAC () + (COND ((NULL (CAR (SETQ SLOTX REGACS))) 1) ;This bletcherous code is + ((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 2) ;here purely for speed + ((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 3) ;reasons, since calls to + ((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 4) ;these functions are so frequent + ((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 5) + ((DO N (PROG2 (SETQ SLOTX REGACS) 1) + (PROG2 (SETQ SLOTX (CDR SLOTX)) (1+ N)) + (> N #%(NACS)) + (AND (NOT (DVP1 SLOTX N)) (RETURN N)))) + (0))) + +(DEFUN FRACB () + ((LAMBDA (Y) + (COND ((NULL (CADR Y)) (SETQ SLOTX (CDDR SLOTX)) 5) ;TRIES EMPTY 5,4,3 FIRST IN THAT ORDER, + ((NULL (CAR Y)) (SETQ SLOTX (CDR SLOTX)) 4) ;THEN TRIES NON-DVP AC IN BACKWARDS ORDER + ((NULL (CAR SLOTX)) 3) ;ASSUMING SLOT IS BEING USED FOR TEMPS + ((NOT (DVP1 (CDR Y) 5)) (SETQ SLOTX (CDR Y)) 5) + ((NOT (DVP1 Y 4)) (SETQ SLOTX Y) 4) + ((NOT (DVP1 SLOTX 3)) 3) + ((NOT (DVP1 (SETQ SLOTX (CDR REGACS)) 2)) 2) + ((1FREE) (SETQ SLOTX REGACS) 1) + (0))) + (CDR (SETQ SLOTX (CDDR REGACS))))) ;THIS HAD BETTER YIELD SLOTX = (FIND 3) +(DECLARE (AND (< #%(NACS) 5) (BARF () |FRACB is losing|))) + +(DEFUN FRAC1 () + ((LAMBDA (AC) + (COND ((1FREE) (SETQ SLOTX REGACS) 1) + ((NOT (ZEROP (SETQ AC (FRACB)))) AC) + ('T (SETQ SLOTX REGACS) (CPUSH1 1 () () ) 1))) + 0)) + +(DEFUN FRAC5 () + ((LAMBDA (N) (COND ((NOT (ZEROP N)) N) + ('T (SETQ SLOTX (CDDDDR REGACS)) ;Must be set SLOTX = (FIND 5) + (CPUSH1 #%(NACS) () () ) + #%(NACS)))) + (FRACB))) + +(DEFUN FREEREGAC (F) + ((LAMBDA (AC) (COND ((ZEROP AC) (BARF () |No free acs - FREEREGAC|) 0) + (AC))) + (COND ((EQ F 'FRAC) (FRAC)) ((FRACB))))) + + +(COMMENT FREENUMAC etc to FUNMODE) + +(DEFUN FREEIFYNUMAC () + (OR (NOT (ZEROP (FREENUMAC1))) ;Insure that there is at least + (PROG2 (CLEARACS #.(- (NUMNACS)) () 'T) ; one free NUMAC + (NOT (ZEROP (FREENUMAC1)))) + (FREENUMAC0))) + +(DEFUN FREENUMAC () + ((LAMBDA (AC) + (AND (ZEROP AC) (SETQ AC (FREENUMAC0))) + AC) + (FREENUMAC1))) + +(DEFUN FREENUMAC1 () + (COND ((AND (NULL (CAR (SETQ SLOTX NUMACS))) (NOT (= TAKENAC1 #.(NUMVALAC)))) + #.(NUMVALAC)) + ((AND (NULL (SETQ SLOTX (CDR SLOTX))) + (NOT (= TAKENAC1 #.(+ (NUMVALAC) 1)))) + #.(+ (NUMVALAC) 1)) + ((AND (NULL (SETQ SLOTX (CDR SLOTX))) + (NOT (= TAKENAC1 #.(+ (NUMVALAC) 2)))) + #.(+ (NUMVALAC) 2)) + ((DO I (PROG2 (SETQ SLOTX NUMACS) #%(NUMVALAC)) + (PROG2 (SETQ SLOTX (CDR SLOTX)) (1+ I)) + (NULL SLOTX) + (AND (NOT (= I TAKENAC1)) (NOT (DVP1 SLOTX I)) (RETURN I)))) + (0))) + +(DEFUN FREENUMAC0 () + (SETQ SLOTX NUMACS) + (COND ((= TAKENAC1 #%(NUMVALAC)) + (SETQ SLOTX (CDR SLOTX)) + (CPUSH1 (1+ #%(NUMVALAC)) () () ) + (1+ #%(NUMVALAC))) + ('T (CPUSH1 #%(NUMVALAC) () () ) + #%(NUMVALAC)))) + + +(DEFUN FUNMODE (F) + (DO Y MODELIST (CDR Y) (NULL Y) + (AND (NOT (ATOM (CAAR Y))) + (EQ (CAAAR Y) F) + (RETURN (CDAR Y))))) + + +(DEFUN FUNTYP-DECODE (X) + ((LAMBDA (T1) + (COND (T1 (COND ((EQ (CAR T1) 'FUNTYP-INFO) (CAADR T1)) + ((CAR T1)))) + ((|carcdrp/|| X) 'CARCDR) + ((SETQ T1 (GETL X '(SUBR LSUBR FSUBR))) + (AND (OR (SYSP (CADR T1)) (STATUS SYSTEM X)) + (CAR T1))))) + (GETL X '(JSP CARCDR *EXPR *FEXPR *LEXPR FUNTYP-INFO)))) + + +(COMMENT GCDR GETMODE) + +(DEFUN GCDR (F L) ;Generalized CDR + (PROG () + (AND (NULL L) (RETURN () )) + #.(COND ((NOT (MEMQ COMPILER-STATE '(() TOPLEVEL))) + '(SETQ F (GET F 'SUBR))) + ('B)) + A (COND ((AND L (NOT #.(COND ((NOT (MEMQ COMPILER-STATE '(() TOPLEVEL))) + '(SUBRCALL T F L)) + ('(FUNCALL F L))))) + (POP L) + (GO A))) + (RETURN L))) + +;;; Get contents, but dont change SLOTX +(DEFUN GCONTENTS (X) + ((LAMBDA (SVSLT) (PROG2 () (CONTENTS X) (SETQ SLOTX SVSLT))) SLOTX)) + + +(DEFUN GENTAG (TAG) + (OR (SYMEVAL TAG) + (PROGN (SET TAG (SETQ TAG (GENSYM))) + (PUSH (CONS () TAG) GL) + (PUTPROP TAG 'T 'USED) + TAG))) + +(DEFUN GETMODE (N) + (COND ((PLUSP N) (GETMODE0 N #%(NUMACP-N N) 'T)) + ((NOT #%(NUMPDLP-N N)) () ) + (#%(FLPDLP-N N) 'FLONUM) + ('FIXNUM))) + +(DEFUN GETMODE0 (N ACP SHEE-IT) + (COND ((AND ACP (CAR #%(ACSMODESLOT N)))) + (((LAMBDA (TEMP) + (COND ((NULL (SETQ TEMP (GCONTENTS N))) + (BARF N |No thing - GETMODE|)) + ((EQ (CAR TEMP) 'QUOTE) + (CAR (MEMQ (TYPEP (CADR TEMP)) '(FIXNUM FLONUM)))) + ((NUMERVARP (CAR TEMP))) + ((AND ACP (NOT (VARBP (CAR TEMP)))) + (COND (FIXSW 'FIXNUM) + (FLOSW 'FLONUM) + (SHEE-IT (BARF N |No mode - GETMODE|) () ))))) + () )))) + + +(COMMENT ILOC and ILOCMODE) + +;;; INTERNAL LOCATORS - RETURN ONE OF +;;; () ;Not found +;;; ((QUOTE MUMBLE) . ()) ;Quoted thing +;;; (SPECIAL FOO) ;Current value of special var +;;; 1 => 5 ;Quantity in REGACS +;;; 7 => 11[8] ;" " NUMACS +;;; -3777[8] => 0 ;" " REGPDL +;;; -7777[8] => -4000[8] ;" " FXPDL +;;; -INF => -10000[8] ;" " FLPDL + + +(DEFUN ILOC0 (X MODE) +;;; Should not change SLOTX, e.g. by calling FIND, or CONT, or CONTENTS +;;; Internally-located? - SPECIAL value cells, QUOTE stuff, and SLOTLIST +;;; entries are internal places acceptable. REturns best of these if x is +;;; somewhere therein; otherwise (). + (COND ((EQ (CAR X) 'QUOTE) (LIST X)) + ((ILOC1 (VARBP (CAR X)) X MODE)))) + +(DEFUN ILOC1 (FL X MODE) + (DO ((I 1 (ADD1 I)) (Y #%(ACSGET MODE) (CDR Y)) + (ENDFLAG) (T1) (BESTLOC 0) (BESTCNT 0)) + ((COND ((NULL Y) + (COND (ENDFLAG) + ('T (SETQ ENDFLAG 'T) + (NULL (SETQ Y #%(PDLGET MODE))))))) + (COND ((NOT (ZEROP BESTCNT)) + (CONVNUMLOC (COND ((< BESTLOC (SETQ T1 #%(NACSGET MODE))) BESTLOC) + ((- T1 BESTLOC))) + MODE)) + ((AND FL (NULL MODE) (SPECIALP (CAR X)))) + ((AND (NOT FL) (SETQ FL (MEMASSQR (CAR X) VL))) + (ILOC1 () (CONS (CAAR FL) (CDR X)) MODE )))) + (AND (CAR Y) + (EQ (CAAR Y) (CAR X)) + (COND ((MEMQ (CDAR Y) '(() DUP IDUP)) + (COND ((ZEROP BESTCNT) + (SETQ BESTLOC I BESTCNT 35397.) ;total random no. + (COND ((NOT FL) (SETQ Y () ENDFLAG 'T)))))) +; THE FIRST INSTANCE IN THE SLOTLIST OF A GENSYM QUANTITY WILL BE THE RIGHT ONE + ((AND FL (CDR X) + (NUMBERP (SETQ T1 (COND ((EQ (CDAR Y) 'OHOME) (GET (CAAR Y) 'OHOME)) + ((CDAR Y))))) + (NOT (< T1 (CDR X))) + (OR (ZEROP BESTCNT) (> BESTCNT T1))) + (SETQ BESTCNT T1 BESTLOC I)))))) + +(DEFUN ILOC2 (FL V TYPE) + (COND ((AND (NULL FL) (EQ (CAR V) 'QUOTE)) (LIST V)) + ((ILOC1 FL V TYPE)) + ((AND TYPE (ILOC1 FL V () ))) + ((AND (NULL FL) (ASSQ (CAR V) SPLDLST)) () ) + ('T (BARF V |Lost ? - ILOC2|) () ))) + + + +(DEFUN ILOCMODE (ITEM ACORFUN TYPE) + (COND ((EQ (CAR ITEM) 'QUOTE) (LIST ITEM)) + ((PROG (Z NPZ ZZ ATP FL NUMWORLD) + (SETQ ATP (ATOM TYPE) NUMWORLD (AND ATP TYPE)) + (SETQ FL (VARBP (CAR ITEM))) + (SETQ Z (ILOC1 FL ITEM NUMWORLD)) + (COND ((NULL Z) + (RETURN (COND ((COND (NUMWORLD (SETQ ZZ (ILOC1 FL ITEM () ))) + ((AND ATP ACORFUN) () ) + ((SETQ ZZ (COND (FL (SETQ NPZ (VARMODE (CAR ITEM))) + (COND ((NULL NPZ) () ) + ((ILOC1 T ITEM NPZ)) + ((ILOC1 T + ITEM + (COND ((EQ NPZ 'FIXNUM) + 'FLONUM) + ('FIXNUM)))))) + ((ILOC1 T ITEM 'FIXNUM)) + ((ILOC1 T ITEM 'FLONUM)))))) + ZZ) + ((NULL ACORFUN) () ) + ((SETQ ZZ (ASSQ (CAR ITEM) SPLDLST)) (CARCDR ZZ ACORFUN)) + ((BARF ITEM |Lost datum - ILOCMODE|))))) + ((COND ((OR (NULL TYPE) (NULL FL))) ;Tedious decision as to whether or not to + ((NUMERVARP (CAR ITEM)) () ) ; try the other areas + ((NOT (ASSQ (CAR ITEM) NUMACS))) ;Numvars locatable in regarea must be sought in + (NUMWORLD () ) ; the numworld, and ILOCNUMs might want to check + ((NULL (CAR TYPE)))) ; the NUMACS + (RETURN Z)) + ((PROG2 (SETQ NPZ (NUMBERP Z)) + NUMWORLD) ;Type = FIXNUM [or FLONUM] + (AND (OR (NOT NPZ) + (NOT (NUMBERP (SETQ ZZ (ILOC1 FL ITEM () ))))) + (RETURN Z)) + (SETQ ZZ (PROG2 () Z (SETQ Z ZZ)))) + ('T (AND (COND ((NULL (CAR TYPE)) (NOT NPZ)) ;(() FIXNUM FLONUM) => call by ILOCREG + ((NOT NPZ) (NOT (EQ (CAR Z) 'SPECIAL)))) + (RETURN Z)) ;(FIXNUM FLONUM) => call by ILOCNUM + (SETQ ZZ (COND ((ILOC1 FL ITEM 'FIXNUM)) + ((ILOC1 FL ITEM 'FLONUM)) + ('T (RETURN Z)))) + (AND (NOT NPZ) (RETURN ZZ)))) + ;So a call for ILOCREG or ILOCNUM has resulted in finding copies in both + ; the numworld and the regworld. So we have to ascertain which copy is best + ;Z holds result of (ILOC0 ITEM () ), i.e. the regworld loc, and + ;ZZ that for (ILOC0 ITEM 'FIXNUM) [or 'FLONUM], the numworld loc + ;RCNT is the time-count for the regworld slot, NCNT for the number world + (RETURN ((LAMBDA (RCNT NCNT) + (AND (NOT (NUMBERP RCNT)) (SETQ RCNT () )) + (AND (NOT (NUMBERP NCNT)) (SETQ NCNT () )) + (COND ((AND (NOT NCNT) (NOT RCNT)) + (COND ((NUMBERP ACORFUN) (COND (#%(NUMACP ACORFUN) ZZ) (Z))) + ((AND FL (NUMERVARP (CAR ITEM))) ZZ) + ((NULL (CAR TYPE)) Z) + (ZZ))) + ((AND NCNT RCNT) (COND ((< RCNT NCNT) Z) (ZZ))) ;PREFER LOWER OF TWO COUNTS + ((AND RCNT (< RCNT CNT)) Z) ;PREFER A COUNT TO A HOME + (ZZ))) ;IF COUNT IS ACCEPTABLE + (CDR (GCONTENTS Z)) + (CDR (GCONTENTS ZZ)))))))) + +(COMMENT ITEML LSUB LJOIN etc)) + +(DEFUN ITEML (Y PROP) +; ITEML compiles an itemlist and returns a list of the compiled +; arguments (internal names therefor, that is) in reverse order + (DO ((AC 1 (ADD1 AC)) (Y Y (CDR Y)) (PNOB 'T 'T) + (Z) (ITEM) (LOC) (ARGNO 1) (EFFS) + (PROP (AND PROP (CDDR PROP)) (AND PROP (CDR PROP)))) + ((NULL Y) Z) + (SETQ ARGNO (COND ((NULL PROP) AC) + ;Oddly enuf, the next case is for CONS etc. + ((EQ (CAR PROP) 'PNOB) (SETQ PNOB () ) 1) + ((MEMQ (CAR PROP) '(FIXNUM FLONUM)) #%(NUMVALAC)) + ('T AC))) + (PUSH (SETQ ITEM (COMP0 (CAR Y))) Z) + (AND (= ARGNO #%(NUMVALAC)) + (SETQ LOC (ILOC0 ITEM (CAR PROP))) + #%(NUMACP LOC) + (SETMODE LOC (CAR PROP))))) + +(DEFUN L/.LE/. (L LL) ;Length L less-than-or-equal-to Length LL + (PROG () + A (AND (NULL L) (RETURN (COND (LL 'LESSP) ('EQUAL)))) + (AND (NULL LL) (RETURN () )) + (SETQ L (CDR L) LL (CDR LL)) + (GO A))) + + +(DEFUN L2F (X) + (COND ((OR (NULL X) (NULL (CDR X))) X) + ('T (SETQ X (REVERSE X)) (RPLACD X (NREVERSE (CDR X)))))) + +(DEFUN LSUB (L LL) + (COND ((NULL LL) L) + ((NOT (MEMQ (CAR LL) L)) (LSUB L (CDR LL))) + ((MAPCAN '(LAMBDA (X) (COND ((MEMQ X LL) () ) + ((LIST X)))) + L)))) + +(DEFUN LADD (L LL) + (COND ((NULL L) LL) + ((LADD (CDR L) (ADD (CAR L) LL))))) + +(DEFUN LAND (L LL) + (COND ((OR (NULL L) (NULL LL)) () ) + ((NOT (MEMQ (CAR LL) L)) (LAND L (CDR LL))) + ((MAPCAN '(LAMBDA (X) (AND (MEMQ X L) (LIST X))) LL)))) + +(DEFUN LJOIN (L LL) ;Like APPEND, but tries + (COND ((NULL L) LL) ; interchanging args if + ((NULL LL) L) ; that will reduce consing + ('T (AND (< (LENGTH LL) (LENGTH L)) + (SETQ L (PROG2 () LL (SETQ LL L)))) + (APPEND L LL)))) + +(DEFUN LEVEL (TAG) (COND ((GET TAG 'LEVEL)) + ((MEMASSQR TAG GL) PRSSL) + ((BARF TAG |Tag with no slotlist level|)))) +(DEFUN LEVELTAG () #%(LET ((Y (GENSYM))) (PUTPROP Y (SLOTLISTCOPY) 'LEVEL) Y)) + +(COMMENT LOADACS LOADINACetc) + +(DEFUN LOADACS (X HLAC PROP) + (COND ((OR (NULL PROP) (NULL (SETQ PROP (CAR PROP)))) + (SETQ PROP '(() () () () () ))) + ((< (LENGTH PROP) HLAC) + (DO I (- HLAC (LENGTH PROP)) (1- I) (SIGNP LE I) + (PUSH () PROP)))) + (DO ((AC HLAC (1- AC)) (FLAG () () ) (TEM)) + ((ZEROP AC)) + (COND ((OR (NULL PROP) + (NULL (CAR PROP)) + (SETQ FLAG (AND (MEMQ (CAR PROP) '(PNOB T)) (CAR PROP))) + (PROG2 (SETQ TEM #%(ILOCREG (CAR X) AC)) (REGADP TEM))) + (LOADAC (CAR X) AC FLAG)) + ((MAKEPDLNUM (CAR X) AC))) + (POP PROP) + (POP X))) + + +(DEFUN LOADAC (VAR AC CONSFL) +;CONSFL = T means no pdlnumbers allowed. +;CONSFL = PNOB means no new pdlnumbers allowed, but existing ones ok +;CONSFL = () means anything goes + #%(LET ((LOC #%(ILOCREG VAR AC))) + (COND ((COND ((NULL CONSFL) () ) + ((EQ (CAR VAR) 'QUOTE) () ) + (#%(NUMACP-N AC) () ) + ((NOT (REGADP LOC)) + (OR (NOT (EQ CONSFL 'PNOB)) #%(ACLOCP LOC))) + ((EQ CONSFL 'PNOB) () ) + ((UNSAFEP VAR))) + (SETQ VAR (MAKESAFE VAR LOC 'REMOVEB)) + (SETQ LOC (ILOC0 VAR () ))) + ('T (REMOVEB VAR))) + (COND (#%(NUMACP-N AC) (LOADINNUMAC VAR AC LOC 'REMOVEB)) + ((NOT (NUMBERP LOC)) ;((QUOTE )) or (SPECIAL ) + (CPUSH AC) ;Sets SLOTX to (FIND AC) + (COND ((AND (NOT (EQ (CAR LOC) 'SPECIAL)) ;If QUOTE stuff to be loaded + (CAR SLOTX) ; is already there then do nothing + (EQ (CAAR SLOTX) 'QUOTE) + (EQUAL VAR (CAR SLOTX)))) + ((AND (NOT (EQ (CAR LOC) 'SPECIAL)) + (MEMQ (CADAR LOC) '(T () ))) + (COND ((CADAR LOC) (OUTPUT (BOLA AC 2))) ;(MOVEI AC 'T) + ((AND (NOT ATPL) ;Convert (MOVEI AD '() ) + (EQ (CAR LOUT) 'MOVEI) ; (MOVEI AC '() ) + (NOT (ATOM (CADDR LOUT))) ;Into (SETZB AD AC) + (QNILP (CADDR LOUT))) + ((LAMBDA (AD) + (SETQ LOUT (SETQ ATPL 'FOO)) + #%(OUTFS 'SETZB AD AC)) + (CADR LOUT))) + ('T (OUTPUT (BOLA AC 5))))) ;(MOVEI AC '() ) + ('T (OUT1 'MOVE AC LOC))) + (CONT AC (COND ((EQ (CAR LOC) 'SPECIAL) (LIST (CAR VAR))) + (VAR)))) + (#%(LET ((LOC-IN-ACP #%(ACLOCP LOC)) (NLARG 0)) + (COND ((AND LOC-IN-ACP + (PROG2 (SETQ NLARG LOC) (NOT #%(NUMACP-N NLARG))) + (EQ (CDAR (FIND LOC)) 'DUP) ;SLOTX is where LOC is in AC + REGPDL + (EQ (CAAR SLOTX) (CAAR REGPDL)) ; of PDL and DUP in AC + (NOT (VARBP (CAAR SLOTX))) ;GENSYM quantity on top + (NOT (DVP1 SLOTX 0))) ; was found + (RPLACA SLOTX () ) ;Change LOC to top of PDL + (SETQ LOC 0))) + (COND ((AND LOC-IN-ACP (= LOC AC)) (CPUSH AC)) + ((NOT (REGADP LOC)) (PUSH VAR LDLST) (MAKEPDLNUM VAR AC)) + ('T ((LAMBDA (ACLOC DAC DATAORG DOD) + (COND ((AND (ZEROP LOC) (NOT DOD) (NOT DAC)) + (OPOP AC () ) + (RPLACA ACLOC DATAORG)) + ((AND (NOT DOD) + (CAR ACLOC) + (COND (#%(PDLLOCP LOC) + (COND ((EQ (CDAR ACLOC) 'DUP) () ) + ((NOT (VARBP (CAAR ACLOC)))) + ((SPECIALP (CAAR ACLOC)) + DAC) + ((= LOC 0)) + ((NOT DAC)) +)) + ((PLUSP HLAC) ;SAYS CALL FROM LOADACS + (OR (> LOC HLAC) (< LOC AC))))) + (OUT1 'EXCH AC LOC) + (CONT LOC (CAR ACLOC)) + (RPLACA ACLOC DATAORG)) + ('T (AND DAC + (PROG2 (FIND AC) + (EQ (CPUSH1 AC () LOC) 'PUSH)) + #%(PDLLOCP LOC) + (SETQ LOC (ILOC0 VAR () ))) + (COND ((AND LOC-IN-ACP + (NOT ATPL) + (EQ (CAR LOUT) 'POP) + (= LOC (CADDR LOUT)) + (EQ (CADR LOUT) 'P)) + (SETQ LOUT (SETQ ATPL 'FOO)) + (CONT LOC () ) + (COND (DOD #%(OUTFS 'MOVE AC 0 'P) + (PUSH DATAORG REGPDL)) + (#%(OUTFS 'POP 'P AC)))) + ('T (COND ((AND LOC-IN-ACP + (> LOC AC) + (PLUSP HLAC) + (NOT (> LOC HLAC)) + (NOT ATPL) + (EQ (CAR LOUT) 'EXCH) + (EQUAL AC (CADDR LOUT)) + (EQUAL LOC (CADR LOUT))) + (SETQ LOUT (SETQ ATPL 'FOO)) + (OUT1 'MOVE LOC AC)) + ('T (OUT1 'MOVE AC LOC))))) + (RPLACA ACLOC + (COND ((NUMBERP (CDR DATAORG)) DATAORG) + ((CONS (CAR DATAORG) 'DUP))))))) + (FIND AC) ;FIND AND CONTENTS SET SLOTX + (DVP1 SLOTX AC) + (CAR (FIND LOC)) + (DVP1 SLOTX LOC))))))) )) + + + +(DEFUN LOADINNUMAC (ITEM AC LOC RMFLG) + (PROG (ACFLG MODE NLARG) + (SETQ ACFLG 'T) + (AND (NULL LOC) + (SETQ LOC #%(ILOCNUM ITEM (COND ((ZEROP AC) (SETQ ACFLG () ) 'FREENUMAC) + ('T AC))))) + (COND ((EQ RMFLG 'REMOVEB) (REMOVEB ITEM) (SETQ RMFLG () )) + ((EQ RMFLG 'REMOVE) (SETQ RMFLG ITEM))) + (COND ((REGADP LOC) + (AND (NOT ACFLG) (SETQ AC (FREENUMAC))) + (AND (NUMBERP LOC) (SETQ ITEM (CONTENTS LOC))) + (SETQ ACFLG (CAR ITEM)) + (COND ((EQ ACFLG 'SPECIAL) (SETQ ACFLG (CADR ITEM)))) + (SETQ MODE (COND ((AND (EQ ACFLG 'QUOTE) + (MEMQ (SETQ MODE (TYPEP (CADR ITEM))) + '(FIXNUM FLONUM))) + MODE) + ((VARMODE ACFLG)) + (FIXSW 'FIXNUM) + (FLOSW 'FLONUM))) + (COND ((AND (NOT (ATOM LOC)) (EQ (CAR LOC) 'SPECIAL)) + (SETQ ITEM (CDR LOC)))) + (FIND AC) + (CPUSH1 AC () LOC) + (OUT2 '(MOVE) AC LOC)) + ('T (SETQ NLARG LOC) + (COND ((AND #%(ACLOCP-N NLARG) (OR (NOT ACFLG) (= NLARG AC))) + (AND RMFLG (REMOVE RMFLG)) ;REMOVEs, if so requested + (CPUSH LOC) + (RETURN LOC))) + (SETQ ITEM (CONTENTS LOC)) + (AND #%(NUMPDLP-N NLARG) (SETQ MODE (GETMODE LOC))) ;A NUMPDL loc + (COND (ACFLG (FIND AC) + (SETQ ACFLG (EQ (CPUSH1 AC () LOC) 'PUSH))) + ('T (AND (ZEROP (SETQ AC (FREENUMAC1))) + (SETQ ACFLG 'T) + (SETQ AC (FREENUMAC0))))) + (AND ACFLG ;Signifies a "PUSH" done + MODE ; and that loc is a NUMPDL + (EQ MODE (GETMODE0 AC 'T 'T)) ; so which PDL was pushed? + (SETQ LOC (ILOC0 ITEM MODE))) + (COND ((AND (OR (= LOC #%(FLP0)) (= LOC #%(FXP0))) ;Loc is top slot of a NUMPDL + (NOT (DVP LOC))) ; and can be popped + (OPOP AC MODE)) + ('T (AND (NULL MODE) ;If loc be NUMPDLP, then MODE + (SETQ MODE (GETMODE0 LOC 'T () ))) ; will already have been set + (OUT1 'MOVE AC LOC))))) ; non-null + (CONT AC (COND ((OR (NULL (CDR ITEM)) (EQ (CDR ITEM) 'DUP) (EQUAL (CDR ITEM) CNT)) + (CONS (CAR ITEM) 'DUP)) + ((OR (NUMBERP (CDR ITEM)) (EQ (CAR ITEM) 'QUOTE)) ITEM) + ((NCONS (CAR ITEM))))) + (SETMODE AC MODE) + (AND RMFLG (REMOVE RMFLG)) ;REMOVEs, if so requested + (RETURN AC))) + + + +(DEFUN LOADINREGAC (X FUN LOC) +; Place a quantity X in some regular accumulator, removeing from LDLST +; "FUN" is advice or heuristic as to which acc is preferable, +; and can be "FRACB", "()", "FREACB", or some specific accumulator number. +; LOC is current location of X; () => look it up again + (AND (NULL LOC) (SETQ LOC #%(ILOCF X))) + (COND (#%(REGACP LOC) (REMOVEB X) (CPUSH LOC)) + ((NOT (ZEROP (SETQ LOC (COND ((EQ FUN 'FRACB) (FRACB)) + ((OR (NULL FUN) (EQ FUN 'FREACB)) + #%(FREACB)) + ((EQ FUN 'FRAC5) (FRAC5)) + (#%(REGACP FUN) FUN) + ('T 0))))) + (LOADAC X LOC () )) + ('T (SETQ LOC 0))) + LOC) + + +(DEFUN LOADINSOMENUMAC (ITEM) (LOADINNUMAC ITEM 0 () 'REMOVEB)) + + +(DEFUN MAKEPDLNUM (ITEM AC) + (PROG (LOC MODE NEWLOC TEM) + (CPUSH AC) + (SETQ LOC #%(ILOCNUM ITEM AC)) + (REMOVEB ITEM) + (SETQ MODE (GETMODE LOC) NEWLOC LOC TEM () ) + (COND (#%(ACLOCP LOC) + (SETQ TEM (CONTENTS LOC)) + (CPUSH LOC) + (CONT LOC () ) + (SETQ NEWLOC (ILOC0 ITEM MODE)) + (SETQ ITEM TEM) + (COND ((NULL NEWLOC) (OPUSH LOC ITEM MODE) + (SETQ NEWLOC (CONVNUMLOC 0 MODE)))) + (CONT LOC (CONS (CAR ITEM) 'DUP)))) + (OUT1 'MOVEI AC NEWLOC) + (COND ((NOT (VARBP (CAR ITEM))) + (AND (NOT (CLMEMBER (CAR ITEM) MODE MODELIST 'EQ)) + (PUSH (CONS (CAR ITEM) MODE) MODELIST)) + (PUTPROP (CAR ITEM) 'T 'UNSAFEP))) + (CONT AC (CONS (CAR ITEM) 'DUP)))) + + +(COMMENT MAKESAFE and MAKESURE) + +(DEFUN MAKESAFE (ITEM LOC RMFLG) + (COND + ((COND ((NOT (REGADP LOC)) + #%(LET ((FL () )) + ((LAMBDA (TAKENAC1) (SETQ FL (CPUSH 1))) #%(NUMVALAC)) + (LOADINNUMAC ITEM + #%(NUMVALAC) + (COND ((OR (NOT (EQ FL 'PUSH)) + (NOT (CAR REGACS)) ;Check (CONTENTS 1) + (NOT (EQ (GETMODE LOC) (GETMODE0 1 () 'T)))) + LOC)) + 'REMOVEB) + (OUTPUT (COND ((EQ (OR (CAR ACSMODE) (GETMODE0 #%(NUMVALAC) 'T 'T)) + 'FIXNUM) + '(JSP T FXCONS)) + ('(JSP T FLCONS)))) + #%(NULLIFY-NUMAC)) + 'T) + ((AND (NUMBERP LOC) + (NOT (AND (= LOC 1) + (NOT ATPL) + (EQ (CAR LOUT) 'JSP) + (MEMQ (CADDR LOUT) + '(FXCONS FLCONS PDLNMK)))) + (UNSAFEP (CONTENTS LOC))) + (LOADAC ITEM 1 () ) + (OUTPUT '(JSP T PDLNMK)) + 'T)) + (RPLACA REGACS (SETQ ITEM (LIST (GENSYM)))) + ;The RPLACA is essentially a quick way to do (CONT 1 MUMBLE) + (AND (NULL RMFLG) (PUSH ITEM LDLST)) ) + ((EQ RMFLG 'REMOVEB) (REMOVEB ITEM)) + ((EQ RMFLG 'REMOVE) (REMOVE ITEM))) + ITEM) + +(DEFUN MAKESURE (UNSAFEP VAR SPFL ARG LARG) +;;; VAR will never be local numvar - checked by caller + (AND (COND ((NULL (SETQ UNSAFEP (P2UNSAFEP UNSAFEP))) ;Possibly a numquantity + (COND ((REGADP LARG) () ) + ((NULL (SETQ LARG (ILOC0 ARG () ))) + (SETQ LARG #%(ILOCF ARG)) + 'T) + ((REGADP LARG) () ) + ((NULL (P2UNSAFEP VAR))))) ;Here, SPFL is null + ((COND (SPFL) + ((ATOM UNSAFEP) (LLTV/.UNSAFE UNSAFEP)) ;Cons for X in (SETQ X Y) if both are + ((MEMQ PROGN UNSAFEP)) ; some weird screw case + ((DO Y UNSAFEP (CDR Y) (NULL Y) ;LLTVs, and Y is unsafe + (AND (LLTV/.UNSAFE (CAR Y)) (RETURN 'T)))))) + ((NOT (P2UNSAFEP VAR)))) ;No cons for local var already unsafe + (MAKESAFE ARG LARG ()))) + +(DEFUN LLTV/.UNSAFE (X) ;Used only by safety-checking function above + (AND (SYMBOLP X) ;Returns non-() iff X is a local NOTYPE variable + (NOT (SPECIALP X)) ; which also happens to be unsafe + (NULL (VARMODE X)) + (MEMQ X UNSFLST))) + +(COMMENT NX2LAST OPUSH OPOP etc) + +(DEFUN NX2LAST (X) + (COND ((NULL (CDR X)) () ) ;Remember, cdr[()]=() + ((PROG (ZZ) + A (SETQ ZZ X) + (AND (NULL (CDR (SETQ X (CDR X)))) (RETURN (CAR ZZ))) + (GO A))))) + + + +(DEFUN OJRST (TAG DONT) (OUTJ0 'JRST 0 TAG 'T DONT)) + +(DEFUN OPUSH (X ITEM MODE) + (PROG (TEMP OP) + (SETQ OP (COND ((AND (NULL (SETQ TEMP (REGADP X))) (NULL MODE)) + (BARF X |PUSH P 7 lossage|)) + ((AND TEMP MODE) '(PUSH)) + ('PUSH))) + (COND ((AND MODE (NOT (ATOM X)) (NOT (ATOM (CAR X))) + (EQ (CADR X) 'QUOTE) (NUMBERP (SETQ TEMP (CADAR X)))) + (SETQ X (LIST '% TEMP)) + (SETQ OP 'PUSH))) + (OUT2 OP + (COND ((EQ MODE 'FIXNUM) (PUSH ITEM FXPDL) 'FXP) + ((NULL MODE) (PUSH ITEM REGPDL) 'P) + ('T (PUSH ITEM FLPDL) 'FLP)) + X))) + +(DEFUN OSPB (TLOC VAR) + ((LAMBDA (N) + #%(OUTFS N TLOC (LIST 'SPECIAL VAR))) + (COND ((NULL TLOC) (SETQ TLOC 0)) + ((PLUSP TLOC) 0) + ('T (SETQ TLOC (ABS TLOC)) 7_33.)))) + + +(DEFUN OPOP (X MODE) + ((LAMBDA (PDL) + (COND ((AND (NOT ATPL) + (EQ (CAR LOUT) 'PUSH) + (EQ (CADR LOUT) PDL) + #%(ACLOCP (CADDR LOUT))) + ((LAMBDA (AC) + (SETQ LOUT (SETQ ATPL 'FOO)) + (COND ((AND (SIGNP G X) (= X AC)) (WARN AC |PUSHPOP - OPOP|)) + ('T (OUT1 'MOVEM AC X)))) + (CADDR LOUT))) + ('T (OUT1 'POP PDL X))) + (AND MODE + #%(ACLOCP X) + (SETMODE X MODE)) + (SHRINKPDL 1 MODE)) + #%(PDLAC MODE))) + + +(COMMENT OUTFUNCALL COUTPUT etc) + +(DEFUN OUTFUNCALL (OP AC FUN) + ((LAMBDA (PROP NUMFL) + (COND ((AND (OR #%(NUMACP-N ARGNO) PNOB EFFS) + (OR (SETQ PROP (GET FUN 'NUMFUN)) + (DO Z MODELIST (CDR Z) (NULL Z) + (AND (EQ FUN (CAAAR Z)) + (NULL (CDAAR Z)) + (RETURN (SETQ PROP (CDAR Z)))))) + (CADR PROP)) + (SETQ NUMFL 'T) + (SETQ OP (CDR (ASSQ OP '((CALL . NCALL) (JCALL . NJCALL) + (CALLF . NCALLF) (JCALLF . NJCALF))))))) + #%(OUTFS OP AC (LIST 'QUOTE FUN)) + (COND (NUMFL (SETMODE #%(NUMVALAC) (CADR PROP)) + #%(NUMVALAC)) + (1))) + () () )) + + +(DEFUN OUTG (X) + (OUTPUT (CAR X)) + (DO X (CDR X) (CDR X) (NULL X) + #%(OUTFS 'CAIN 1 (LIST 'QUOTE (CAAR X))) + #%(OUTFS 'JUMPA 0 (CDAR X))) + (OUTPUT '(PUSHJ P *UDT)) + #%(OUTFS 'JUMPA 0 (CAR X)) + (|Oh, FOO!|)) + + + +(DEFUN ICOUTPUT (X) + (COND (FASLPUSH (PUSH X LAPLL)) + ((ATOM X) + (COND ((EQ X GOFOO) (TERPRI)) ;Signal for CR + ((EQ X NULFU) (PRINC '| |)) ;Signal for SPACE + ((NULL X) (PRINC '|() |)) + ('T (PRIN1 X)))) + ((HUNKP X) + '#%(LET* ((EP (AND (EQ (CAR X) '**SELF-EVAL**) + (*:EXTENDP X))) + (VP (AND EP (GET 'VECTOR 'VERSION) (VECTORP X)))) + (COND ((AND EP (NOT VP)) + (SEND X 'PRINT () 0 'T)) + ('T (PROG (N I) + (DECLARE (FIXNUM N I)) + (SETQ I 0) + (SETQ N (COND + (VP (PRINC '|#(|) (VECTOR-LENGTH X)) + ('T (PRINC '|(|) (HUNKSIZE X) ))) + A (ICOUTPUT (CXR I X)) + (COND ((= I N) + (COND (VP (PRINC '|/)|)) + ('T (PRINC '| . )|))) + (RETURN () ))) + (ICOUTPUT (COND (VP (VREF X I)) + ('T (CXR I X)))) + (COND (VP (PRINC '| |)) + ('T (PRINC '| . |))) + (GO A)))))) + ((AND (EQ (CAR X) 'QUOTE) (NULL (CDDR X))) + (COND ((AND (NOT (ATOM (CADR X))) + (OR (EQ (CAADR X) SQUID) (EQ (CDADR X) GOFOO))) + ((LAMBDA (Y) + (COND ((OR (EQ (CDR Y) GOFOO) + (NOT (EQ (CADR Y) MAKUNBOUND))) + (PRINC '/(EVAL/ ) + (ICOUTPUT (CAADR X)) + (PRINC '/))) + ('T (PRINC 'MAKUNBOUND)))) + (CADR X))) + ('T (PRINC '|'|) (ICOUTPUT (CADR X))))) + ('T (PROG () + (PRINC '|(|) + A (ICOUTPUT (CAR X)) + (COND ((NULL (SETQ X (CDR X)))) + ((ATOM X) (PRINC '| . |) (PRIN1 X)) + ('T (PRINC '| |) (GO A))) + (PRINC '|)|) ))) + () ) + + + + + +(DEFUN OUTPUT (X) + ((LAMBDA (ATP) + (COND ((COND ((AND ATP (NOT (EQ X 'FOO)))) + ((NOT ATPL) (NOT (EQ (CAR LOUT) 'JRST))) + ((NOT (EQ LOUT 'FOO))) + ((NOT ATPL1) (NOT (EQ (CAR LOUT1) 'JRST))) + (T)) + (COND ((EQ LOUT 'FOO) (SETQ LOUT X ATPL ATP)) + ('T (COND ((EQ LOUT1 'FOO)) + ((PROG2 (AND (NOT ATPL1) + (EQ (CAR LOUT1) 'JUMPA) + (SETQ LOUT1 (CONS 'JRST (CDR LOUT1)))) + () )) + (FASLPUSH (PUSH LOUT1 LAPLL)) + ('T (ICOUTPUT GOFOO) + (ICOUTPUT LOUT1) + (ICOUTPUT NULFU))) + (SETQ LOUT1 LOUT ATPL1 ATPL LOUT X ATPL ATP)))))) + (ATOM X))) + +(DEFUN OUT1 (A B C) + #%(LET (Z X ACP (N@P (ATOM A)) (TPC (TYPEP C)) (N 0)) +;;; A might be "MOVE" or "(MOVE)", the latter meaning MOVE indirect +;;; B is usually 0 - 17, or maybe "P", or "T" +;;; C is N for slotloc N +;;; "FOO" for symbol FOO +;;; "(SPECIAL FOO)" for special variable FOO +;;; "(QUOTE FUN)" for direct reference to "FUN", as in (CALL 1 'FUN) +;;; "((QUOTE THING))" for loading quotified stuff, +;;; as in (MOVEI 1 'THING), or (PUSH P (% 0 0 'THING)) + (SETQ ACP (AND (EQ TPC 'FIXNUM) (PLUSP (SETQ N C)))) + (SETQ X + (COND ((OR (MEMQ TPC '(FIXNUM SYMBOL)) (SYMBOLP (CAR C))) + (COND ((AND N@P ACP #%(REGACP-N N) (SETQ X (GET A 'IMMED))) + (SETQ N@P () ) X) + (N@P A) + ((CAR A)))) + ('T (SETQ C (CAR C)) ;C WAS "((QUOTE THING))" + (COND ((SETQ X (COND (N@P (GET A 'IMMED)) ((CDR A)))) + (SETQ N@P 'T) + X) + ('T (SETQ C (LIST '% 0 0 C)) + (COND (N@P A) ((CAR A)))))))) + (SETQ Z (COND ((AND ACP (NOT N@P)) (SETQ N@P 'T) (LIST 0 C)) + ((AND (NOT ACP) (EQ TPC 'FIXNUM)) + (COND (#%(NUMPDLP-N N) + (COND (#%(FLPDLP-N N) (CONS (- C #%(FLP0)) '(FLP))) + ('T (CONS (- C #%(FXP0)) '(FXP))))) + ((CONS C '(P))))) + ((NCONS C)))) + (SETQ Z (CONS B (COND (N@P Z) ((CONS '@ Z))))) + (OUTPUT (CONS X Z)))) + + + +(DEFUN OUT3 (OP ACX AD) + (COND ((REGADP AD) (OUT2 OP ACX AD)) + ('T (OUT1 (CAR OP) ACX AD)))) + + +(DEFUN OUT2 (OP ACX AD) + (COND ((OR (ATOM OP) (ATOM AD) (ATOM (CAR AD)) (NOT (EQ (CAAR AD) 'QUOTE))) + (OUT1 OP ACX AD)) + (#%(LET* ((NEWAD (CADAR AD)) (TYPE (TYPEP NEWAD)) NEWOP (II 0)) + (COND ((COND ((AND (EQ TYPE 'FIXNUM) + (SETQ NEWOP (GET (CAR OP) 'IMMED)) + (COND ((AND (NOT (< (SETQ II NEWAD) 0)) + (< II 1_18.))) + ((AND (LESSP -1_18. II 0) + (SETQ NEWOP (GET NEWOP 'MINUS))) + (SETQ NEWAD (- II)) + 'T))) + ;Fixnum with 18. bits or less + 'T) + ((AND (EQ TYPE 'FLONUM) + (ZEROP (BOOLE 1 (SETQ II (LSH NEWAD 0)) + 262143.)) ;777777[8] + (SETQ NEWOP (GET (CAR OP) 'FLOATI))) + ;Exponent/Mantissa combined are 18. bits or less + (COND ((AND (> II 0) + (MEMQ NEWOP '(FDVRI FMPRI)) + (ZEROP (BOOLE 1 II 67108863.))) ;377777777[8] + ;Floating-point power of two. + (SETQ II (- (LSH II -27.) 129.)) + (AND (EQ NEWOP 'FDVRI) (SETQ II (- II))) + (SETQ NEWOP 'FSC)) + ('T (SETQ II (LSH II -18.)))) + (SETQ NEWAD II) + 'T) + ((MEMQ TYPE '(FIXNUM FLONUM)) + (SETQ NEWOP (CAR OP) NEWAD (LIST '% NEWAD)) + 'T) + ((AND (EQ TYPE 'LIST) (EQ (CAR NEWAD) SQUID)) + (SETQ NEWOP (CAR OP)))) + #%(OUTFS NEWOP ACX NEWAD)) + ('T (OUT1 OP ACX AD))))))) + + +(DEFUN OUT3FIELDS (Z Y X) (OUTPUT (LIST X Y Z))) +(DEFUN OUT4FIELDS (V Z Y X) (OUTPUT (LIST X Y Z V))) +(DEFUN OUT5FIELDS (W V Z Y X) (OUTPUT (LIST X Y Z V W))) + + + +(DEFUN OUTJ (INST LARG TAG) + (AND (NOT #%(ACLOCP LARG)) (BARF LARG |Not ac - OUTJ|)) + (CLEARVARS) + (OUTJ0 INST LARG TAG () LARG)) + + +(COMMENT OUTJ0) + +(DEFUN OUTJ0 (INST LARG TAG JSP DONT) + (PROG (TEM SVSLT YAGPV AC LARGSLOTP NLARG) + (SETQ LARGSLOTP (NUMBERP LARG)) + (SETQ AC 0 NLARG (COND (LARGSLOTP LARG) (0))) + (AND (AND (NOT JSP) LARGSLOTP #%(PDLLOCP-N NLARG)) + (SETQ SVSLT (CONTENTS LARG))) + (AND (RSTD TAG + (COND (#%(ACLOCP DONT) DONT) (0)) + (COND ((AND LARGSLOTP #%(ACLOCP-N NLARG)) LARG) (0))) + SVSLT + (SETQ LARG #%(ILOCF SVSLT)) + (SETQ NLARG (COND ((SETQ LARGSLOTP (NUMBERP LARG)) LARG) (0)))) + (COND ((AND (NOT JSP) + (COND ((NOT LARGSLOTP) + (EQ (CAR LARG) 'SPECIAL)) + ((AND SVSLT (NULL (CDR SVSLT)) #%(REGACP-N NLARG)) + (OR (VARBP (CAR SVSLT)) + (ASSQ (CAR SVSLT) SPLDLST)))) + (SETQ YAGPV (MEMQ () REGACS))) + (SETQ AC (- #%(NACS+1) (LENGTH YAGPV))) + (CONT AC (CONS (COND ((NOT (ATOM LARG)) (CADR LARG)) + ((CAR SVSLT))) 'DUP)))) + (COND ((OR JSP (NOT LARGSLOTP) (NOT #%(ACLOCP-N NLARG))) () ) + (#%(REGACP-N NLARG) + (AND (SETQ TEM (ASSQ INST '((JUMPE () ((QUOTE () ))) + (JUMPN ((QUOTE () )) () )))) + (CADDR TEM) + (SETQ SVSLT (CONTENTS LARG)) + (RPLACA SLOTX (CAADDR TEM)))) + (#%(NUMACP-N NLARG) + (AND (MEMQ INST '(SOJN SOJE)) + (RPLACA SLOTX () )))) + ;Set up the acs of the level of TAG, assuming that the jump is taken + ; but dont worry about prog tags + (AND (SETQ YAGPV (GET TAG 'LEVEL)) + (ACMRG (CAR YAGPV) (CADR YAGPV) (CADDR YAGPV) REGACS NUMACS ACSMODE + (COND ((NOT (GET TAG 'USED)) (PUTPROP TAG 'T 'USED))))) + (COND (TEM (FIND LARG) ;Jump falls through, + (COND ((CADR TEM) (RPLACA SLOTX (CAADR TEM))) ; so reset SLOTLIST accordingly + (SVSLT (RPLACA SLOTX SVSLT))))) + (SETQ DONT (COND (JSP () ) + ((AND LARGSLOTP #%(ACLOCP-N NLARG)) + (COND ((AND #%(NUMACP-N NLARG) + (NOT (ATOM INST)) + (MEMQ (CAR INST) '(TRNN TRNE TLNN TLNE))) + (OUT1 (GET (CAR INST) 'CONV) LARG (CDR INST)) + (SETQ INST 'JUMPA)))) + ('T (OUT1 (COND ((EQ INST 'JUMPE) 'SKIPN) ('SKIPE)) AC LARG) + (SETQ INST 'JUMPA)))) + #%(OUTFS INST + (COND (DONT 0) (LARG)) + (COND ((AND (AND (NOT ATPL) JSP (EQ INST 'JRST)) + (SETQ TEM (GET TAG 'PREVI)) + (EQUAL LOUT TEM)) + (SETQ LOUT (SETQ ATPL 'FOO)) + (LIST TAG -1)) + (TAG))) + (RETURN LARG))) ; RETURN LOC OF ARG + +(COMMENT OUTTAG) + +(DEFUN OUTTAG (X) +; OUTTAG returns non-null iff TAG was used + (COND ((AND X (GET X 'USED)) + (CLEANUPSPL () ) + (CLEARVARS) + ((LAMBDA (LL) + (COND (LL (RESTORE LL) + (ACSMRGL LL)) + ('T #%(CLEARALLACS)))) + (LEVEL X)) + (OUTTAG0 X) + X))) + + +(DEFUN OUTTAG0 (X) + ((LAMBDA (V) + (COND ((AND (AND (NOT ATPL) (NOT ATPL1)) ; JUMPX AC,TG + (MEMQ (CAR LOUT) '(JRST JUMPA)) + (EQ X (CADDR LOUT1)) ; JRST 0 TG1 + (NOT (EQ (CAR LOUT1) 'JUMPA)) ;TG: . . . + (SETQ V (GET (CAR LOUT1) 'CONV))) ;Turns into JUMP[X'] AC,TG1 + (SETQ LOUT (LIST V (CADR LOUT1) (CADDR LOUT))) + (SETQ LOUT1 (SETQ ATPL1 'FOO)))) ;ATPL is already () + (COND ((NOT ATPL) + (AND (NOT (EQ (CAR LOUT) 'JUMPA)) + (OR (EQ (CAR LOUT) 'JRST) ; JUMPX AC,TG + (GET (CAR LOUT) 'CONV)) ;TG: .. . + (EQ X (CADDR LOUT)) ;Turns into just TG: + (SETQ LOUT (SETQ ATPL 'FOO)))) + ((NOT (EQ LOUT 'FOO)) ; JUMPX AC,TG + (AND (NOT ATPL1) ;TG1: + (NOT (EQ (CAR LOUT1) 'JUMPA)) + (OR (EQ (CAR LOUT1) 'JRST) ;TG: . . . + (GET (CAR LOUT1) 'CONV)) ;Becomes merely the two tags + (EQ X (CADDR LOUT1)) + (SETQ LOUT1 (SETQ ATPL1 'FOO))))) + (OUTPUT X)) + () )) +;;; Note how the lines (EQ X (CADDR LOUT1)) and (EQ X (CADDR LOUT)) +;;; Prevent taking clauses like (SKIPN 0 FOO) or (CAIE AC FOO) +;;; JUMPx and JUMP[x'] are invertible conditions + + +(DEFUN PROGHACSET (SPFL EXP) + ;Special hac for (LAMBDA (SVAR1) (PROG (SVAR2) :)) or for + ; (LAMBDA (SVAR1) (COMMENT :) : (PROG (SVAR2) : )) for only one call to SPECBIND + (COND ((AND SPFL + (COND ((EQ (CAR EXP) 'PROG)) + ((AND (EQ (CAR EXP) PROGN) + (EQ (CAADR EXP) 'PROG) + (NULL (GCDR (FUNCTION + (LAMBDA (Z) + (NOT (MEMQ (CAAR Z) '(COMMENT DECLARE))))) + (CDDR EXP)))) + (SETQ EXP (CADR EXP)) + 'T)) + (GCDR (FUNCTION (LAMBDA (Z) (SPECIALP (CAR Z)))) (CADDR (CDDDR EXP)))) + (SETQ SFLG 'T) + () ) + ('T (SETQ SFLG () ) SPFL))) + +(DEFUN QNILP (X) (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (NULL (CADR X)))) + +(DEFUN Q0P+0P (X) + (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (SETQ X (CADR X))) + #%(LET ((TYPE (TYPEP X))) + (COND ((AND (EQ TYPE 'FLONUM) (= X 0.0)) 0.0) + ((AND (EQ TYPE 'FIXNUM) (= X 0)) 0))) ) + +(DEFUN Q1P+1P-1P (X) + (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (SETQ X (CADR X))) + #%(LET ((TYPE (TYPEP X))) + (COND ((EQ TYPE 'FLONUM) + (COND ((= X 1.0) 1.0) ((= X -1.0) -1.0))) + ((EQ TYPE 'FIXNUM) + (COND ((= X 1) 1) ((= X -1) -1)))))) + +(DEFUN QNP (X) (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (NUMBERP (CADR X)))) + +(DEFUN REGADP (X) + #%(LET ((N 0)) + (OR (NOT (NUMBERP X)) ;(SPECIAL A), ((QUOTE 5)) + #%(REGADP-N (SETQ N X))))) ;NUMWORLD + +(DEFUN REMOVEB (X) (OR (NULL X) (REMOVE X) (REMOVS X))) + +(DEFUN REMOVE (X) ;REMOVE does not take CARCDR'ings off the SPLDLST + (AND X (SETQ LDLST (DELQ X LDLST)) + (COND ((EQ (CAR X) 'QUOTE)) + ((NUMBERP (CDR X)) + (REMOVS X) + 'T)))) + +(DEFUN REMOVS (X) + (AND (AND X SPLDLST) + (SETQ X (CLMEMBER (CAR X) + (CDR X) + SPLDLST + (COND ((NUMBERP (CDR X)) '=) ('ASSQ)))) + (RPLACA X () ))) + +(COMMENT REMPROPL and String-processing) + +;;; (PNAMECONC 'ABC 'D '(C D) '(ASDF DDD ER) 'FOO) => ABCDCDASDFDDDER +;;; for each single-character symbol, a number in the ASCII range is ok. +(DEFUN PNAMECONC N + (PROG (ARGL LL) + (SETQ ARGL (LISTIFY N)) + A (SETQ LL (MAPCAN '(LAMBDA (A) (COND ((ATOM A) (PCGAV A)) + ((MAPCAN 'PCGAV A)))) + ARGL)) + (COND ((MEMQ () LL) (SETQ ARGL (ERROR ARGL + '|Bad argument list - PNAMECONC| + 'WRNG-TYPE-ARG)) + (GO A))) + (RETURN (MAKNAM LL)))) + +(DEFUN PCGAV (A) ;Get the ASCII values for a list of chars + ((LAMBDA (TP) + (COND ((AND (EQ TP 'SYMBOL) (NOT (= (GETCHARN A 2) 0))) (EXPLODEN A)) + ((LIST (COND ((EQ TP 'SYMBOL) (GETCHARN A 1)) + ((AND (EQ TP 'FIXNUM) (< 1 128.) (NOT (< A 0))) A) + ('T () )))))) + (TYPEP A))) + + +(DEFUN REMPROPL (FL LL) (MAPC '(LAMBDA (X) (REMPROP X FL)) LL)) + +(DEFUN LREMPROP (NAME L) + (PROG (V FL) + A (SETQ V (GETL NAME L)) + (AND (NULL V) (RETURN FL)) + (COND ((REMPROP NAME (CAR V)) (SETQ FL 'T))) + (GO A))) + + +(COMMENT MSOUT) + +(DEFUN MSOUT (W MSG FLAG L1 L2) + (DECLARE (SPECIAL UNFASLSIGNIF)) + (AND (NOT (AND (EQ FLAG 'WARN) (SYMBOLP W) (GET W 'SKIP-WARNING))) + #%(LET ((OUTFILES CMSGFILES) (TERPRI 'T) (PRINLEVEL L1) (PRINLENGTH L2) + (BASE 10.) (*NOPOINT () ) (^R 'T) (^W 'T) (II 0)) + (AND (COND ((OR YESWARNTTY (EQ FLAG 'BARF) (NULL OUTFILES))) + ((MEMQ FLAG '(DATA ERRFL)) (NULL GAG-ERRBREAKS))) + (NOT (MEMQ TYO OUTFILES)) ;^W shuts off "T" output + (PUSH TYO OUTFILES)) + (AND (OR UNFASLCOMMENTS (NULL YESWARNTTY)) + (SETQ UNFASLSIGNIF 'T)) + (SETQ II (+ (COND ((MEMQ FLAG '(ERRFL DATA BARF)) + (PRINC '|/î(COMMENT **ERROR** |) + 20.) + ('T (PRINC '|/î(COMMENT **** |) 15.)) + (FLATSIZE W) + 1 + (FLATC MSG))) + (PRIN1 W) + (PRINC '| |) + (AND (> II 71.) (PRINC '|/î/ / |)) + (PRINC MSG) + (COND ((AND TOPFN (NOT (EQ FLAG 'FASL))) + (PRINC '| in function |) + (PRIN1 TOPFN))) + (PRINC '/)) + (COND ((MEMQ FLAG '(ERRFL DATA)) + (COND (QUIT-ON-ERROR + (MAPC 'FORCE-OUTPUT CMSGFILES) + (MAPC 'FORCE-OUTPUT OUTFILES) + (QUIT)) + ((NULL GAG-ERRBREAKS) + (PRINC '|/î; DATA ERROR - TO PROCEED TYPE $P |) + (MSOUT-BRK W COBARRAY CREADTABLE 'DATA))) + (COND ((EQ FLAG 'ERRFL) (SETQ ERRFL 'T)) + ('T (ERR 'DATA)))) + ((EQ FLAG 'BARF) + (PRINC '|/î;%%%%%%%% COMPILER ERROR - CALL JONL %%%%%%%% |) + (MSOUT-BRK W SOBARRAY SREADTABLE 'BARF) + (ERR 'BARF)))))) + +(DEFUN MSOUT-BRK (ARGS OBARRAY READTABLE FL) + (MAPC 'FORCE-OUTPUT CMSGFILES) + (MAPC 'FORCE-OUTPUT OUTFILES) + (LET ((MSGFILES '(T)) (BASE 10.) (IBASE 10.) *NOPOINT READ ^R) + (cond ((not LINEMODEP) (*BREAK 'T FL)) + ((unwind-protect + (prog2 (sstatus LINMO () ) + (*BREAK 'T FL)) + (sstatus LINMO T))))) + (TERPRI)) + +(COMMENT RESTORE and RST etc) + + +(DEFUN RESTORE (X) + (AND X + (DO ((MODES '(() FIXNUM FLONUM) (CDR MODES)) ;Cycles thru pdls REGPDL FXPDL FLPDL + (RSL) + (XS (CDDDR X) (CDR XS))) + ((OR (NULL MODES) (NULL XS)) RSL) + (PROG (RSTNO N PDLTP P X MODE) + (SETQ X (CAR XS) MODE (CAR MODES)) + (SETQ P #%(PDLAC MODE) PDLTP #%(PDLGET MODE)) + (AND (MINUSP (SETQ RSTNO (DIFFERENCE (LENGTH PDLTP) (LENGTH X)))) + (BARF (LIST X '/î (SLOTLISTCOPY) ) |RESTORE lossage|)) + A1 (AND (ZEROP RSTNO) (RETURN RSL)) + (SETQ N 0 RSL 'T) + A2 (COND ((NOT (OR (NULL PDLTP) + (= N RSTNO) + (DVP1 PDLTP (CONVNUMLOC 0 MODE)))) + (SETQ N (ADD1 N)) + (SETQ PDLTP (CDR PDLTP)) + (COND ((EQ MODE 'FIXNUM) (SETQ FXPDL PDLTP)) + ((NULL MODE) (SETQ REGPDL PDLTP)) + ('T (SETQ FLPDL PDLTP))) + (GO A2))) +; So subtract off as much as possible and pop top PDL slot +; to some safe slot. For safe slots try first those with the +; same item name on the back of the PDL, and then those +; of the acs; as a last resort try FREEAC. + + (SETQ RSTNO (DIFFERENCE RSTNO N)) +; (AND (EQ LOUT 'FOO) (SETQ LOUT LOUT1) (SETQ LOUT1 'FOO)) +; Above instruction had to be removed because of JRST followed FOO case + (AND (NOT ATPL) + (EQ (CAR LOUT) 'SUB) ;This converts two restores of + (EQ (CADR LOUT) P) ;SUB P,[N,,N] - SUB P,[M,,M] + (SETQ N (PLUS N (CADDDR (CADDR LOUT))) ; into one + LOUT (SETQ ATPL 'FOO))) ;SUB P,[N+M,,N+M] + (AND (NOT ATPL1) + (EQ (CAR LOUT1) 'SUB) + (EQ (CADR LOUT1) P) + (OR (EQ LOUT 'FOO) + (AND (NOT ATPL) + (OR (EQ (CAR LOUT) 'SUB) + (EQ (CAR LOUT) 'PUSHJ) + (AND (EQ (CAR LOUT) 'JSP) + (NOT (EQ (CADDR LOUT) 'PDLNMK)))))) + (SETQ N (PLUS N (CADDDR (CADDR LOUT1))) + LOUT1 LOUT ATPL1 ATPL LOUT (SETQ ATPL 'FOO))) + (AND (COND ((ZEROP N) () ) + ((AND (NOT ATPL) (EQ (CAR LOUT) 'PUSH)) + (AND (EQ (CADR LOUT) P) + (PROG2 (SETQ LOUT (SETQ ATPL 'FOO)) 'T))) + ((AND (AND (NOT ATPL) (NOT ATPL1)) + (EQ (CAR LOUT1) 'PUSH) + (EQ (CAR LOUT) 'SUB)) + (AND (EQ (CADR LOUT1) P) + (PROG2 (SETQ LOUT1 (SETQ ATPL1 'FOO)) 'T)))) + (SETQ N (1- N))) + (AND (NOT (ZEROP N)) #%(OUTFS 'SUB P (LIST '% 0 0 N N))) + (AND (ZEROP RSTNO) (RETURN RSL)) + ((LAMBDA (N BESTCNT BESTLOC FL TEM) + (COND ((AND (SETQ TEM (VARBP (CAR FL))) (NOT (EQ TEM 'SPECIAL))) ;localvarp + (DO ((L (FIND N) (CDR L)) (V X (CDR V))) + ((NULL V)) + (COND ((NULL (CAR V))) + ((NOT (EQ (CAAR V) (CAAR PDLTP)))) + ((NULL (CDAR V)) + (COND ((AND (EQ (CAAR L) (CAAR V)) + (EQ (CDAR L) 'OHOME))) + ((NOT (DVP1 L N))) + ((NOT (AND (MEMQ (CDAR L) '(() OHOME)) + (VARBP (CAAR L)))) + (SETQ BESTLOC (FREACB)) + (OUT1 'MOVE BESTLOC N) + (CONT BESTLOC (CONTENTS N)) + (CONT N () )) + ((BARF N |Someones in my home - RESTORE |))) + (RETURN (SETQ BESTCNT (SETQ BESTLOC N)))) + ((OR (AND (SETQ FL (NUMBERP (CDAR V))) + (GREATERP (CDAR V) BESTCNT)) + (ZEROP BESTCNT)) + (SETQ BESTLOC N) + (AND FL (SETQ BESTCNT (CDAR V))))) + (SETQ N (SUB1 N)))) + (#%(ACLOCP (SETQ FL (ILOC0 FL MODE))) + (SETQ BESTLOC FL BESTCNT 1))) + (SETQ FL (CAR PDLTP)) + (COND ((AND (ZEROP BESTCNT) + (NOT ATPL) + (EQ (CAR LOUT) 'PUSH) + #%(ACLOCP (SETQ BESTLOC (CADDR LOUT)))) + (WARN (LIST BESTLOC N) |PUSHPOP - RESTORE|) + (SETQ LOUT (SETQ ATPL 'FOO)) + (SHRINKPDL 1 MODE)) + ('T (AND (ZEROP BESTCNT) + (COND ((NULL MODE) (SETQ BESTLOC (FREACB))) + ((NOT (ZEROP (SETQ BESTLOC (FREENUMAC1))))) + ('T (BARF () |Not enuf NUMACS - RESTORE|)))) + (CONT BESTLOC FL) + (OPOP BESTLOC MODE)))) + (CONVNUMLOC (MINUS RSTNO) MODE) 0 0 (CAR PDLTP) () ) + (SETQ RSTNO (SUB1 RSTNO)) + (SETQ PDLTP (COND ((EQ MODE 'FIXNUM) FXPDL) + ((NULL MODE) REGPDL) + (FLPDL))) + (GO A1))))) + + + +(DEFUN RST (X) +; Restore slotlist to level of a tag, +; Valuable stuff should not be in accs +; If value is non-null, it must be a slotlist level + (AND X (RESTORE (LEVEL X)))) + +(DEFUN RSTD (TAG A1 A2) ;Restore, but dont take the + (DECLARE (FIXNUM A1 A2)) + (PROG (SV1 SV2 RSL) ; accumulators A1 and A2 for temps + (COND ((ZEROP A1) + (AND (ZEROP A2) (RETURN (RST TAG))) + (SETQ A1 A2 A2 0))) + (AND (= A1 A2) (SETQ A2 0)) + (SETQ SV1 (CONTENTS A1)) + (RPLACA SLOTX '(NIL . TAKEN)) + (COND ((NOT (ZEROP A2)) + (SETQ SV2 (CONTENTS A2)) + (RPLACA SLOTX '(NIL . TAKEN)))) + (SETQ RSL (RST TAG)) + (CONT A1 SV1) + (AND (NOT (ZEROP A2)) (CONT A2 SV2)) + (RETURN RSL))) + +(DEFUN RETURNTAG NIL + ((LAMBDA (TAG) + #%(OUTFS 'MOVEI 'T TAG) + (OPUSH 'T '(NIL . TAKEN) () ) + TAG) + (GENSYM))) + + + +(DEFUN SETMODE (AC MODE) (RPLACA #%(ACSMODESLOT AC) MODE)) + + +(DEFUN SHRINKPDL (N MODE) + (CASEQ MODE + (NIL (SETQ REGPDL #%(NCDR REGPDL N))) + (FIXNUM (SETQ FXPDL #%(NCDR FXPDL N))) + (FLONUM (SETQ FLPDL #%(NCDR FLPDL N))))) + +(DEFUN STRETCHPDL (N MODE) + (DO ((I N (1- I)) (L () (CONS '(NIL . TAKEN) L))) + ((ZEROP I) + (CASEQ MODE + (NIL (SETQ REGPDL (NCONC L REGPDL))) + (FIXNUM (SETQ FXPDL (NCONC L FXPDL))) + (FLONUM (SETQ FLPDL (NCONC L FLPDL))))))) + + +(DEFUN SLOTLISTCOPY () + (LIST (APPEND REGACS () ) (APPEND NUMACS () ) (APPEND ACSMODE () ) + (APPEND REGPDL () ) (APPEND FXPDL () ) (APPEND FLPDL () ))) + +(DEFUN SLOTLISTSET (L) + (SETQ REGACS (CAR L) NUMACS (CADR L) ACSMODE (CAR (SETQ L (CDDR L))) + REGPDL (CADR L) FXPDL (CAR (SETQ L (CDDR L))) FLPDL (CADR L))) + +;;; Returns "(SPECIAL x)" if "x" is indeed SPECIAL + (DEFUN SPECIALP (X) + (COND ((GET X 'SPECIAL)) + ((NULL SPECVARS) () ) + ((CDR (ASSQ X SPECVARS))))) + +(DEFUN STRTIBLE (X) + (OR (NULL X) + ((LAMBDA (TYP) + (COND ((MEMQ TYP '(SYMBOL FLONUM))) + ((AND (EQ TYP 'LIST) + (NOT (EQ (CAR X) SQUID)) + (STRTIBLE (CAR X)) + (STRTIBLE (CDR X)))) + ((HUNKP X) + (AND (EQ (CXR 1 X) '**SELF-EVAL**) + (STATUS FEATURE STRING) + (STRINGP X))))) + (TYPEP X)))) + + +(COMMENT UNSAFEP and VARBP) + + +(DEFUN UNSAFEP (X) ;Called only on the output of "COMP" + (COND ((NULL X) () ) ;Must coordinate this function with "VARBP" + ((EQ (SETQ X (CAR X)) 'QUOTE) () ) + (((LAMBDA (Y) + (COND ((NULL Y) () ) ;?? + ((EQ (CAR Y) 'UNSAFEP)) ;Unsafe GENSYM + ((EQ (CAR Y) 'OHOME) ;AHA! Local var + (COND ((MEMQ X UNSFLST)) ;LLTV unsafe + ((VARMODE X)))) ;NUMVAR unsafe + ('T () ))) ;Specs are safe + (GETL X '(SPECIAL OHOME UNSAFEP)))))) + + +(DEFUN VARBP (X) + (COND ((NULL X) () ) + ((NOT (SYMBOLP X)) (BARF X |Not a SYMBOL - VARBP|)) + (((LAMBDA (Y) + (COND ((NULL Y) (COND ((ASSQ X SPECVARS) 'SPECIAL))) + ((EQ (CAR Y) 'SPECIAL) 'SPECIAL) + ('T))) + (GETL X '(SPECIAL OHOME))) ))) + +(DEFUN VARMODE (VAR) + (COND ((NULL VAR) () ) + ((CDR (COND ((ASSQ VAR MODELIST)) ('( () ) )))) + ((GET VAR 'NUMVAR)))) + + +;;; End of PHASE2 auxilliary functions + + +(COMMENT FUNCTIONS TO RUN DECLARATIONS) + + + +;;; Switch Declarations functions + +(DEFUN ASSEMBLE (X) (SETQ ASSEMBLE X)) ;;; A switch +(DEFUN CLOSED (X) (SETQ CLOSED X)) ;;; C switch +(DEFUN DISOWNED (X) (SETQ DISOWNED X)) ;;; D switch +(DEFUN EXPR-HASH (X) (SETQ EXPR-HASH X)) ;;; E switch +(DEFUN FASL (X) (SETQ FASL X)) ;;; F switch +(DEFUN FIXSW (X) (SETQ FIXSW X)) ;;; + switch +(DEFUN FLOSW (X) (SETQ FLOSW X)) ;;; $ switch +(DEFUN GAG-ERRBREAKS (X) (SETQ GAG-ERRBREAKS X)) ;;; G switch +(DEFUN HUNK2-TO-CONS (X) (SETQ HUNK2-TO-CONS X)) ;;; 2 switch +(DEFUN EXPAND-OUT-MACROS (X) (SETQ EXPAND-OUT-MACROS X));;; H switch +(DEFUN MACROS (X) (SETQ MACROS X)) ;;; M switch +(DEFUN MAPEX (X) (SETQ MAPEX X)) ;;; X switch +(DEFUN MUZZLED (X) (SETQ MUZZLED X)) ;;; W switch +(DEFUN NOLAP (X) (SETQ NOLAP X)) ;;; K switch +(DEFUN ARRAYOPEN (X) (SETQ ARRAYOPEN X)) ;;; O switch +(DEFUN SPECIALS (X) (SETQ SPECIALS X)) ;;; S switch +(DEFUN SYMBOLS (X) (SETQ SYMBOLS X)) ;;; Z switch +(DEFUN UNFASLCOMMENTS (X) (SETQ UNFASLCOMMENTS X)) ;;; U switch + + +;;; Standard Declarations defined as FEXPRs + +(DEFUN *EXPR FEXPR (X) (*DECLARE X '*EXPR)) +(DEFUN *FEXPR FEXPR (X) (*DECLARE X '*FEXPR)) +(DEFUN *LEXPR FEXPR (X) (*DECLARE X '*LEXPR)) +(DEFUN **LEXPR FEXPR (X) (*DECLARE X '*LEXPR) (*DECLARE X '**LEXPR)) +(DEFUN /@DEFINE FEXPR (X) X 'T) +(DEFUN EOC-EVAL FEXPR (X) (SETQ EOC-EVAL (APPEND EOC-EVAL X () ))) +(DEFUN FIXNUM FEXPR (X) (NUMPROP X 'FIXNUM)) +(DEFUN FLONUM FEXPR (X) (NUMPROP X 'FLONUM)) +(DEFUN GENPREFIX FEXPR (X) (SETQ GENPREFIX (EXPLODEC (CAR X)))) +(DEFUN IGNORE FEXPR (X) (*DECLARE X 'IGNORE)) +(DEFUN NOTYPE FEXPR (DECLS) (NUMPROP DECLS () )) +(DEFUN OWN-SYMBOL FEXPR (L) + (COND ((NOT (MEMQ COMPILER-STATE '(MAKLAP DECLARE))) + (PDERR (CONS 'OWN-SYMBOL L) + |OWN-SYMBOL can only be done in top level declarations|)) + (((LAMBDA (OBARRAY) + (MAPCAN '(LAMBDA (X) + (COND ((NOT (SYMBOLP X)) () ) + ('T (REMOB X) + (PUTPROP (INTERN (COPYSYMBOL X () )) + 'T + 'OWN-SYMBOL) + (LIST X)))) + L)) + COBARRAY)))) +(DEFUN RECOMPL FEXPR (X) (SETQ RECOMPL (APPEND X RECOMPL))) +(DEFUN SPECIAL FEXPR (X) (*DECLARE X 'SPECIAL)) +(DEFUN UNSPECIAL FEXPR (L) + (COND ((EQ COMPILER-STATE 'COMPILE) + (PDERR (CONS 'UNSPECIAL L) |Cant locally unspecialize|)) + ('T (REMPROPL 'SPECIAL L)))) + + + +(DEFUN *DECLARE (L PROP) + (MAPC + '(LAMBDA (X) + (COND ((AND (NOT (MEMQ PROP '(SPECIAL IGNORE))) (SYSP X)) + (COND ((OR (|carcdrp/|| X) + (AND (GET X 'FSUBR) (NOT (EQ X 'EDIT)) (NOT (EQ PROP '*FEXPR))) + (AND (GET X 'ACS) ;First char is * or . + ((LAMBDA (N) (OR (= N 52) (= N 56))) + (GETCHARN X 1))) + (GET X 'JSP) + (MEMQ X '(LIST RPLACA RPLACD SET EQ EQUAL NULL NOT + ZEROP PROG2 PROGN ASSQ MEMQ BOOLE PRINC PRIN1 PRINT + READ READCH TYI TYO PLIST PUTPROP REMPROP))) + (DBARF (CONS PROP L) |This declaration wont work|)) + ('T (LREMPROP X '(ACS ARITHP CONTAGIOUS + FUNTYP-INFO NOTNUMP NUMBERP + P1BOOL1ABLE )) + (PUTPROP X 'T PROP)))) + ((EQ PROP 'SPECIAL) + (AND (EQ COMPILER-STATE 'COMPILE) + (ASSQ X RNL) (SETQ X (CDR (ASSQ X RNL)))) + #%(let ((newprop `(SPECIAL ,x))) + (or (equal (get x 'SPECIAL) newprop) + (putprop x newprop 'SPECIAL)))) + ('T (PUTPROP X 'T PROP))) + () ) + L)) + +(DEFUN NUMPROP (DECLS TYP) + (PROG (TEMP PROP TOPFN) + (MAPC '(LAMBDA (DECL) + (COND ((ATOM DECL) + (AND (EQ COMPILER-STATE 'COMPILE) + (SETQ TEMP (ASSQ DECL RNL)) + (SETQ DECL (CDR TEMP))) + (COND ((NULL TYP) (REMPROP DECL 'NUMVAR)) + ((AND (SETQ TEMP (GET DECL 'NUMVAR)) + (NOT (EQUAL TEMP TYP))) + (WARN DECL |Variable being redeclared|)) + ('T (PUTPROP DECL TYP 'NUMVAR)))) + ('T (SETQ PROP (NMPSUBST (CDR DECL) TYP)) + (AND (SETQ TEMP (GET (CAR DECL) 'NUMFUN)) + (NOT (EQUAL PROP TEMP)) + (WARN DECL |Function being redeclared|)) + (PUTPROP (CAR DECL) PROP 'NUMFUN)))) + DECLS))) + +(DEFUN NMPSUBST (LIST TYP) + (AND (DO X LIST (CDR X) (NULL X) + (AND (NOT (MEMQ (CAR X) '(() FIXNUM FLONUM))) (RETURN 'T))) + (SETQ LIST + (MAPCAR '(LAMBDA (X) + (COND ((MEMQ X '(FIXNUM FLONUM)) X) + ((MEMQ X '(() NOTYPE T ?)) () ) + (((LAMBDA (TYP) + (COND ((MEMQ TYP '(FIXNUM FLONUM)) TYP) + ('T (PDERR (LIST X '-IN- LIST) + |Incorrect arg for number declaration|) + () ))) + (TYPEP X))))) + LIST))) + (CONS (REVERSE LIST) (CONS (COND ((NOT (MEMQ TYP '(FIXNUM FLONUM))) () ) + (TYP)) + LIST))) + + + +(DEFUN ARRAY* FEXPR (LIST) (MAPC 'AR*1 LIST)) + +(DEFUN AR*1 (X) + (PROG (TYPE NAME TEM PROP N Y) + (AND (OR (ATOM X) + (NOT (MEMQ (CAR X) '(FIXNUM FLONUM NOTYPE T ? () )))) + (GO BF)) + (SETQ TYPE (COND ((MEMQ (CAR X) '(FIXNUM FLONUM)) (CAR X)) + ('NOTYPE)) + Y (CDR X)) + A (AND (NULL Y) (RETURN () )) + (COND ((NOT (ATOM (CAR Y))) + (SETQ PROP (CAR Y) NAME (CAR PROP) N (LENGTH (CDR PROP))) + (AND (DO Z (CDR PROP) (CDR Z) (NULL Z) + (AND (NOT (FIXP (CAR Z))) (RETURN T))) + (DO Z (CDR (SETQ PROP (APPEND PROP () ))) (CDR Z) (NULL Z) + (COND ((FIXP (CAR Z))) + ((AND (QNP (CAR Z)) (FIXP (CADAR Z))) + (RPLACA Z (CADAR Z))) + ('T (RPLACA Z () )))))) + ((NOT (NUMBERP (CADR Y))) (GO BF)) + ('T (SETQ NAME (CAR Y) N (CADR Y) PROP (LIST NAME) Y (CDR Y)))) + (AND (OR (LREMPROP NAME '(*EXPR *LEXPR *FEXPR)) + (AND (REMPROP NAME 'NUMFUN) (NOT (GETL NAME '(*ARRAY))))) + (WARN NAME |Function being re-declared as an array|)) + (COND ((AND (SETQ TEM (GET NAME '*ARRAY)) (NOT (EQUAL TEM PROP))) + #%(WARN NAME |array re-declared|) + (REMPROP NAME 'NUMFUN))) + (PUTPROP NAME PROP '*ARRAY) + (PUTPROP NAME + (CONS () (CONS (COND ((NOT (EQ TYPE 'NOTYPE)) TYPE)) + #%(NCDR '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM) + (- 7 N)))) + 'NUMFUN) + (SETQ Y (CDR Y)) + (GO A) + BF (PDERR X |Bad array declaration|))) + + + diff --git a/src/comlap/complr.936 b/src/comlap/complr.936 new file mode 100755 index 00000000..5155fc49 --- /dev/null +++ b/src/comlap/complr.936 @@ -0,0 +1,3061 @@ +;;; COMPLR -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ***** LISP COMPILER (COMPLR) ******************* +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + +(SETQ COMPLRVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/936))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + +(EVAL-WHEN (COMPILE) + (ALLOC '(LIST (55296. 65536. 0.2) FIXNUM (4096. 6144. 0.2))) + (COMPDECLARE) + (FASLDECLARE) + (GENPREFIX |/|cl|)) + + + +(DEFUN COMPLRVERNO () ;PRINCs version number + (SETQ ^W (SETQ ^R (SETQ ^Q () ))) + (PRINC '|/îLISP COMPILER |) + (AND (STATUS FEATURE GG) + (PRINC '|[Running Interpretively] |)) + (PRINC (OR (GET 'COMPLR 'VERSION) COMPLRVERNO)) + (COND ((STATUS FEATURE SHARABLE) (PRINC '| [in (SHARABLE) LISP |)) + ('T (PRINC '| [in LISP |))) + (PRINC (STATUS LISPV)) + (PRINC '|]|) + () ) + + +(COMMENT CHOMP CL and COMPILE) + +(DEFUN CHOMP FEXPR (L) + #%(LET ((VL (COND ((NOT (ATOM (CAR L))) (PROG2 () (CAR L) (SETQ L (CDR L)))))) + (MSGFILES '(T)) (CMSGFILES '(T)) (READTABLE CREADTABLE) + (FASLPUSH 'T) (YESWARNTTY 'T) (COMPILER-STATE 'COMPILE) + (*LOC 0) (FILOC 0) (LITLOC 0) (SYMBOLS SYMBOLS) + DATA TOPFN ^W ^Q ^R PURE *PURE LAPLL FASL ASSEMBLE NOLAP UNFASLSIGNIF + CURRENTFNSYMS CURRENTFN MAINSYMPDL SYMPDL ENTRYNAMES ALLATOMS + DDTSYMP ATOMINDEX SYMBOLSP LITERALS ) + (LAP-A-LIST '(()) ) ;Be sure LAP is loaded + (SETQ L (MAPCAN '(LAMBDA (X) + (COND ((GETL X '(EXPR FEXPR)) + (AND (SETQ DATA (GETL X '(SUBR FSUBR LSUBR))) + (NOT (SYSP X)) + (REMPROP X (CAR DATA))) + (LIST X)))) + L)) + (COND ((NULL VL) (MAPC 'CHMP1 L)) + ((CHMP2 L))) + L)) + + +(DEFUN CHMP1 (X) ;"CHOMP" one function + (SETQ DATA (GETL X '(EXPR FEXPR)) CFVFL () LAPLL () ) + (COMPILE X (CAR DATA) (CADR DATA) () () ) + (LAP-A-LIST (SETQ LAPLL (NREVERSE LAPLL))) + (AND (COND ((SYSP X) + (AND (SETQ DATA (GETL X '(EXPR FEXPR SUBR FSUBR LSUBR))) + (MEMQ (CAR DATA) '(EXPR FEXPR)) + (SETQ DATA '(SUBR FSUBR LSUBR)))) + ('T (AND (SETQ DATA (GETL X '(*EXPR *FEXPR *LEXPR SUBR FSUBR LSUBR))) + (MEMQ (CAR DATA) '(SUBR FSUBR LSUBR)) + (SETQ DATA '(*EXPR *FEXPR *LEXPR))))) + (SETQ DATA (CAR (GETL X DATA))) + (PUTPROP X (CAR (REMPROP X DATA)) DATA))) + + + +(DEFUN CL FEXPR (L) ;Compile a list of functions given by atom name + #%(LET (LAPLL DATA (SYMBOLS SYMBOLS) (READTABLE CREADTABLE) TOPFN + (COMPILER-STATE 'COMPILE) (YESWARNTTY 'T) (CMSGFILES '(T)) + GAG-ERRBREAKS FASL FASLPUSH ASSEMBLE NOLAP) + (CONS 'COMMENT + (MAPCAR '(LAMBDA (J) + (AND (SETQ DATA (GETL J '(EXPR FEXPR))) + (PROG2 (SETQ CFVFL () TOPFN J) + (COMPILE J (CAR DATA) (CADR DATA) () () )))) + (SETQ CL (OR L CL)))))) + +((LAMBDA (X) + (PUTPROP 'CL:CL (CADR X) (CAR X))) + (GETL 'CL '(FSUBR FEXPR))) + + + +(DEFUN COMPILE (NAME-ARG FLAG EXP file? P1GFY) + (PROG (*NOPOINT ACSMODE AL ARGNO ARITHP ATPL ATPL1 BVARS CNT CONDP + CONDUNSF CTAG DPL EFFS ERRFL EXLDL FL FLPDL REAL-SUBRP FXPDL GL + GOBRKL GONE2 HLAC IGNOREVARS KTYPE L-END-CNT LDLST LMBP LOCVARS + LOUT LOUT1 LPRSL LSUBRF MARR-LOSS MODELIST NAME NARGS NLNVS + NLNVTHTBP NUMACS OLVRL OPVRL P1CNT P1CSQ P1LL P1LLCEK P1LSQ P1PSQ + P1SPECIALIZEDVS P2P PKTYP PNOB PROGP PROGUNSF PRSSL PVRL REGACS + REGPDL RNL ROSENCEK SFLG SPECVARS SPFL SPLDLST SYSFUNP TAKENAC1 TEM + UNSFLST VGOL VL) + (SETQ CNT 1 REAL-SUBRP 'T) + (COND ((ATOM NAME-ARG) (SETQ NAME NAME-ARG NAME-ARG () )) + ('T (SETQ NAME (CAR NAME-ARG)) + (SETQ REAL-SUBRP (MEMQ (CADDR NAME-ARG) + '(SUBR FSUBR LSUBR))))) + (COND ((NOT P1GFY) + (GENSYM 0) + (SETQ TOPFN NAME) + (COND ((SETQ SYSFUNP (SYSP NAME)) + (COND + ((COND ((AND (SETQ TEM (FUNTYP-DECODE NAME)) + (NOT (GET NAME TEM))) + () ) + (REAL-SUBRP 'T) + ('T (AND (GET NAME 'ARGS) + (SETQ TEM (ARGS NAME)) + (NOT (EQUAL (GET NAME 'ARGS) TEM)) + (ARGS NAME ())) + () )) + (ARGS NAME ()) + (SETQ SYSFUNP 'T) + (or (get name 'SKIP-WARNING) + (WARN (cond ((filep infile) + `(,name FROM USER FILE ,(namestring infile))) + (name)) + |Redefining system function|)))))))) + (COND ((NULL (EQ (CAR EXP) 'LAMBDA)) (DBARF EXP |No function| 4 6)) + ((AND (CADR EXP) (ATOM (CADR EXP))) + (COND (REAL-SUBRP + (AND (OR (GETL NAME '(*EXPR *FEXPR)) + (NOT (MEMQ FLAG '(EXPR LEXPR)))) + (WRNTYP NAME)) + (ARGS NAME () ) + (AND (MEMQ SYSFUNP '(T () )) + (PUTPROP NAME 'T '*LEXPR)))) + (SETQ LSUBRF (SETQ FLAG 'LEXPR)) + (SETQ EXP (CONS (CAR EXP) (CONS (LIST (CADR EXP)) (CDDR EXP)))))) + (COND (LSUBRF) + ((or (> (setq nargs (length (cadr exp))) #%(nacs)) + (get name '**LEXPR)) + (SETQ LSUBRF 'LSUBR FLAG 'LEXPR) ;CONVERT LONG EXPR TO LSUBR + (COND (REAL-SUBRP + (LREMPROP NAME '(*EXPR *FEXPR)) + (COND ((AND (NOT P1GFY) (MEMQ SYSFUNP '(T () ))) + (PUTPROP NAME 'T '*LEXPR) + (P1ACK NAME + 'LSUBR + (SETQ AL (CONS NARGS NARGS)) + NARGS) ))))) + ((COND ((NOT REAL-SUBRP) () ) + ((EQ FLAG 'EXPR) + (COND ((NOT P1GFY) + (SETQ AL (CONS () NARGS)) + (P1ACK NAME 'SUBR AL NARGS))) + (SETQ FL '*EXPR) + 'T) + ((EQ FLAG 'FEXPR) + (REMPROP NAME 'ARGS) + (SETQ FL '*FEXPR) + 'T)) + (AND (SETQ SPFL (GETL NAME '(*EXPR *FEXPR *LEXPR))) + (NOT (EQ FL (CAR SPFL))) + (WRNTYP NAME)) + (PUTPROP NAME 'T FL)) + ((EQ FLAG 'LEXPR) (SETQ LSUBRF 'LSUBR FLAG 'LEXPR))) + (SETQ KTYPE (AND REAL-SUBRP (GET NAME 'NUMFUN)) + EXP (P1LMBIFY (CADR EXP) (CDDR KTYPE) (CDDR EXP)) + P1LL (CAR EXP) EXP (CDR EXP)) + (AND KTYPE (SETQ KTYPE (CADR KTYPE))) + (MAPC '(LAMBDA (X) + (COND ((AND X (NOT (SPECIALP X)) (NULL (VARMODE X))) + (PUSH X UNSFLST)))) + P1LL) + (SETQ EXP (P1GLM P1LL EXP)) + (SETQ UNSFLST (LSUB UNSFLST (P1SPECIALIZEDVS))) + (AND (SETQ FL (UUVP 'P1LL)) (WARN FL |Unused LAMBDA variables|)) + (AND ERRFL (ERR 'DATA)) + (AND NLNVS (NLNVASG (MAPCAR 'CAR NLNVS))) + (MAPC '(LAMBDA (X) (PUTPROP (CAR X) () 'OHOME)) LOCVARS) + (SETQ LOUT (LIST 'LAP + NAME + (COND ((NULL NAME-ARG) + (CDR (ASSQ FLAG COMPILATION-FLAGCONVERSION-TABLE))) + ((NULL (CDDR NAME-ARG)) (CADR NAME-ARG)) + ((CADDR NAME-ARG))))) + (SETQ LOUT1 (SETQ ATPL1 'FOO)) ;ATPL is still () + (AND (NOT (= BASE 8.)) + ((LAMBDA (B BASE) + (OUTPUT (SUBST B 'BASE '(EVAL (SETQ IBASE BASE)))) + (PROG2 #%(|Oh, FOO!|) #%(|Oh, FOO!|)) + (SETQ *NOPOINT () )) + BASE 8.)) + (AND AL #%(OUTFS 'ARGS NAME AL)) + (COND (SYMBOLS (OUTPUT '(SYMBOLS T)) + (COND ((> (FLATC NAME) 5) (OUTPUT (GENSYM)))))) + (AND KTYPE + (OUTPUT (COND ((EQ LSUBRF 'LEXPR) + (COND ((EQ KTYPE 'FIXNUM) '(JSP D (*LCALL -1))) + ('(JSP D (*LCALL -2))))) + ((EQ LSUBRF 'LSUBR) + (OUTPUT (COND ((EQ KTYPE 'FIXNUM) '(SKIPA T (% 0 0 FIX1A))) + ('(SKIPA T (% 0 0 FLCONS))))) + (SETQ MARR-LOSS (LIST (GENSYM))) + '(MOVEI T 0)) + ((EQ KTYPE 'FIXNUM) '(PUSH P (% 0 0 FIX1))) + ('(PUSH P (% 0 0 FLOAT1)))))) + (SETQ HLAC (SETQ LPRSL (SETQ TAKENAC1 0))) + (SETQ P1CNT CNT CNT 1 BVARS () PNOB () P2P 'T) + (SETQ AL #%(INITIALSLOTS)) + (SETQ REGACS (APPEND (CAR AL) () )) + (SETQ NUMACS (APPEND (CADR AL) () )) + (SETQ ACSMODE (APPEND NUMACS () )) + (SETQ REGPDL () FXPDL () FLPDL () ) + (SETQ ARGNO (COND (KTYPE #%(NUMVALAC)) (1))) + (COND ((EQ LSUBRF 'LEXPR) (OUTPUT '(JSP D *LCALL))) + ((EQ LSUBRF 'LSUBR) + (DO I NARGS (1- I) (ZEROP I) (PUSH () REGPDL)) + (COND (MARR-LOSS + (SETQ FXPDL (LIST MARR-LOSS)) + (PUSH MARR-LOSS LDLST) + (OUTPUT '(PUSH FXP T))))) + ((AND (EQ FLAG 'FEXPR) (CDAR (CDDDDR EXP))) + (OUTPUT '(EXCH 1 2)) + (OUTPUT '(MOVE TT SP)) + (OUTPUT '(JSP T FIX1A)) + (OUTPUT '(EXCH 1 2)))) + (SETQ FL (CDDDDR EXP)) + (CNPUSH (APPEND NLNVTHTBP (CAR (CDDDDR FL))) () ) + (SETQ BVARS (APPEND (CAR FL) BVARS) ;LSUBRF = +1 => SUBR + LSUBRF (COND ((EQ LSUBRF 'LSUBR) -1) (+1))) ;LSUBRF = -1 => LSUBR + (SETQ SPFL SFLG) + (DO ((AC (LSH (1+ LSUBRF) -1) (+ AC LSUBRF)) + (X (COND ((< LSUBRF 0) (REVERSE (CAR FL))) ((CAR FL))) (CDR X)) + (MODE)) + ((NULL X)) + (COND ((AND (CAR X) (SPECIALP (CAR X))) + (COND ((NULL SPFL) + (SETQ SPFL 'T) + (CPUSH #.(+ (NUMVALAC) 2)) + (OUTPUT '(JSP T SPECBIND)))) + (OSPB AC (CAR X)))) + (COND ((NULL (CAR X))) + ((> LSUBRF 0) (CONT AC (LIST (CAR X)))) ;SUBR TYPE + ((NOT (SPECIALP (CAR X))) + (CONT AC (COND ((SETQ MODE (VARMODE (CAR X))) + (PUSH (CONS AC (CONS (LIST (CAR X)) MODE)) DPL) + ()) + ('T (LIST (CAR X)))))))) + (MAPC '(LAMBDA (L) (OPUSH (CAR L) (CADR L) (CDDR L))) DPL) + (SETQ EXP (CADDDR (CDDR EXP))) + (COND (DPL (SETQ SFLG () )) ;DPL is the delayed-pushes list + ((SETQ SPFL (PROGHACSET SPFL EXP)))) + (LOADAC (COMP EXP) ARGNO 'T) ;Since PNOB has been (), this should + ; not cause a PDLNMK + (AND KTYPE + (SETQ FL (GETMODE0 ARGNO 'T () )) + (NOT (EQ KTYPE FL)) + (WARN NAME |This function was declared numerical, + but the resultant type is incorrect|)) + (COND (MARR-LOSS + (OUT1 'SKIPE 'T (ILOC1 () MARR-LOSS 'FIXNUM)) + (OUTPUT '(JSP T 0 T)) + #%(|Oh, FOO!|) + (REMOVE MARR-LOSS))) + (SETQ FL + (COND (SPFL '(JRST 0 UNBIND)) + ((AND (NOT (OR FXPDL FLPDL)) + (NOT ATPL)) + (COND ((AND (SETQ AL (ASSOC (CAR LOUT) + '((PUSHJ . JRST) (NCALL . NJCALL) + (CALL . JCALL) (NCALLF . NJCALF) + (CALLF . JCALLF)))) + (COND ((OR (NULL (CDDDR LOUT)) + (NOT (MEMQ '@ LOUT)) + (NOT (NUMBERP (CADDDR LOUT))))) + ((ZEROP (CADDDR LOUT)) + (NOT (EQ (CADR (CDDDR LOUT)) 'P))) + ((NOT #%(PDLLOCP (CADDDR LOUT)))))) + (SETQ AL (CONS (CDR AL) + (COND ((EQ (CDR AL) 'JRST) (CONS 0 (CDDR LOUT))) + ((CDR LOUT))))) + (SETQ LOUT (SETQ ATPL 'FOO)) + AL) + ((AND (EQ (CAR LOUT) 'JSP) (EQUAL LOUT '(JSP T PDLNMK))) + (SETQ LOUT (SETQ ATPL 'FOO)) + '(JRST 0 PDLNKJ)) + ('T '(POPJ P)))) + ('T '(POPJ P)))) + (CONT ARGNO '(NIL . TAKEN)) + (RESTORE #%(INITIALSLOTS)) + (OUTPUT FL) + (MAPC 'OUTG VGOL) + (COND (LDLST (BARF LDLST |Left on LDLST|))) + (AND SYMBOLS (NOT (EQ SYMBOLS 'T)) (OUTPUT '(SYMBOLS T))) + (OUTPUT () ) (OUTPUT () ) (OUTPUT () ) + (COND ((NOT FASLPUSH) (ICOUTPUT GOFOO) (ICOUTPUT GOFOO))) + (GCTWA) + (COND ((NOT (= CNT P1CNT)) + (BARF (LIST P1CNT CNT) |Unequal count|))) + (RETURN NAME))) + + + + +(COMMENT BASIC COMP FUNCTION and COMPFORM) + +;;; Results from the "COMP" type functions can be +;;; () if computing for effects only; otherwise, is +;;; (QUOTE MUMBLE) +;;; (VAR . CNT) +;;; (G0005 . () ) +;;; where G0005 is either 1) The internal name of some computational result, or +;;; 2) A carcdr'ing, like 1) above, but which may be delayed + +(DEFUN COMP (X) ((LAMBDA (EFFS) (COMP0 X)) () )) ;For value +(DEFUN COMPE (X) ((LAMBDA (EFFS PNOB) (COMP0 X)) 'T 'T)) ;For effects +(DEFUN COMP1 (X) (COMPW X () 1)) ;For value, into accumulator 1 +(DEFUN COMPW (X EFFS ARGNO) (COMP0 X)) ;Can specify effects and accumulator number + +(DEFUN COMPR (X MODE OEFFS OPNOB) ;This seems to be useful in several places + (COND (MODE (COMPW X () (FREENUMAC))) + ('T ((LAMBDA (EFFS PNOB ARGNO) (COMP0 X)) + () + OPNOB + (COND (OEFFS 1) + ((NOT #%(NUMACP-N ARGNO)) ARGNO) + (#%(FREAC))))))) + +(DEFUN COMP0 (X) ;The basic "CHOMP" + ((LAMBDA (Y MODE) + (COND ((EQ MODE 'SYMBOL) ;"CHOMPING" a variable + (SETQ CNT (ADD1 CNT)) + (COND ((NULL EFFS) + (SETQ Y (CONS X CNT)) + (COND ((SPECIALP X) (PUSH Y SPLDLST)) + ((ILOC0 Y (SETQ MODE (VARMODE X)))) + ((AND MODE (ILOC0 Y () ))) + ((COND ((OR (MEMQ X PVRL) + (DO Y OPVRL (CDR Y) (NULL Y) + (AND (MEMQ X (CAR Y)) + (RETURN 'T))) ) + (AND MODE (PDERR X |Uninitialized number variable|)) + 'T) + ((MEMQ X OLVRL))) + (SETQ Y (COND ((NULL MODE) '(QUOTE () )) + ((EQ MODE 'FIXNUM) '(QUOTE 0)) + ('T '(QUOTE 0.0))))) + ((BARF Y |What kind of variable is this - COMP0|)))))) + ((NOT (EQ MODE 'LIST)) (BARF X |What is this cruft - COMP0|)) + ((EQ (CAR X) 'QUOTE) (SETQ Y X)) ;"CHOMPING" quoted frob + ((AND (NOT (ATOM (CAR X))) (EQ (CAAR X) CARCDR)) ;"CHOMPING" a carcdring + (COND (EFFS (COMP0 (CADR X))) + ('T (SETQ Y (COND ((NOT (SYMBOLP (CADR X))) + (COND (#%(NUMACP-N ARGNO) (COMP1 (CADR X))) + ((COMP0 (CADR X))))) + ((SPECIALP (CADR X)) + (CAR (PUSH (CONS (CADR X) (SETQ CNT (ADD1 CNT))) + LDLST))) + ('T (COMP0 (CADR X))))) + (PUSH (XCONS (CONS (CDAR X) Y) + (SETQ Y (GENSYM))) + SPLDLST) + (SETQ Y (LIST Y))))) + ('T (SETQ Y (COMPFORM X)))) + (COND ((NULL EFFS) (PUSH Y LDLST) Y))) + () (TYPEP X))) + + +(DEFUN COMPFORM (F) + (PROG (X Y Z FNARGS VALAC NARGS TEM T1 CCSLD ARRAYP JSP UNSAFEP) + (SETQ VALAC 1) + A (SETQ X (CAR F) Y (CDR F)) + (AND (SETQ T1 (NOT (ATOM X))) ;Non-Atomic function forms + (COND ((EQ (CAR X) 'LAMBDA) (RETURN (COMLAMAP F))) + ((EQ (CAR X) COMP) + (AND (SYMBOLP (CDDR X)) + (SPECIALP (CDDR X)) + #%(NO-DELAYED-SPLDS)) + (SETQ FNARGS (COMP1 (CDDR X))) + (COND (CCSLD) + ((AND (NULL Y) + (OR (NULL SPLDLST) + (PROG2 (CLEANUPSPL 'T) + (OR (NULL SPLDLST) + (AND (NULL (CDR SPLDLST)) + (EQ (CAR FNARGS) (CAAR SPLDLST)))))))) + ('T #%(NO-DELAYED-SPLDS))) + (SETQ X (COND ((EQ (CADR X) 'FUNCALL) + (COND ((> (LENGTH Y) #%(NACS)) + (SETQ + VALAC + (COMLC (LIST COMP 'FUNCALL FNARGS) + Y + () )) + (GO CALLX))) + () ) + ((CDR X)))) + (LOADACS (SETQ Z (ITEML Y () )) (SETQ NARGS (LENGTH Z)) () ) + (SETQ TEM #%(PDLLOCP (SETQ T1 (ILOCMODE FNARGS 'FRACF () )))) + (REMOVEB FNARGS) + (AND #%(CLEARALLACS) TEM (SETQ T1 (ILOC0 FNARGS () ))) + (COND ((NULL X) + (OUT1 (COND ((AND (OR #%(NUMACP-N ARGNO) PNOB) + (VARBP (CAR FNARGS)) + (SETQ F (OR (FUNMODE (CAR FNARGS)) + (GET 'FNARGS 'NUMFUN))) + (SETQ F (CADR F))) + (RPLACA ACSMODE F) ;(SETMODE #%(NUMVALAC) FOO) + (SETQ VALAC #%(NUMVALAC)) + '(NCALLF . NCALLF)) + ('(CALLF . CALLF))) + NARGS + T1)) + ('T (COND ((MEMQ (CAR X) '(FIXNUM FLONUM)) + (OUT1 'MOVE #%(NUMVALAC) T1) + (OUTPUT #.(SUBST (NUMVALAC) 'AC ''(PUSHJ P 1 AC))) + (RPLACA ACSMODE (CAR X)) + (SETQ VALAC #%(NUMVALAC))) + ((OUT1 '(PUSHJ) 'P T1))))) + (AND TEM #%(|Oh, FOO!|)) + (GO CALLX)) + ((NOT (EQ (CAR X) MAKUNBOUND)) (GO LOSTF)) + ((AND (EQ (CAR (SETQ X (CDR X))) 'FSUBR) (ATOM (CDR X))) + (AND (NOT (GET (CDR X) 'ACS)) #%(NO-DELAYED-SPLDS)) + (LOADAC (COMPW Y () 1) 1 () ) + (SETQ X (CDR X)) + (GO F-*)) + ((EQ (CAR X) '*MAP) + (COND ((CADR X) #%(NO-DELAYED-SPLDS)) ;Mapping unknown funct + ('T (CSLD () 'T () ))) ;Fun has no side-effects + (COND ((NOT (EQ (CADDR X) '*MAP)) + (COMLC (CADDR X) Y () ) + (GO CALLX))) + (LOADACS ((LAMBDA (EFFS ARGNO) + (LIST (COMP0 (CAR Y)) + (COMP0 (PROG2 (SETQ ARGNO 1) + (CADR Y))))) + () 2) + 2 + () ) + #%(CLEARALLACS) + #%(OUTFS 'PUSHJ 'P (CDDR X)) + (GO CALLX)) + ((EQ (CAR X) 'RPLACD) (RETURN (COMRPLAC 'RPLACD Y 'T))) + ((EQ (CAR X) 'MAKNUM) + (AND (NOT #%(NUMACP-N ARGNO)) (SETQ UNSAFEP PNOB)) + (SETQ VALAC (COMMAKNUM Y)) + (GO RETV)) + ((EQ X ARGLOC) ;bind to specific location + (SETQ VALAC (CAR Y)) ;mostly for use by CATCHALL + (GO RETV)) + ('T (GO LOSTF)))) + (COND ((SETQ TEM (GETL X '(ARITHP NUMBERP NOTNUMP))) + (AND EFFS (OR (NOT (EQ (CAR TEM) 'NOTNUMP)) + (EQ (CADR TEM) 'NOTNUMP)) + (WARN F |You're losing some value here| 3 5)) + (COND ((NOT (EQ (CAR TEM) 'NUMBERP)) + (AND (EQ (CAR TEM) 'ARITHP) + (BARF F |ARITHP function in COMPFORM???|))) + ((EQ (CADR TEM) 'NOTYPE) + (COND ((COND ((MEMQ X '(EQ EQUAL)) + (COND ((OR (EQ X 'EQ) + (MEMQ (CAR Y) '(FIXNUM FLONUM))) + (COMEQ Y () 'T) + 'T))) + ((MEMQ X '(GREATERP LESSP *GREAT *LESS)) + (COND (#%(KNOW-ALL-TYPES (CAR Y)) + (COMGRTLSP F () 'T) + 'T))) + ((MEMQ X '(ZEROP PLUSP MINUSP ODDP)) + (COND ((AND (NOT CLOSED) + (MEMQ (CAR Y) '(FIXNUM FLONUM))) + (COMZP F () 'T) + 'T))) + ((BARF F |Lost NOTYPE NUMBERP-function|))) + (BOOLOUT () () ) + (GO RET-NO)) + ('T (SETQ F (CONS X (SETQ Y (CDR Y)))))) + () ) + ((EQ X IDENTITY) + (SETQ Z (COMP0 (CADR Y))) + (COND ((NOT EFFS) + (SETQ T1 #%(ILOCNUM Z 'FREENUMAC)) + (AND #%(NUMACP T1) + (NULL (GETMODE0 T1 'T () )) + (SETMODE T1 (CAR Y))) )) + (RETURN Z)) + ((OR (EQ X 'FIX) + (NULL (CAR Y)) + (AND CLOSED (NOT (ATOM (CAR Y))))) ;For closed-CALL arith + (SETQ F (CONS X (SETQ Y (CDR Y)))) + () ) + ((MEMQ X '(ADD1 SUB1)) (RETURN (COMAD1SB1 X Y))) + ((MEMQ X '(PLUS DIFFERENCE TIMES QUOTIENT)) + (RETURN (COMARITH X Y))) + ((MEMQ X '(*DIF *PLUS *TIMES *QUO HAULONG)) + (AND #%(KNOW-ALL-TYPES (CAR Y)) + (RETURN (COND ((EQ X 'HAULONG) (COMHAULONG Y)) + ('T (COMARITH X Y))))) + (SETQ F (CONS X (SETQ Y (CDR Y)))) + () ) + ((MEMQ X '(FLOAT IFIX)) + (RETURN (COMFIXFLT (COMPW (CADR Y) () #%(NUMVALAC)) + (COND ((EQ X 'FLOAT) 'FLONUM) + ('FIXNUM))))) + ((EQ X 'REMAINDER) (RETURN (COMREMAINDER (CDR Y)))) + ((MEMQ X '(ABS MINUS)) (RETURN (COMABSMINUS X Y))) ))) + (COND ((SETQ T1 (FUNTYP-DECODE X)) + (COND ((EQ T1 'FSUBR) ;Compile for Special Forms + (COND ((EQ X 'COND) + (SETQ UNSAFEP (AND PNOB (CADDR Y))) + (COMCOND Y () () () ) + (AND (NOT EFFS) + #%(NUMACP-N ARGNO) + (NULL (CAR (SETQ TEM #%(ACSMODESLOT ARGNO)))) + (RPLACA TEM (COND ((NULL (SETQ Z (CADDDR Y))) + (BARF () |No type for COMCOND|)) + ((ATOM Z) Z) + ((CADR Z))))) + (GO RET-NO)) + ((EQ X 'PROG) + (SETQ VALAC (COMPROG Y)) + (SETQ UNSAFEP (CADDR (CDDDDR Y))) + (GO RETV)) + ((EQ X 'SETQ) (RETURN (COMSETQ Y))) + ((EQ X 'GO) (COMGO Y) (RETURN ''())) + ((AND (EQ X 'ERR) (NULL (CDR Y))) + (LOADAC (COMP1 (CAR Y)) 1 'T) + (OUTPUT '(JRST 0 ERUNDO)) + (GO RET)) + ((OR (EQ X 'COMMENT) (EQ X 'DECLARE)) + (OUTPUT (CONS 'COMMENT Y)) + (RETURN '(QUOTE COMMENT))) + ((MEMQ X '(AND OR)) + (COND ((NOT EFFS) (BARF F |AND or OR loss| 3 6))) + (CLEAR (CADR Y) 'T) + (SETQ Z (L2F (CDDDDR Y))) + (COND ((AND (NULL (CDDR Z)) + (NOT (ATOM (CAR Z))) + (SETQ T1 (COND ((EQ (CAAR Z) 'GO) + (AND (ATOM (CADAR Z)) + (ADR (CADAR Z)))) + ((EQ (CAAR Z) 'RETURN) + (AND (QNILP (CADAR Z)) + (GENTAG 'EXITN))))) + (EASYGO)) + (BOOL1 (CADR Z) T1 (EQ X 'AND)) + (SETQ CNT (PLUS 2 CNT))) + ('T (BOOL2LOOP (CDR Z) + (SETQ T1 (LEVELTAG)) + (EQ X 'OR)) + (COMPE (CAR Z)) + (SETQ CNT (PLUS 2 CNT)) + (OUTTAG T1))) + (DIDUP (CADDR Y)) + (GO RET)) + ((EQ X 'SIGNP) (COMSIGNP Y () () ) (GO RETV)) + ((MEMQ X '(ERRSET *CATCH CATCH-BARRIER + %CATCHALL %PASS-THRU)) + (SETQ Z (COMERSET X Y)) + (COND ((EQ X 'ERRSET) (RETURN Z)) + ('T (GO RETV)))) + ((EQ X 'STORE) + (COND ((AND ARRAYOPEN + (ATOM (CAAR Y)) + (COND ((AND (SETQ ARRAYP (GET (CAAR Y) '*ARRAY)) + (NOT (EQ ARRAYP 'T))) + (SETQ X (CAAR Y) Z (CDAR Y)) + (AND (SETQ T1 (GET X 'NUMFUN)) (SETQ T1 (CADR T1))) + (SETQ TEM (COMPR (CADR Y) T1 () () )) + 'T) + ((EQ (CAAR Y) 'ARRAYCALL) + (SETQ T1 (CADAR Y) + TEM (COMPR (CADR Y) T1 () () ) + X (COMP1 (CADDAR Y)) + Z (CDDDAR Y) + ARRAYP () ) + 'T))) + (SETQ Z (NREVERSE (ITEML Z '(FIXNUM FIXNUM FIXNUM + FIXNUM FIXNUM FIXNUM FIXNUM)))) + (SETQ VALAC (COM-AREF X Z TEM T1 ARRAYP))) + (((LAMBDA (V LOC TAKENAC1) + (CONT TAKENAC1 () ) + (REMOVE LOC) + (LOADAC V 1 'T) + (CLEARNUMACS) + (OUTPUT '(JSP T *STORE))) + (COMP1 (CADR Y)) + (COMPW (CAR Y) 'T 1) + (+ #%(NUMVALAC) 2)))) + (GO RETV)) + ((EQ X 'ARRAYCALL) + (SETQ VALAC (COMARRAY (COMP1 (CADR Y)) (CDDR Y) () (CAR Y))) + (GO RETV)) + ((EQ X 'LSUBRCALL) + (SETQ VALAC (COMLC (LIST COMP (CAR Y) (COMP1 (CADR Y))) + (CDDR Y) + () )) + (GO CALLX)) + ((EQ X 'PROGV) + (SETQ TEM (COMPW (CAR Y) () 5) T1 (COMP1 (CADR Y))) + (AND (NULL (ILOCMODE TEM 5 () )) + (DBARF F |Bad variables list|)) + (LOADAC TEM 5 () ) ;Maybe should be safe things? + (LOADAC T1 1 () ) + #%(CLEARALLACS) + (OUTPUT '(JSP T VBIND)) + ((LAMBDA (GOBRKL) + (SETQ TEM (COMPROGN (CDDR Y) EFFS)) + (COND ((AND (NULL EFFS) (CDR TEM) (SPECIALP (CAR TEM))) + (LOADAC TEM ARGNO () ) + (SETQ TEM () )) + ('T (AND (NULL EFFS) #%(ILOCN TEM)) + (REMOVEB TEM)))) + (CONS '( UNBIND . () ) GOBRKL)) + (OUTPUT '(PUSHJ P UNBIND)) + (COND (TEM (RETURN TEM)) ((GO RETV)))) + ('T (GO F-FORM)))) + ((EQ T1 'SUBR) ;Compile for SUBR type + (COND ((EQ X 'NULL) (COMNULL (CAR Y)) (GO RET-NO)) + ((EQ X 'RETURN) + (COMRETURN Y 'T) + (CONT PVR () ) + (RETURN ''())) + ((MEMQ X '(RPLACA RPLACD SETPLIST)) + (RETURN (COMRPLAC X Y () ))) + ((AND (EQ X '*PRINC) + (NOT (ATOM (CAR Y))) + (EQ (CAAR Y) 'QUOTE) + (STRTIBLE (CADAR Y))) ;### REMEMBER: P1 AND P1BASICBOOL1ABLE + (GO OUTSTRT)) + ((AND (SETQ TEM (GET X 'P1BOOL1ABLE)) + (NOT (ATOM TEM))) + (COMTP F TEM () 'T 'T) + (GO RET-NO)) + ((EQ X 'SET) + (COMSET Y) ;Leaves ARG in 1 + (GO RET)) + ((MEMQ X '(ROT LSH ASH FSC)) + (RETURN (COMSHIFTS X Y))) + ((EQ X 'TYPEP) + (COND (EFFS (SETQ F (CADR F)) (GO A))) + (COMTP F () () 'T 'T) + (GO RET-NO)) + ((EQ X 'ARG) + (SETQ UNSAFEP (NOT #%(NUMACP-N ARGNO))) + (SETQ VALAC (COMARG Y)) + (GO RETV)) + ((EQ X '*THROW) + #%(LET (EFFS (ARGNO 2) PNOB (HLAC 0)) + (SETQ TEM (COMP0 (CAR Y)) + ARGNO 1 + T1 (COMP0 (CADR Y)) + HLAC 2) + (LOADAC TEM 2 'T) ;The tag name + (LOADAC T1 1 'T)) ;The value + #%(CLEARALLACS) + (OUTPUT '(JRST 0 (ERUNDO -1))) + (GO RET)) + ((EQ X 'PLIST) + (SETQ VALAC (COMPLIST Y)) + (GO RETV)) + ((MEMQ X '(RPLACX CXR)) + (SETQ VALAC (COM-X-C-R X Y)) + (GO RETV)) + ((EQ X 'SFA-CALL) + (LOADACS (ITEML Y () ) 3 () ) + #%(CLEARALLACS) + (OUTPUT '(MOVEI TT SFCALI)) + (OUTPUT '(XCT 0 @ 1 1)) + (GO RETV)) + ((EQ X 'MUNKAM) + (SETQ UNSAFEP 'T) + (SETQ VALAC (COMMUNKAM Y)) + (GO RETV)) + ((MEMQ X '(EXAMINE DEPOSIT)) + (SETQ VALAC (COMEX-DP X Y)) + (GO RETV)) )) + ((EQ T1 'JSP) + (SETQ JSP (GET X 'JSP)) + (AND (EQ X 'CONS) + (QNILP (CADR Y)) + (SETQ X 'NCONS + Y (LIST (CAR Y)) + JSP (GET X 'JSP))) + (SETQ T1 (COND ((CDR JSP) ;CONS, NCONS + '((PNOB PNOB PNOB PNOB PNOB) ; and XCONS + () PNOB PNOB PNOB PNOB PNOB)) + ('(( T T T T ) () T T T T )))) ;%HUNKn + (GO LDARGS)) + ((MEMQ T1 '(EXPR *EXPR)) ) ;Normal case - Do nothing + ((MEMQ T1 '(*LEXPR LSUBR)) ;Compile L-type form + (COND ((EQ X PROGN) (PROG2 (REMOVE (SETQ Z (COMPROGN Y EFFS))) (RETURN Z))) + ((EQ X 'PROG2) + (COMPE (CAR Y)) + (SETQ T1 (COMP0 (CADR Y))) + (MAPC 'COMPE (CDDR Y)) + (REMOVE T1) + (RETURN T1)) + ((AND (EQ X 'BOOLE) (EQ (CAAR Y) 'QUOTE)) (RETURN (COMBOOLE Y))) + ((AND (EQ X 'PRINC) + (NOT (ATOM (CAR Y))) + (EQ (CAAR Y) 'QUOTE) + (STRTIBLE (CADAR Y))) + (GO OUTSTRT))) + (SETQ VALAC (COMLC X Y () )) + (GO CALLX)) + ((EQ T1 '*FEXPR) #%(NO-DELAYED-SPLDS) (GO F-FORM)) + ('T (GO LOSTF)))) ;*FEXPR should be case left + ((SETQ ARRAYP (GET X '*ARRAY)) + (COND ((AND ARRAYOPEN (NOT (EQ ARRAYP 'T))) + (SETQ VALAC (COMARRAY X Y ARRAYP () )) + (GO RET)))) + ((EQ X GOFOO) ;Hac for MAP series + ((LAMBDA (AC) + (OUTPUT '(PUSH P (% 0 0 '()))) + (PUSH (LIST (CAR Y)) REGPDL) + (OUTPUT (CONS 'MOVEI (CONS AC '(0 P)))) + (CONT AC (LIST (CADR Y)))) + (FRAC1)) + (SETQ OLVRL (DELQ (CAR Y) (DELQ (CADR Y) OLVRL))) + (GO RET)) + ('T (GO LOSTF) )) + (SETQ T1 (OR (GET X 'NUMFUN) (FUNMODE X))) + + LDARGS ;Compile for normal EXPR or SUBR type + (COND ((OR (NULL SPLDLST) + (NULL LDLST) + ARRAYP + JSP + (AND (GET X 'ACS) (NOT (EQ (GET X 'NOTNUMP) 'EFFS))) + (NULL (FLUSH-SPL-NILS))) + (SETQ Z (ITEML Y T1)) + (SETQ TEM () ) + (COND ((AND (CDR Y) ;Commutative 2-arg function + (NULL (CDDR Y)) ;2nd arg in acc 1, but + (NULL ARRAYP) + (SETQ TEM (GET X 'COMMU)) ; first arg not in ac + (EQUAL (ILOC0 (CAR Z) () ) 1) + (NOT (EQUAL (ILOC0 (CADR Z) () ) 1))) + (SETQ Z (REVERSE Z)) + (SETQ X TEM) + (AND JSP (SETQ JSP (GET X 'JSP)))))) + ('T #%(NO-DELAYED-SPLDS) ;Spec var and carcdr loads + (SETQ Z (ITEML Y T1)))) + (LOADACS Z (SETQ NARGS (LENGTH Z)) T1) + + CALL ;Output a "CALL" to the function + (COND ((NULL JSP) + (CLEARACS1 X () ) + (SETQ VALAC (OUTFUNCALL 'CALL NARGS X))) + ('T (COND ((NULL (CDR JSP)) (SETQ JSP (CAR JSP))) ;%HUNKn cases + ('T (SETQ JSP (COND ((NOT (UNSAFEP (CAR REGACS))) + (CAR JSP)) ;4-way split depending + ((CDR JSP)))) ; on safety of args + (COND ((EQ JSP 'PUNT) (SETQ JSP () ) (GO CALL))) ;punt this case, do CALL + (SETQ JSP (COND ((OR (NULL (CDR JSP)) ;dont check 2nd arg on + (NOT (UNSAFEP (CADR REGACS))));1-arg functions + (CAR JSP)) + ((CDR JSP)))))) + (CLEARACS1 X () ) + (OUTPUT JSP))) + CALLX (AND CCSLD (DIDUP CLPROGN)) ;Delete IDUPS if CSLD was called + (AND UNSAFEP (BARF () |UNSAFEP after "CALL" - COMPFORM|)) + (AND (OR CCSLD + (AND (NOT JSP) + (SYMBOLP X) + (OR (NOT (GET X 'ACS)) + (NOT (EQ (GET X 'NOTNUMP) 'NOTNUMP))))) + (CARCDR-FREEZE () () )) ;Freeze carcdrings if unsure + RETV (COND (EFFS (CONT VALAC () ) (RETURN () ))) + + RET (COND (EFFS (RETURN () )) + ('T (SETQ Z (LIST (GENSYM))) + (AND (AND UNSAFEP (NOT #%(NUMACP-N VALAC))) + (PUTPROP (CAR Z) 'T 'UNSAFEP)) + (CONT VALAC Z) + (RETURN Z))) + + RET-NO (SETQ VALAC ARGNO) + (GO RETV) + + + F-FORM (CPUSH 1) + (OUT1 'MOVEI 1 (LIST 'QUOTE Y)) + (CONT 1 () ) + F-* (SETQ NARGS 15.) ;15. Indicates F-type CALL + (GO CALL) + + OUTSTRT + (SETQ T1 (COND ((NULL (CDR Y)) 0) + ((EQ (CAR (SETQ T1 (COMP (CADR Y)))) 'MSGFILES) + (REMOVE T1) + 15.) + ((LOADINREGAC T1 'FRACB () )))) + (COND ((SYMBOLP (SETQ Y (CADAR Y)))) + ('T (SETQ Y (MAKNAM (EXPLODEN Y))))) + (COND (USE-STRT7 + #%(OUTFS 'STRT7 T1 `(% ASCII ,y))) + ('T #%(OUTFS 'STRT T1 `(% SIXBIT ,(6bstr y)) ))) + (RETURN '(QUOTE T)) + + LOSTF (BARF X |Lost function - COMPFORM|) )) + + + +(COMMENT COMABSMINUS and COMARITH) + +(DEFUN COMABSMINUS (FUN ARG) + ((LAMBDA (OP ARG AC TYPE LARG) + (SETQ LARG (ILOCMODE ARG 'FREENUMAC TYPE)) + (REMOVE ARG) + (COND ((AND (NOT ATPL) + (EQ (CAR LOUT) 'MOVE) + #%(NUMACP LARG) + (NOT (DVP LARG)) + (NUMBERP (CADR LOUT)) + (= (CADR LOUT) LARG)) + (RPLACA LOUT (CAR OP)) + (SETQ AC LARG)) + ('T (COND (#%(NUMACP LARG) + (SETQ AC LARG) + (CPUSH LARG) + #%(OUTFS (COND ((EQ (CAR OP) 'MOVN) 'MOVNS) ('MOVMS)) + 0 + LARG)) + ('T (OUT3 OP (SETQ AC (FREENUMAC)) LARG))))) + (SETMODE AC TYPE) + (CAR (CONT AC (LIST (GENSYM))))) + (COND ((EQ FUN 'MINUS) '(MOVN)) ((EQ FUN 'ABS) '(MOVM))) + (COMPW (CADR ARG) () #%(NUMVALAC)) + 0 + (CAR ARG) + () )) + +(DEFUN COMAD1SB1 (FUN ARG) + ((LAMBDA (AC N) + (AND (EQ (CAR ARG) 'FLONUM) (SETQ N (+ N 2))) + (AND (EQ FUN 'SUB1) (SETQ N (1+ N))) + (OUTPUT (A1S1A (- AC #%(NUMVALAC)) N)) + (SETMODE AC (CAR ARG)) + (CAR (CONT AC (LIST (GENSYM))))) + (LOADINSOMENUMAC (COMPW (CADR ARG) () #%(NUMVALAC))) + 0)) + + + +(DEFUN COMARITH (FUN LL) + ((LAMBDA (MIXP TYPEL ARGL) + (SETQ TYPEL (COND ((NULL (CAR LL)) (CAR COMAL)) + ((EQ (CAR LL) 'FIXNUM) (CADR COMAL)) + ((EQ (CAR LL) 'FLONUM) (CADDR COMAL)) + ('T (SETQ MIXP (MEMQ '() (CAR LL))) (CAR LL)))) + (SETQ ARGL ((LAMBDA (ARGNO EFFS PNOB TEM) + (MAPCAR '(LAMBDA (ARG TYPE) + (COND (TYPE + (FREEIFYNUMAC) + (SETQ ARGNO #%(NUMVALAC)) + (SETQ ARG (COMP0 ARG)) + (AND (NOT (EQ (CAR ARG) 'QUOTE)) + (SETQ TEM (ASSQ (CAR ARG) NUMACS)) + (NULL (GETMODE0 + (- #.(+ (NUMVALAC) (NUMNACS)) + (LENGTH (MEMQ TEM NUMACS))) + 'T + () )) + (NUMODIFY ARG TYPE)) + ARG) + ('T (SETQ ARGNO 1) + (COMP0 ARG)))) + (CDR LL) + TYPEL)) + #%(NUMVALAC) () () () )) + (COND ((OR (EQ TYPEL (CAR COMAL)) MIXP) + (CAR (CONT (COMLC FUN ARGL 'T) (LIST (GENSYM))))) + ((PROG (ARG1 ARG2 OP AC AD MODE) + (SETQ AC 0 MODE (CAR TYPEL)) + (SETQ OP (CDR (ASSQ FUN (COND ((EQ MODE 'FIXNUM) + '((PLUS ADD) (DIFFERENCE SUB) + (TIMES IMUL) (QUOTIENT IDIV))) + ('T '((PLUS FADR) (DIFFERENCE FSBR) + (TIMES FMPR) (QUOTIENT FDVR))))))) + (REMOVE (SETQ ARG1 (CAR ARGL))) + A (AND (NULL (SETQ ARGL (CDR ARGL))) (RETURN ARG1)) + (COND ((CDR TYPEL) (SETQ TYPEL (CDR TYPEL)))) + (SETQ ARG2 (CAR ARGL)) + (COND ((NOT (EQ MODE (CAR TYPEL))) + (COND ((EQ MODE 'FIXNUM) + (SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM))) + (SETQ OP (CDR (ASSQ (CAR OP) '((ADD FADR) (SUB FSBR) + (IMUL FMPR) (IDIV FDVR)))))) + ('T (PUSH ARG1 LDLST) + (PUSH (SETQ ARG2 (COMFIXFLT ARG2 'FLONUM)) LDLST))))) + (COND ((AND (MEMQ FUN '(PLUS TIMES)) + (NOT #%(ACLOCP (ILOC0 ARG1 MODE))) + #%(ACLOCP (SETQ AD (ILOC0 ARG2 MODE)))) + (REMOVEB ARG2) + (CPUSH (SETQ ARG2 ARG1 AC AD))) + ((EQ (CAR OP) 'IDIV) + (SETQ AD ((LAMBDA (TAKENAC1) (FREENUMAC)) + #.(+ (NUMVALAC) (NUMNACS) -1))) + (SETQ AC (LOADINNUMAC ARG1 AD () 'REMOVEB)) + (COND ((= AC #.(+ (NUMVALAC) (NUMNACS) -1)) + (LOADAC ARG1 AD () ) + (CONT AC () ) + (SETQ AC AD)))) + ('T (SETQ AC (LOADINSOMENUMAC ARG1)))) + (COND ((AND (EQ FUN 'TIMES) ;TRAP FOR MUL BY POWER OF 2 + (EQ MODE 'FIXNUM) + (QNP ARG2) + #%(/2^N-P (CADR ARG2))) + (REMOVE ARG2) + (COND ((> (CADR ARG2) 1) + #%(OUTFS 'ASH AC (1- (HAULONG (CADR ARG2))))) + ((= (CADR ARG2) 0) #%(OUTFS 'MOVEI AC 0))) + (GO B))) + (SETQ AD ((LAMBDA (TAKENAC1) #%(ILOCNUM ARG2 'FREENUMAC)) AC)) + (REMOVEB ARG2) + (COND ((EQ (CAR OP) 'IDIV) + ((LAMBDA (II) + (AND (CPUSH-DDLPDLP II AD) ;LEAVES SLOTX SET AT II + (SETQ AD (1- AD))) + (RPLACA SLOTX () ) + (SETMODE AC () )) + (1+ AC))) + ((AND #%(ACLOCP AD) (= AD #.(NUMVALAC)) (MEMQ FUN '(PLUS TIMES))) + (SETQ AD AC AC #.(NUMVALAC)))) + (AND (CPUSH-DDLPDLP AC AD) (SETQ AD (1- AD))) + (OUT3 OP AC AD) + B (SETMODE AC MODE) + (SETQ ARG1 (CAR (CONT AC (LIST (GENSYM))))) + (GO A))))) + () () () )) + + +(COMMENT COMARRAY) + + +(DEFUN COMARRAY (X Y FORM MODE) + (SETQ Y (NREVERSE + (ITEML Y (COND ((AND FORM (SETQ Y (GET X 'NUMFUN))) (SETQ MODE (CADR Y)) Y) + (#%(NCDR '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM) + (- 5 (LENGTH Y)))))))) + (COM-AREF X Y () MODE FORM)) + + + +(DEFUN COM-AREF (X Y STORE MODE FORM) + ;Compile for array references + (PROG (LOC ADDR ACX SVSLT FLAG TAKENAC1 ACLQ PARITY II) + (DECLARE (FIXNUM PARITY)) + (SETQ TAKENAC1 0 PARITY 0) + (SETQ LOC (COND ((AND (NOT EFFS) (NOT #%(NUMACP-N ARGNO))) ARGNO) + (STORE (FRAC1)) + ((FRAC5)))) + (COND ((AND (NULL MODE) STORE) + (SETQ ADDR #%(ILOCREG STORE LOC)) + (REMOVS STORE) + (SETQ STORE (MAKESAFE STORE ADDR () )))) + (SETQ ADDR + (CONS '@ + (COND ((NULL FORM) ;FORM=() => "ARRAYCALL" TYPE + (SETQ ACLQ (LIST (GENSYM)) + ACX (COND ((OR MODE (NOT STORE)) + (LOADINREGAC X + LOC + (ILOCMODE X LOC () ))) + ((LOADINREGAC X 'FRAC5 () ))) + SVSLT (FIND ACX)) + (RPLACA SVSLT ACLQ) + (PUSH ACLQ LDLST) + (LIST 1 ACX)) + ('T (SETQ FORM (COND ((EQ FORM 'T) () ) + ((CDR FORM)))) + (LIST (LIST 'ARRAY X)))))) + (COND ((NULL (CDR Y)) + (COND ((AND STORE + MODE + (NOT (EQ (CAR STORE) 'QUOTE)) + (SETQ FLAG (ILOC2 (VARBP (CAR STORE)) STORE MODE)) + (NUMBERP FLAG) + (= FLAG #%(NUMVALAC)) + (NOT (ZEROP (FREENUMAC1)))) + (SETQ TAKENAC1 #%(NUMVALAC) + FLAG (CAR #%(ACSSLOT #%(NUMVALAC))) + SVSLT (CAR #%(ACSMODESLOT #%(NUMVALAC))) + LOC (LOADINSOMENUMAC (CAR Y)) + TAKENAC1 0) + (OUT1 'EXCH LOC #%(NUMVALAC)) + (CONT LOC FLAG) + (SETMODE LOC SVSLT) + (SETQ FLAG () ) + #%(NULLIFY-NUMAC)) + ((QNP (CAR Y)) (REMOVE (CAR Y)) (SETQ FLAG (CADAR Y))) + ('T (LOADAC (CAR Y) #%(NUMVALAC) (SETQ FLAG () ))))) + ('T (PROG (N D) + (SETQ N 0 TAKENAC1 #%(NUMVALAC)) + (COND ((AND FORM + (DO ((ZZ FORM (CDR ZZ)) (Z Y (CDR Z))) + ((NULL Z) (SETQ FLAG 'T)) + (COND ((AND (QNP (CAR Z)) + (FIXP (SETQ ACX (CADAR Z))) + (COND ((FIXP (SETQ D (CAR ZZ)))) + ((EQ Y Z) (SETQ D 0) 'T))) + (SETQ N (+ (* D N) ACX))) ;Dimensionality and particular index + ((EQ Y Z) (RETURN () )) ;combined when both are constant + ('T (MAPC 'REMOVE (LSUB Y Z)) + (COND ((FIXP (CAR ZZ)) + (SETQ N (* N (CAR ZZ)) + FORM (CONS () (CONS CLPROGN (CDR ZZ))) + Y (CONS () Z))) + ('T (SETQ Y (CONS (LIST 'QUOTE N) Z) + FORM (CONS () ZZ)))) + (SETQ FLAG () ) + (RETURN 'T))))) + (SETQ PARITY (COND ((ODDP N) -1) (1))) + (COND (FLAG (MAPC 'REMOVE Y) ;Here, FLAG=T signals + (SETQ FLAG N) ;a constant linearized index + (RETURN () )) + ((AND (NULL (CAR Y)) (NULL (CDDR Y))) + (SETQ PARITY 0) ;PARITY has been lost here + (LOADAC (CADR Y) #%(NUMVALAC) () ) + (AND (NOT (ZEROP N)) ;Note that FLAG = () + #%(OUTFS 'ADDI #%(NUMVALAC) N)) + (RETURN () )) + ('T (CPUSH #%(NUMVALAC)) + (SETQ TAKENAC1 (SETQ ACX (FREENUMAC))) + #%(OUTFS 'MOVEI ACX N)))) + ('T (SETQ FLAG 'T))) + (SETQ N (1- (LENGTH Y))) + ;At this point, FLAG=() signals a partial index calcualtion has been done + (COND ((NULL FLAG)) + ('T (SETQ ACX (LOADINSOMENUMAC (CAR Y))) + (AND (NOT (= ACX #%(NUMVALAC))) (CPUSH #%(NUMVALAC))) + (CONT ACX () ) + (SETQ TAKENAC1 ACX))) + A (COND ((AND FORM (SETQ FORM (CDR FORM)) (FIXP (CAR FORM))) + (SETQ II (CAR FORM)) + (AND (NOT MODE) (NOT (ODDP II)) (SETQ PARITY 1)) + (COND (#%(/2^N-P II) #%(OUTFS 'ASH ACX (1- (HAULONG II)))) + ('T (OUT2 '(IMUL) ACX (LIST (LIST 'QUOTE (CAR FORM))))))) + ((OR (NULL FORM) (NOT (EQ (CAR FORM) CLPROGN))) + (AND (NOT MODE) (MINUSP PARITY) (SETQ PARITY 0)) + (COND ((= ACX #%(NUMVALAC)) + (SETQ ACX (FREENUMAC)) + (RPLACA SLOTX () ) ;FREENUMAC leaves SLOTX at AC slot + #%(OUTFS 'MOVEI ACX 0 #%(NUMVALAC)) + (SETQ TAKENAC1 ACX))) + (OUTPUT (BOLA N 4)) ;"(MOVNI 7 N)" + #%(NULLIFY-NUMAC) + (AND ACLQ + (NOT (EQ ACLQ (CAR SVSLT))) + (SETQ ADDR (ACLQ-FIND ACLQ () ) + SVSLT (FIND (CADDR ADDR)))) + (OUTPUT (CONS 'IMUL (CONS ACX ADDR))))) + (COND ((CDR (SETQ Y (CDR Y))) + (COND (MODE) + ((QNP (CAR Y)) + (AND (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY)))) + ('T (SETQ PARITY 0))) + (AREF-ADD (CAR Y) ACX) ;"(ADD ACX LOC[(CAR Y)])" + (SETQ N (1- N)) + (GO A)) + ('T (COND ((QNP (CAR Y)) + (AND (NOT MODE) (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY))) + (REMOVE (CAR Y)) + #%(OUTFS 'MOVEI #%(NUMVALAC) (CADAR Y) ACX)) + ((PROG2 (SETQ PARITY 0) (= ACX #%(NUMVALAC))) + (AREF-ADD (CAR Y) ACX)) + ('T (LOADAC (CAR Y) #%(NUMVALAC) () ) + #%(OUTFS 'ADD #%(NUMVALAC) ACX))) + (CONT ACX () ) + (RETURN (SETQ FLAG () )) ))) ;Normal exit leaves FLAG = () + (SETQ TAKENAC1 0))) + (COND (FLAG (COND ((AND MODE STORE + (NUMBERP (SETQ LOC (ILOC0 STORE MODE))) + (= LOC #.(NUMVALAC))) + (SETQ LOC ((LAMBDA (TAKENAC1) (FREENUMAC)) + #%(NUMVALAC))) + (LOADAC STORE LOC () ))) ;Non-null FLAG indicates constant + (CLEARACS -1 'T () )) + ('T (PUSH (SETQ FORM (LIST (GENSYM))) LDLST) ;INDEX not yet loaded; null FLAG + (RPLACA NUMACS FORM) ;Means computed index in NUMVALAC + (RPLACA ACSMODE 'FIXNUM))) + (AND MODE (GO NUMARRAY)) + + SARRAY + (SETQ ACX 'T) ;FLAG on whether or not to look up ACLQ again + (SETQ LOC (COND (STORE (LOADINREGAC STORE 'FRAC5 (ILOC0 STORE () ))) + ((AND (NOT EFFS) (NOT #%(NUMACP-N ARGNO))) + (SETQ ACX () ) + (AND ACLQ (REMOVE ACLQ)) + (CPUSH ARGNO) + ARGNO) + ('T (FRAC5)))) + (AND ACLQ ACX (NOT (EQ ACLQ (CAR SVSLT))) + (SETQ ADDR (ACLQ-FIND ACLQ LOC) + SVSLT (FIND (CADDR ADDR)))) + (SETQ ADDR (CONS LOC ADDR)) + (COND (FLAG #%(OUTFS 'MOVEI #%(NUMVALAC) (LSH FLAG -1)) + (OUTPUT (CONS (COND ((ODDP (SETQ II FLAG)) (COND (STORE 'HRRM) ('HRRZ))) + ('T (COND (STORE 'HRLM) ('HLRZ)))) + ADDR))) + ('T (REMOVE FORM) + (COND ((ZEROP PARITY) + (OUTPUT #.(SUBST (NUMVALAC) 'AC ''(ROT AC -1))) + (OUTPUT #.(SUBST (NUMVALAC) 'AC ''(JUMPL AC (* 3)))) + (OUTPUT (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR)) + (OUTPUT '(JUMPA 0 (* 2))) + (OUTPUT (CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR)) + #%(|Oh, FOO!|)) + ('T (COND ((OR ATPL ATPL1 + (NOT (EQ (CAR LOUT) 'MOVEI)) + (COND ((EQ (CAR LOUT1) 'ASH) () ) + ((EQ (CAR LOUT1) 'IMULI) (ODDP (CADDR LOUT1)))) + (NOT (= (CADDDR LOUT) (CADR LOUT1)))) + (OUTPUT #.(SUBST (NUMVALAC) 'AC ''(ROT AC -1)))) + ('T (RPLACA (CDDR LOUT1) + (COND ((EQ (CAR LOUT1) 'ASH) (1- (CADDR LOUT1))) + ('T (// (CADDR LOUT1) 2)))) + (RPLACA (CDDR LOUT) (// (CADDR LOUT) 2)))) + (OUTPUT (COND ((PLUSP PARITY) (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR)) + ((CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR)))))))) + (GO END) + + NUMARRAY + (COND (FLAG #%(OUTFS 'MOVEI #%(NUMVALAC) FLAG))) + (SETQ LOC (COND (STORE ((LAMBDA (TAKENAC1) (LOADINSOMENUMAC STORE)) + #%(NUMVALAC))) + ('T (COND (#%(NUMACP-N ARGNO) ARGNO) (#%(NUMVALAC)))))) + (AND ACLQ (NOT (EQ ACLQ (CAR SVSLT))) + (SETQ ADDR (ACLQ-FIND ACLQ () ) + SVSLT (FIND (CADDR ADDR)))) + (OUTPUT (CONS (COND (STORE 'MOVEM) ('MOVE)) (CONS LOC ADDR))) + (SETMODE LOC MODE) + (AND (NULL FLAG) (REMOVE FORM)) + END + (COND (ACLQ (RPLACA SVSLT () ) (REMOVE ACLQ))) + (RETURN LOC))) + + +(DEFUN ACLQ-FIND (ACLQ LOC) ;Called only by COM-AREF + ((LAMBDA (ACX) + (COND (#%(REGACP ACX)) + ((NULL LOC) (LOADAC ACLQ (SETQ ACX (FRAC5)) () )) + (((LAMBDA (SVSLT) + (SETQ LOC (CAR SVSLT)) + (RPLACA SVSLT '(NIL . TAKEN)) + (LOADAC ACLQ (SETQ ACX (FRAC5)) () ) + (RPLACA SVSLT LOC)) + (FIND LOC)))) + (LIST '@ 1 ACX)) + (ILOC0 ACLQ () ))) + + +(DEFUN AREF-ADD (ITEM ACX) ;COM-AREF "ADD" + (OUT3 '(ADD) ACX (ILOCMODE ITEM 'FREENUMAC 'FIXNUM)) + (REMOVE ITEM)) + + + +(DEFUN COMARG (Y) + (PROG (Z) + (COND ((NOT (EQ (CAAR Y) 'QUOTE)) + (SETQ Z (COND (#%(NUMACP-N ARGNO) (COMP1 (CAR Y))) + ((COMP0 (CAR Y))))) + (AND EFFS (PROG2 (REMOVE Z) (RETURN () ))) + (SETQ Z (LOADINSOMENUMAC Z)) + #%(OUTFS 'ADD Z 'ARGLOC) + (SETQ Y '((QUOTE 0))) + #%(LET ((TAKENAC1 Z)) (CPUSH ARGNO)) + (CONT Z () )) + ((NULL (CADAR Y)) + (CPUSH ARGNO) + (OUTPUT `(MOVE ,argno + ,@(cond (#%(numacp-n argno) + (rplaca #%(acsmodeslot argno) 'FIXNUM) + '(@) )) + (ARGLOC 1) )) + (RETURN ARGNO)) + ('T (CPUSH ARGNO) + (COND ((SETQ Z (MEMQ ARGLOC REGACS)) + (SETQ Z (- (+ 1 #%(NACS)) (LENGTH Z)))) + ((SETQ Z (MEMQ ARGLOC NUMACS)) + (SETQ Z (- (+ #%(NUMVALAC) #%(NUMNACS)) (LENGTH Z)))) + ('T (CONT (SETQ Z #%(FREACB)) ARGLOC) + #%(OUTFS 'MOVE Z 'ARGLOC))))) + (OUTPUT (COND (#%(NUMACP-N ARGNO) + (RPLACA #%(ACSMODESLOT ARGNO) () ) + `(MOVE ,argno @ ,(cadar y) ,z)) + (`(HRRZ ,argno ,(cadar y) ,z)))) + (RETURN ARGNO))) + + + +(COMMENT COMBOOLE) + +(DEFUN COMBOOLE (ARGL) + ((LAMBDA (N ARGNO EFFS Y) + (SETQ Y (CAR ARGL)) + (COND ((OR (NOT (FIXP (CADR Y))) (< (SETQ N (CADR Y)) 0) (> N 15.)) + (DBARF ARGL |Wrong value for operation code of BOOLE|))) + (SETQ ARGL (MAPCAR 'COMP0 (CDR ARGL))) + ((LAMBDA (AC ARG1 AD) + (COND ((OR (= N 3) (= N 5) (= N 10.) (= N 12.) (= N 0) (= N 15.)) + (COND ((OR (= N 0) (= N 15.)) + (SETQ AC (FREENUMAC)) + #%(OUTFS (CAR (CBA N)) AC AC)) + ('T (COND ((OR (= N 3) (= N 12.)) + (SETQ ARG1 (CAR (LAST ARGL))))) + (SETQ AC (LOADINSOMENUMAC ARG1)) + (COND ((OR (= N 10.) (= N 12.)) + (COND ((AND (NOT ATPL) + (EQ (CAR LOUT) 'MOVE)) + (RPLACA LOUT (CAR (CBA 10.)))) + ('T (OUTPUT `(,(car (cba 12.)) ,ac)))))))) + (MAPC 'REMOVEB ARGL) + (SETMODE AC 'FIXNUM)) + ((NULL (CDR ARGL)) + #%(WARN (CONS Y ARGL) |Too few args to BOOLE - COMBOOLE|) + (REMOVEB ARG1) + ARG1) + ((DO ((ARGL (CDR ARGL) (CDR ARGL))) + ((NULL ARGL) ARG1) + (COND ((AND (NOT #%(ACLOCP (ILOC0 ARG1 'FIXNUM))) + #%(ACLOCP (SETQ AD (ILOC0 (CAR ARGL) 'FIXNUM)))) + (REMOVEB (CAR ARGL)) + (CPUSH AD) + (SETQ AC AD + AD #%(LET ((TAKENAC1 AC)) + #%(ILOCNUM ARG1 'FREENUMAC))) + (COND ((OR (= N 2) (= N 13)) (SETQ N (+ N 2))) + ((OR (= N 4) (= N 15)) (SETQ N (- N 2)))) + (REMOVEB ARG1)) + ('T (SETQ AC (LOADINSOMENUMAC ARG1)) + #%(LET ((TAKENAC1 AC)) + (SETQ AD #%(ILOCNUM (CAR ARGL) 'FREENUMAC))) + (REMOVEB (CAR ARGL)))) + (COND ((AND (NOT ATPL) (EQ (CAR LOUT) 'MOVE) (EQUAL (CADR LOUT) AD)) + (CONT AD () ) + (SETQ LOUT (CONS (CAR (CBA N)) (CONS AC (CDDR LOUT))))) + ('T (OUT3 (CBA N) AC AD))) + (COND ((CDR ARGL) + ;Prepare for next time around loop + (PUSH (SETQ ARG1 (LIST (GENSYM))) LDLST) + (CONT AC ARG1))) + (SETMODE AC 'FIXNUM)))) + (CAR (CONT AC (LIST (GENSYM))))) + 0 (CAR ARGL) () )) + 0 #%(NUMVALAC) () () )) + + +(COMMENT COMCOND) + +(DEFUN COMCOND (Y BTEST F C@LCP) + ;;Typical y = (complexity setqlist condunsf mod clause 1 - - clause n) + (AND (AND C@LCP (NOT (GET C@LCP 'LEVEL))) + ;PROG tag - make sure that the PRSSL has been set + (CPVRL)) + (CLEAR (CADR Y) 'T) + #%(LET ((CEXIT (COND (C@LCP) ((LEVELTAG)))) + (EXLDL LDLST) + (CONDPNOB PNOB) + CLZTAG SVSPLDLST TEM ACX LASTCLZP JSP SNILP PNOB) + (COND ((AND (NOT EFFS) + (NOT BTEST) + (NOT (= ARGNO 1)) + (> (CAR Y) 1) + (NOT #%(NUMACP-N ARGNO))) + ;;A COND for value which is complex enough to warrant + ;; switching the valac to 1 + (SETQ ARGNO 1))) + (DO ((EXP (CDDDDR Y) (CDR EXP)) + (ARGNO ARGNO)) + ((NULL EXP) () ) + (SETQ SNILP 'T) + (SETQ LASTCLZP (NULL (CDR EXP))) + (COND ((OR (NULL (CDAR EXP)) (EQ (CADAR EXP) NULFU)) + ;COND pair with only one part or like ((NULL EXP) () ) + ; for value expressed as (EXP NULFU) + (COND (BTEST + (COND ((OR F LASTCLZP (CDAR EXP)) + (BOOL1LCK (CAAR EXP) BTEST F)) + ('T (BOOL1LCK (CAAR EXP) CEXIT 'T))) + (CLEARVARS)) + (EFFS + (IF LASTCLZP + (COMPE (CAAR EXP)) + (BOOL1LCK (CAAR EXP) CEXIT (NULL (CDAR EXP)))) + (CLEARVARS)) + ((AND (NOT LASTCLZP) + (NULL (CDAR EXP)) + #%(NUMACP-N ARGNO)) + #%(ILOCF (SETQ TEM (COMPR (CAAR EXP) () 'T 'T))) + (SETQ CLZTAG (LEVELTAG)) + (BOOL3 TEM () CLZTAG () ) + (LOADAC TEM ARGNO () ) + (CLEARVARS) + (OJRST CEXIT () ) + (SLOTLISTSET (LEVEL CLZTAG)) + (OUTTAG0 CLZTAG)) + ('T #%(LET ((CONDPNOB PNOB)) + (LOADAC (COMP (CAAR EXP)) + ARGNO + (NOT CONDPNOB))) + (CLEARVARS) + (AND (NOT LASTCLZP) + (COND ((AND (NULL (CDAR EXP)) + (OR #%(NUMACP-N ARGNO) + (AND (NOT ATPL) + (EQ (CAR LOUT) 'JSP) + (MEMQ (CADDR LOUT) '(FXCONS FLCONS))))) + (OJRST CEXIT () )) + ('T + (COND ((SETQ TEM (BADTAGP CEXIT)) + (SETQ TEM (LEVELTAG)) + (OUTJ (COND ((CDAR EXP) 'JUMPN) + ('JUMPE)) + ARGNO + TEM) + (OJRST CEXIT () ) + (SLOTLISTSET (LEVEL TEM)) + (OUTTAG0 TEM)) + ((OUTJ (IF (CDAR EXP) + 'JUMPE + 'JUMPN) + ARGNO + CEXIT))))))))) + ((AND (SETQ TEM (NULL (CDDAR EXP))) + (EQ (CAADAR EXP) 'GO) + (ATOM (CADADR (CAR EXP))) + (EASYGO)) + ;Like "(EXP (GO FOO))" + (SETQ SNILP (BOOL1 (CAAR EXP) (ADR (CADADR (CAR EXP))) 'T))) + ((AND TEM + (EQ (CAADAR EXP) 'RETURN) + (QNILP (CADR (CADAR EXP))) + (EASYGO)) + ;Like "(EXP (RETURN () ))" + (SETQ SNILP (BOOL1 (CAAR EXP) (GENTAG 'EXITN) 'T))) + ((AND (NOT EFFS) ;(COND . . . + (NOT BTEST) ; ((FOO BAR) . . . X) + (COND ((NULL (CDR EXP)) ; (T Y)) + (SETQ TEM ''()) ;OR LATTER CLAUSE MIGHT SIMPLY BE + (OR (ATOM (CAAR EXP)) ; (Y), OR BE ABSENT [EG, (T () )] + (P1BOOL1ABLE (CAAR EXP)))) + ((NULL (CDDR EXP)) ;X MUST BE VAR, OR QUOTED + (SETQ TEM ;Y MUST BE 1INSP + (COND ((NULL (CDR (SETQ TEM (CADR EXP)))) + (CAR TEM)) + ((AND (NULL (CDDR TEM)) + (EQ (CAAR TEM) 'QUOTE) + (CADR TEM)) + (CADR TEM)))) ;X HELD BY JSP, Y BY TEM + (COND ((NULL TEM) () ) + ((ATOM TEM) (1INSP TEM)) + ((MEMQ (CAR TEM) '(QUOTE FUNCTION))) + (#%(NUMACP-N ARGNO) () ) + ((AND (NOT (ATOM (CAR TEM))) + (EQ (CAAR TEM) CARCDR) + (NULL (CDDAR TEM)) + (ATOM (CADR TEM))))))) + (PROG2 (SETQ SVSPLDLST (CDDAR EXP) ACX () ) 'T) + (COND ((ATOM (SETQ JSP (CAR (LAST (CAR EXP))))) + (COND ((NULL (SETQ ACX (1INSP JSP))) () ) + ((NOT (EQ ACX CLPROGN)) + (SETQ ACX () ) + 'T) + ('T (SETQ ACX 'T) + (AND (NULL SVSPLDLST) + (COND ((ATOM TEM) (NOT (VARMODE TEM))) + ((QNILP TEM))))))) + ((EQ (CAR JSP) 'QUOTE) + (AND (NULL SVSPLDLST) + (COND ((SYMBOLP TEM) + (OR #%(NUMACP-N ARGNO) + (NOT (VARMODE TEM)))) + ((QNILP TEM))) + (SETQ ACX 'T)) + 'T))) + (AND ACX (SETQ ACX TEM TEM JSP JSP ACX ACX 'T));ACX=T => INVERTED TEST + (SETQ CLZTAG () ) + (CPUSH ARGNO) + (COND ((AND (NULL SVSPLDLST) + (COND ((ATOM (CAAR EXP)) + (SETQ SVSPLDLST (CAAR EXP)) + 'T) + ((AND (EQ (CAAAR EXP) 'NULL) + (ATOM (CADAAR EXP))) + (SETQ ACX (NULL ACX) SVSPLDLST (CADAAR EXP)) + 'T))) + (REMOVE (SETQ SVSPLDLST (COMP0 SVSPLDLST))) + (OUT1 (COND (ACX 'SKIPN) ('SKIPE)) + 0 + #%(ILOCN SVSPLDLST))) + ((COND (SVSPLDLST () ) + ((CCHAK-BOOL1ABLE (CAAR EXP) ACX)) + ((AND (EQ (CAAAR EXP) 'NULL) + (CCHAK-BOOL1ABLE (CADAAR EXP) (NULL ACX)))))) + ('T (SETQ CLZTAG (LEVELTAG)) + (BOOL1 (CAAR EXP) CLZTAG ACX) + (AND (CDDAR EXP) + (MAPC 'COMPE (CDR (L2F (CDAR EXP))))) + (CLEARVARS) + (RST CLZTAG))) + (REMOVE (SETQ JSP (COMP0 JSP))) + (SETQ JSP (ILOCMODE JSP + ARGNO + (IF #%(NUMACP-N ARGNO) + '(FIXNUM FLONUM) + '(() FIXNUM FLONUM)))) + (COND ((OR (AND (SETQ ACX (NUMBERP JSP)) (= ARGNO JSP)) + (AND (NULL ACX) + (NULL (CDR JSP)) + (EQUAL (CAR JSP) (CONTENTS ARGNO)))) + (COND ((AND (NOT CLZTAG) + (NOT ATPL) + (SETQ ACX (GET (CAR LOUT) 'CONV))) + (RPLACA LOUT ACX)) + ((OUTPUT '(SKIPA))))) + ((NOT #%(NUMACP-N ARGNO)) + (COND ((AND (NOT ACX) (QNILP (CAR JSP))) + (OUTPUT (BOLA ARGNO 1))) + ('T (OUT1 'SKIPA ARGNO JSP)))) + ((AND (NOT ACX) (NULL (CDR JSP)) (Q0P+0P (CAR JSP))) + #%(OUTFS 'TDZA ARGNO ARGNO)) + ('T (OUT3 '(SKIPA) ARGNO JSP))) + (COND (CLZTAG + (OUTPUT CLZTAG) + (SETQ SVSPLDLST (LIST REGACS NUMACS ACSMODE)) + (SLOTLISTSET (LEVEL CLZTAG)))) + (REMOVE (SETQ TEM (COMP0 TEM))) + (COND (#%(NUMACP-N ARGNO) + (OUT3 '(MOVE) ARGNO #%(ILOCNUM TEM ARGNO)) + (RPLACA #%(ACSMODESLOT ARGNO) () )) + ((PROG2 (SETQ JSP LOUT ACX #%(ILOCREG TEM ARGNO)) + (COND ((NOT (NUMBERP ACX)) (SETQ JSP 'T)) + ((NOT (= ACX ARGNO)) + (SETQ JSP () ) + (AND (REGADP ACX) (SETQ JSP 'T)) + 'T))) + (OUT1 (COND (JSP 'MOVE) + ('T (AND #%(NUMACP ACX) + (OR (NOT (EQ (CDR (CONTENTS ACX)) 'DUP)) + (PROG2 (CONT ACX () ) + () + (SETQ ACX #%(ILOCNUM TEM () ))) + (NOT #%(PDLLOCP ACX))) + (BARF TEM |Lost skip hac - CCMOD|)) + 'MOVEI)) + ARGNO + ACX)) + ((OR (NOT (EQ JSP LOUT)) + (AND (NOT ATPL) (EQ (CAR LOUT) 'JRST))) + () ) + ('T ((LAMBDA (INST) + (COND ((OR (COND (CLZTAG ATPL1) (ATPL)) + (NOT (MEMQ (CAR INST) '(TDZA SKIPA)))) + (BARF INST |Sussman loses - CCMOD|)) + ((EQ (CAR INST) 'TDZA) + (SETQ INST (CONS 'SETZM (CONS '0 (CDDR INST))))) + ('T (SETQ INST (CONS 'MOVE (CDR INST))))) + (COND (CLZTAG (SETQ LOUT1 INST)) + ('T (SETQ LOUT INST)))) + (COND (CLZTAG LOUT1) (LOUT))))) + #%(|Oh, FOO!|) + (AND CLZTAG (ACSMRGL SVSPLDLST)) + (SETQ SNILP 'T) + (AND (CDR EXP) (SETQ EXP (CDR EXP)))) + ('T (SETQ CLZTAG (LEVELTAG)) + (COND ((AND BTEST (NULL F) LASTCLZP) + (BOOL1LCK (CAAR EXP) BTEST () )) + ((AND EFFS LASTCLZP) + (BOOL1LCK (CAAR EXP) CEXIT () )) + ((BOOL1 (CAAR EXP) CLZTAG () ))) + (SETQ SVSPLDLST (APPEND (FLUSH-SPL-NILS) () )) + (SETQ ACX () ) + (COMPROGN (CDR (SETQ TEM (L2F (CDAR EXP)))) 'T) + (COND ((EQ (CAAR TEM) 'COND) + (RST CEXIT) + #%(LET ((PNOB CONDPNOB)) + (COMCOND (CDAR TEM) BTEST F CEXIT))) + (BTEST (BOOL1 (CAR TEM) BTEST F)) + (EFFS (COMPE (CAR TEM))) + ('T (SETQ ACX ARGNO) + (SETQ TEM #%(LET ((PNOB CONDPNOB)) + (COMP0 (CAR TEM)))) + (COND ((OR (NOT (QNILP TEM)) + (AND (NOT (QNILP (CONTENTS ACX))) + (COND ((NOT LASTCLZP)) + ((SETQ SNILP () ))))) + (LOADAC TEM ACX (NOT CONDPNOB))) + ((REMOVEB TEM))))) + (COND ((NOT (SETQ JSP (AND (NOT ATPL) (EQ (CAR LOUT) 'JRST)))) + (CLEARVARS) + (COND ((OR (NOT LASTCLZP) + (AND SNILP + (NOT EFFS) + (NOT BTEST) + (GET CLZTAG 'USED) + (SNILPTST CLZTAG))) + (SETQ SNILP () ) + (OJRST CEXIT ACX)) + ('T (RST CEXIT))))) + #%(|Oh, FOO!|) + (SETQ SPLDLST SVSPLDLST) + (SETQ TEM (COND ((COND ((NOT LASTCLZP)) + ((GET CLZTAG 'USED) + (AND SNILP + (NOT EFFS) + (NOT BTEST) + (SNILPTST CLZTAG) + (SETQ SNILP () )) + 'T)) + (OUTTAG0 CLZTAG) + (LEVEL CLZTAG)) + ((AND (NOT C@LCP) (GET CEXIT 'USED)) + (COND ((NOT (EQ (SETQ TEM (LEVEL CEXIT)) PRSSL)) TEM) + ((MAPCAR '(LAMBDA (X) (APPEND X () )) TEM)))))) + (COND ((NULL TEM)) + ((AND LASTCLZP (NOT JSP) (NOT C@LCP)) + (ACSMRGL TEM)) + ('T (SLOTLISTSET TEM)))))) + (COND (BTEST (COND ((AND (NOT F) (NOT SNILP)) (OJRST BTEST () )))) + ((AND (NOT EFFS) (NOT SNILP)) (OUT1 'MOVEI ARGNO '(QUOTE () )))) + (SETQ CNT (PLUS CNT 2)) + (COND (C@LCP) + ((OUTTAG CEXIT)) + ('T (CLEARVARS) (RST CEXIT))) + (DIDUP (CADR Y)))) + +(DEFUN SNILPTST (CLZTAG) + (NOT ((LAMBDA (REGACS) (QNILP (CONTENTS ARGNO))) (CAR (LEVEL CLZTAG))))) + + +(DEFUN CCHAK-BOOL1ABLE (EXP ACX) + (AND (P1BASICBOOL1ABLE EXP) + (NOT (MEMQ (CAR EXP) '(SIGNP NULL PROG2))) + ((LAMBDA (PROP) + (COND ((NOT (AND (EQ PROP 'NUMBERP) + (MEMQ (CAR EXP) '(GREATERP LESSP)) ;LIMIT GREATERP AND + (AND (CDDDR EXP) (NULL (CDDDDR EXP))))) ; LESSP TO TWO ARGS + (COND ((MEMQ (CAR EXP) '(EQ EQUAL)) + (COMEQ (CDR EXP) () ACX)) + ((MEMQ (CAR EXP) '(GREATERP LESSP)) + (COMGRTLSP EXP () ACX)) + ((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP ODDP)) + (COMZP EXP () ACX)) + ((MEMQ PROP '(T NUMBEREP)) + (BARF EXP |Lost in CCHAK-BOOL1ABLE|)) + ('T (COMTP EXP PROP () ACX () ))) + 'T))) + (GET (CAR EXP) 'P1BOOL1ABLE)))) + + +(COMMENT COMEQ) + +(DEFUN COMEQ (EXP TAG F) +; Compile EQ. JRST to TAG (or SKIP one instruction) when sense is normal +; (normal sense signalled by non-null F) +; Return non-null iff JUMP to TAG is being outputted by COMEQ + (PROG (X Y Y/' LX LY AC TYPEL TYPX TYPY TEMP N) + (SETQ N 1) + (SETQ TYPEL (SETQ TYPY (SETQ TYPX (POP EXP)))) + (COND (TYPEL + (AND (NOT (MEMQ TYPEL '(FIXNUM FLONUM))) + (SETQ TYPX (CAR TYPEL) TYPY (CADR TYPEL))) + (SETQ TEMP (OR (AND (EQ TYPX 'FIXNUM) + (OR (Q0P+0P (SETQ X (CAR EXP))) + (Q1P+1P-1P X))) + (AND (EQ TYPY 'FIXNUM) + (OR (Q0P+0P (SETQ Y (CADR EXP))) + (Q1P+1P-1P Y))))))) + (COND ((AND TEMP TAG) + (AND (NOT Y) (SETQ X (CADR EXP))) + (SETQ AC (LOADINSOMENUMAC (COMPW X () #%(NUMVALAC)))) + (AND (NOT (= TEMP 0)) (SETMODE AC () ) (CONT AC () )) + (OUTJ (COND ((= TEMP 0) (COND (F 'JUMPE) ('JUMPN))) + ((< TEMP 0) (COND (F 'AOJE) ('AOJN))) + ('T (COND (F 'SOJE) ('SOJN)))) + AC + TAG) + (RETURN 'T))) + (NUMODIFY (SETQ X (COMPW (CAR EXP) () (COND (TYPX #%(NUMVALAC)) (1)))) TYPX ) + (SETQ Y (COMPW (CADR EXP) () (COND (TYPY (FREENUMAC)) + ((AND (NULL TYPX) + (NOT EFFS) + (EQUAL 1 (ILOC0 X () ))) + ARGNO) + (1)))) +; Possibly LY = 1 but Y = (SPECIAL FOO) or (QUOTE FOO) +; will cause LX to become 1 + (SETQ LY (ILOCMODE Y (COND (TYPY 'FREENUMAC) ('FRACF)) TYPY)) + (SETQ LX (ILOCMODE X (COND (TYPX 'FREENUMAC) ('FRACF)) TYPX)) + (COND ((OR (AND TYPEL (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) + (NUMBERP (CADR X))) + (AND TYPY (NOT TYPX))) + (SETQ TEMP X X Y Y TEMP) + (SETQ TEMP LX LX LY LY TEMP) + (SETQ TEMP TYPX TYPX TYPY TYPY TEMP))) + (COND ((AND #%(ACLOCP LX) (NOT (AND TYPX (REGADP LX)))) + (SETQ AC LX) + (AND (NUMBERP LY) + (= LY 1) + (NOT (EQUAL Y (CAR REGACS))) + (SETQ LY (ILOC0 Y () ))) + (SETQ Y/' Y) + (REMOVE X)) + ((AND #%(ACLOCP LY) (NOT (AND TYPY (REGADP LY)))) + (SETQ AC LY LY LX Y/' X X Y TEMP TYPX TYPX TYPY TYPY TEMP) + (REMOVE X)) + ('T (SETQ AC (COND ((NOT TYPX) + (COND ((NOT (DVP1 REGACS 1)) + (LOADAC X 1 () ) 1) + ('T (LOADINREGAC X () LX)))) + ((LOADINSOMENUMAC X)))) + (SETQ Y/' Y))) +; At this point +; AC contains loc of one arg +; X is internal form of that arg +; LY has loc of other +; Y/' is internal form of arg in LY + (COND (TAG (CLEARVARS) + (COND ((AND #%(PDLLOCP LY) + (PROG2 () 'T + (SETQ TEMP (CDDDR (LEVEL TAG)) N LY) + (SETQ N (LENGTH + (COND ((NOT #%(NUMPDLP-N N)) + (PROG2 () (CAR TEMP) (SETQ TEMP REGPDL))) + ((NOT #%(FLPDLP-N N)) + (PROG2 () (CADR TEMP) (SETQ TEMP FXPDL))) + ('T (PROG2 () (CADDR TEMP) (SETQ TEMP FLPDL))))))) + (> LY (CONVNUMLOC (SETQ N (- N (LENGTH TEMP))) + (AND (NOT (REGADP LY)) TYPY)))) + (SETQ LY (COND ((NULL TYPY) (FRAC5)) + (((LAMBDA (TAKENAC1) (FREENUMAC)) AC)))) + (LOADAC Y/' LY () ) + (RSTD TAG AC LY)) + ((AND (RSTD TAG AC 0) (NOT (PLUSP N))) + (SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY)))) + (REMOVE Y/')) + ((NULL TAG) + (REMOVE Y/') + (AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO () LY)) 'PUSH) + (EQ (PROG2 (FIND AC) (CPUSH1 AC () LY)) 'PUSH)) + #%(PDLLOCP LY) + (SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY))))) + (SETQ TEMP (COND (#%(EQUIV F TAG) '(CAMN)) ('T '(CAME)))) + (COND (#%(NUMACP-N AC) (OUT3 TEMP AC LY)) + ((OUT1 (CAR TEMP) AC LY))) + (AND TAG (OUTJ0 'JUMPA 0 TAG 'T () )) )) + + +(DEFUN NUMODIFY (X TYPX) + (COND ((NULL TYPX) () ) + ('T (SETQ X (ILOCMODE X 'FREENUMAC TYPX)) + (AND #%(NUMACP X) (RPLACA #%(ACSMODESLOT X) TYPX)) + X))) + + + +(DEFUN COMEX-DP (X Y) + #%(LET* ((VALAC (COND (#%(NUMACP-N ARGNO) ARGNO) ((FREENUMAC)))) + (T1 (COMPW (CAR Y) () VALAC)) + TEM Z) + (AND (EQ X 'DEPOSIT) (SETQ Y (COMPW (CADR Y) () #%(NUMVALAC)))) + (SETQ T1 (COND ((AND (NOT (EQ (CAR T1) 'QUOTE)) + (SETQ Z (ILOCMODE T1 () 'FIXNUM)) + (COND (#%(ACLOCP Z) (SETQ TEM (REGADP Z)) 'T) + ((NOT (REGADP Z))))) + (REMOVE T1) + Z) + ((LOADINNUMAC T1 VALAC () 'REMOVEB)))) + (COND ((EQ X 'EXAMINE) + (CPUSH VALAC) + (COND (TEM #%(OUTFS 'MOVE VALAC '@ 0 T1)) + ('T (OUT1 '(MOVE) VALAC T1))) + (SETMODE VALAC 'FIXNUM)) + ('T #%(LET ((TAKENAC1 T1)) (SETQ Y (LOADINSOMENUMAC Y))) + (COND (TEM #%(OUTFS 'MOVEM Y '@ 0 T1)) + ('T (OUT1 '(MOVEM) Y T1))) + (AND (NOT EFFS) + #%(OUTFS 'MOVEI + (SETQ VALAC (COND (#%(NUMACP-N ARGNO) ARGNO) ((FRACB)))) + ''T)) )) + VALAC)) + + +(COMMENT COMERSET) + +(DEFUN COMERSET (FUN Y) + #%(LET ((GOBRKL GOBRKL) (ARGNO 1) (TAG (GENSYM)) + ERSTP PASSP CATP RSL V) + (CASEQ FUN (ERRSET (SETQ ERSTP 'T)) + (%PASS-THRU (SETQ PASSP 'T)) + ((*CATCH %CATCHALL CATCH-BARRIER) (SETQ CATP 'T)) + ('T (BARF FUN |What type frame - COMERSET|))) + (COND ((OR PASSP (AND CATP (EQ FUN '%CATCHALL))) + #%(LET ((FTAG (GENSYM))) + #%(CLEARALLACS) + (COND (CATP #%(OUTFS 'MOVEI T TAG) ; for CATCHALL + (OUTPUT '(JSP TT (ERSETUP -3)))) + + (PASSP (OUTPUT '(JSP TT PTNTRY)))) ; for PASS-THRU + #%(OUTFS 'JUMPA 0 FTAG) + #%(|Oh, FOO!|) + (AND PASSP (PROG2 (STRETCHPDL LPASST-P+1 () ) + (STRETCHPDL LPASST-FXP 'FIXNUM))) + (STRETCHPDL 1 () ) ;For ret addr of POPJ P below + (SETQ RSL (SLOTLISTCOPY)) + (LOADAC (COMP1 (CAR Y)) 1 'T) + (RESTORE RSL) + (OUTPUT '(POPJ P)) + (OUTPUT FTAG) + (SHRINKPDL 1 () ) + (AND PASSP (PROG2 (SHRINKPDL LPASST-P+1 () ) + (SHRINKPDL LPASST-FXP 'FIXNUM))) )) + ('T (LOADAC (COMP1 (CAR (COND (ERSTP (CDR Y)) (Y)))) 1 'T) ; for CATCH varieties + (CLEARACS 2 'T () ) + (CLEARNUMACS) + #%(OUTFS 'MOVEI 2 TAG) + (OUTPUT (CASEQ FUN (ERRSET '(JSP TT ERSETUP)) + (*CATCH '(JSP TT (ERSETUP -1))) + (CATCH-BARRIER '(JSP TT (ERSETUP -2))) )))) + (STRETCHPDL LERSTP+1 () ) + (SETQ RSL (SLOTLISTCOPY)) + (PUSH (CONS (COND (CATP 'CATCH) (FUN)) RSL) GOBRKL) + (SETQ V (COND (ERSTP (COMP0 (COND ((AND EFFS (EQ (CAAR Y) 'NCONS)) ;Value from ERRSET will + (CADAR Y)) ; will generally be + ((CAR Y))))) ; in 1 since it is + ('T (COMPROGN (CDR Y) EFFS)))) ; of form (NCONS FOO) + (COND ((AND (NOT EFFS) (NOT (EQUAL 1 (ILOC0 V () )))) + (LOADAC V 1 'T)) ; so put it in 1 + ((NULL EFFS) (REMOVE V))) + (RESTORE RSL) + (AND #%(CLEARALLACS) (BARF () |What got pushed - COMERSET|)) + (OUTPUT (COND (ERSTP (AND EFFS (OUTPUT '(MOVEI 1 'T))) ;Break up frame of + '(JRST 0 ERUNDO)) ; ERRSET + (PASSP '(JSP TT PTEXIT)) ; PASS-THRU + (CATP '(JRST 0 (ERUNDO -2))))) ; nearest CATCH + (SHRINKPDL LERSTP+1 () ) + (OUTPUT TAG) + (SETQ CNT (+ CNT 2)) + (COND (EFFS () ) + (T (RPLACA REGACS (SETQ V (LIST (GENSYM)))) V)))) + +(COMMENT COMFIXFLT and COMHAULONG) + +(DEFUN COMFIXFLT (ITEM MODE) ;MODE IS ALWAYS EITHER "FIXNUM" OR "FLONUM" + (COND ((EQ (CAR ITEM) 'QUOTE) + (REMOVE ITEM) + ((LAMBDA (TYPE) + (COND ((MEMQ TYPE '(FIXNUM BIGNUM)) + (COND ((EQ MODE 'FIXNUM) + (COND ((EQ TYPE 'BIGNUM) + (PDERR (CADR ITEM) |Too big to be FIXNUM|) + (SETQ ITEM '0))) + ITEM) + ((LIST 'QUOTE (FLOAT (CADR ITEM)))))) + ((EQ MODE 'FLONUM) ITEM) + ((LIST 'QUOTE (FIX (CADR ITEM)))))) + (TYPEP (CADR ITEM)))) + ('T + #%(LET ((LOC #%(NUMVALAC))) + (DECLARE (SPECIAL LOC)) + (COND ((EQ MODE 'FIXNUM) + #%(LET ((TAKENAC1 (+ #%(NUMVALAC) #%(NUMNACS) -1))) + (SETQ LOC (LOADINSOMENUMAC ITEM))) + (AND (> LOC #.(+ 1 (NUMVALAC))) + (LOADAC ITEM (SETQ LOC #%(NUMVALAC)) () )) + (CPUSH (1+ LOC)) + (MAPC 'OUTPUT + (CASEQ LOC + (#.(+ 0 (NUMVALAC)) ;to flush the QUOTE + '((MULI #.(NUMVALAC) 256.) + (TSC #.(NUMVALAC) #.(NUMVALAC)) + (ASH #.(+ 1 (NUMVALAC)) -163. #.(NUMVALAC)))) + (#.(+ 1 (NUMVALAC)) + '((MULI #.(+ 1 (NUMVALAC)) 256.) + (TSC #.(+ 1 (NUMVALAC)) #.(+ 1 (NUMVALAC))) + (ASH #.(+ 2 (NUMVALAC)) -163. #.(+ 1 (NUMVALAC))))) + (T (BARF LOC |LOC no good for IFIX - COMFIXFLT|)))) + (CONT LOC () ) + (SETMODE LOC ()) + (SETQ LOC (1+ LOC))) + ('T (LOADAC ITEM (SETQ LOC #%(NUMVALAC)) () ) + (OUTPUT '(JSP T IFLOAT)))) + (SETMODE LOC MODE) + (CAR (CONT LOC (SETQ DATA (LIST (GENSYM))))))))) + + +(DEFUN COMHAULONG (Y) + ((LAMBDA (ARGNO ACX EFFS) + (LOADAC (COMP0 (CADR Y)) ARGNO () ) + (SETQ ACX (COND ((= ARGNO #%(NUMVALAC)) (+ 2 #%(NUMVALAC))) + (#%(NUMVALAC)))) + (COND ((AND (NOT ATPL) + (EQ (CAR LOUT) 'MOVE) + (FIXP (CADR LOUT)) + (= (CADR LOUT) ARGNO)) + (SETQ LOUT (CONS 'MOVM (CDR LOUT)))) + (#%(OUTFS 'MOVMS 0 ARGNO))) + (CLEARNUMACS) + (MAPC 'OUTPUT + (COND ((AND (= ACX #%(NUMVALAC)) (= ARGNO (1+ #%(NUMVALAC)))) + #.(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC)))) + ''((MOVEI TT 36.) (JFFO D (* 2)) (TDZA TT TT) (SUBI TT 0 R)))) + ((AND (= ACX (+ 2 #%(NUMVALAC))) (= ARGNO #%(NUMVALAC))) + #.(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC)))) + ''((MOVEI R 36.) (JFFO TT (* 2)) (TDZA R R) (SUBI R 0 D)))) + ((BARF (LIST ARGNO ACX) |Lose lose - COMHAULONG|)))) + (SETMODE ACX 'FIXNUM) + (CAR (CONT ACX (LIST (GENSYM))))) + (COND ((= ARGNO #%(NUMVALAC)) (1+ #%(NUMVALAC))) + (#%(NUMVALAC))) + () + ())) + + +(COMMENT COMGO and COMGORET) + +(DEFUN COMGO (Y) + (COND ((ATOM (CAR Y)) + (COMGORET (ADR (CAR Y)) 0)) + ('T (CPVRL) + (LOADAC (COMP1 (CAR Y)) 1 'T) + (COMGORET (GENTAG 'VGO) 1)))) + + +(DEFUN COMGORET (TAG AC) + (CPVRL) + (CLEARVARS) + (COND ((EASYGO) (OJRST TAG AC)) + ('T (CLEARNUMACS) + ((LAMBDA (L LDLST CNT) + (MAPC '(LAMBDA (Y) (AND (EQ (CAR Y) 'UNBIND) + (CDR Y) + (SETQ CNT (CDR Y)))) + GOBRKL) + (MAPC '(LAMBDA (Y) + (COND ((EQ (CAR Y) 'UNBIND) (OUTPUT '(PUSHJ P UNBIND))) + ('T (RESTORE (CDR Y)) + (OUTPUT + (COND ((EQ (CAR Y) 'ERRSET) ;For ERRSETs + '(JSP T GOBRK)) + ((EQ (CAR Y) 'CATCH) + '(JSP T (GOBRK -1))) ;For CATCHs + ('(JSP TT PTEXIT)))) ;For PASS-THRU + (SHRINKPDL LERSTP+1 () )))) ; or UNWIND-PROTECT + GOBRKL) + (COND ((NULL L-END-CNT)) + ((> L-END-CNT CNT) (SETQ CNT L-END-CNT))) + (OJRST TAG AC) + (SLOTLISTSET L)) + (SLOTLISTCOPY) PROGP CNT)))) + + + +(COMMENT COMGRTLSP) + +;;; Chart of how COMGRTLSP works, using LESSP for example +;;; (LESSP A B), which is not 2LONG, and +;;; (LESSP A B C D), which is 2LONG +;;; P1 is the comparison between A and B, P2 between B and C, +;;; P3 between C and D. In the normal sense of the test, the +;;; result is either a JUMP to a TAG, or a SKIP of one instruction. +;;; In the inverted sense, the logical sense of the test is +;;; complemented. The argument "F" is non-null for the normal sense. + +;;; Examples for the 2LONG case follow. After it are the +;;; examples for the not-2LONG case. + + +;;; When TAG is supplied, and there is no level problem with it + +;;; Normal Inverted +;;; ---------------- -------------- +;;; CAIL P1 CAIL P1 +;;; JRST LOSE JRST TAG +;;; CAIL P2 CAIL P2 +;;; JRST LOSE JRST TAG +;;; |CAIGE| P3 CAIL P3 +;;; JRST TAG JRST TAG +;;; LOSE: . . . + +;;; When TAG is supplied, and there is a level problem + +;;; Normal Inverted +;;; ---------------- -------------- +;;; CAIL P1 CAIL P1 +;;; JRST LOSE JRST WIN +;;; CAIL P2 CAIL P2 +;;; JRST LOSE JRST WIN +;;; CAIL P3 |CAIGE| P3 +;;; JRST LOSE JRST LOSE +;;; [PDL corrections] WIN: [PDL corrections] +;;; JRST TAG JRST TAG +;;; LOSE: ... LOSE: . . . + +;;; When no TAG is supplied + +;;; Normal Inverted +;;; ---------------- -------------- +;;; CAIL P1 CAIL P1 +;;; JRST LOSE JRST WIN +;;; CAIL P2 CAIL P2 +;;; JRST LOSE JRST WIN +;;; CAIL P3 CAIL P3 +;;; LOSE: . . . WIN: SKIPA + + + +;;; For all cases which are not-2LONG + +;;; With TAG, normal With TAG, inverted +;;; ---------------- -------------- +;;; |CAIGE| P1 CAIL P1 +;;; JRST TAG JRST TAG + +;;; No TAG, normal No TAG, inverted +;;; ---------------- -------------- +;;; CAIL P1 |CAIGE| P1 + + + + +(DEFUN COMGRTLSP (EXP TAG F) + (PROG (ARGL TYPEL MODE ARG1 ARG2 AC AD OP BTAG CTAG B2F SAVE FL 2LONG) + (SETQ TYPEL (COND ((NULL (CADR EXP)) (SETQ OP 'FIXNUM) '(()) ) + ((NOT (MEMQ (CADR EXP) '(FIXNUM FLONUM))) (CADR EXP)) + ((NCONS (SETQ OP (CADR EXP)))))) + (SETQ ARGL ((LAMBDA (ARGNO EFFS) + (MAPCAR '(LAMBDA (X) + (SETQ SAVE (COMP0 X)) + (NUMODIFY SAVE OP) + SAVE) + (CDDR EXP))) + #%(NUMVALAC) () )) + (SETQ 2LONG (CDDR ARGL)) + (COND ((AND TAG + (NOT 2LONG) + (OR (Q0P+0P (SETQ ARG1 (CAR ARGL))) + (Q0P+0P (SETQ ARG2 (CADR ARGL))))) + (SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'JUMPL) + ((EQ (CAR EXP) 'GREATERP) 'JUMPG) + ((GO BARF)))) + (SETQ ARG2 (COND (ARG2 (REMOVE ARG2) ARG1) + ('T (SETQ OP (GET OP 'COMMU)) + (REMOVE ARG1) + (CADR ARGL)))) + (OUTJ (COND (F OP) ((GET OP 'CONV))) + (LOADINNUMAC ARG2 0 () 'REMOVE) + TAG) + (RETURN 'T))) + (SETQ MODE (CAR TYPEL) ARG1 (CAR ARGL)) + (SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'CAML) + ((EQ (CAR EXP) 'GREATERP) 'CAMG) + ((GO BARF)))) + (SETQ BTAG (COND ((NOT 2LONG) + (AND #%(EQUIV TAG F) + (SETQ OP (GET OP 'CONV))) + TAG) + ('T (CLEARVARS) ;REALLY only have to clear out vars + (FREEIFYNUMAC) ; which will be SETQ in this computation + (SETQ CTAG (LEVELTAG)) + (COND ((NULL TAG) CTAG) + ('T (AND (BADTAGP TAG) (SETQ B2F CTAG)) + (COND ((OR F B2F) CTAG) + (TAG))))))) + (DO ((ARGL (CDR ARGL) (CDR ARGL))) + ((NULL ARGL)) + (SETQ ARG2 (CAR ARGL) TYPEL (OR (CDR TYPEL) TYPEL)) + (COND ((NOT (EQ MODE (CAR TYPEL))) + (COND ((EQ MODE 'FIXNUM) + (SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM)))) + ((SETQ ARG2 (COMFIXFLT ARG2 'FLONUM)))))) + (COND ((AND (NOT #%(ACLOCP (SETQ AD (ILOCMODE ARG1 'FREENUMAC MODE)))) + (PROG2 (SETQ SAVE (ILOCMODE ARG2 'FREENUMAC MODE)) 'T) + (COND (#%(NUMACP SAVE) (REMOVE ARG2) 'T) + ((EQ (CAR ARG1) 'QUOTE) + (SETQ SAVE (LOADINNUMAC ARG2 0 () 'REMOVE)) + 'T))) + (SETQ AC SAVE FL 'T SAVE ARG1)) + ('T (COND (#%(NUMACP AD) + (SETQ AC AD)) + ((SETQ AC (LOADINNUMAC ARG1 0 () 'REMOVE)))) + (REMOVE ARG1) + ((LAMBDA (TAKENAC1) (SETQ AD (ILOCMODE ARG2 'FREENUMAC MODE))) AC) + (SETQ SAVE ARG2 FL () ))) + (COND ((OR (NULL 2LONG) (CDR ARGL))) ;Fix up last clause of 2LONGs + ((NULL TAG) (SETQ BTAG () )) ; for reversal of condition + ((AND F (NULL B2F)) (SETQ BTAG TAG OP (GET OP 'CONV))) + ((AND (NULL F) B2F) + (PUTPROP (SETQ BTAG (SETQ CTAG (GENSYM))) + (GET B2F 'LEVEL) + 'LEVEL) + (SETQ OP (GET OP 'CONV)))) + (COND (TAG (AND (RSTD BTAG AC 0) + (NUMBERP AD) + (SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE))) + (REMOVEB SAVE) + (CLEARVARS)) + ('T (REMOVE SAVE) + (AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO () AD)) 'PUSH) + (EQ (PROG2 (FIND AC) (CPUSH1 AC () AD)) 'PUSH)) + #%(PDLLOCP AD) + (SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE))))) + (OUT3 (ASSQ (COND ((NULL FL) OP) ((GET OP 'COMMU))) + '((CAML) (CAMLE) (CAMG) (CAMGE))) + AC + AD) + (AND BTAG (OUTJ0 'JUMPA 0 BTAG 'T 0)) + (SETQ ARG1 ARG2)) + (COND (CTAG (SETQ SAVE (SLOTLISTCOPY)) + (COND (B2F (AND (NULL F) (OUTTAG B2F)) + (OUTJ0 'JRST 0 TAG 'T 0))) + (SLOTLISTSET (LEVEL CTAG)) + (SETQ REGACS (CAR SAVE) ;This is half a + NUMACS (CADR SAVE) ; SLOTLISTSET + ACSMODE (CADDR SAVE)) + (OUTTAG0 CTAG) + (AND (NULL TAG) (NULL F) (OUTPUT '(SKIPA))))) + (RETURN () ) + BARF (BARF EXP |This is no fun - COMGRTLSP|))) + +(COMMENT COMLAMAP) + +(DEFUN COMLAMAP (FORM) +;;; FORM = ((LAMBDA complexity setqlist (specvars modelist ignorevars) +;;; lamvars body endcount lamunsf nlnvthtbp) +;;; arg1 arg2 ... argn) + #%(LET ((OLVRL OLVRL) (BVARS BVARS) (GOBRKL GOBRKL) (MODELIST) + (CONDPNOB PNOB) (LLL (CDDAR FORM)) + SPECVARS IGNOREVARS LARG SPFL LMRSL MODE TEM Y PNOB ITEM SETQLIST) + (POP LLL SETQLIST) + (POP LLL MODELIST) + #%(DESETQ (SPECVARS MODELIST IGNOREVARS) MODELIST) + (CLEAR SETQLIST () ) ;Check out the SETQ-list + (COND ((MEMQ PROGN SETQLIST) (CLEARACS0 () )) ;but not vars that will go out + ('T ((LAMBDA (CNT) (CLEARVARS)) (CADDR LLL)))) ;of date during LAMBDA + (SETQ LMRSL (SLOTLISTCOPY)) ;Remember how deep the slotlist is + (CNPUSH (CAR (CDDDDR LLL)) () ) ;Push NLNVTHTBP + + (AND (CDR FORM) ;Compute up arglist, iloc items, + (PROG (SPLL1 SPLLV RGLLL RGLLM LMQL VMS N LARGSLOTP) ;Keep track of QUOTE stuff for + (SETQ VMS (MAPCAR 'VARMODE (CAR LLL))) ;efficient binding, and separate + (DO ((VAR (REVERSE (CAR LLL)) (CDR VAR)) ;out items for SPECIAL vars + (TYPEL (REVERSE VMS) (CDR TYPEL)) + (ACLQ 'T) ;Hac to help find free acs + (AARGS (DO ((EFFS) (T1) (ARGNO 1) (AARGS) (TYPEL VMS (CDR TYPEL)) + (Y (CDR FORM) (CDR Y)) (VAR (CAR LLL) (CDR VAR))) + ((NULL Y) AARGS) + (COND ((NULL (CAR VAR)) (PUSH (COMPE (CAR Y)) AARGS)) + ((AND (NOT (SETQ SPFL (SPECIALP (CAR VAR)))) + (CAR TYPEL)) + (PUSH (COMPW (CAR Y) () #%(NUMVALAC)) AARGS) + (COMLOCMODE (CAR AARGS) 'FREENUMAC (CAR TYPEL) (CAR VAR))) + ('T (SETQ TEM PNOB ;PNOB prohibited + PNOB (AND (NOT SPFL) (CAR VAR)) ; on special vars + T1 (COMP0 (CAR Y)) + PNOB TEM) + (PUSH (OR (MAKESURE (CAR Y) (CAR VAR) SPFL T1 #%(ILOCN T1)) + T1) + AARGS)))) + (CDR AARGS))) + ((NULL VAR)) + (AND (NULL (CAR VAR)) (GO DOX)) + (SETQ SPFL (SPECIALP (CAR VAR))) + (SETQ MODE (AND (NOT SPFL) (CAR TYPEL))) + (SETQ LARG (ILOCMODE (CAR AARGS) () MODE)) + (REMOVE (CAR AARGS)) + (SETQ LARGSLOTP (NUMBERP LARG)) + (COND ((AND (NOT LARGSLOTP) (NULL (CDR LARG))) + (COND ((AND SPFL (NOT (QNILP (CAR LARG))) (NOT (ASSOC LARG LMQL))) + (COND ((NULL ACLQ) (SETQ N 0)) + ((NOT (ZEROP (SETQ N (FRACB))))) + ((EQ ACLQ 'CLEARVARS) (SETQ ACLQ () )) + ('T (CLEARVARS) (SETQ ACLQ 'CLEARVARS N (FRACB)))) + (COND ((ZEROP N) + (OPUSH LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN)) MODE)) + ('T (PUSH (CONS LARG N) LMQL) + (OUT1 'MOVE N LARG) + (CONT N (CONS LARG 'TAKEN)) + (SETQ ITEM (CONS (CAR VAR) LARG))))) + ('T (SETQ ITEM (CONS (CAR VAR) LARG))))) + ('T (COND ((COND (LARGSLOTP (COND ((AND (NOT MODE) (NOT (REGADP LARG))) + () ) + ('T (FIND LARG) + (AND (> LARG 0) + SPFL + (CPUSH1 LARG 'T () )) + (NOT (DVP1 SLOTX LARG))))) + ((AND SPFL (NOT (ZEROP (SETQ N (LOADINREGAC + (CAR AARGS) + 'FRACB + () ))))) + + (SETQ LARG N) + 'T) + ('T (AND (NOT (EQ (CAR LARG) 'SPECIAL)) + (BARF LARG |Not LARGSLOTP - COMLAMAP|)) + (OPUSH LARG () MODE) + (SETQ LARG (CONVNUMLOC 0 MODE)) + 'T)) + (CONT LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN)))) + ('T (SETQ ITEM (CONS (CAR VAR) (CONS 'ILOC0 (CAR AARGS)))) + (PUSH (CAR AARGS) LDLST))))) + (COND (SPFL (PUSH ITEM SPLL1) (PUSH (CAR VAR) SPLLV)) + ('T (PUSH MODE RGLLM) (PUSH ITEM RGLLL))) + DOX ) + + (SETQ SPFL (PROGHACSET SPLL1 (CADR LLL))) + +; Cause the LAMBDA bindings to happen + + (MAPC + '(LAMBDA (VAR MODE) + (COND ((EQ (CDR VAR) 'TAKEN) ;(VAR . TAKEN) + (RPLACD VAR () )) + ((AND (NULL (CDDR VAR)) ;(VAR . ((QUOTE () ))) + (OR (QNILP (CADR VAR)) ;(VAR . ((QUOTE 0))) + (AND MODE (Q0P+0P (CADR VAR))))) + (PUSH (CAR VAR) OLVRL)) + ('T + (SETQ TEM (COND ((EQ (CADR VAR) 'ILOC0) ;(VAR . (ILOC0 . QUANT)) + #%(ILOCF (CDDR VAR))) + ('T (CDR VAR)))) ;(VAR . ((QUOTE THING))) + + (COND ((AND (NOT MODE) (NOT (REGADP TEM))) + (SETQ N (FRACB)) + (COND ((ZEROP N) (CLEARVARS) (SETQ N (FRACB)))) + (AND (ZEROP N) (BARF REGACS |COMLAMAP acs lossage|)) + (AND (NOT (MEMQ (CAR VAR) UNSFLST)) + (BARF (LIST (CAR VAR) TEM) |Unsafe var - COMLAMAP|)) + (MAKEPDLNUM (CDDR VAR) N) + (CONT N (LIST (CAR VAR)))) + ('T (AND (EQ (CADR VAR) 'ILOC0) (REMOVEB (CDDR VAR))) + (OPUSH TEM (LIST (CAR VAR)) MODE)))))) + RGLLL RGLLM) +;;; For binding to a special var, the item must be in an accumulator +;;; and a call to the pseudo function SPECBIND is made + (COND (SPLL1 (CPUSH (+ #%(NUMVALAC) 2)) ;SPECBIND uses acc R [= 11 = TT+2] + (OUTPUT '(JSP T SPECBIND)) + (MAPC '(LAMBDA (VAR) + (MAP '(LAMBDA (SL) ;Kill REGAC slots + (AND (SETQ ITEM (CAR SL)) ; with specbound vars + (EQ (CAR ITEM) (CAR VAR)) + (MEMQ (CDR ITEM) '(DUP () )) + (RPLACA SL () ))) + REGACS) + (SETQ LARG + (COND ((EQ (CDR VAR) 'TAKEN) + (RPLACD VAR CNT) + (SETQ LARG (ILOC1 'T VAR () )) + (COND ((NOT (NUMBERP LARG)) + (BARF () |Lost TAKEN - COMLAMAP|)) + ((PROG2 (SETQ N LARG) #%(PDLLOCP N)) + (CONT LARG () ))) + (RPLACD VAR 'DUP) + LARG) + ((QNILP (CADR VAR)) () ) + ((EQ (CADR VAR) 'ILOC0) + (SETQ TEM (PROG2 () + #%(ILOCF (SETQ TEM (CDDR VAR))) + (REMOVEB TEM))) + (COND (#%(PDLLOCP TEM) + (AND (NOT (DVP TEM)) (RPLACA SLOTX () )) + TEM) + ('T (BARF TEM |Lost ILOC0 - COMLAMAP|)))) + ((SETQ LARG (ASSOC (CDR VAR) LMQL)) + (CONT (CDR LARG) (LIST (CAR VAR))) + (CDR LARG)) + ('T (BARF () |Lost entirely - COMLAMAP|)))) + (OSPB LARG (CAR VAR))) + SPLL1) + (DIDUP SPLLV) + (MAPC 'CARCDR-FREEZE SPLLV (CAR COMAL)) ;(CAR COMAL) has infinite list of ()s + (PUSH (CONS 'UNBIND (CADDR LLL)) GOBRKL))))) + +; EXECUTE LAMBDA BODY AND RESTORE SLOTLIST + + (SETQ BVARS (APPEND (CAR LLL) BVARS)) + (SETQ ITEM ((LAMBDA (PNOB L-END-CNT) (COMP0 (CADR LLL))) + CONDPNOB (OR L-END-CNT (CADDR LLL))) + TEM () ) + (COND ((AND (NOT EFFS) + (NOT (EQ (CAR ITEM) 'QUOTE)) + (PROG2 (SETQ TEM (MEMQ (CAR ITEM) (CAR LLL)) Y #%(ILOCN ITEM)) + (OR TEM (NOT #%(ACLOCP Y))))) + (SETQ LARG (COND (#%(NUMACP-N ARGNO) (LOADINNUMAC ITEM ARGNO Y 'REMOVEB)) + ((AND (OR TEM (NOT CONDPNOB)) + (OR (NOT (REGADP Y)) (UNSAFEP ITEM))) + (LOADAC ITEM 1 'T) + 1) + ((LOADINREGAC ITEM ARGNO Y)))) + (AND (OR TEM (NOT (EQUAL ITEM (CONTENTS LARG)))) + (CONT LARG (SETQ ITEM (LIST (GENSYM))))) + (PUSH ITEM LDLST))) + (COND ((AND (L/.LE/. (CAR (SETQ TEM (CDDDR LMRSL))) REGPDL) + (L/.LE/. (CADR TEM) FXPDL) + (L/.LE/. (CADDR TEM) FLPDL)) + (RESTORE LMRSL)) + ('T (DO Z '(REGACS () NUMACS () REGPDL 0 FXPDL #.(FXP0) FLPDL #.(FLP0)) + (CDDR Z) + (NULL Z) + (DO ((SLOTL (SYMEVAL (CAR Z)) (CDR SLOTL)) (I 0 (1+ I))) + ((NULL SLOTL)) + (AND (CAR SLOTL) + (MEMQ (CAAR SLOTL) (CAR LLL)) + (RPLACA SLOTL () )))))) + (SETQ CNT (1+ CNT)) + (COND (SPFL (OUTPUT '(PUSHJ P UNBIND)))) + (DIDUP SETQLIST) + (CLEANUPSPL () ) + (REMOVE ITEM) + ITEM)) + + + +(DEFUN COMLOCMODE (ITEM FUN MODE VAR) + ((LAMBDA (LARG NLARG OPPOSER) + (SETQ OPPOSER (COND ((NOT (NUMBERP LARG)) + (COND ((EQ (CAR LARG) 'SPECIAL) (VARMODE (CADR LARG))) + ((EQ (CAAR LARG) 'QUOTE) + (CAR (MEMQ (TYPEP (CADAR LARG)) '(FIXNUM FLONUM)))))) + ((PROG2 (SETQ NLARG LARG) #%(NUMACP-N NLARG)) + (COND ((GETMODE0 LARG 'T () )) + ('T (SETMODE LARG MODE) MODE))) + (#%(NUMPDLP-N NLARG) + (COND (#%(FLPDLP-N NLARG) 'FLONUM) + ('FIXNUM))) + ((GETMODE LARG)) + ('T MODE))) + (AND OPPOSER + (NOT (EQ MODE OPPOSER)) + (DBARF (LIST (CONS VAR MODE) (CONS ITEM OPPOSER)) + |Binding number variable to quantity of wrong type|)) + 0 + LARG) + #%(ILOCNUM ITEM FUN) + 0 + ())) +;;; dont try to substitute ILOC1 or ILOC2 for this ILOCNUM - +;;; You have to satisfy conflicts between the REGWORLD and NUMWORLD + + +(COMMENT COMLC for lsubr calls) + +(DEFUN COMLC (X Y ITEMFL) +; Compile a CALL to an L-FORM - P1 places L-type CALLs within the scope of an +; internal LAMBDA application like ((LAMBDA () (LCALL * *)) () ). +; Thus a CLEAR is done by COMLAMAP + #%(LET ((OARGNO (COND ((AND (EQ (CAR X) COMP) (EQ (CADR X) 'FUNCALL)) 1) + ((OR PNOB #%(NUMACP-N ARGNO)) ARGNO) + (1))) + (ARGNO 1) (OPNOB PNOB) (PNOB 'T) (NARGS (LENGTH Y))) + (PROG (TAG Z LZ RSL PDLTP) + (SETQ NARGS (LENGTH Y)) + (COND ((NOT (ATOM X)) + (AND (EQ (CAR X) COMP) #%(ILOCF (CADDR X)))) + ((ZEROP NARGS) + (CLEARACS1 X 'GENSYM) ;Remembering that COMLAMAP has CLEARVARS'd + (OUTPUT '(MOVEI T 0)) + (SETQ ARGNO OARGNO PNOB OPNOB) + (RETURN (COML1 X 'CALL)))) + (CLEARACS #.(+ (NACS) (NUMNACS)) () 'GENSYM) ;Remembering that COMLAMAP has CLEARVARS'd + (SETQ TAG (RETURNTAG)) + (SETQ PDLTP (LIST (APPEND REGPDL '()))) + (SETQ RSL (APPEND '(() () () ) PDLTP)) + (MAPC + '(LAMBDA (ARG) + (SETQ LZ #%(ILOCREG (SETQ Z (COND (ITEMFL ARG) + ('T (COMPW ARG () 1)))) + 1)) + (RESTORE RSL) + (COND ((NOT (REGADP LZ)) (MAKEPDLNUM Z (SETQ LZ (FRACB)))) + ((REMOVEB Z))) + (COND ((AND #%(ACLOCP LZ) + (NOT ATPL) + (EQ (CAR LOUT) 'SUB) + (EQ (CADR LOUT) 'P) + (EQUAL LOUT '(SUB P (% 0 0 1 1)))) + (SETQ LOUT (SETQ ATPL 'FOO)) + (OUT1 'MOVEM LZ 0) + (PUSH '(NIL . TAKEN) REGPDL)) + ('T (AND #%(PDLLOCP LZ) (SETQ LZ (ILOC0 Z () ))) + (OPUSH LZ '(NIL . TAKEN) () ))) + (RPLACA PDLTP (CONS '(NIL . TAKEN) (CAR PDLTP)))) + Y) + (AND (CLEARACS0 () ) ;Check for importent things + (BARF () |Too much value - COMLC|)) ; being inadvertently left in ACs + (CLEARACS1 X () ) ;Clobber out the ACs to be used + #%(OUTFS 'MOVNI 'T NARGS) + (SETQ ARGNO OARGNO PNOB OPNOB) + (SETQ Z (COML1 X 'JCALL)) + (OUTPUT TAG) + (SHRINKPDL (1+ NARGS) () ) + (RETURN Z)))) + + + +(DEFUN COML1 (X OP) + (COND ((EQ (CAR X) COMP) + ((LAMBDA (LOC INST) + (REMOVEB (CADDR X)) + (COND (INST (SETQ INST (COND ((EQ OP 'CALL) (CAR INST)) + ((CADR INST)))) + (OUT1 (CAR INST) (CADR INST) LOC) + 1) + ('T (OUT1 'MOVE #%(NUMVALAC) LOC) + (OUTPUT (COND ((EQ OP 'CALL) '(PUSHJ P @ 1 #.(NUMVALAC))) + ('T '(JRST 0 @ 1 #.(NUMVALAC))))) + (RPLACA ACSMODE (CADR X)) + #%(NUMVALAC)))) + #%(ILOCF (CADDR X)) + (COND ((EQ (CADR X) 'FUNCALL) '(((CALLF) 16) ((JCALLF) 16))) + ((NULL (CADR X)) '(((PUSHJ) P) ((JRST) 0)))))) + ((OUTFUNCALL OP 16 X)))) + + +(DEFUN COMMAKNUM (Y) + #%(LET ((VALAC 1) Z TEM) + #%(LET ((ARGNO (COND (#%(NUMACP-N ARGNO) + (COND ((NOT (DVP ARGNO)) (SETQ TEM ARGNO)) + ((NOT (ZEROP (SETQ TEM (FREENUMAC1))))) + ((SETQ TEM #%(NUMVALAC)))) + (FRAC5)) + ('T ;(SETQ UNSAFEP PNOB) + (SETQ TEM () ) 1))) + EFFS PNOB) + (SETQ Z (COMP0 (CAR Y)) Y ARGNO)) + (CPUSH (SETQ VALAC (OR TEM #%(NUMVALAC)))) + (SETQ Y #%(ILOCREG Z Y)) + (REMOVEB Z) + (AND #%(ACLOCP Y) (CPUSH Y)) + (CCSWITCH VALAC Y) + (SETMODE VALAC 'FIXNUM) + (COND ((NULL TEM) + (CPUSH 1) + (COND ((NOT PNOB) + (SETQ VALAC 1) + (OUTPUT '(JSP T FXCONS)) + #%(NULLIFY-NUMAC))))) + VALAC)) + + +(DEFUN COMMUNKAM (Y) + #%(LET* ((Z (COMP0 (CAR Y))) + (TEM #%(ILOCN Z)) + (VALAC (COND ((AND #%(ACLOCP TEM) + (NOT #%(NUMACP TEM))) + TEM) + (#%(NOT (NUMACP-N ARGNO)) ARGNO) + ((FRAC5))))) + (REMOVEB Z) + (COND (#%(NUMACP TEM) #%(LET ((TAKENAC1 TEM)) (CPUSH VALAC))) + ((CPUSH VALAC))) + (OUT1 (COND ((REGADP TEM) '(HRRZ)) ('HRRZ)) VALAC TEM) + VALAC)) + + +(DEFUN COMNULL (Y) + ((LAMBDA (LY TEM FL N) + (COND ((NOT EFFS) + (COND ((CCHAK-BOOL1ABLE Y () )) + ('T (SETQ TEM (COMP0 Y) LY #%(ILOCREG TEM ARGNO) + FL (NUMBERP LY)) + (AND FL (SETQ N LY)) + (REMOVEB TEM) + (FIND ARGNO) + (AND (CPUSH1 ARGNO () LY) + FL + #%(REGPDLP-N N) + (SETQ FL (NUMBERP (SETQ LY (ILOC0 TEM () )))) + (SETQ N LY)) + (COND ((AND FL #%(ACLOCP-N N)) (OUTPUT (BOLA N 3))) + ('T (OUT1 'SKIPE 0 LY))))) + (BOOLOUT () () )) + ((COMPE Y)))) + () () () 0)) + + +(DEFUN COMPLIST (Y) + #%(LET ((VALAC 1) Z T1 TEM) + (SETQ T1 #%(ILOCN (SETQ Z (COMP0 (CAR Y)))) + TEM (COND ((NOT (NUMBERP T1)) () ) + ((> T1 0) 'PLUSP) + ('T))) + (REMOVEB Z) + (SETQ VALAC (COND ((EQ TEM 'PLUSP) (CPUSH T1) T1) + ((NOT (DVP ARGNO)) ARGNO) + (#%(FREAC)))) + (COND ((AND (NULL TEM) + (NULL (CDR T1)) + (EQ (CAAR T1) 'QUOTE)) + #%(OUTFS 'HRRZ + VALAC + (COND ((CADAR T1) (CAR T1)) + ('T 'NILPROPS)))) + ('T (COND ((EQ TEM 'PLUSP) + #%(OUTFS 'SKIPN (COND ((= T1 VALAC) 0) (T1)) T1)) + ((OUT1 'SKIPN VALAC T1))) + #%(OUTFS 'SKIPA VALAC 'NILPROPS) + #%(OUTFS 'HRRZ VALAC 0 VALAC) + #%(|Oh, FOO!|))) + VALAC)) + + +(COMMENT COMPROG COMPROGN AND COMRETURN) + +(DEFUN COMPROG (Y) +;;; Y = (complexity setqlist golist progvars progbody progunsf nlnvthtbp) + (AND (NULL SFLG) (CLEAR (CADR Y) 'T)) + #%(LET ((OARGNO ARGNO) + (PVR ARGNO) + (OPVRL (COND (PVRL (CONS PVRL OPVRL)) (OPVRL))) + (SPFL SFLG) + (OEFFS EFFS) + (ARGNO 1) + (EFFS 'T) + (EXLDL LDLST) + (PROGP LDLST)) + (OR (AND (NOT EFFS) (NOT (= ARGNO 1)) (< (CAR Y) 2)) + #%(NUMACP-N ARGNO) + (SETQ PVR 1)) + (PROG (EXIT EXITN LPRSL PRSSL GOBRKL VGO GL PVRL SPECVARS MODELIST + IGNOREVARS PNOB RETURNP TEM LY L-END-CNT PROGTYPE) + (SETQ MODELIST (CAR (SETQ LY (CDDDR Y)))) + #%(DESETQ (SPECVARS MODELIST IGNOREVARS) MODELIST) + (MAPC '(LAMBDA (X) + (AND (SPECIALP X) + (PROG2 (COND ((NULL SPFL) + (SETQ SPFL 'T) + (CPUSH #.(+ (NUMVALAC) 2)) + (OUTPUT '(JSP T SPECBIND)))) + (OSPB () X)))) + (CADR LY)) + (COND (SFLG (CLEAR (CADR Y) 'T) (SETQ SFLG () ))) + (SETQ CNT (ADD1 CNT)) + (SETQ GL (CADDR Y)) + (SETQ PVRL (MAPCAN '(LAMBDA (X) (AND (NOT (SPECIALP X)) (LIST X))) + (CAR (SETQ LY (CDR LY))))) + (CNPUSH (CADDR (SETQ LY (CDR LY))) () ) ;PUSH NLNVTHTBP + (MAP '(LAMBDA (X) + (SETQ CNT (ADD1 CNT)) + (COND ((ATOM (CAR X)) + (COND ((SETQ TEM (ADR (CAR X))) + #%(CLEARALLACS) + (CPVRL) + (RESTORE PRSSL) + (COND ((NOT ATPL) (PUTPROP TEM LOUT 'PREVI))) + (OUTTAG0 TEM) + (CLEANUPSPL () ))) + (SETQ RETURNP () )) + ((AND (NULL (CDR X)) (EQ (CAAR X) 'RETURN)) + (COMRETURN (CDAR X) () ) + (SETQ RETURNP 'T)) + ('T (COND ((EQ (CAAR X) 'COND) + (AND (MEMQ GOFOO (CADDAR X)) (RESTORE PRSSL)) + (COMCOND (CDAR X) + () + () + (AND (CDR X) + (EQ (CAADR X) 'GO) + (ATOM (SETQ TEM (CADADR X))) + (ADR TEM)))) + ('T (COMPW (CAR X) 'T 1)))))) + (CAR LY)) + (COND ((AND (NULL LPRSL) + (COND ((NULL EXIT) + (AND (NOT OEFFS) (CMPRGLDNIL 'T)) + 'T) + ((NULL EXITN)))) + (CLEANUPSPL () ) + (SETQ CNT (+ CNT 2)) + #%(CLEARALLACS)) + ('T (SETQ RETURNP (AND (NOT RETURNP) + (OR ATPL (NOT (EQ (CAR LOUT) 'JRST))))) + (OUTTAG EXITN) + (AND (NOT OEFFS) (CMPRGLDNIL RETURNP)) + (OUTTAG EXIT) + #%(CLEARALLACS) + (OR EXIT EXITN (CLEANUPSPL () )) + (SETQ CNT (+ CNT 2)))) + (COND (SPFL (CPUSH #.(+ (NUMVALAC) 2)) (OUTPUT '(PUSHJ P UNBIND)))) + (DIDUP (CADR Y)) + (AND VGO (PUSH (CONS VGO (GCDR 'CAAR GL)) VGOL)) + (AND #%(NUMACP-N PVR) + (SETMODE PVR (COND (PROGTYPE) ('FIXNUM)))) + (RETURN PVR)))) + + + +(DEFUN COMPROGN (L OEFFS) + (IF L + (LET ((EFFS 'T) + (ARGNO ARGNO) + (OARGNO ARGNO)) + ;;First, compute for effects all but last item + (DO ((NL)) + ((NULL (SETQ NL (CDR L)))) + (COMP0 (CAR L)) + (SETQ L NL)) + ;;Then restore the original EFFS and ARGNO, and do last one + (SETQ EFFS OEFFS ARGNO OARGNO) + (COMP0 (CAR L))))) + +(DEFUN CMPRGLDNIL (FL) + (AND (OR FL EXITN) + (COND (#%(NUMACP-N PVR) (LOADAC '(QUOTE 0) PVR () )) + ((NOT (QNILP (CONTENTS PVR))) (LOADAC '(QUOTE () ) PVR 'T))))) + +(DEFUN COMRETURN (Y GOP) + ((LAMBDA (ARGNO) + (COND ((QNILP (CAR Y)) + (GENTAG 'EXITN) + (AND GOP (COMGORET EXITN 0))) + ('T ((LAMBDA (PNOB ARGNO EFFS) + (LOADAC (COMP0 (CAR Y)) PVR 'T)) + () PVR ()) + (AND #%(NUMACP-N PVR) + (SETQ Y (CAR #%(ACSMODESLOT PVR))) + (COND ((NULL PROGTYPE) (SETQ PROGTYPE Y)) + ((NOT (EQ PROGTYPE Y)) (SETQ PROGTYPE 'FIXNUM)))) + (GENTAG 'EXIT) + (AND (OR GOP EXITN) (COMGORET EXIT PVR))))) + PVR)) + +(COMMENT COMREMAINDER AND COMSHIFTS) + +(DEFUN COMREMAINDER (ARGL) + (DO ((ARGNO #%(NUMVALAC)) (TAKENAC1 TAKENAC1) (EFFS) (ARG1) (ARG2) (AC) (LARG) (SVSLT)) + () + (SETQ ARG1 (COMP0 (CAR ARGL))) + (AND (NOT (EQ (CAR ARG1) 'QUOTE)) ;If 2nd arg computation is + (NOT (ATOM (CADR ARGL))) ; complicated, and 1st is + (NOT (EQ (CAR (CADR ARGL)) 'QUOTE)) ; in NUMAC, but dunno type, + (SETQ LARG (ILOC0 ARG1 'FIXNUM)) ; then force to be FIXNUM + #%(NUMACP LARG) + (NULL (CAR (SETQ LARG #%(ACSMODESLOT LARG)))) + (RPLACA LARG 'FIXNUM)) + (SETQ ARGNO #%(NUMVALAC) + ARG2 (COMP0 (CADR ARGL)) + TAKENAC1 (1- (+ #%(NUMVALAC) #%(NUMNACS))) + AC (FREENUMAC) + LARG #%(ILOCNUM ARG1 #%(NUMVALAC))) + (COND ((AND #%(NUMACP LARG) + (< LARG #.(1- (+ (NUMVALAC) (NUMNACS))))) + (REMOVEB ARG1) + (SETQ AC LARG)) + ((LOADINNUMAC ARG1 AC () 'REMOVEB))) + (FIND AC) + (CPUSH1 AC () () ) + (RPLACA SLOTX '(NIL . TAKEN)) + (SETQ SLOTX (CDR (SETQ SVSLT SLOTX))) ;SETUP FOR ENTRY TO CPUSH1 + (CPUSH1 (1+ AC) () () ) + (SETQ LARG #%(ILOCNUM ARG2 (1+ AC))) + (REMOVEB ARG2) + (OUT3 '(IDIV) AC LARG) + (SETQ LARG #%(ACSMODESLOT AC)) + (AND (NULL (CDR LARG)) (BARF AC |WHATS THIS AC DOING HERE -COMREMAINDER|)) + (RPLACA LARG () ) ;SETMODE AC NIL + (RPLACA (CDR LARG) 'FIXNUM) ;SETMODE AC+1 'FIXNUM + (RPLACA SVSLT () ) ;CONT AC () + (RETURN (CAR (RPLACA (CDR SVSLT) (LIST (GENSYM))))))) + + +(DEFUN COMSHIFTS (OP AARGS) + #%(LET ((ARGNO #%(NUMVALAC)) + (TAKENAC1 0) + EFFS ARG1 ARG2 ) + (SETQ ARG1 (COMP0 (CAR AARGS)) ARG2 (COMP0 (CADR AARGS))) + (SETQ TAKENAC1 (LOADINSOMENUMAC ARG1)) + (SETQ ARG1 (COND ((EQ (CAR ARG2) 'QUOTE) (REMOVE ARG2) (CADR ARG2)))) + (COND ((COND ((NULL ARG1) () ) + ((EQ OP 'FSC) (> ARG1 262143.)) ;FSC N,HUGE leaves unnormalized + ((= ARG1 0)))) ;LSH.ASH.ROT N,0 does nothing + ('T (SETQ ARG2 (COND (ARG1 (LIST ARG1)) + ((LIST 0 (LOADINSOMENUMAC ARG2))))) + (AND (NOT ARG1) + (EQ OP 'FSC) + #%(OUTFS 'CAIG (CADR ARG2) 262143.)) + (OUTPUT (CONS OP (CONS TAKENAC1 ARG2))))) + (SETMODE TAKENAC1 (COND ((EQ OP 'FSC) 'FLONUM) ('FIXNUM))) + (CAR (CONT TAKENAC1 (LIST (GENSYM)))))) + + + +(COMMENT COMRPLAC) + +(DEFUN COMRPLAC (FUN L VAL) + (PROG (X Y LX LY OCNT) + (CSLD () 'T () ) ;Grabs in only CARCDR loadings + (SETQ OCNT CNT) + ((LAMBDA (PNOB EFFS ARGNO) + (SETQ X (COMP0 (CAR L)) + Y (COMP0 (CADR L))) + (SETQ Y (MAKESAFE Y #%(ILOCREG Y 1) () ))) + () () 1) + (SETQ LX #%(ILOCN X) LY (ILOC0 Y () )) + (AND (NOT (REGADP LX)) (PDERR (CONS FUN L) |Cant RPLAC numeric data|)) + (AND #%(PDLLOCP LX) + (EQ (CDR (CONTENTS LX)) 'IDUP) + (PROG2 ((LAMBDA (CNT) (DIDUP (LIST (CAR X)))) OCNT) + (SETQ LX (ILOC0 X () )))) + (COND ((AND (EQ FUN 'SETPLIST) ;Skip case of + (OR (NOT (EQ (CAR X) 'QUOTE)) (NULL (CADR X)))) ; (SETPLIST x '()) + (REMOVEB X) + (SETQ OCNT (COND (#%(ACLOCP LX) (CPUSH LX) LX) + ((OR EFFS (DVP ARGNO)) #%(FREAC)) + ('T ARGNO))) + (OUT1 'SKIPN OCNT LX) + #%(OUTFS 'MOVEI OCNT 'NILPROPS) + (PUSH (SETQ X (LIST (GENSYM))) LDLST) + (CONT (SETQ LX OCNT) X))) + (COND ((QNILP Y) (OUT1 (GET FUN 'INSTN) 0 LX)) + ('T (SETQ LY #%(ILOCREG Y (COND ((AND (NULL EFFS) ;This is just ILOCF + (AND (NUMBERP LX) (= LX 1)) + (= ARGNO 1) ; except when result + (NULL VAL)) ; is to go into 1 + #%(FREAC)) + ('FRAC1)))) + (AND (NOT #%(ACLOCP LY)) (LOADAC Y (SETQ LY (FRAC1)) 'T)) + (OUT1 (GET FUN 'INST) LY (ILOC0 X () )))) + ;;SO FORGET ABOUT ANY NASCENT CARCDRINGS + (OR VAL (PSETQ X Y Y X)) + ;; common case is VAL = (), so just return 2nd arg to RPLACA + (REMOVE X) + (CLEANUPSPL 'COMRPLAC) + (REMOVE Y) + (RETURN Y))) + +(DEFUN COMSET (Y) + #%(LET (NAME V (ARGNO 1) EFFS) + (CSLD 'T () () ) + (SETQ NAME (COMP0 (CAR Y))) + (SETQ V (COMP0 (CADR Y))) + (LOADAC NAME 4 () ) + (AND (SETQ NAME (GETMODE0 4 () () )) + (PDERR (CONS 'SET Y) |SET applied to numeric datum|)) + (LOADAC V 1 'T) + (CPUSH #%(NUMVALAC)) + (OUTPUT '(JSP T *SET)) + #%(NULLIFY-NUMAC))) + + +(COMMENT COMSETQ) + +(DEFUN COMSETQ (Y) + (PROG (LARG HOME V Z TEM NLP MODE LARGSLOTP DOD CMPVL SPFL NLARG) + COMSQ1 + (SETQ MODE (AND (NOT (SETQ SPFL (SPECIALP (CAR Y)))) (VARMODE (CAR Y)))) + (SETQ NLP (CDDR Y)) + (SETQ HOME (ILOC0 (SETQ V (CONS (CAR Y) CNT)) MODE) TEM () ) + (COND ((AND MODE + HOME + (SETQ TEM (NOT (ATOM (CADR Y)))) + (SETQ Z (COND ((EQ (CAADR Y) 'ADD1) 'AOS) + ((EQ (CAADR Y) 'SUB1) 'SOS))) + (AND (CDDR (CADR Y)) (NULL (CDDDR (CADR Y)))) ;LENGTH = 3 + (EQ (CAR V) (CAR (CDDADR Y))) + (EQ (CADADR Y) 'FIXNUM) + (OR (NOT (ASSQ (CAR V) LDLST)) (NOT (DVP HOME))) + (NOT (REGADP HOME))) + (COND ((AND #%(ACLOCP HOME) (CDR (CONTENTS HOME))) + (CPUSH1 HOME 'T () ) ;SLOTX has still been setup by CONTENTS + (RPLACA SLOTX () ) ; hence this becomes (CONT HOME () ) + (SETQ HOME (ILOC2 'T V 'FIXNUM)))) + (FREEZE-VAR (CAR V) '(REGACS () REGPDL 0) () 'T MODE) ;Remember, increments CNT + (ASIDE-FROM-FOO Z NLP HOME (CAR V) MODE) ;Z has INST, (CAR V) the var's name + (SETQ CNT (PLUS CNT 2)) + (GO COMPS3))) + (COND ((AND TEM ;Prev value is + (SETQ TEM (CAADR Y)) ;(AND MODE HOME (NOT (ATOM (CADR Y)))) + (MEMQ TEM '(PLUS TIMES DIFFERENCE *DIF)) + (CDDDR (CADR Y)) ;Typical Y = (N (PLUS FIXNUM N FOO)) + (NULL (CDDDDR (CADR Y))) ; Check length[cadr[y]] = 4 + (CAR (SETQ Z (CDADR Y))) ;Z = (FIXNUM N FOO) + (ATOM (CAR Z)) + (EQ (CAR Y) (CADR Z)) + (SETQ Z (CADDR Z)) + (COND ((NOT #%(ACLOCP HOME))) + ((EQ (CDR (CONTENTS HOME)) 'DUP) + (RPLACA SLOTX () )) + ((ATOM Z) () ) + ((NOT (EQ (CAR Z) CARCDR))))) + (COND ((MEMQ TEM '(*DIF DIFFERENCE)) + (SETQ TEM 'PLUS) + (SETQ Z (LIST 'MINUS (CADADR Y) Z)))) + (SETQ Y (LIST (CAR Y) (LIST TEM (CADADR Y) Z (CAR Y)))))) + (SETQ CMPVL (COMPR (CADR Y) + MODE + EFFS + (AND (NOT SPFL) (OR MODE (MEMQ (CAR Y) UNSFLST))))) + (SETQ LARG (COND (MODE (COMLOCMODE CMPVL 'ARGNO MODE (CAR Y))) + ('T #%(ILOCREG CMPVL (COND (NLP 'FRACF) ('ARGNO)))))) + (AND (OR SPFL (NOT MODE)) + (SETQ TEM (MAKESURE (CADR Y) (CAR Y) SPFL CMPVL LARG)) + (SETQ CMPVL TEM + LARG (COND ((EQ (CAR REGACS) CMPVL) 1) + ((ILOC0 CMPVL () )) + ((BARF CMPVL |Lost at makesure - COMSETQ|))))) + (AND (SETQ LARGSLOTP (NUMBERP LARG)) (SETQ NLARG LARG)) + (COND ((AND SPFL + (SETQ TEM (ASSQ (CAR Y) LDLST)) + (NOT (NUMBERP (ILOC0 TEM () )))) + #%(OUTFS 'PUSH 'P (LIST 'SPECIAL (CAR Y))) + (PUSH (CONS (CAR Y) CNT) REGPDL) + (SETQ SPLDLST (DELQ TEM SPLDLST)) + (AND LARGSLOTP + #%(REGPDLP-N NLARG) + (SETQ NLARG (SETQ LARG (1- NLARG)))))) + (REMOVEB CMPVL) + (COND ((AND MODE ;MODE=T => SPFL=() + LARGSLOTP + (NOT ATPL) + (AND (CDDDR LOUT) (NULL (CDDDDR LOUT))) ;LENGTH = 4 + (SETQ TEM (GET (CAR LOUT) 'BOTH)) + (NUMBERP (CADDR LOUT)) + (= LARG (CADR LOUT)) + (EQ (CADDDR LOUT) #%(PDLAC MODE)) + (EQUAL (SETQ Z (ILOC0 V MODE)) + (CONVNUMLOC (CADDR LOUT) MODE)) + (NOT (DVP (CADR LOUT))) + (OR (NOT (ASSQ (CAR Y) LDLST)) (NOT (DVP Z)))) + (CONT (CADR LOUT) (CONS (CAR Y) 'DUP)) + (RPLACA LOUT TEM) + (FREEZE-VAR (CAR V) '(REGACS () REGPDL 0) () 'T MODE) + (SETQ CNT (1+ CNT)) + (GO COMPS3))) + (SETQ V (CAR Y)) +; So freeze world at this point + (SETQ TEM (FREEZE-VAR V + '(REGACS () NUMACS () REGPDL 0 FXPDL #.(FXP0) FLPDL #.(FLP0)) + (CAR CMPVL) + () + MODE)) + (AND LARGSLOTP #%(PDLLOCP-N NLARG) + (SETQ LARGSLOTP (NUMBERP (SETQ LARG (ILOC2 (VARBP (CAR CMPVL)) + CMPVL + (GETMODE LARG))))) + (SETQ NLARG LARG)) + (SETQ DOD (AND LARGSLOTP (DVP LARG))) + (SETQ HOME + (COND (SPFL) ;HOME = () => + ((NULL TEM) () ) ;Local var without home on PDL + ((NOT (DVP4 (CAAR TEM) (CDR TEM))) ; or else locvar with DVP home + (CDR TEM)))) ;HOME = non-null => + ; can store into old homeloc + (SETQ CNT (1+ CNT)) + (COND ((AND (OR EFFS NLP) (NOT HOME) (OR MODE (REGADP LARG))) + (SETQ V (LIST V)) + (COND ((AND LARGSLOTP (NOT DOD)) + (COND ((AND MODE #%(REGADP-N NLARG)) (OPUSH LARG V MODE)) + ('T (CONT LARG V)))) + ('T (OPUSH LARG V MODE))) + (GO COMPS3))) + + (COND ((AND HOME + (COND (MODE (Q0P+0P (CADR Y))) + ('T (QNILP (CADR Y))))) + (ASIDE-FROM-FOO 'SETZM NLP HOME V MODE) + (GO COMPS3))) + + (COND ((COND ((NOT DOD) () ) + ((NOT (NUMBERP LARG)) () ) + (MODE #%(NUMACP-N NLARG)) + ('T #%(REGACP-N NLARG))) + (CPUSH LARG)) + ((AND (NULL MODE) LARGSLOTP #%(NUMACP-N NLARG)) + (AND DOD (CPUSH LARG)) + (PUSH (SETQ CMPVL (CONS (CAR CMPVL) CNT)) LDLST) + (SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP) (NOT #%(NUMACP-N ARGNO))) + ARGNO) + ((FRAC1)))) + (MAKEPDLNUM CMPVL LARG)) + ((OR (NOT LARGSLOTP) + DOD + (MINUSP LARG) + (DVP LARG) + (AND MODE (REGADP LARG))) + (LOADAC CMPVL (SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP)) + (COND ((NOT #%(NUMACP-N ARGNO)) + (COND (MODE #%(NUMVALAC)) (ARGNO))) + (MODE ARGNO) + ((FRAC5)))) + (MODE (FREENUMAC)) + ((FRAC5)))) + ()))) + (CONT LARG (LIST V)) + (COND (SPFL + (COND ((REGADP LARG) + (COND ((ZEROP LARG) (OPOP SPFL () )) + ('T #%(OUTFS 'MOVEM LARG SPFL)))) + ('T (BARF (LIST V LARG) |Special set from ? - COMSETQ|))))) + + COMPS3 + (COND (NLP (SETQ Y NLP) (GO COMSQ1)) + ((NULL EFFS) + (SETQ V (CONS (CAR Y) CNT)) + (AND SPFL (SETQ SPLDLST (CONS V SPLDLST))) + (RETURN V))))) + +;;; Puts out things like (SETZ 0 (SPECIAL FOO)) (SETZB 7 -3 FXP) +;;; (AOS 0 11) (SOS 7 0 FXP) + +(DEFUN ASIDE-FROM-FOO (INST NLP HOME V MODE) ;CALLED ONLY FROM COMSETQ + ((LAMBDA (AC) + (OUT1 (COND ((OR NLP EFFS) INST) + ('T (SETQ AC (COND (MODE (FREENUMAC)) + ((NOT (DVP ARGNO)) ARGNO) + ((NOT (ZEROP (SETQ AC (FRACB)))) AC) + ('T (CPUSH ARGNO) ARGNO))) + + (COND ((EQ INST 'SETZM) 'SETZB) (INST)))) + AC + (COND ((NUMBERP HOME) (CONT HOME (LIST V)) HOME) + (HOME))) ;Should be (SPECIAL foo) + (AND (NOT (ZEROP AC)) (CONT AC (CONS V (COND ((NUMBERP HOME) 'DUP))))) + () ) + 0)) + + +(DEFUN FREEZE-VAR (V L ITEM OEFFS MODE) + ((LAMBDA (OHOME HOME II N) + (SETQ V (CONS V (SETQ CNT (1+ CNT)))) + (DO ZZ L (CDDR ZZ) (NULL ZZ) + (DO ((Z (SYMEVAL (CAR ZZ)) (CDR Z)) (I 0 (1+ I)) (PDLP (CADR ZZ))) + ((NULL Z)) + (AND (CAR Z) + (EQ (CAAR Z) (CAR V)) + (COND ((MEMQ (CDAR Z) '(() OHOME)) + (COND ((NULL PDLP) (RPLACA Z V)) + ((AND (NULL (CDAR Z)) (NULL HOME)) + (SETQ HOME Z II (- PDLP I))) + ((AND (EQ (CDAR Z) 'OHOME) (NULL OHOME)) + (SETQ OHOME Z N (- PDLP I))) + ((BARF () |King of confusion - FREEZE-VAR|)))) + ((MEMQ (CDAR Z) '(DUP IDUP)) (RPLACD (CAR Z) (1- CNT))))))) + (AND HOME (RPLACA HOME V)) + (COND (OHOME + (COND ((DVP4 (CAR OHOME) N) + (OPUSH N + (CONS (CAR V) (GET (CAR V) 'OHOME)) + MODE) + (AND HOME + (NOT OEFFS) + (EQ (GETMODE N) (GETMODE II)) + (SETQ II (1- II))))) + (PUTPROP (CAR V) CNT 'OHOME)) + (HOME + (COND ((DVP4 (CAR HOME) II) + (OPUSH II V MODE) + (SETQ II (1- II)))) + (PUTPROP (CAR V) CNT 'OHOME) + (RPLACA HOME (CONS (CAR V) 'OHOME)))) + (CARCDR-FREEZE (CAR V) ITEM) + (AND (NOT OEFFS) HOME (CONS HOME II))) + () () 0 0)) + + +(COMMENT COMTP for "TYPEP") + +(DEFUN COMTP (EXP INST TAG F VALUEP) ;Compile for "TYPEP" +#%(LET ((ARGNO (COND (VALUEP ARGNO) ((FRAC1))))) + (PROG (TEM LOC AC ACP) ; and similar functions + (SETQ AC 0) ;Table index for that type datum + (SETQ LOC #%(ILOCN (SETQ TEM (COMP (CADR EXP))))) ; into some free NUMAC, which is returned + (REMOVE TEM) ; [except for case of "ATOM"] + (AND VALUEP ;If no TAG, then for value + (CPUSH-DDLPDLP ARGNO LOC) + (SETQ LOC (1- LOC))) + (COND ((COND ((NUMBERP LOC) (SETQ TEM (GETMODE LOC))) ;If quantity is known to be + ((AND (NULL (CDR LOC)) + (MEMQ (SETQ TEM (TYPEP (CADAR LOC))) + '(FIXNUM FLONUM))))) + (SETQ LOC (COND ((EQ (CAR EXP) 'TYPEP) TEM) ; either FIXNUM or FLONUM + ((MEMQ (CAR EXP) '(ATOM NUMBERP)) 'T) ; then return that instead + ((EQ (CAR EXP) 'BIGP) () ) ; of compiling code for getting + ((MEMQ (CAR EXP) '(FIXP FLOATP FIXNUMP)) ;the type bits into a NUMAC + #%(EQUIV (EQ (CAR EXP) 'FLOATP) + (EQ TEM 'FLONUM))))) + (SETQ TEM #%(EQUIV LOC F)) ;Match the type of cadr[exp] + (COND (TAG (AND TEM (PROG2 (CLEARVARS) (OJRST TAG 0)))) ;predicates - but not "TYPEP" + ((OUTPUT (COND ((NULL INST) (LIST 'MOVEI ARGNO (LIST 'QUOTE LOC))) + (#%(EQUIV LOC F) (BOLA ARGNO 2)) + ('T (BOLA ARGNO 5) ))))) + (RETURN 'T))) + (COND (#%(ACLOCP LOC) + (CPUSH LOC) + (CONT LOC () ) + (SETQ AC LOC ACP 'T))) + (COND ((EQ (CAR EXP) 'TYPEP) + (AND (OR EFFS #%(NUMACP-N ARGNO)) (BARF () |Sumpins wrong - COMTP|)) + (OUT1 'SKIPN + (COND ((NULL ACP) (SETQ AC ARGNO) ARGNO) + (0)) + LOC) + (OUTPUT (BOLA AC 2)) ;MOVEI ARGNO,'T + #%(OUTFS 'LSH AC -9.) ; ### since ()=NIL is SYMBOL + (CONT AC () ) + (OUTPUT (CONS 'HRRZ (CONS ARGNO (CDR (STGET AC))))) + (RETURN () ))) + (COND ((NULL ACP) (SETQ AC (FREENUMAC)) (OUT1 'MOVE AC LOC))) + (COND (TAG (CLEARVARS) (RSTD TAG AC 0))) + (COND ((EQ (CAR EXP) 'ATOM) + #%(OUTFS 'LSH AC -9.) + (CONT AC () ) + (SETQ INST (COND (#%(EQUIV F TAG) 'SKIPL) ('SKIPGE))) + (OUTPUT (CONS INST (STGET AC))) + (COND (TAG (OUTJ0 'JUMPA 0 TAG 'T 0)) ;Like OJRST, but no + (VALUEP (BOOLOUT () () )))) ; subsequent deletions + ('T (PROG (VTAG) + (COND ((NOT (EQ (CAR EXP) 'SYMBOLP))) + ((AND TAG F) (OUTJ 'JUMPE AC TAG)) + ((AND F (NULL TAG) (NULL VALUEP)) + (OUTPUT (BOLA AC 6)) ;SKIPN 0 ac + (OUTPUT (BOLA AC 2))) ;MOVEI ac,'T + ('T #%(OUTFS 'JUMPE AC (SETQ VTAG (GENSYM))) )) + #%(OUTFS 'LSH AC -9.) + (CONT AC () ) + (SETQ TEM (CDR (STGET AC))) + (COND ((NOT #%(NUMACP-N AC)) + (SETQ AC (FREENUMAC)) + (RPLACA SLOTX () ))) ;(CONT AC () ) + (OUTPUT (CONS 'MOVE (CONS AC TEM))) + (SETQ INST (COND (F (CAR INST)) ((CDR INST)))) + (COND (TAG (OUTJ INST AC TAG) + (AND VTAG (OUTPUT VTAG))) + ('T #%(OUTFS (CAR INST) AC (CDR INST)) + (AND VTAG (NULL F) (OUTPUT VTAG)) + (AND VALUEP (BOOLOUT (AND F VTAG) () ))))))) ))) + +(COMMENT COMSIGNP and COMZP) + +;;; This compilation critically depends on the subr for NUMBERP leaving a +;;; numerical value in accumulatr TT with the correct algebraic sign. + +(DEFUN COMSIGNP (EXP TAG F) + ((LAMBDA (INST) + (AND (NULL INST) + (SETQ INST '(- . JUMP)) + (PDERR (CAR EXP) |Wrong type arg to SIGNP|)) + (LOADAC (COMP1 (CADR EXP)) 1 () ) + (CPUSH #%(NUMVALAC)) + #%(NULLIFY-NUMAC) + (OUTPUT '(CALL 1 'NUMBERP)) + (COND ((COND ((NULL TAG)) + (F (CLEARVARS) (RSTD TAG 1 0) 'T)) + (OUTPUT '(SKIPE 0 1))) + ('T (CLEARVARS) (OUTJ0 'JUMPE 1 TAG () 1))) + (SETQ INST (COND ((OR F (NULL TAG)) (CDR INST)) + ((GET (CDR INST) 'CONV)))) + (RPLACA REGACS () ) ;(CONT 1 () ) + (COND (TAG (OUTJ0 INST 'TT TAG 'T 0)) + ('T #%(OUTFS INST 'TT '(* 2)) + (OUTPUT '(MOVEI 1 '() ))))) + (ASSQ (CAR EXP) + '((L . JUMPL) (E . JUMPE) (LE . JUMPLE) + (GE . JUMPGE) (N . JUMPN) (G . JUMPG))))) + + +(DEFUN COMZP (EXP TAG F) + ((LAMBDA (Z INST NODDP) + (SETQ INST (COND (TAG (CAR INST)) ((CDR INST)))) + (AND (NOT F) (SETQ INST (GET INST 'CONV))) + (COND (TAG (OUTJ (COND (NODDP INST) + ;((ASSQ INST '((TRNN . 1) (TRNE . 1)))) + ((EQ INST 'TRNN) '(TRNN . 1)) + ((EQ INST 'TRNE) '(TRNE . 1))) + (LOADINSOMENUMAC Z) + TAG)) + ((NOT NODDP) + (SETQ NODDP (LOADINSOMENUMAC Z)) + (CPUSH ARGNO) + #%(OUTFS INST NODDP '1)) + ('T (SETQ NODDP #%(ILOCF Z)) + (REMOVE Z) + (COND (#%(ACLOCP NODDP) (CPUSH NODDP) (CPUSH ARGNO)) + ((CPUSH-DDLPDLP ARGNO NODDP) (SETQ NODDP (1- NODDP)))) + (OUT3 (ASSQ INST '((SKIPE) (SKIPG) (SKIPL) (SKIPN) (SKIPLE) (SKIPGE))) + 0 + NODDP)))) + (COMPW (CADDR EXP) () (FREENUMAC)) + (CDR (ASSQ (CAR EXP) '((ZEROP . (JUMPE . SKIPE)) + (PLUSP . (JUMPG . SKIPG)) + (MINUSP . (JUMPL . SKIPL)) + (ODDP . (TRNN . TRNN))))) + (NOT (EQ (CAR EXP) 'ODDP)))) + + + +(DEFUN COM-X-C-R (X Y) + #%(LET (HNK LHNK VAL LVAL INDEX I-QTD-P (I 0)) + #%(LET (EFFS (ARGNO 1)) + (SETQ INDEX (COMP0 (NTH 0 Y)) HNK (COMP0 (NTH 1 Y))) + (SETQ I-QTD-P (COND ((NOT (EQ (CAR INDEX) 'QUOTE)) () ) + ((FIXP (CADR INDEX))) + ((OR (ATOM (CADR INDEX)) + (NOT (EQ (CAADR INDEX) SQUID))) + (PDERR (CONS X Y) + |Non-numeric index for CXR/RPLACX|) + ()))) + (AND (EQ X 'RPLACX) + (SETQ ARGNO 2 + VAL (COMP0 (NTH 2 Y)) + VAL (MAKESAFE VAL #%(ILOCREG VAL 2) () )))) + (COND ((NOT I-QTD-P) + ;Insure that INDEX is in the slotlist + (ILOCMODE INDEX #%(NUMVALAC) 'FIXNUM) + (SETQ LHNK 1)) + ((AND (NOT EFFS) + (NOT #%(NUMACP-N ARGNO)) + (COND ((NOT (DVP ARGNO))) + ('T (CPUSH1 ARGNO 'CLEARVARS () ) + (NOT (DVP1 SLOTX ARGNO))))) + (SETQ LHNK ARGNO)) + (#%(ACLOCP (SETQ LHNK (ILOC0 HNK () )))) + ('T (SETQ LHNK (FRAC1)) )) + ;Be sure that the "hunk" (and "value" if RPLACX) gets into a REGAC + (COND ((AND (EQ X 'RPLACX) (NOT I-QTD-P)) + #%(LET ((HLAC 2)) + (LOADAC VAL 2 () ) + (LOADAC HNK 1 () ) + (SETQ LVAL 2))) + ('T (LOADAC HNK LHNK () ) + (COND ((EQ X 'RPLACX) + (OR #%(ACLOCP (SETQ LVAL (ILOC0 VAL () ))) + #%(LET* ((SAVSLOT (FIND LHNK)) + (SAVHNK (CAR SAVSLOT))) + (RPLACA SAVSLOT '(NIL . TAKEN)) + (SETQ LVAL (COND ((= LHNK 1) (FRAC5)) + ((FRAC1)))) + (RPLACA SAVSLOT SAVHNK))) + (LOADAC VAL LVAL () )) ))) + (COND (I-QTD-P + (AND (OR (< (SETQ I (CADR INDEX)) 0) (> I 1023.)) + (PDERR (CONS X Y) |Index out of range - CXR/RPLACX|)) + (REMOVE INDEX) + (COND ((EQ X 'RPLACX) + #%(OUTFS (COND ((ODDP I) 'HRLM) ('HRRM)) + LVAL + (LSH I -1) + LHNK)) + ('T #%(OUTFS (COND ((ODDP I) 'HLRZ) ('HRRZ)) + LHNK + (LSH I -1) + LHNK)))) + ('T (LOADAC INDEX #%(NUMVALAC) () ) + (OUTPUT (COND ((EQ X 'RPLACX) '(JSP T %RPX)) + ('T '(JSP T %CXR)))) + #%(NULLIFY-NUMAC) )) + LHNK)) + diff --git a/src/comlap/faslap.392 b/src/comlap/faslap.392 new file mode 100755 index 00000000..f98f165a --- /dev/null +++ b/src/comlap/faslap.392 @@ -0,0 +1,860 @@ +;;; FASLAP -*-LISP-*- +;;; ************************************************************** +;;; ***** MacLISP ****** (Assembler for compiled code) *********** +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a read-only file! (All writes reserved) ******* +;;; ************************************************************** + + + +(SETQ FASLVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/392))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + + +;;; This assembler is normally part of the compiler, and produces +;;; binary (FASL) files suitable for loading with FASLOAD. + + + +(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|fl|) ) + + + +(DEFUN FASLVERNO () + (PRINC '|/îFASLAP Assembler |) + (PRINC FASLVERNO) + (PRINC '| |)) + + + + +(DEFUN FASLIFY (LL FL) + (PROG (Y) + (COND ((EQ FL 'LIST)) + ((OR (EQ FL 'LAP) + (AND (NULL FL) (NOT (ATOM LL)) (EQ (CAR LL) 'LAP))) + (DO ((Z LL (AND ^Q (READ EOF))) (EOF (LIST ()))) + ((NULL Z) (SETQ LL (NREVERSE (CONS () Y)))) + (AND (NULL ^Q) + (PROG2 (PDERR CURRENTFN |Has EOF in middle of LAP code|) + (ERR 'FASLAP))) + (PUSH Z Y))) + (FL (SETQ FBARP 'T) + (BARF () |FASLIFY is losing|)) + (T (SETQ Y LL LL ()) (GO B))) + A (AND (NULL LL) (RETURN ())) + (SETQ Y (CAR LL)) + B (COND ((ATOM Y)) ;IGNORE RANDOM ATOMS + ((EQ (CAR Y) 'LAP) ;PROCESS LAP + (SETQ CURRENTFN (CADR Y)) + (FASLPASS1 LL) + (SETQ LL (FASLPASS2 LL)) + (SETQ FILOC (+ FILOC *LOC)) + (AND (NOT (EQ COMPILER-STATE 'COMPILE)) + TTYNOTES + (PROG (^W ^R) + (INDENT-TO-INSTACK 0) + (PRIN1 CURRENTFN) + (PRINC '| Assembled|)))) + ((MUNGEABLE Y) (COLLECTATOMS Y) (BUFFERBIN 14. -1_18. Y)) + (T (COND ((EQ (CAR Y) 'DECLARE) + (ERRSET (MAPC 'EVAL (CDR Y)) ()) + (SETQ Y ())) + ((OR (EQ (CAR Y) 'COMMENT) (NOT (EQ (CAR Y) 'QUOTE)))) + ((SUBMATCH (CADR Y) '(THIS IS THE LAP FOR)) + (SETQ Y + (AND UNFASLCOMMENTS + (SUBST (CADDDR (CDDADR Y)) + 'DATA + ''(THIS IS THE UNFASL + FOR LISP FILE DATA))))) + ((SUBMATCH (CADR Y) '(COMPILED BY LISP COMPILER)) + (SETQ Y ()))) + (COND ((AND Y (OR UNFASLCOMMENTS + (NOT (MEMQ (CAR Y) '(COMMENT QUOTE))))) + ((LAMBDA (^R ^W OUTFILES) + (TERPRI) ;PUT NON-MUNGEABLE INTO UNFASL FILE + (COND ((AND (NOT (ATOM Y)) + (EQ (CAR Y) 'QUOTE)) + (PRINC '/') (SETQ Y (CADR Y)))) + (PRIN1 Y) (PRINC '/ )) + T T UFFIL) + (SETQ UNFASLSIGNIF T))))) + (SETQ LL (CDR LL)) + (GO A))) + + +;;; FASLPASS1 PERFORMS PASS 1 PROCESSING FOR A LAP FUNCTION. +;;; THIS INCLUDES DEFINING SYMBOLS, doing the COLLECTATOMS work for +;;; most address fields [e.g., for xxx in (OP AC xxx IDX)], so that +;;; the USERATOMS-HOOK wont ever have to cause auotloadings during +;;; the middle of a function, AND SAVING VARIOUS PIECES +;;; OF INFORMATION FOR PASS 2. + +(DEFUN FASLPASS1 (Q) ;Q HAS (LAP FOO SUBR) OR WHATEVER + ((LAMBDA (BASE IBASE) + (PROG (AMBIGSYMS N EXPR) + (AND (NOT (EQ (CAAR Q) 'LAP)) + (SETQ FBARP 'T) + (DBARF Q |Not a LAP listing - FASLPASS1|)) + (SETQ *LOC 0) + (SETQ CURRENTFN (CADAR Q) CURRENTFNSYMS ()) + (PUSH CURRENTFN ENTRYNAMES) + (PUTPROP CURRENTFN FILOC 'ENTRY) + (AND UNFASLCOMMENTS (NOTE-IN-UNFASL FILOC (CAR Q) ())) ;Tells about entry points + (DO Z (CDR Q) (CDR Z) (COND ((NULL Z) + (DBARF () |No () [or "NIL"] in LAP code - FASLPASS1|) + (SETQ FBARP 'T)) + ((NULL (SETQ EXPR (CAR Z))))) + (COND ((ATOM EXPR) + (FASLDEFSYM EXPR (LIST 'RELOC (+ FILOC *LOC)))) + ((EQ (CAR EXPR) 'ENTRY) + (COND ((GET (CADR EXPR) 'ENTRY) + (PDERR CURRENTFN |Multiple ENTRY with duplicated name|) + (ERR 'FASLAP)) + (T (PUSH (CADR EXPR) ENTRYNAMES) + (PUTPROP (CADR EXPR) (SETQ DATA (+ FILOC *LOC)) 'ENTRY) + (AND UNFASLCOMMENTS + (NOTE-IN-UNFASL DATA EXPR () ))))) + ((EQ (CAR EXPR) 'DEFSYM) ;DEFSYM + (DO X (CDR EXPR) (CDDR X) ;SO DEFINE THE SYMBOLS + (NOT (AND X (CDR X))) ;NOTE THAT EVAL IS USED, + (FASLDEFSYM (CAR X) (EVAL (CADR X))))) ; NOT FASLEVAL + ((EQ (CAR EXPR) 'DDTSYM) ;DECLARE DDT SYMBOLS + (SETQ DDTSYMP T) ;REMEMBER THAT THIS FN HAD DDTSYM + (MAPC (FUNCTION *DDTSYM) (CDR EXPR))) ;TRY TO GET THEM FROM DDT + ((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS + (MAPC (FUNCTION EVAL) (CDR EXPR))) + ((EQ (CAR EXPR) 'SYMBOLS) ;SYMBOLS - FOR NOW, JUST + (SETQ SYMBOLSP T)) ; REMEMBER THAT ONE HAPPENED + ((MEMQ (CAR EXPR) '(SIXBIT ASCII BLOCK)) ;HAIRY BLOBS + (SETQ *LOC (+ *LOC (SETQ N (BLOBLENGTH EXPR))))) + ((NOT (MEMQ (CAR EXPR) '(COMMENT ARGS))) + (RECLITCOUNT EXPR T) + (SETQ *LOC (1+ *LOC))))) + (SETQ LITLOC *LOC) ;REMEMBER WHERE TO ASSEMBLE LITERALS + (SETQ LITERALS (NREVERSE LITERALS)))) + 8. 8.)) + + + +(DEFUN RECLITCOUNT (insn PASS1P) + ;;On pass 1, merely ascertain number of code words using literals, and + ;; check the COLLECTATOMS problem + (COND ((AND (CDDR insn) + (SETQ insn (COND ((OR (EQ (CADDR insn) '/@) + (EQ (CADR insn) '/@)) + (CADDDR insn)) + ((CADDR insn)))) + ;; Note that this lets HUNKs go thru + (NOT (ATOM insn))) + (COND ((NOT (EQ (CAR insn) '%)) + (cond ((or (memq (car insn) '(QUOTE FUNCTION SPECIAL ARRAY + EVAL SQUID)) + (eq (car insn) SQUID)) + (collectatoms (cadr insn)))) + 0) + ((LAPCONST (CDR insn)) 0) + (PASS1P + ;;On pass1, not really interested in count + (and (not (eq pass1p 'COLLECTATOMS)) + (PUSH (CDR insn) LITERALS)) + (reclitcount (cdr insn) 'COLLECTATOMS) + 0) + ((MEMQ (CADR insn) '(SIXBIT ASCII BLOCK)) + (BLOBLENGTH (cdr insn))) + ((1+ (RECLITCOUNT (cdr insn) () ))))) + (0))) + + + +;;; FASLPASS2 PERFORMS PASS 2 PROCESSING FOR A LAP FUNCTION. +;;; THIS INCLUDES RETRIEVING INFORMATION SAVED ON PASS 1 +;;; (IN PARTICULAR SYMBOLS), HANDLING DDT SYMBOLS TO BE +;;; RETRIEVED AT LOAD TIME, PROCESSING LITERALS, DEFINING +;;; ENTRY POINTS TO THE LOADER, AND OF COURSE CONVERTING +;;; INSTRUCTIONS TO BINARY CODE. THE FUNCTION MAKEWORD IS +;;; CALLED TO PROCESS INDIVIDUAL LAP STATEMENTS. + +(DEFUN FASLPASS2 (Q) ;Q HAS LAP LISTING + ((LAMBDA (BASE IBASE LITCNT) + (PROG (DDTSYMS AMBIGSYMS LASTENTRY ENTRYPOINTS LITERALP + UNDEFSYMS OLOC EXPR OLITERALS LL N TEM) + (SETQ OLITERALS LITERALS OLOC *LOC *LOC 0) + (COLLECTATOMS (CDR (SETQ EXPR (CAR Q)))) ;MUST COLLECT NAME AND TYPE OF SUBR + (PUSH (CONS (CONS (CADR EXPR) (CADDR EXPR)) (GET CURRENTFN 'ENTRY)) + ENTRYPOINTS) ;SAVE ENTRY POINT INFO + (COND ((GET CURRENTFN 'SYMBOLSP) ;SYMBOLS PSEUDO ANYWHERE MAKES ENTRY DEFINED + (BUFFERBIN 13. 0 CURRENTFN))) ; - OUTPUT AS DDT SYMBOL + (SETQ LASTENTRY CURRENTFN) + (DO Z (CDR Q) (CDR Z) (COND ((NULL (SETQ EXPR (CAR Z))) + (SETQ LL Z) + T)) + (COND ((ATOM EXPR) ;MAYBE A TAG SHOULD BE + (COND (SYMBOLSP (BUFFERBIN 13. 0 EXPR)))) ; OUTPUT AS A DDT SYMBOL + ((EQ (CAR EXPR) 'ENTRY) ;ENTRY POINT + (COND ((NOT (= (SETQ N (+ FILOC *LOC)) + (GET (CADR EXPR) 'ENTRY))) ;BETTER BE AT + (BARF (CADR EXPR) |Phase screw at ENTRY - FASLPASS2|))) + (COLLECTATOMS (CDR EXPR)) ;COLLECT NAME AND TYPE + (PUSH (CONS (CONS (CADR EXPR) ;SAVE INFO ABOUT ENTRY + (COND ((CDDR EXPR) + (CADDR EXPR)) + ((CADDAR Q)))) + N) + ENTRYPOINTS) + (AND SYMBOLSP (BUFFERBIN 13. 0 (CADR EXPR))) + (SETQ LASTENTRY (CADR EXPR))) + ((EQ (CAR EXPR) 'ARGS) ;ARGS DECLARATION + (COND ((EQ (CADR EXPR) LASTENTRY) ;SHOULD BE JUST AFTER ENTRY + (PUTPROP (CADR EXPR) (CADDR EXPR) 'ARGSINFO)) ;SAVE INFO + ('T (COND ((GET (CADR EXPR) 'ENTRY) ;TWO WAYS TO BARF AT LOSER + (PDERR EXPR |Misplaced ARGS info|)) + ((PDERR EXPR |Function not seen for this info|))) + (ERR 'FASLAP)) )) + ((EQ (CAR EXPR) 'SYMBOLS) ;TURN DDT SYMBOLS OUTPUT + (SETQ SYMBOLSP (CADR EXPR))) ; SWITCH ON OR OFF + ((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS + (MAPC (FUNCTION EVAL) (CDR EXPR))) + ((EQ (CAR EXPR) 'DDTSYM) ;SAVE DDTSYMS TO PUT + (MAPC '(LAMBDA (X) (AND (NOT (MEMQ X DDTSYMS)) (PUSH X DDTSYMS))) + (CDR EXPR))) + ((NOT (MEMQ (CAR EXPR) '(DEFSYM COMMENT))) (MAKEWORD EXPR)))) + + (AND (OR LITERALS (NOT (= *LOC LITLOC))) (GO PHAS)) + (SETQ LITERALP T) ;THIS LETS FASLEVAL KNOW WE'RE DOING LITERALS + (MAPC (FUNCTION MAKEWORD) OLITERALS) ;SO ASSEMBLE ALL THEM LITERALS + (AND (NOT (= *LOC (+ LITLOC LITCNT))) (GO PHAS)) + (MAPC '(LAMBDA (X) + (SETQ TEM (GET (CAAR X) 'ARGSINFO)) + (BUFFERBIN 11. (BOOLE 7 (LSH (ARGSINFO (CAR TEM)) 27.) + (LSH (ARGSINFO (CDR TEM)) 18.) + (CDR X)) + (CAR X))) + ENTRYPOINTS) + (AND DDTSYMS ;BARF ABOUT DDT SYMBOLS + (COND ((NULL DDTSYMP) + (WARN DDTSYMS |Undefined symbols - converted to DDT symbols|)) + ((WARN DDTSYMS |DDT symbols|)))) + (AND UNDEFSYMS (PROG2 (PDERR UNDEFSYMS |Undefined symbols|) + (ERR 'FASLAP))) + (REMPROPL 'SYM CURRENTFNSYMS) + (REMPROPL 'SYM DDTSYMS) + (MOBYSYMPOP SYMPDL) ;RESTORE DISPLACED SYMBOLS + (RETURN LL) ;NORMAL EXIT + PHAS (BARF () |Literal phase screw|))) + 8. 8. 0)) + +(DEFUN ARGSINFO (X) (COND ((NULL X) 0) ((= X 511.) X) ((1+ X)))) + +;;; FASLEVAL IS ONLY USED BY MAKEWORD, TO EVALUATE THE +;;; FIELDS OF A LAP INSTRUCTION. + +(DEFUN FASLEVAL (X) ;EVALUATE HAIRY FASLAP EXPRESSION + (COND ((NUMBERP X) X) ;A NUMBER IS A NUMBER IS A NUMBER + ((ATOM X) + (COND ((EQ X '*) (LIST 'RELOC (+ FILOC *LOC))) ;* IS THE LOCATION COUNTER + ((GET X 'GLOBALSYM)) ;TRY GETTING GLOBARSYM PROP + ((GET X 'SYM)) ;TRY GETTING SYM PROPERTY + ((OR (NULL X) (MEMQ X UNDEFSYMS)) 0) ;0 FOR LOSING CASES + (((LAMBDA (Y) (AND Y (PUTPROP X Y 'SYM))) (GETMIDASOP X))) + ((NULL DDTSYMP) ;MAYBE CAN PASS THE BUCK ON + (PUSH X DDTSYMS) ; TO FASLOAD (IT WILL GET + (*DDTSYM X)) ; SYMBOL FROM DDT WHEN LOADING) + (T (PUSH X UNDEFSYMS) 0))) ;OH, WELL, GUESS IT'S UNDEFINED + ((EQ (CAR X) 'QUOTE) + (COND ((ATOM (CADR X)) X) + ((EQ (CAADR X) SQUID) + (COND ((EQ (CADR (SETQ X (CADR X))) MAKUNBOUND) + '(0 (() 34))) + (X))) + ((EQ (CDADR X) GOFOO) (LIST 'EVAL (CAADR X))) + (X))) + ((OR (MEMQ (CAR X) '(SPECIAL FUNCTION ARRAY)) (EQ (CAR X) SQUID)) + X) + ((EQ (CAR X) 'EVAL) (CONS SQUID (CDR X))) + ((EQ (CAR X) '%) + (COND ((NOT (= FSLFLD 1)) ;LITERALS MUST BE IN ADDRESS FIELD + (PDERR X |Literal not in address field|) + (ERR 'FASLAP)) + ((LAPCONST (CDR X))) ;MAYBE IT'S A LAP CONSTANT + ((NOT LITERALP) + (SETQ LITERALS (CDR LITERALS)) ;KEEPING COUNT OF THE NUMBER OF LITERALS + ((LAMBDA (RLC) + (SETQ LITCNT + (+ LITCNT + (COND ((MEMQ (CADR X) '(SIXBIT ASCII BLOCK)) + (BLOBLENGTH (CDR X))) + ((ZEROP (RECLITCOUNT (CDR X) ())) 1) + (T (SETQ RLC (+ RLC (RECLITCOUNT (CDR X) ()))) + (- RLC LITCNT -1))))) + (LIST 'RELOC (+ FILOC LITLOC RLC))) + LITCNT)) + ((PROG2 () ;HO! HO! HO! YOU THINK THIS WILL WORK?? + (FASLEVAL '*) + (MAKEWORD (CDR X)))))) + ((MEMQ (CAR X) '(ASCII SIXBIT)) ;A WORD OF ASCII + (CAR (PNGET (CADR X) + (COND ((EQ (CAR X) 'ASCII) 7) (6))))) ;OR OF SIXBIT + ((EQ (CAR X) 'SQUOZE) ;A WORD OF SQUOZE [MAY BE EITHER + (SQOZ/| (CDR X))) ; (SQUOZE SYMBOL) OR (SQUOZE # SYMBOL)] + ((EQ (CAR X) '-) ;SUBTRACTION (OR MAYBE NEGATION) + (COND ((NULL (CDDR X)) + (FASLMINUS (FASLEVAL (CADR X)))) + ((FASLDIFF (FASLEVAL (CADR X)) + (FASLEVAL (CDDR X)))))) + ((EQ (CAR X) '+) ;ADDITION + (FASLPLUS (FASLEVAL (CADR X)) + (FASLEVAL (CDDR X)))) + ((CDR X) (FASLPLUS (FASLEVAL (CAR X)) ;A RANDOM LIST GETS ADDED UP + (FASLEVAL (CDR X)))) + ((FASLEVAL (CAR X))))) ;SUPERFLUOUS PARENS - RE-FASLEVAL + +;;; THE VALUE OF FASLEVAL IS ONE OF THE FOLLOWING FROBS: +;;; A NUMBER +;;; ( -GLITCHES-) NUMBER (PLUS GLITCHES) +;;; (RELOC -GLITCHES-) RELOCATABLE VALUE (PLUS GLITCHES) +;;; (SPECIAL ) REFERENCE TO VALUE CELL +;;; (QUOTE ) S-EXPRESSION CONSTANT +;;; (FUNCTION ) REFERENCE TO FUNCTION [SAME AS (QUOTE )] +;;; (ARRAY ) REFERENCE TO ARRAY POINTER +;;; FOO RESULT OF INVALID ARGS TO FASLEVAL +;;; +;;; A "GLITCH" IS ONE OF THE FOLLOWING: +;;; (() . ) GLOBALSYM [ INDICATES WHICH ONE] +;;; ( () . ) DDT SYMBOL, VALUE UNKNOWN [ IS A NUMBER] +;;; ( . ) DDT SYMBOL, VALUE KNOWN TO DDT ABOVE FASLAP +;;; IS EITHER - FOR NEGATIVE OR () FOR POSITIVE. +;;; +;;; FASLPLUS, FASLMINUS, AND FASLDIFF ARE USED TO PERFORM ARITHMETIC ON THESE FROBS. +;;; NO ARITHMETIC CAN BE PERFORMED ON THE SPECIAL, QUOTE, FUNCTION, ARRAY, AND FOO FROBS. +;;; ARITHMETIC CAN BE PERFORMED ON ALL THE OTHERS, EXCEPT THAT ONE CANNOT CREATE +;;; A NEGATIVE RELOC FROB, I.E. ONE CAN SUBTRACT A RELOC FROM A RELOC, BUT NOT +;;; A RELOC FROM AN ABSOLUTE. + +(DEFUN FASLPLUS (K Q) ;ADD TWO FROBS + (COND ((NUMBERP K) + (COND ((NUMBERP Q) (+ K Q)) + ((EQ (CAR Q) 'RELOC) + (CONS 'RELOC (CONS (+ K (CADR Q)) (CDDR Q)))) + ((NUMBERP (CAR Q)) + (CONS (+ K (CAR Q)) (CDR Q))) + ('FOO))) + ((EQ (CAR K) 'RELOC) + (COND ((NUMBERP Q) + (CONS 'RELOC (CONS (+ Q (CADR K)) (CDDR K)))) + ((NUMBERP (CAR Q)) + (CONS 'RELOC (CONS (+ (CAR Q) (CADR K)) + (APPEND (CDR Q) (CDDR K))))) + ('FOO))) + ((NUMBERP (CAR K)) + (COND ((NUMBERP Q) + (CONS (+ Q (CAR K)) (CDR K))) + ((EQ (CAR Q) 'RELOC) + (CONS 'RELOC (CONS (+ (CAR K) (CADR Q)) + (APPEND (CDR K) (CDDR Q))))) + ((NUMBERP (CAR Q)) + (CONS (+ (CAR K) (CAR Q)) + (APPEND (CDR K) (CDR Q)))) + ('FOO))) + ('FOO))) + +(DEFUN FASLDIFF (K Q) ;SUBTRACT TWO FROBS + (COND ((NUMBERP K) + (COND ((NUMBERP Q) (- K Q)) + ((NUMBERP (CAR Q)) + (CONS (- K (CAR Q)) (FASLNEGLIS (CDR Q)))) + ('FOO))) + ((EQ (CAR K) 'RELOC) + (COND ((NUMBERP Q) + (CONS 'RELOC (CONS (- (CADR K) Q) (CDDR K)))) + ((EQ (CAR Q) 'RELOC) + (CONS (- (CADR K) (CADR Q)) + (APPEND (CDDR K) (FASLNEGLIS (CDDR Q))))) + ((NUMBERP (CAR Q)) + (CONS 'RELOC + (CONS (- (CADR K) (CAR Q)) + (APPEND (CDDR K) + (FASLNEGLIS (CDR Q)))))) + ('FOO))) + ((NUMBERP (CAR K)) + (COND ((NUMBERP Q) + (CONS (- (CAR K) Q) (CDR K))) + ((NUMBERP (CAR Q)) + (CONS (- (CAR K) (CAR Q)) + (APPEND (CDR K) (FASLNEGLIS (CDR Q))))) + ('FOO))) + ('FOO))) + +(DEFUN FASLMINUS (Q) ;NEGATE A FROB + (COND ((NUMBERP Q) (- Q)) + ((NUMBERP (CAR Q)) + (CONS (- (CAR Q)) (FASLNEGLIS (CDR Q)))) + ('FOO))) + +(DEFUN FASLNEGLIS (K) ;NEGATES A LIST OF GLITCHES + (MAPCAR (FUNCTION (LAMBDA (Q) + (CONS (CAR Q) + (CONS (CADR Q) + (COND ((CDDR Q) ()) + ('-)))))) + K)) + +;;; LAPCONST IS A "SEMI-PREDICATE" WHICH WHEN APPLIED TO THE CDR +;;; OR A LITERAL DETERMINES WHETHER OR NOT IT IS ONE OF A NUMBER +;;; OF SPECIAL "LAP CONSTANTS" WHICH ARE DEFINED IN LISP (IN A +;;; TABLE AT LOCATION R70) SINCE COMPILED CODE USES THEM SO OFTEN. +;;; IF NOT, IT RETURNS (); IF SO, IT RETURNS A FASLEVAL FROB +;;; INDICATING A REFERENCE TO R70 AS A GLOBALSYM. + +(DEFUN LAPCONST (X) ;SPECIAL LAP CONSTANTS ARE + (COND ((NOT (SIGNP E (CAR X))) + (AND (NULL (CDR X)) (LAPC1 (CAR X)))) ;(% '()), (% FIX1), OR (% FLOAT1) + ((NULL (CDR X)) '(0 (() -1))) ;(% 0) OR (% 0.0) + ((OR (NOT (FIXP (CADR X))) + (NOT (= (CADR X) 0)) + (NULL (SETQ X (CDDR X)))) + ()) + ((NULL (CDR X)) (LAPC1 (CAR X))) ;(% 0 0 '()), (% 0 0 FIX1), OR (% 0 0 FLOAT1) + ((AND (FIXP (CAR X)) + (< (CAR X) 16. ) + (> (CAR X) 0) + (FIXP (CADR X)) + (= (CAR X) (CADR X))) + (LCA (CAR X))))) ;(% 0 0 N N) FOR 0 < N < 16. + +(DEFUN LAPC1 (X) + (COND ((EQ X 'FIX1) '(-2 (() -1))) + ((EQ X 'FLOAT1) '(-1 (() -1))) + ((AND (EQ (TYPEP X) 'LIST) (EQ (CAR X) 'QUOTE) (EQ (CADR X) '()) + '(0 (() -1)))))) + + + + +;;; ATOMINDEX is used to retrieve the index of an atom (this +;;; index must have been previously defined by COLLECTATOMS). +;;; Symbol atoms have ATOMINDEX properties; indices of +;;; numbers are kept in a hash table called NUMBERTABLE. + +(eval-when (eval compile) + (setq useratoms-non-types '(LIST SYMBOL FIXNUM FLONUM BIGNUM)) + ;; memorize x as a user-atom we've collected. Gets + ;; (atom . index) as the argument + (defmacro USERATOMS-INTERN (x) + `(PUSH ,x USERATOMS-INTERN)) + ;; get the user-atom x's atomindex, or nil if it doesn't have one + (defmacro USERATOMS-LOOKUP (x) + `(CDR (ASSQ ,x USERATOMS-INTERN))) + ) + + +(DEFUN ATOMINDEX (X TYPE) + (let ((user-index (if (not (memq type '#.useratoms-non-types)) + (useratoms-lookup x)))) + (cond ((not (null user-index)) user-index) + ((null x) 0) + (T (and (null type) (setq type (typep x))) + (setq type (cond ((eq type 'symbol) (get x 'atomindex)) + ((not (memq type '(fixnum flonum bignum))) ()) + ((cdr (hassocn x type))))) + (and (null type) (barf x |Atomindex screw|)) + type)))) + + + +;; COLLECTATOMS finds all atoms in an s-expression and assigns an atomindex +;; to each one which doesn't already have one. These index assignments are also +;; output into the binary file. It is through these indices that s-expressions +;; are described to the loader. + +;; The hook USERATOMS-HOOKS if non-null should be a list of function to invoke +;; on each object being COLLECTATOMSed. If one returns non-null, the return +;; value should be the NCONS of the form to be EVAL'd to create the frob. +;; +;; See also ATOMINDEX + +(defun COLLECTATOMS (x) + (do ((user-object nil nil) + (type) (marker)) + ((null x)) + (cond ((null x) (return () )) ;() is always pre-collected + ((eq (setq type (typep x)) 'LIST) + (collectatoms (car x)) + (setq x (cdr x))) ;Loop until no more + ((eq type 'SYMBOL) + (cond ((null (get x 'ATOMINDEX)) + (push x allatoms) + (cond ((setq marker + (getl x '(+INTERNAL-STRING-MARKER + +INTERNAL-TEMP-MARKER))) + (setq user-object ;code to generate uninterned sym! + `(pnput ',(pnget x 7) nil)) + (collectatoms user-object) + (setq user-object + `(,useratoms-intern-frob + ,user-object + ,x . ,(setq atomindex (1+ atomindex)))) + (bufferbin 14. -2_18. user-object) + (putprop x (cdddr user-object) 'ATOMINDEX) + (cond ((eq (car marker) '+INTERNAL-STRING-MARKER) + (setq user-object ;Self-evaling, with marker + `(setq ,x ',x)) + (collectatoms user-object) + (bufferbin 14. -1_18. user-object))) + (cond (user-string-mark-in-fasl + (setq user-object + `(DEFPROP ,x T ,(car marker))) + (collectatoms user-object) + (bufferbin 14. -1_18. user-object)))) + ('T (putprop x + (setq atomindex (1+ atomindex)) + 'atomindex) + (bufferbin 10. 0 x))))) + (return () )) + ((memq type '(FIXNUM FLONUM BIGNUM)) + (let ((bkt (hassocn x type))) + (cond ((null (cdr bkt)) + (setq atomindex (1+ atomindex)) + (rplacd bkt (list (cons type (cons x atomindex)))) + (bufferbin 10. 0 x)))) + (return () )) + ;; Someday, it may be that we want to allow ordinary MacLISP + ;; data types to be filtered thru this USERATOMS-HOOK, and the + ;; next two clauses will have to be moved up to the beginning of + ;; this COND then; but for now, it is verrrry slow. + ((useratoms-lookup x) (return () )) ;Don't repeat + ((and useratoms-hooks + (do ((hooks useratoms-hooks (cdr hooks))) + ((or (null hooks) + (setq user-object (funcall (car hooks) x))) + user-object))) + ;;Hunks will generally have a symbol in their CXR 1 + (and (not (atom user-object)) (collectatoms (car user-object))) + (useratoms-intern `(,x . ,(setq atomindex (1+ atomindex)))) + (bufferbin 14. -2_18. + `(,useratoms-intern-frob ,(car user-object) + ,x . ,atomindex)) + (return () )) ;No more + ((hunkp x) + (do i (1- (hunksize x)) (1- i) (< i 0) + (collectatoms (cxr i x))) + (return () )) + (T (barf x |Unrecognizable datum -- Collectatoms|))))) + + +(DEFUN HASSOCN (X TYPE) + (PROG (BKT OBKT FIXFLOP I) + (SETQ FIXFLOP (MEMQ TYPE '(FIXNUM FLONUM))) + (SETQ I (\ (ABS (SXHASH X)) 127.)) + (AND (MINUSP I) (SETQ I 0)) + (SETQ OBKT (NUMBERTABLE I)) + A (COND ((NULL (SETQ BKT (CDR OBKT))) + (RETURN (COND (OBKT) ;RETURN ( . ()) + ((STORE (NUMBERTABLE I) + (LIST ())))))) ;THE "LAST" OF A BKT + ((NOT (EQ TYPE (CAAR BKT)))) + ((COND ((NOT FIXFLOP) (EQUAL X (CADAR BKT))) + (T (= X (CADAR BKT)))) + (RETURN (CDAR BKT)))) ;RETURN (N . INDEX) + (SETQ OBKT BKT) + (GO A))) + +;;; FASLDEFSYM IS USED TO DEFINE SYMBOLS; IT ALSO CHECKS FOR VARIOUS +;;; ERRORS, INCONSISTENCIES, AND AMBIGUITIES. + +(DEFUN FASLDEFSYM (SYM VAL) ;DEFINE A SYMBOL + (PROG (Z) + (COND ((GET SYM 'GLOBALSYM) + (PDERR SYM |Cant redefine a GLOBALSYM - FASLDEFSYM|) + (ERR 'FASLAP)) + ((SETQ Z (GET SYM 'SYM)) ;MAYBE IT'S ALREADY DEFINED? + (COND ((EQUAL Z VAL) (RETURN Z)) ;REDEFINING TO SAME VALUE DOESN'T HURT + ((NOT (MEMQ SYM AMBIGSYMS)) ;ELSE IT IS AN AMBIGUOUS SYMBOL + (PUSH SYM AMBIGSYMS) ;OH, WE'LL REDEFINE IT, ALL RIGHT, + (AND (NOT (MEMQ SYM CURRENTFNSYMS)) ; BUT WE'LL ALSO BARF + (SETQ MAINSYMPDL (PUSH (CONS SYM Z) SYMPDL)))))) + (T (PUSH SYM CURRENTFNSYMS))) + (RETURN (PUTPROP SYM VAL 'SYM)))) ;SO DEFINE THE SYMBOL (MUST RETURN THE VALUE) + +(DEFUN BLOBLENGTH (X) ;DETERMINES LENGTH OF A BLOB + (COND ((EQ (CAR X) 'SIXBIT) ;SIXBIT + (// (+ 5 (FLATC (CADR X))) 6)) + ((EQ (CAR X) 'ASCII) ;ASCII (actually, ASCIZ) + (1+ (// (FLATC (CADR X)) 5))) + ((NUMBERP (SETQ DATA (CADR X))) ;MUST BE BLOCK - ACCEPT NUMBER + DATA ) + ((AND (SYMBOLP DATA) ;ACCEPT SYMBOL With numeric VAL + (NUMBERP (SETQ DATA (GET DATA 'SYM)))) + DATA) + (T (PDERR X |Undefined arg for block expression|) + (ERR 'FASLAP) ))) + +(DEFUN SUBMATCH (X Y) ;"true" IFF LIST Y IS A PREFIX OF LIST X + (DO ((X X (CDR X)) (Y Y (CDR Y))) + ((NULL Y) T) + (AND (NULL X) (RETURN ())) ;X WAS TOO SHORT + (AND (NOT (EQ (CAR X) (CAR Y))) (RETURN ())))) ;THEY DONT MATCH + +(DEFUN MUNGEABLE (X) ;SHOULD RANDOM S-EXPR BE PUT IN BINARY FILE + (NOT (OR (MEMQ (CAR X) '(QUOTE COMMENT DECLARE)) ;NOT IF QUOTED OR COMMENT + (AND (EQ (CAR X) 'EVAL) ;NOT IF (EVAL 'FOO) + (EQ (TYPEP (CADR X)) 'LIST) ; (THIS GIVES US A HOOK TO + (EQ (CAADR X) 'QUOTE))))) ; AVOID MUNGING IF DESIRED) + +(DEFUN MOBYSYMPOP (L) + (DO X L (CDR X) (NULL X) + (PUTPROP (CAAR X) (CDAR X) 'SYM))) + +;;; LISTOUT OUTPUTS AN S-EXPRESSION AS A SEQUENCE OF LIST-SPECS. +;;; EACH LIST-SPEC MAY BE AS FOLLOWS: +;;; 0,,N THE ATOM WHOSE ATOMINDEX IS N +;;; 100000,,N LISTIFY THE LAST N ITEMS, TO CREATE A NEW ITEM +;;; 200000,,N MAKE A DOTTED LIST OUT OF THE LAST N+1 ITEMS +;;; 300000,,0 MERELY EVALUATE THE TOP THING ON THE STACK +;;; 7XXXXD,,INS TERMINATE, D IS INFORMATION DIGIT, INS MAY BE +;;; THE LH OF THE INSTRUCTION FOR A TYPE 5 WORD +;;; LISTOUT DOES NOT GENERATE THE TERMINATION WORD + +(defun LISTOUT (x) + (let* ((type (typep x)) + (index (if (not (memq type '#.useratoms-non-types)) + (useratoms-lookup x)))) + (cond ((not (null index)) (faslout index)) + ((eq type 'RANDOM) + (barf *LOC |Relative location of QUOTE randomness|)) + ((and (eq type 'LIST) + (or (eq (car x) SQUID) + (eq (car x) useratoms-intern-frob))) + (setq squidp 'T) + (listout (cadr x)) + (and (eq (car x) SQUID) (faslout 3_33.))) + ((EQ TYPE 'LIST) + (DO ((I 0 (1+ I)) (Y X (CDR Y)) (N 0)) + ((COND ((NULL Y) + (SETQ N 1_33.) ;FASL code to make up standard LIST + 'T) ; terminating in the null list + ((OR (NOT (PAIRP Y)) (EQ (CAR Y) SQUID)) + (LISTOUT Y) ;Output the non-() list terminator + (SETQ N 2_33.) ; and signal FASL code for + 'T)) ; non-standard list. + (FASLOUT (BOOLE 7 I N))) ;_15.,, + (LISTOUT (CAR Y)))) + ((HUNKP X) + (DO ((I 1 (1+ I)) (N (HUNKSIZE X))) + ((NOT (< I N)) + (LISTOUT (CXR 0 X)) + (FASLOUT (BOOLE 7 4_33. N))) + (LISTOUT (CXR I X)))) + ('T (FASLOUT (ATOMINDEX X TYPE))) ))) + +;;; BUFFERBIN TAKES TWO ARGUMENTS: A NUMBER, WHICH IS THE +;;; RELOCATION TYPE, AND SOME OBJECT. THE FORMAT OF THIS SECOND +;;; OBJECT DEPENDS ON THE TYPE, AS FOLLOWS: +;;; # TYPE FORMAT OF SECOND AND THIRD OBJECTS +;;; 0 ABSOLUTE +;;; 1 RELOCATABLE +;;; 2 SPECIAL +;;; 3 SMASHABLE CALL +;;; 4 QUOTED ATOM ATOM +;;; 5 QUOTED LIST +;;; 6 GLOBALSYM +;;; 7 GETDDTSYM <() OR FIXNUM> +;;; 8 ARRAY REFERENCE +;;; 9 [UNUSED] +;;; 10. ATOMINDEX INFO 0 +;;; 11. ENTRY INFO ARGSINFO ( . ) +;;; 12. LOC +;;; 13. PUTDDTSYM 0 +;;; 14. EVAL MUNGEABLE <-N,,0> +;;; 15. END OF BINARY [IGNORED - IN PRACTICE () IS USED] + + + +(DEFUN BUFFERBIN (TYP N X) + (DECLARE (FIXNUM TYP)) + (STORE (BTAR BINCT) TYP) + (STORE (BXAR BINCT) N) + (STORE (BSAR BINCT) X) + (COND ((AND (NOT (= TYP 17)) (< BINCT 8.)) (SETQ BINCT (1+ BINCT))) + (T (DO ((N 0 (BOOLE 7 (LSH N 4) (BTAR I))) ;PACK 9 TYPE BYTES INTO + (I 0 (1+ I))) ;ONE WORD + ((> I BINCT) (FASLOUT (LSH N (* 4 (- 8. BINCT)))))) + (DO I 0 (1+ I) (> I BINCT) + (SETQ TYP (BTAR I) N (BXAR I)) + (COND ((OR (< TYP 5) (= TYP 6) (= TYP 8.)) (FASLOUT N)) + (T (SETQ X (BSAR I)) + (COND ((= TYP 5) + (SETQ SQUIDP ()) + (LISTOUT X) + (FASLOUT (BOOLE 7 -1_18. (LSH N -18.))) + (FASLOUT (COND (SQUIDP 0) ((SXHASH X))))) + ((= TYP 10.) + (LET ((TYPE (TYPEP X))) + (COND ((EQ TYPE 'SYMBOL) + (SETQ X (PNGET X 7)) + (FASLOUT (LENGTH X)) + (MAPC 'FASLOUT X)) + ((EQ TYPE 'BIGNUM) + (FASLOUT (BOOLE 7 3_33. + (COND ((MINUSP X) 7_18.) + (0)) + (LENGTH (CDR X)))) + (MAPC 'FASLOUT (REVERSE (CDR X)))) + ((MEMQ TYPE '(FIXNUM FLONUM)) + (FASLOUT (COND ((EQ TYPE 'FIXNUM) 1_33.) + (2_33.))) + (FASLOUT (LSH X 0))) + (T (BARF (LIST TYP N type X) + | - BUFFERBIN screw type 10|))))) + ((= TYP 11.) + (FASLOUT (LOGIOR (LSH (ATOMINDEX (CAR X) 'SYMBOL) + 18.) + (ATOMINDEX (CDR X) 'SYMBOL))) + (FASLOUT N)) + ((= TYP 14.) (LISTOUT X) (FASLOUT N)) + ((= TYP 15.) (FASLOUT #.(car (pnget '|*FASL+| 6)))) + ((= TYP 7) (FASLOUT N) (AND X (FASLOUT X))) + ((= TYP 13.) (FASLOUT (SQOZ/| (LIST X)))) + (T (BARF (LIST TYP N X) | - BUFFERBIN screw|)))))) + (SETQ BINCT 0)))) + + + +(DEFUN POPNCK@ MACRO (L) + (SUBST (CADR L) + 'tag + '(COND ((NULL (SETQ L (CDR L))) (GO DONE)) + ((EQ (CAR L) '/@) (SETQ WRD (BOOLE 7 WRD 20_18.)) (GO tag))))) + +(DEFUN MKEVAL MACRO (L) + (SUBST (CADR L) + 'n + '(PROG2 (SETQ FSLFLD n) + (AND (EQ (SETQ SYM (FASLEVAL (CAR L))) 'FOO) (GO MKWERR)) + (SETQ TYPE (TYPEP SYM))))) + +(DEFUN MAKEWORD (L) + (DECLARE (FIXNUM WRD NN II REL LN)) + (PROG (WRD NN SYM TYPE OPGL ACGL ADDRGL INDXGL NOGL REL SYL OL) + (SETQ NOGL T REL 0 WRD 0 OL L) + (COND ((EQ (CAR L) 'SQUOZE) + (BINOUT (SQOZ/| (CDR L))) + (SETQ *LOC (1+ *LOC)) + (RETURN ())) + ((EQ (CAR L) 'BLOCK) + (SETQ TYPE (TYPEP (SETQ SYM (CADR L)))) + (AND (EQ TYPE 'SYMBOL) (SETQ TYPE (TYPEP (SETQ SYM (GET SYM 'SYM))))) + (AND (NOT (EQ TYPE 'FIXNUM)) (GO MKWERR)) + (DO II SYM (1- II) (ZEROP II) (BINOUT 0)) + (SETQ *LOC (+ *LOC SYM)) + (RETURN ())) + ((COND ((EQ (CAR L) 'ASCII) (SETQ NN 7) T) + ((EQ (CAR L) 'SIXBIT) (SETQ NN '6) T)) + (MAPC 'BINOUT (SETQ SYM (PNGET (CADR L) NN))) + #%(LET ((LN (LENGTH SYM))) + (COND ((NOT (ZEROP (SETQ NN (- (BLOBLENGTH L) LN)))) + (BINOUT 0) + (AND (NOT (= 1 NN)) + (BARF L |How Much ASCII? - MAKEWORD|)) + (SETQ LN (+ NN LN)))) + (SETQ *LOC (+ *LOC LN))) + (RETURN ()))) + (MKEVAL 3) + (COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD SYM)) + ((NOT (EQ TYPE 'LIST)) (GO MKWERR)) + ((EQ (CAR SYM) 'RELOC) + (SETQ REL 1 WRD (CADR SYM)) + (AND (SETQ OPGL (CDDR SYM)) (SETQ NOGL ()))) + ((NUMBERP (CAR SYM)) (SETQ NOGL () OPGL (CDR SYM) WRD (CAR SYM))) + (T (GO MKWERR))) + A (POPNCK@ A) + (MKEVAL 2) + (COND ((EQ TYPE 'FIXNUM) (SETQ WRD (+ WRD (ROT (BOOLE 1 SYM 17) -13.)))) + ((NOT (EQ TYPE 'LIST)) (GO MKWERR)) + ((NUMBERP (CAR SYM)) + (SETQ NOGL () ACGL (CDR SYM)) + (SETQ WRD (BOOLE 7 WRD (ROT (BOOLE 1 (CAR SYM) 17) -13.)))) + (T (GO MKWERR))) + B (POPNCK@ B) + (MKEVAL 1) + (COND ((EQ TYPE 'FIXNUM) (SETQ NN SYM)) + ((NOT (EQ TYPE 'LIST)) (GO MKWERR)) + ((NUMBERP (CAR SYM)) (SETQ NOGL () ADDRGL (CDR SYM) NN (CAR SYM))) + ((PROG2 (SETQ SYL (CADR SYM)) (MEMQ (CAR SYM) '(QUOTE FUNCTION))) + (SETQ REL (COND ((OR (EQ (SETQ TYPE (TYPEP SYL)) 'LIST) + (HUNKP SYL)) + (SETQ ADDRGL SYL NN 0) + 5) + ('T (SETQ NN (ATOMINDEX SYL TYPE)) + 4)))) + ((COND ((EQ (CAR SYM) 'SPECIAL) (SETQ REL 2) T) + ((EQ (CAR SYM) 'ARRAY) (SETQ REL 10) T)) + (AND (NOT (SYMBOLP SYL)) (GO MKWERR)) + (SETQ NN (ATOMINDEX SYL 'SYMBOL))) + ((EQ (CAR SYM) 'RELOC) + (SETQ REL 1 NN (CADR SYM)) + (AND (SETQ ADDRGL (CDDR SYM)) (SETQ NOGL ()))) + ((COND ((EQ (CAR SYM) 'EVAL) + (SETQ ADDRGL (CONS SQUID (CDR SYM))) + T) + ((EQ (CAR SYM) SQUID) (SETQ ADDRGL SYM) T)) + (SETQ REL 5)) + (T (GO MKWERR))) + (SETQ WRD (BOOLE 7 (BOOLE 1 WRD -1_18.) (BOOLE 1 (+ WRD NN) 777777))) + C (POPNCK@ C) + (MKEVAL 0) + (COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD (+ WRD (ROT SYM 18.)))) + ((NOT (EQ TYPE 'LIST)) (GO MKWERR)) + ((NUMBERP (CAR SYM)) + (SETQ NOGL () INDXGL (CDR SYM) WRD (+ WRD (ROT (CAR SYM) 18.)))) + (T (GO MKWERR))) + DONE (AND (= REL 4) (MEMQ (CAR OL) '(CALL JCALL NCALL NJCALL)) (SETQ REL 3)) + (SETQ *LOC (1+ *LOC)) + (BUFFERBIN REL WRD (AND (= REL 5) (PROG2 () ADDRGL (SETQ ADDRGL ())))) + (COND ((NOT NOGL) + (AND OPGL (GLHAK OPGL 3)) + (AND ACGL (GLHAK ACGL 2)) + (AND ADDRGL (GLHAK ADDRGL 1) (GO MKWERR)) + (AND INDXGL (GLHAK INDXGL 0)))) + (RETURN ()) + MKWERR (PDERR OL |- Ill-formed expression - MAKEWORD|) + (ERR 'FASLAP))) + + +(DEFUN GLHAK (GLITCH FIELD) + (DECLARE (FIXNUM FIELD)) + (COND ((NULL (CAAR GLITCH)) + (COND ((NOT (= FIELD 1))) ;RETURNS "true" IF LOSES + (T (BUFFERBIN 6 + (BOOLE 7 (COND ((CDDAR GLITCH) -4_33.) (0)) + (BOOLE 1 (CADAR GLITCH) 777777)) + ()) + (AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD))))) + (T (BUFFERBIN 7 + (BOOLE 7 (COND ((CDDAR GLITCH) -4_33.) (0)) ;PLUS OR MINUS? + (COND ((CADAR GLITCH) 2_33.) (0)) ;VALUE KNOWN AT ASSEMBLY TIME? + (ROT FIELD -4) ;FIELD NUMBER + (CAAR GLITCH)) ;SQUOZE REPRESENTATION + (CADAR GLITCH)) ;GUESS AT SYMVAL + (AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD))))) + +(DEFUN BINOUT (X) (BUFFERBIN 0 X ())) + + +(DEFUN *DDTSYM (SYM) (FASLDEFSYM SYM (LIST '0 (LIST (SQOZ/| (LIST SYM)) (GETDDTSYM SYM))))) + + +(DEFUN FASLOUT (X) (OUT IMOSAR X)) + diff --git a/src/comlap/initia.120 b/src/comlap/initia.120 new file mode 100755 index 00000000..90943a67 --- /dev/null +++ b/src/comlap/initia.120 @@ -0,0 +1,838 @@ +;;; INITIA -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ***** (Initialization for COMPLR) ************* +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + + +(SETQ INITIAVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/120))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) + ) + + + +(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|in|) ) + + +(EVAL-WHEN (EVAL) (SETQ CAR 'T)) + + +(AND (NOT (STATUS FEATURE SAIL)) + (MAPC '(LAMBDA (X) + (LET (((TYPE FUN . L) X) (PROP)) + (SETQ PROP (GET FUN TYPE)) + (MAPC '(LAMBDA (X) (AND (NOT (GET X TYPE)) + (PUTPROP X PROP TYPE))) + L))) + '((FSUBR UREAD EREAD) (LSUBR OPEN EOPEN) (SUBR LOAD ELOAD)))) + + + + + +(COMMENT INITIALIZING FUNCTIONS) + +(DEFUN INITIALIZE FEXPR (L) + (SSTATUS FEATURE COMPLR) + (SSTATUS FEATURE NCOMPLR) + (SETQ OPSYS (STATUS FILESYSTEM-TYPE)) ;I REALLY INTENDED THIS TO BE + (setq LINEMODEP (or (eq opsys 'DEC10) ; "FILESYSTEM-TYPE", BUT ... + (and (eq opsys 'DEC20) + (eq (status OPSYSTEM-TYPE) 'TOPS-20)))) + (AND (EQ OPSYS 'DEC10) + (EQ (STATUS OPSYSTEM-TYPE) 'SAIL) + (SETQ OPSYS 'SAIL)) + (SETQ MAKLAP-DEFAULTF-STYLE 'MIDAS) + (SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY))) + (SETQ READTABLE (SETQ SREADTABLE (GET 'READTABLE 'ARRAY))) + (SETQ SWITCHTABLE ;Setup before INTERNing + (APPEND '( + (/$ FLOSW () ) (/+ FIXSW () ) (/~ QUIT-ON-ERROR () ) + (/2 HUNK2-TO-CONS ()) (/7 USE-STRT7 ()) + (A ASSEMBLE () ) (C CLOSED () ) + (D DISOWNED () ) (E EXPR-HASH () ) + (F FASL #.(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T)) + (G GAG-ERRBREAKS () ) (H EXPAND-OUT-MACROS T) + (I INITIALIZE () ) + (K NOLAP #.(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T)) + (M MACROS () ) (O ARRAYOPEN T) + (R RUNTIME-LIMITP () ) (S SPECIALS () ) + (T TTYNOTES #.(AND (NOT (MEMQ COMPILER-STATE + '(MAKLAP DECLARE))) T)) + (W MUZZLED () ) (X MAPEX () ) + (Y YESWARNTTY #.(AND (NOT (MEMQ COMPILER-STATE + '(MAKLAP DECLARE))) T) ) + (Z SYMBOLS () ) + ) + ())) + (PUSH (COND (#%(SAILP) + (SETQ MAKLAP-DEFAULTF-STYLE () ) + '(U UNFASLCOMMENTS () )) + ( '(U UNFASLCOMMENTS T))) + SWITCHTABLE) + (DO I 65. (1+ I) (> I 90.) + (AND (NOT (ASSQ (ASCII I) SWITCHTABLE)) + (PUSH (LIST (ASCII I) + (IMPLODE (APPEND '(S W I T C H /-) (LIST (ASCII I)))) + () ) + SWITCHTABLE))) + (COND ((STATUS FEATURE NO-EXTRA-OBARRAY) + (SETQ CREADTABLE READTABLE COBARRAY OBARRAY)) + ('T (SETQ CREADTABLE (ARRAY + () + READTABLE + (COND ((AND (BOUNDP 'IREADTABLE) + (EQ (TYPEP IREADTABLE) 'ARRAY) + (EQ (CAR (ARRAYDIMS IREADTABLE)) + 'READTABLE)) + IREADTABLE) + ('T)))) + ;;Glaag, patch up for the /#-MACRO-DATALIST thing! + #%(let ((y (get 'SHARPM 'VERSION))) + (cond ((null y) (+internal-lossage 'SHARPM 'INITIALIZE () )) + ((alphalessp y "82")) + (T (push #%(let ((x (assoc READTABLE /#-MACRO-DATALIST))) + (cons CREADTABLE (cdr x))) + /#-MACRO-DATALIST)))) + (SETQ COBARRAY (ARRAY + () + OBARRAY + (COND ((AND (BOUNDP 'IOBARRAY) + (EQ (TYPEP IOBARRAY) 'ARRAY) + (EQ (CAR (ARRAYDIMS IOBARRAY)) + 'OBARRAY)) + IOBARRAY) + ((GET 'OBARRAY 'ARRAY))))) + (LET ((OBARRAY COBARRAY) (READTABLE CREADTABLE)) + (MAPC '(LAMBDA (X) + (COND ((NOT (EQ X (INTERN X))) + (REMOB X) + (INTERN X)))) + (STATUS FEATURES)) + (MAPC '(LAMBDA (X) (INTERN (CADR X))) SWITCHTABLE) + (MAPC 'INTERN SAIL-MORE-SYSFUNS) +; (AND #%(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%) ) + ))) + (SETSYNTAX '/~ 'MACRO 'MACR-AMP-FUN) +; (AND #%(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%)) + #%(LET ((PROP (LSUB '(MACRO SPECIAL ARGS *EXPR *FEXPR *LEXPR + NUMVAR NUMFUN *ARRAY OHOME SKIP-WARNING) + L)) + (Z () ) + (TMP () ) ) + (MAPATOMS '(LAMBDA (Y) + (SETQ TMP (ASSQ Y CCLOAD:INITIAL-PROPS)) + (LREMPROP Y (LSUB PROP (CDR TMP))) ;Remove compilation + (COND ((SETQ DATA (GET Y 'FUNTYP-INFO)) ;properties. + (COND ((ARGS Y)) + ((GET Y (CAR DATA)) (ARGS Y (CDR DATA))) + ((CDR DATA) (PUTPROP Y (CDR DATA) 'ARGS)))) + ((AND (NOT (SYSP Y)) (NULL TMP)) (ARGS Y () ))) + (AND (BOUNDP Y) ;SPECIALize the + (NOT (MEMQ Y '(T NIL))) ;system varialbes + (SETQ DATA Y) + (MEMQ 'VALUE (STATUS SYSTEM DATA)) + (PUSH Y Z)))) + (APPLY 'SPECIAL Z) + ;; (STATUS SYSTEM) doesn't win on following + (AND (BOUNDP '+INTERNAL-INTERRUPT-BOUND-VARIABLES) + (APPLY 'SPECIAL +INTERNAL-INTERRUPT-BOUND-VARIABLES)) + (SPECIAL +INTERNAL-WITHOUT-INTERRUPTS) + (FASLINIT)) + (PUTPROP '%HUNK1 '(() . 1) 'ARGS) + (PUTPROP '%HUNK2 '(() . 2) 'ARGS) + (PUTPROP '%HUNK3 '(() . 3) 'ARGS) + (PUTPROP '%HUNK4 '(() . 4) 'ARGS) + (SETQ PRINLEVEL (SETQ PRINLENGTH (SETQ *RSET () ))) + (SETQ BASE 8. IBASE 8. *NOPOINT 'T RUNTIME-LIMIT 600.0E6) + (SETQ MACRO-EXPANSION-USE () ) + (SETQ COMPILATION-FLAGCONVERSION-TABLE + '((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR))) + (SETQ SPECVARS () GENPREFIX '(/| G) GFYC 0 P1GFY () + CLOSED () FIXSW () FLOSW () MACROLIST () + GAG-ERRBREAKS () RNL () CFVFL () + UNDFUNS () P1LLCEK () LAPLL () ROSENCEK () + FASLPUSH () RECOMPL () CMSGFILES () LAP-INSIGNIF 'T + EOC-EVAL () COMPILER-STATE 'TOPLEVEL CHOMPHOOK () + USERATOMS-HOOKS '(EXTSTR-USERATOMS-HOOK) USERATOMS-INTERN () + TOPFN () ONMLS () READ () MSDEV 'DSK MSDIR () + CL () CLEANUPSPL 0 FILESCLOSEP () IMOSAR () + EOF-COMPILE-QUEUE () USER-STRING-MARK-IN-FASL T ) + #%(SETUP-CATCH-PDL-COUNTS) + (MAPC '(LAMBDA (X) (SET (CADR X) (CADDR X))) SWITCHTABLE) + (MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X () ))) + '(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND IDENTITY + USERATOMS-INTERN-FROB)) + (PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO) + (SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND)))) + (SETQ STSL (LIST (DELQ 'TERPR (STATUS STATUS)) + (DELQ 'TERPR (STATUS SSTATUS)))) + (SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN)) + (SETQ CAAGL (LIST (LIST (CONS MAKUNBOUND ARGLOC) 1) + (LIST (CONS MAKUNBOUND ARGLOC) 2))) + (SETQ MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT EXITN PVR STSL)) + (LIST (CONS 'GOFOO GOFOO)))) + (SETQ COMAL (SUBST '() 'NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) ) + (RPLACD (CAR COMAL) (CAR COMAL)) ;Sets up infinite + (RPLACD (CADR COMAL) (CADR COMAL)) ; type lists for COMARITH + (RPLACD (CADDR COMAL) (CADDR COMAL)) + + (FIXNUM BASE IBASE BPORG BPEND TTY) ;Some known declarations + (FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME) + (GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (IFIX) + (^ FIXNUM FIXNUM) (\\ FIXNUM FIXNUM) (LSH) (ROT) (ASH) + (SXHASH) (TYIPEEK) (TYI) (HAULONG) (HUNKSIZE) + (+INTERNAL-CHAR-N () FIXNUM) + (+INTERNAL-STRING-WORD-N () FIXNUM) + (LDB FIXNUM FIXNUM) (DPB FIXNUM FIXNUM) + (*LDB FIXNUM FIXNUM) (*DPB FIXNUM FIXNUM) + (LOAD-BYTE FIXNUM FIXNUM FIXNUM) + (DEPOSIT-BYTE FIXNUM FIXNUM FIXNUM FIXNUM) + (*LOAD-BYTE FIXNUM FIXNUM FIXNUM) + (*DEPOSIT-BYTE FIXNUM FIXNUM FIXNUM FIXNUM) ) + (FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM) (LENGTHF)) + (PUTPROP 'BOOLE (CONS (CADR COMAL) (CONS 'FIXNUM (CADR COMAL))) 'NUMFUN) + (PUTPROP IDENTITY 'T 'NUMBERP) + (PUTPROP 'FIXNUM-IDENTITY `(,IDENTITY FIXNUM) 'ARITHP) + (PUTPROP 'FLONUM-IDENTITY `(,IDENTITY FLONUM) 'ARITHP) + (FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME) + (^$ FLONUM FIXNUM) (FSC) (FLOAT)) + (NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM)) + (ARRAY* (NOTYPE OBARRAY 1 READTABLE 1)) + (PUTPROP PROGN 'T '*LEXPR) + (COND (#%(SAILP) + (MAPC '(LAMBDA (X) (PUTPROP X 'T 'SKIP-WARNING)) + '(PUSH POP LET)) + (SSTATUS TTYINT 200. (STATUS TTYINT 194.)) + (SSTATUS TTYINT 467. 'S-C) + (MAPC #'(LAMBDA (X) + (OR (GET X 'MACRO) + (PUTPROP X + (INTERN (PNAMECONC X '| | 'MACRO)) + 'MACRO))) + '(LET! MACRODEF MATCH-MACRO TRANS TRANSDEF)))) + (SSTATUS TTYINT '/ 'INT-^^-FUN) + (SSTATUS TTYINT '/ 'INT-^^-FUN) + (SSTATUS TTYINT '/ 'DEBUG-BREAK) + (SETQ OBARRAY #.(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'COBARRAY) + ('SOBARRAY))) + (SETQ READTABLE #.(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'CREADTABLE) + ('SREADTABLE))) + (setq error-break-environment (cons cobarray creadtable)) + (GCTWA)) + + + + +(DEFUN DEBUG-BREAK N N + (NOINTERRUPT () ) + (MSOUT-BRK ARGS SOBARRAY SREADTABLE 'SOBARRAY-ENVIRONMENT)) + +;;; Function for ~ macro char +(DEFUN MACR-AMP-FUN () + ((LAMBDA (OBARRAY READTABLE) + (COND ((= (TYIPEEK) #.(INVERSE-ASCII '/~)) + (TYI) + (SETQ OBARRAY SOBARRAY READTABLE SREADTABLE))) + (READ)) + COBARRAY CREADTABLE)) + +;;; Function for control-^ interrupt +(DEFUN INT-^^-FUN N + (SETQ SAVED-ERRLIST ERRLIST ERRLIST () N (ARG 2)) + (SSTATUS TOPLEVEL '(INT-^^-TOPLE)) + (DO () ((OR (= (LISTEN) 0) (= (TYI) N)))) + (^G)) + + +(DEFUN INT-^^-TOPLE () ;Starts up MAKLAP from ^^ + #%(ERL-SET) + (SSTATUS TOPLEVEL () ) + (setq LINEMODEP (or (eq opsys 'DEC10) + (and (eq opsys 'DEC20) + (eq (status OPSYSTEM-TYPE) 'TOPS-20)))) + (COMPLRVERNO) + (NOINTERRUPT () ) + (cond ((not LINEMODEP) (maklap)) + ((unwind-protect (prog2 (sstatus LINMO T) (MAKLAP)) + (sstatus LINMO ()))))) + +(DEFUN DB FEXPR (L) ;Setup for debugging + L + (SETQ SAVED-ERRLIST ERRLIST ERRLIST () ) + (SSTATUS TOPLEVEL '(DB-TOPLE)) + (^G)) + +(DEFUN DB-TOPLE () + (SSTATUS UUOLI) + #%(ERL-SET) + (*RSET (NOUUO 'T)) + (SETQ OBARRAY SOBARRAY READTABLE SREADTABLE) + (SETQ ^W (SETQ ^R () )) + (setq LINEMODEP ()) + (sstatus LINMO ()) + (SETQ ERRSET (FUNCTION (LAMBDA (X) X (BREAK ERRSET)))) + (PROG (L) + A (COND ((NOT (GET 'BS 'FSUBR)) + (COND (#%(ITSP) (SETQ L '((DSK LIBLSP) BS FASL))) + ((PROBEF (SETQ L '((DSK) BS FASL)))) + ('T (TERPRI) + (PRINC '|Please load BS FASL!|) + (BREAK LOAD) + (GO A))) + (ELOAD L)))) + (SSTATUS TOPLEVEL () )) + + +(DEFUN S-C (() ()) (CDUMP '|SAVE COMPLR|)) + + + + +;This function never returns, but is a way to start up the toplevel complr +(DEFUN CDUMP N + (SETQ ERRLIST () SAVED-ERRLIST '((COMPLRVERNO))) + (SSTATUS TOPLEVEL '(COMPLR-TOPLE)) + (SETQ CDUMP (LISTIFY N)) + (OR (GET 'COMPLR 'VERSION) + (PUTPROP 'COMPLR COMPLRVERNO 'VERSION)) + (*THROW () ()) + ;;(COMMENT Hopefully, this goes to a TOPLEVEL user of COMPLR-TOPLE) + ) + +(DEFUN COMPLR-TOPLE () ;Initial TOPLEVEL loop + (SETQ OBARRAY COBARRAY READTABLE CREADTABLE) + (SSTATUS TOPLEVEL () ) + (SETQ - () + () ) + #%(ERL-SET) + (SSTATUS NOFEATURE NOLDMSG) + (GCTWA 1) + (GC) + (APPLY (COND ((STATUS FEATURE SHARABLE) + (AND (NULL (CDR CDUMP)) (PUSH () CDUMP)) + 'PURE-SUSPEND) + ('SUSPEND)) + CDUMP) + (COMPLR-TOPLE-AFTER-SUSPEND)) + +(DEFUN COMPLR-TOPLE-AFTER-SUSPEND () + ;; This function is an entry-point which some systems + ;; depend on. e.g. the macsyma-source-compiler. -gjc + (SSTATUS GCTIM 0) + (setq LINEMODEP (or (eq opsys 'DEC10) + (and (eq opsys 'DEC20) + (eq (status OPSYSTEM-TYPE) 'TOPS-20)))) + #%(LET ((UID (STATUS USERID)) + (USN (COND ((STATUS STATUS HOMED) (STATUS HOMED)) ((STATUS UDIR)))) + (MSGFILES '(T)) + (COMPILER-STATE 'DECLARE) + FIX-FILE FILE OFILE DEFAULTF-DEVICE) + (SETQ DEFAULTF-DEVICE (CASEQ OPSYS + (ITS '(DSK LSPDMP)) + (DEC20 '(PS MACLISP)) + (SAIL '(DSK (MAC LSP))) + (T '(LISP))) + DEFAULTF `(,defaultf-device * ,(caseq opsys + (ITS '>) + (SAIL '|___|) + (T 'LSP))) + FIX-FILE `(,defaultf-device CLFIX ,(get 'COMPLR 'VERSION))) + (SETQ DEFAULTF-DEVICE + `((,(car defaultf-device) ,(status UDIR)) ,.(cdr defaultf)) +) + (COND ((STATUS FEATURE SHARABLE) + (ANNOUNCE-&-LOAD-INIT-FILE 'COMPLR () FIX-FILE)) + ('T (COMPLRVERNO) + (TERPRI) + (COND ((SETQ FIX-FILE (PROBEF FIX-FILE)) + (TERPRI) + (PRINC '|Loading fix-up file |) + (PRIN1 (NAMESTRING FIX-FILE)) + (COND ((ATOM (ERRSET (LOAD FIX-FILE))) + (PRINC '| *** Errors in Fix File ***|) + (BREAK FIX))))) + (SETQ OFILE `((,(cond (#%(dec20p) 'PS) ('DSK)) ,usn) + ,.(cond (#%(itsp) `(,uid COMPLR)) + ('T `(COMPLR INI)))) + FILE (PROBEF OFILE) + DEFAULTF DEFAULTF-DEVICE) + (COND ((COND (FILE) + (#%(ITSP) + (RPLACA (CDR OFILE) '*) + (AND (SETQ FILE (CAR (ERRSET (EOPEN OFILE '(NODEFAULT)) + () ))) + (SETQ FILE (TRUENAME FILE))) + FILE)) + (TERPRI) (TERPRI) + (PRINC '|Loading "|) + (PRINC (NAMESTRING FILE)) + (PRINC '|", COMPLR initialization file for |) + (PRINC (COND ((OR (EQ (CADR OFILE) '*) (NOT #%(ITSP))) USN) + (UID))) + (TERPRI) + (AND (ATOM (ERRSET (ELOAD FILE) 'T)) + (PRINC '| *** Errors during loading *** BEWARE!| TYO)))) )) + (COND ((SETQ DATA (STATUS JCL)) + (LET (WINP (JCL-LINE DATA) RUNP) + (SETQ WINP (ERRSET + (PROG (M L LL) + (SETQ L DATA) + A (AND (< (SETQ M (GETCHARN (CAR L) 1)) 27.) + ;Flush control chars + (NOT (= M 17.)) ;[except ^Q] from + (SETQ L (CDR L)) ;front of JCL list + (GO A)) + (SETQ LL () ) + B (SETQ M (GETCHARN (CAR L) 1)) + (PUSH (COND ((AND (< M 123.) (> M 96.)) + (- M 32.)) ;Uppercaseify + (M)) ; rest of line + LL) + (AND (SETQ L (CDR L)) (GO B)) + C (AND (< (CAR LL) 27.) ;Flush control + (SETQ LL (CDR LL)) ; chars from + (GO C)) ; end of line + (SETQ LL (NREVERSE LL)) + (cond ((not (eq (status OPSYSTEM-TYPE) 'ITS)) + (cond ((and (= (car ll) #/R) + (cdr ll) + (= (cadr ll) #/U) + (cddr ll) + (= (caddr ll) #/N) + (cdddr ll) + (= (cadddr ll) #\SPACE)) + (setq ll (nthcdr 4 ll) + runp 'T))) + (prog (x n) + (declare (fixnum n)) + (setq n (if runp #/; #\SPACE)) + ;Flush subsystem name -- e.g. COMPLR + A (and (null ll) (return () )) + (pop ll x) + (if (not (= x n)) (go A)) + ;Flush leading spaces + B (cond ((null ll)) + ((= (car ll) #\SPACE) + (pop ll) + (go B)))))) + (cond ((not LINEMODEP) (APPLY 'MAKLAP ll)) + ((unwind-protect + (prog2 (sstatus linmo T) + (APPLY 'MAKLAP ll)) + (sstatus linmo () ))))) + 'T )) + (COND ((ATOM WINP) + (COND (WINP (PRINC '| *** Errors from JCL command *** /î;JCL = /"|) + (PRINC (MAKNAM JCL-LINE)) + (PRINC '/"/î ) + (BREAK JCL)) + ('T (PRINC '| *** Errors (probably I/O) in COMPLR Toplevel|) + (do ((l '((INFILE . INPUT) (IMOSAR . FASL)) (cdr l)) + (x)) + ((null l)) + (setq x (symeval (caar l))) + (and (filep x) + (memq 'FILEPOS (cdr (status FILEM x))) + (princ `(,(filepos x) = CURRENT ,(cdar l) FILEPOS)))) + (BREAK COMPLR-TOPLE))) )) + (INT-^^-TOPLE))) + ('T (cond ((not LINEMODEP) (maklap)) + ((unwind-protect (prog2 (sstatus linmo T) (MAKLAP)) + (sstatus linmo ()))))))) ) + + + + + +;;; NOTE: THE LIST OF GLOBALSYMS SHOULD CORRESPOND TO +;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP. + + +(DEFUN FASLINIT () + (GETMIDASOP ()) + (LET ((OBARRAY OBARRAY) (FL) + (PROPS '(SYM ATOMINDEX ARGSINFO ENTRY GLOBALSYM)) + (ACS '(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP))) + (MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS))) + (SETQ LDFNM (FASLAPSETUP/| () )) ;Sets up GLOBALSYMS + (COND ((AND (BOUNDP 'COBARRAY) + (EQ (TYPEP COBARRAY) 'ARRAY) + (SETQ FL (ARRAYDIMS COBARRAY)) + (EQ (CAR FL) 'OBARRAY) + (NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY)))) + (SETQ FL '(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL + ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM + THIS IS THE UNFASL FOR LISP FILE COMPILED BY COMPILER)) + (MAPATOMS '(LAMBDA (X) (AND (GETL X '(SYM GLOBALSYM)) (PUSH X FL)))) + ;;;AFTER THE FASLAPSETUP/|, ONLY SYMS SHOULD BE GLOBALSYMS. IN ORDER: + ;*SET *MAP PRINTA SPECBIND UNBIND IOGBND *LCALL *UDT ARGLOC + ;INUM ST FXNV1 PDLNMK PDLNKJ FIX1A FIX1 FLOAT1 IFIX IFLOAT + ;FXCONS FLCONS ERSETUP ERUNDO GOBRK CARCDR *STORE NPUSH PA3 + ;MAKUNBOUND FLTSKP FXNV2 FXNV3 FXNV4 FIX2 FLOAT2 AREGET + ;UINITA UTIN INTREL INHIBIT NOQUIT CHECKI 0PUSH 0*0PUSH + ;NILPROPS VBIND %CXR %RPX + (SETQ OBARRAY COBARRAY) + (MAPC 'INTERN FL) ;Cross-interns GLOBALSYMS + (MAPC 'INTERN (APPEND PROPS ACS))) ;Plus a few other words + (T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE))) + (SETQ SQUIDP ()) ;Lists and set up GLOBALSYMS + (DO ((I 0 (1+ I)) (L ACS (CDR L))) ;Now define SYMS for LISP acs + ((NULL L)) + (AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM))) + (ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.) + (ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.) + (DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((() -1))))) + (SETQ IMOSAR () IMOUSR ()) + (SSTATUS FEATURE FASLAP) + (GCTWA))) + + + +(COMMENT FILL INITIAL ARRAYS) + + + +(ARRAY AC-ADDRS T #.(+ (NUMVALAC) (NUMNACS) 1)) +(ARRAY PDL-ADDRS T 3 #.(+ 1 (NPDL-ADDRS))) +(ARRAY STGET T #.(+ (NUMVALAC) (NUMNACS))) +(ARRAY BOLA T #.(+ (NACS) (NUMNACS) 1) 7) +(ARRAY CBA T 16.) +(ARRAY A1S1A T #.(NUMNACS) 4) +(ARRAY PVIA T 3 (1+ (MAX #.(MAX-NPUSH) #.(MAX-0PUSH) #.(MAX-0*0PUSH)))) + + +(PROGN (DO CNT #.(+ (NUMVALAC) (NUMNACS)) (1- CNT) (< CNT 1) ;Sets AC-ADDRS + (STORE (AC-ADDRS CNT) CNT)) + (DO CNT #.(NPDL-ADDRS) (1- CNT) (< CNT 1) ;Sets PDL-ADDRS + (STORE (PDL-ADDRS 0 CNT) (- CNT #.(NPDL-ADDRS))) + (STORE (PDL-ADDRS 1 CNT) (- (+ CNT #.(FXP0)) #.(NPDL-ADDRS))) + (STORE (PDL-ADDRS 2 CNT) (- (+ CNT #.(FLP0)) #.(NPDL-ADDRS)))) + ;;; (STGET n) is for accessing segment table into register n + (DO CNT #.(+ (NUMVALAC) (NUMNACS) -1) (1- CNT) (< CNT 1) + (STORE (STGET CNT) (SUBST CNT 'N '(0 ST N)))) + + (DO ((HLAC #.(+ (NACS) (NUMNACS)) (1- HLAC)) + (ATPL `((TDZA N N) + (MOVEI N ,(if (eq *:truth 'T) ''T '*:truth)) + (SKIPE 0 N) + (MOVNI #.(NUMVALAC) N) + (MOVEI N '() ) + (SKIPN 0 N)))) + ((< HLAC 1)) + (DO ((CNT 1 (1+ CNT)) (ATPL1 ATPL (CDR ATPL1))) + ((NULL ATPL1)) + (STORE (BOLA HLAC CNT) (SUBST HLAC 'N (CAR ATPL1))))) + (FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) ;Sets CBA + (ANDCM) (SETM) (XOR) (IOR) (ANDCB) + (EQV) (SETCM) (ORCA) (SETCA) + (ORCM) (ORCB) (SETO))) + (DO CNT #.(- (NUMNACS) 1) (1- CNT) (< CNT 0) ;Sets A1S1A + (DO ((HLAC 0 (1+ HLAC)) (L '((ADDI 1) + (SUBI 1) + (FADRI 66304.) ;66304. = 201400[8] + (FSBRI 66304.)) + (CDR L))) + ((NULL L)) + (STORE (A1S1A CNT HLAC) (LIST (CAAR L) + (+ CNT #.(NUMVALAC)) + (CADAR L))))) + + ;;; Makes up array of JSPs to places that push the appropriate number + ;;; of pdl-variable initialization values, onto the appropriate stack. + ;;; (PVIA 0 n) ==> (JSP T (NPUSH -n)) pushes ()s onto REGPDL + ;;; (PVIA 1 n) ==> (JSP T (0PUSH -n)) pushes 0s onto FXPDL + ;;; (PVIA 2 n) ==> (JSP T (0*0PUSH -n)) pushes 0.0s onto FLPDL + (STORE (PVIA 0 0) #.(MAX-NPUSH)) + (STORE (PVIA 1 0) #.(MAX-0PUSH)) + (STORE (PVIA 2 0) #.(MAX-0*0PUSH)) + (STORE (PVIA 0 1) '(PUSH P (% 0 0 '()))) + (STORE (PVIA 1 1) '(PUSH FXP (% 0))) + (STORE (PVIA 2 1) '(PUSH FLP (% 0.0))) + (STORE (PVIA 0 2) 'NPUSH) + (STORE (PVIA 1 2) '0PUSH) + (STORE (PVIA 2 2) '0*0PUSH) + (DO CNT 0 (1+ CNT) (> CNT 2) + (DO HLAC (PVIA CNT 0) (1- HLAC) (< HLAC 3) + (STORE (PVIA CNT HLAC) (LIST 'JSP 'T (LIST (PVIA CNT 2) (- HLAC)))))) + + (COND (*PURE + (MAPC '(LAMBDA (GL) + (SETQ GL (GET GL 'ARRAY)) + (DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0) + (STORE (ARRAYCALL T GL CNT) + (PURCOPY (ARRAYCALL T GL CNT))))) + '(AC-ADDRS STGET CBA)) + (MAPC '(LAMBDA (GL) + (SETQ GL (GET GL 'ARRAY)) + (DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0) + (DO HLAC (1- (CADDR (ARRAYDIMS GL))) + (1- HLAC) + (< HLAC 0) + (STORE (ARRAYCALL T GL CNT HLAC) + (PURCOPY (ARRAYCALL T GL CNT HLAC)))))) + '(PDL-ADDRS BOLA A1S1A PVIA)))) +) + + + +(COMMENT PUT PROPERTIES ON VARIOUS SYMBOLS) + +(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST) + (DEFPROP RPLACA (HRLM . HRLM) INST) + (DEFPROP RPLACD (HLLZS . HLLZS) INSTN) + (DEFPROP RPLACA (HRRZS . HRRZS) INSTN) + (DEFPROP SETPLIST (HRRM . HRRM) INST) + (DEFPROP SETPLIST (HLLZS . HLLZS) INSTN) + (DEFPROP A (HLRZ . HLRZ) INST) + (DEFPROP D (HRRZ . HRRZ) INST) + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED)) + '(MOVE CAMN CAME + ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN + AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA) + '(MOVEI CAIN CAIE + ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI + ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI)) + + + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'JSP)) + '(CONS XCONS NCONS %HUNK1 %HUNK2 %HUNK3 %HUNK4) + '( + (((JSP T %CONS) . + (JSP T %C2NS)) + . ((JSP T %PDLC) . + (JSP T %C2NS))) + (((JSP T %XCONS) . + (JSP T %PDLXC)) + . PUNT ) + (((JSP T %NCONS)) . + ((JSP T %PDLNC))) + ((JSP T %HUNK1)) + ((JSP T %HUNK2)) + ((JSP T %HUNK3)) + ((JSP T %HUNK4)) + )) + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU)) + '(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL) + '(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG)) + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV)) + '(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML + CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL) + '(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE + CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE)) + ;A status option with no STATUS property means no evaluation of its + ; entries. "(x . y)" means "x" is for sstatus and "y" for status; + ; x and y are "A" to mean evaluate all but option name, and "B" to + ; mean evaluate all but option name and next thing. + (MAPC '(LAMBDA (Z Y) (MAPC '(LAMBDA (X) (PUTPROP X Z 'STATUS)) Y)) + + '((A . A) (() . A) (A . () ) (B . B)) + '((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO PDLMA INTER + GCMIN GCSIZ GCMAX) + (DIVOV FTVSI + TOPLE UUOLI ABBRE GCTIM GCWHO WHO1 WHO2 WHO3 + EVALH BREAK MAR CLI FLUSH PUNT RANDO /_ LOSEF) + (SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI OSPEE HSNAM) + (MACRO SYNTA CHTRA))) + + + + + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS)) + '(MOVEI ADDI SUBI) + '(MOVNI SUBI ADDI)) + + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH)) + '(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR) + '(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB)) + + (MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI)) + '(FADR FSBR FMPR FDVR MOVE) + '(FADRI FSBRI FMPRI FDVRI MOVSI)) + + ((LAMBDA (Y) + (MAPC '(LAMBDA (X) + (COND ((GET (CAR X) 'AUTOLOAD) + (COND ((NULL (CDDR X))) + ((EQUAL (SETQ Y (ARGS (CAR X))) (CDDR X))) + (T (AND Y (ERROR '|ARGS data doesn't match| + X + 'FAIL-ACT)) + (ARGS (CAR X) (CDDR X)))) + (AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO))))) + '((ALLFILES SUBR () . 1) + (CGOL FSUBR) (CGOLREAD LSUBR) (CREATE-JOB LSUBR 3 . 5) + (FORMAT LSUBR 2 . 510.) (INF-EDIT MACRO) (LEDIT FSUBR) + (LAP FSUBR) (LAP-A-LIST SUBR () . 1) + (DUMPARRAYS SUBR () . 2) (LOADARRAYS SUBR () . 1) + (DIRECTORY LSUBR 1 . 2) (MAPALLFILES SUBR () . 2) + (MAPDIRECTORY LSUBR 2 . 3) + (SORT SUBR () . 2) (SORTCAR SUBR () . 2) + (GRIND FSUBR) (GRIND0 FSUBR) (GRINDEF FSUBR) + (SPRINTER SUBR () . 1) (TRACE FSUBR) + (LOOP MACRO) (DEFINE-LOOP-PATH MACRO) + (DEFINE-LOOP-SEQUENCE-PATH MACRO) + (DEFVST MACRO) (SETVST MACRO) (STRUCT-TYPEP SUBR () . 1) + (STRINGP SUBR () . 1) + (*:FIXNUM-TO-CHARACTER SUBR () . 1) + (*:CHARACTER-TO-FIXNUM SUBR () . 1) + (MAKE-STRING LSUBR 1 . 2) (STRING-PNPUT SUBR () . 2) + (REPLACE LSUBR 2 . 5) (SUBSEQ LSUBR 1 . 3) + (TO-LIST LSUBR 1 . 3) (TO-VECTOR LSUBR 1 . 3) + (TO-STRING LSUBR 1 . 3) (TO-BITS LSUBR 1 . 3) + (SETSYNTAX-SHARP-MACRO LSUBR 3 . 4) + (PTR-TYPEP SUBR () . 1) (EXTENDP SUBR () . 1) + (SI:MAKE-EXTEND SUBR () . 2) (SI:EXTEND LSUBR 1 . 510.) + (SI:XREF SUBR () . 2) (SI:XSET SUBR () . 3) + (SI:DEFCLASS*-1 LSUBR 3 . 4) + (ADD-METHOD SUBR () . 3) (FIND-METHOD SUBR () . 2) + (WHICH-OPERATIONS SUBR () . 1) (DESCRIBE LSUBR 1 . 2) + (SEND-AS LSUBR 3 . 510.) (LEXPR-SEND LSUBR 2 . 510.) + (LEXPR-SEND-AS LSUBR 3 . 510.) + (Y-OR-N-P LSUBR) (YES-OR-NO-P LSUBR) + (CERROR LSUBR 4 . 510.) (FERROR LSUBR 2 . 510.)))) + () ) + + (DEFPROP %CATCHALL (FSUBR) FUNTYP-INFO) + (DEFPROP %PASS-THRU (FSUBR) FUNTYP-INFO) + + + (MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;Has no side-effects + '( + %HUNK1 %HUNK2 %HUNK3 %HUNK4 *APPEND ALPHALESSP + APPEND ARRAYDIMS ASSOC ASSQ ATOM BAKLIST + BIGP BOUNDP CONS COPYSYMBOL ERRFRAME + EVALFRAME EXPLODE EXPLODEC EXPLODEN + FILEP FIXP FLOATP GETCHAR GETL HUNK + HUNKP LAST LISTARRAY LISTIFY MAKNAM + MEMBER MEMQ NCONS NTHCDR NULL NUMBERP + PLIST PNGET REVERSE SAMEPNAMEP SIGNP + SUBLIS SUBST SYMBOLP SYSP TYPEP XCONS + )) + (MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;Has side-effects + '( + *ARRAY *DELETE *DELQ *NCONC *READCH *REARRAY + ALARMCLOCK ASCII CURSORPOS DELETE DELQ DUMPARRAYS + FILLARRAY GENSYM IMPLODE INTERN LOADARRAYS NCONC NRECONC + NREVERSE READCH REMOB REMPROP SASSOC SASSOC SASSQ SETPLIST + SETSYNTAX SORT SORTCAR SUSPEND TERPRI VALRET + )) + (MAPC '(LAMBDA (X) (PUTPROP X 'T 'NOTNUMP)) ;Has side-effects, and returns T + '(TYO /+TYO *TYO DEPOSIT PRIN1 PRINC PRINT *PRIN1 *PRINC *PRINT)) + + +;;; In general, function-names with ACS properties have no side-effects, except +;;; for those explicity mentioned under the NOTNUMP property above. Thus +;;; (NOT (GET x 'ACS)) is a general test for potentially-random side-effects. + + (MAPC '(LAMBDA (DATA) + (MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA)))) + (CDR DATA))) + '( + +;; ((ACS 1) IN OUT LINEL PAGEL CHARPOS LINENUM PAGENUM +;; CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST +;; TRUENAME PROBEF DELETEF DEFAULTF) + ((ACS 1) FASLP) + ((ACS 2) MERGEF) +;; ((ACS 3) NAMESTRING SHORTNAMESTRING) +;; ((ACS 4) RUBOUT RENAMEF ENDPAGEFN EOFFN DELETEF FILEPOS +;; LENGTHF CNAMEF) + ((ACS 4) FILEP) +;; ((ACS 5) OPEN CLOSE) + ;Missing are INCLUDE and LOAD, because they may cause + ; totally unforseen side-effects + + ((ACS 1) LENGTH ADD1 SUB1 MINUS ABS FLOAT FIX + SIN COS SQRT LOG EXP ZEROP PLUSP MINUSP ODDP + 1+ 1- 1+/$ 1-/$) + ((ACS 1) LAST SLEEP RANDOM NOINTERRUPT EXAMINE + ARG MUNKAM ERRFRAME) + + ((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN + GREATERP LESSP ATAN + *PLUS *TIMES *GREAT *QUO *DIF *LESS /\/\ /^ /^$ + HAULONG HAIPART GCD BOOLE REMAINDER) + ((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT + CONS NCONS XCONS SUBLIS NCONC *NCONC *DELQ + DELQ ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM + SAMEPNAMEP ALPHALESSP GETCHARN LISTIFY + NTH NTHCDR) + + ((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY + LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS + PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC + SYSP COPYSYMBOL SXHASH MAKNAM GETL + REVERSE NREVERSE NRECONC GETL PUTPROP ARGS) + + ((ACS 4) ASSOC SASSOC SASSQ CRUNIT) + + ((ACS 4) %HUNK1 %HUNK2 %HUNK3 %HUNK4) + + ((ACS 5) SUBST *DELETE DELETE MEMBER *APPEND APPEND + *ARRAY *REARRAY LOADARRAYS + BAKTRACE BAKLIST ERRPRINT + ALLOC *FUNCTION SUSPEND SETSYNTAX + EXPLODEC EXPLODE EXPLODEN + PNPUT INTERN IMPLODE REMOB ASCII READCH *READCH + *TERPRI TERPRI *TYO TYO /+TYO *TYI TYI TYIPEEK + CURSORPOS + GETMIDASOP GETDDTSYM PUTDDTSYM +;; UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND +))) + + ;EVAL, *EVAL, READ, *READ and MAP series aren't here, since + ; they permint random evaluations [hence random side effects] + ;PAGEBPORG isn't here since it setqs BPORG, and may cause a GC. + + + + (MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'P1BOOL1ABLE)) + '(AND OR NULL NOT EQ = > < COND MEMQ SIGNP)) + + (MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE)) + '(EQUAL GREATERP LESSP ODDP *GREAT *LESS ZEROP PLUSP MINUSP)) + + (MAPC '(LAMBDA (INST INSTN) + (PUTPROP INST + (CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN)) + 'P1BOOL1ABLE) + (or (get inst 'NOTNUMP) + (putprop inst 'NOTNUMP 'NOTNUMP))) + '(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP FIXNUMP SI:ARRAY-HEADERP) + ;(175300 161000 120000 40000 20000 20 10000 100000 4000) + '(64192. 57856. 40960. 16384. 8192. 16. 4096. 32768. 2048.)) + + (MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'CONTAGIOUS)) + '(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO)) + + (MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'NUMBERP)) + '(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO + ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG)) + + (MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP)) + '(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP ZEROP PLUSP MINUSP)) + + (MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP)) + '( (/+ PLUS FIXNUM) (+$ PLUS FLONUM) + (/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM) + (/* TIMES FIXNUM) (*$ TIMES FLONUM) + (/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM) + (/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM) + (// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM) + (/> GREATERP () ) (/< LESSP () ) + (/\ REMAINDER FIXNUM) (/= EQUAL () ) + ;; (FIXNUM-IDENTITY IDENTITY FIXNUM) ;SET UP BY INITIALIZE + ;; (FLONUM-IDENTITY IDENTITY FLONUM) ;SET UP BY INITIALIZE + )) +) + diff --git a/src/comlap/maklap.80 b/src/comlap/maklap.80 new file mode 100755 index 00000000..05350324 --- /dev/null +++ b/src/comlap/maklap.80 @@ -0,0 +1,1187 @@ +;;; MAKLAP -*-LISP-*- +;;; ************************************************************** +;;; ***** MacLISP ***** (File parser for COMPLR) ***************** +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + +(SETQ MAKLAPVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/80))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + + +(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|mk|)) + + +(comment COUTPUT and MACRO-EXPAND) + +(DEFUN COUTPUT (X) + (COND ((AND EXPAND-OUT-MACROS (NOT (ATOM X)) (NOT (EQ (CAR X) 'QUOTE))) + (SETQ X (MACRO-EXPAND X)))) + (ICOUTPUT X)) + +(DEFUN MACRO-EXPAND (X) + (COND ((OR (not (pairp X)) (eq (car x) 'QUOTE)) + X) + (((LAMBDA (MCX-TRACE) + (COND ((EQ (*CATCH 'MCX-TRACE (MCX-TRACE X)) CLPROGN) + (SETQ MCX-TRACE ()) + (MCX-TRACE X)) + ('T X))) + 'T)))) + +(DEFUN MAP-MCX-TRACE (L) + (AND L + (DO ((ANS) (TEM)) + ((NULL L) (NREVERSE ANS)) + (SETQ TEM (MCX-TRACE (CAR L))) + (AND (NULL MCX-TRACE) (PUSH TEM ANS)) + (POP L)))) + + +(DEFUN MCX-TRACE (X) + (COND ((OR (not (pairp X)) (EQ (CAR X) 'QUOTE)) + X) + ((LET (Y Z) + (COND ((ATOM (CAR X)) + (COND ((NOT (SYMBOLP (CAR X))) X) + ((and (setq z (get (car x) 'SOURCE-TRANS)) + (do ((l z (cdr l))) + ((null l) () ) + (multiple-value (y z) (funcall (car l) x)) + (if z (return 'T)))) + (COND (MCX-TRACE (*THROW 'MCX-TRACE CLPROGN)) + ('T (MCX-TRACE Y)))) + ((GET (CAR X) '*FEXPR) X) + ((NOT (EQ (SETQ Y (P1MACROGET X)) NULFU)) + (COND (MCX-TRACE (*THROW 'MCX-TRACE CLPROGN)) + ('T (MCX-TRACE Y)))) + ((OR (EQ (CAR X) 'LAMBDA) + (EQ (SYSP (CAR X)) 'FSUBR)) + (CASEQ (CAR X) + ((SETQ PROG LAMBDA ARRAY SIGNP + ARRAYCALL SUBRCALL LSUBRCALL + STATUS SSTATUS EVAL-WHEN) + ;All but first "arg" is eval'd + (SETQ Y (MAP-MCX-TRACE (CDDR X))) + (COND (MCX-TRACE ()) + ((LIST* (CAR X) (CADR X) Y)))) + ((COND) + (CONS 'COND (MAPCAR 'MAP-MCX-TRACE (CDR X)))) + ((DO CASEQ) + (SETQ X (COND ((EQ (CAR X) 'DO) (P1DO X)) + ('T (P1CASEQ X)))) + (AND (NULL X) (*THROW 'MCX-TRACE ())) + (MCX-TRACE X)) + ((FUNCTION) + (COND ((OR (ATOM (SETQ Y (CADR X))) + (NOT (EQ (CAR Y) 'LAMBDA))) + X) + ('T (SETQ Z (MAP-MCX-TRACE (CDDR Y))) + (COND (MCX-TRACE () ) + (`(FUNCTION + (LAMBDA ,(cadr y) + ,.z))))))) + ((GO AND OR ERRSET ERR STORE PUSH POP SETF + PROGV *CATCH *THROW CATCH-BARRIER + CATCHALL UNWIND-PROTECT) + ;All args eval'd + (MAP-MCX-TRACE X)) + ((CATCH THROW) + ;First arg is eval'd, second quoted. + (SETQ Y (MCX-TRACE (CADR X))) + (SETQ Z (MAP-MCX-TRACE (CDDDR X))) + (COND (MCX-TRACE ()) + ((CONS (CAR X) + (CONS Y + (CONS (CADDR X) Z)))))) + ((DEFUN) + (AND (MEMQ (CAR (SETQ Y (CDDR X))) + '(EXPR FEXPR MACRO)) + (POP Y Z)) + (SETQ Y (CONS (CAR Y) + (MAP-MCX-TRACE (CDR Y)))) + (COND (MCX-TRACE ()) + (`(DEFUN ,(cadr x) + ,@(and z (list z)) + ,.y)))) + ((DECLARE COMMENT DEFPROP + FASLOAD INCLUDE UWRITE UREAD + UCLOSE UKILL UAPPEND UPROBE CRUNIT + BREAK EDIT GCTWA) + X) + (T (BARF X |Unknown FSUBR in MCX-TRACE|)))) + ('T (MAP-MCX-TRACE X)))) + ((EQ (CAAR X) 'LAMBDA) + (SETQ Y (MAP-MCX-TRACE (CDDAR X)) + Z (MAP-MCX-TRACE (CDR X))) + (COND (MCX-TRACE ()) + ('T `((LAMBDA ,(cadar x) ,.y) ,.z)))) + ('T (SETQ Y (MCX-TRACE (CAR X)) + Z (MAP-MCX-TRACE (CDR X))) + (COND (MCX-TRACE ()) + ((CONS Y Z))))))))) + + + +(COMMENT FILE-TRANSDUCERS) + +(DEFUN CMP1 (GSBSTACK) ;Transduce a file compileing those sexps which try to define functions + SYMBOLS CREADTABLE COBARRAY CMSGFILES +(LET ((SYMBOLS SYMBOLS) (READTABLE CREADTABLE) + (OBARRAY COBARRAY) (MSGFILES CMSGFILES)) + (PROG (ERRFL X NAME NAMEFORM DECLARATION-FLAGCONVERSION-TABLE FL FORM + PRATTSTACK PXHFL EOF-COMPILE-QUEUE EOF-SEEN) + (SETQ DECLARATION-FLAGCONVERSION-TABLE + '((*FEXPR . FEXPR) (*EXPR . EXPR) (*LEXPR . EXPR))) + (AND RECOMPL + (MAP '(LAMBDA (L) (AND (NOT (EQ (CAR L) (SETQ X (INTERN (CAR L))))) + (RPLACA L X))) + RECOMPL)) + (SETQ PRATTSTACK GSBSTACK) + A0 (SETQ FILEPOSIBLE (AND (NULL GSBSTACK) + (FILEP INFILE) + (MEMQ 'FILEPOS (STATUS FILEMODE INFILE)))) + A (COND (PRATTSTACK (POP PRATTSTACK FORM)) + ((OR GSBSTACK (EQ GOFOO (SETQ FORM (COMPREAD GOFOO)))) + (AND FASLPUSH LAPLL (TERFASL)) + (RETURN GOFOO))) + (AND CHOMPHOOK (MAPC '(LAMBDA (F) (FUNCALL F FORM)) CHOMPHOOK)) + B (COND ((ATOM FORM) (GO ICF)) + ((EQ (CAR FORM) 'DEFPROP) + (SETQ X (CDDR FORM) FL (CADR X) NAME (CADR FORM)) + (COND ((OR (NULL (CDR X)) (CDDR X) (NOT (SYMBOLP NAME))) + (GO GH)) + ((OR (ATOM (CAR X)) (NOT (EQ (CAAR X) 'LAMBDA))) + (GO ICF)) + ((EQ FL 'MACRO) + (CMP1-MACRO-ENLIVEN (CONS 'DEFUN + (CONS NAME + (CONS 'MACRO + (CDAR X)))) + () )) + ((ASSQ FL COMPILATION-FLAGCONVERSION-TABLE) + (SETQ FORM (CONS 'DEFUN + (CONS NAME + (CONS FL + (CDAR X))))) + (GO B)) + ((AND (SETQ X (GETL NAME '(*EXPR *FEXPR *LEXPR))) + (NOT (EQ FL (CDR (ASSQ (CAR X) DECLARATION-FLAGCONVERSION-TABLE))))) + (WRNTYP NAME) + (PUTPROP NAME 'T (CAAR (MEMASSQR FL DECLARATION-FLAGCONVERSION-TABLE))))) + (GO ICF)) + ((EQ (CAR FORM) 'DEFUN) + (AND (OR (NULL (CDR FORM)) (NULL (CDDR FORM)) (NULL (CDDDR FORM))) + (GO GH)) + (COND ((SYMBOLP (SETQ NAME (CADR FORM))) (SETQ NAMEFORM () )) + ((ATOM NAME) (GO GH)) + ('T (SETQ NAME (CAR (SETQ NAMEFORM NAME))) + (AND (COND ((NOT (SYMBOLP NAME))) + ((NULL (CDR NAMEFORM))) + ((NOT (SYMBOLP (CADR NAMEFORM)))) + ((NULL (CDDR NAMEFORM)) ()) + ((NOT (SYMBOLP (CADDR NAMEFORM))))) + (GO GH)))) + (AND (NOT (MEMQ (SETQ FL (CADDR FORM)) '(FEXPR EXPR MACRO))) + (SETQ FORM (CONS 'DEFUN + (CONS (OR NAMEFORM NAME) + (CONS (SETQ FL 'EXPR) + (CDDR FORM)))))) + (AND (NULL (CDDDDR FORM)) (GO GH)) + (COND ((ATOM (SETQ X (NTH 3 FORM)))) + ((OR (MEMQ '&OPTIONAL X) + (MEMQ '&REST X) + (MEMQ '&AUX X) + (MEMQ '&RESTV X) + (MEMQ '&RESTL X) + (DO L X (CDR L) (NULL L) + (AND (NOT (SYMBOLP (CAR L))) + (RETURN 'T)))) + (SETQ FORM (CONS 'DEFUN& (CDR FORM))) + (GO B))) + (AND NAMEFORM + (EQ (CADR NAMEFORM) 'MACRO) + (CMP1-MACRO-ENLIVEN (CONS 'DEFUN + (CONS NAME + (CONS 'MACRO + (CDDDR FORM)))) + () )) + (COND ((AND (NULL NAMEFORM) (EQ FL 'MACRO)) + (CMP1-MACRO-ENLIVEN FORM 'T)) + ((AND RECOMPL (NOT (MEMQ NAME RECOMPL)))) + ((ASSQ FL COMPILATION-FLAGCONVERSION-TABLE) + (SETQ UNDFUNS (DELQ NAME UNDFUNS)) + (SETQ LAP-INSIGNIF () ) + (SETQ PXHFL 'T) + (COND ((NULL NAMEFORM) (SETQ NAMEFORM NAME)) + ((NOT (ATOM NAMEFORM)) + (COND ((NULL (CDDR NAMEFORM)) + (SETQ NAME (PNAMECONC (CAR NAMEFORM) + '/ + (CADR NAMEFORM))) + (ICOUTPUT (LIST 'DEFPROP + (CAR NAMEFORM) + NAME + (CADR NAMEFORM))) + (SETQ NAMEFORM NAME)) + ('T (SETQ PXHFL () ))) )) + (AND EXPR-HASH + PXHFL + (ICOUTPUT (LIST 'DEFPROP + NAME + (SXHASH (CONS 'LAMBDA (CDDDR FORM))) + 'EXPR-HASH))) + #%(LET ((COMPILER-STATE 'COMPILE) (^W ^W) (^R ^R)) + (COMPILE NAMEFORM + FL + (CONS 'LAMBDA (CDDDR FORM)) + INFILE + () ) + (COND (TTYNOTES + (SETQ ^W (SETQ ^R () )) + (LET ((TTN-FUN (GET (IF (ATOM NAMEFORM) + NAMEFORM + (CAR NAMEFORM)) + 'TTYNOTES-FUNCTION))) + (AND TTN-FUN + (SETQ NAMEFORM + (FUNCALL TTN-FUN NAMEFORM)))) + (COND (NAMEFORM + (INDENT-TO-INSTACK 0) + (PRIN1 NAMEFORM) + (PRINC '| Compiled|))))) + (SETQ ^W (SETQ ^R 'T)) + (COND (FASLPUSH (AND LAPLL (TERFASL))) + ('T (TYO #\FORMFEED ))) + (COND ((AND TTYNOTES NAMEFORM) + (SETQ ^W (SETQ ^R () )) + (IF FASLPUSH + (PRINC '| and assembled |) + (TYO #\SPACE ))))) + (GO A)) + ('T (GO ICF) )) + (AND RECOMPL (GO A))) + ((COND ((AND (EQ (CAR FORM) 'ARRAY) (SETQ NAME (CADR FORM))) + (MEMQ (SETQ FL (CADDR FORM)) '(T () FIXNUM FLONUM OBARRAY))) + ((AND (EQ (CAR FORM) '*ARRAY) + (P1EQQTE (CADR FORM)) + (SETQ NAME (CADADR FORM)) + (COND ((MEMQ (SETQ FL (CADDR FORM)) '(T () ))) + ((P1EQQTE FL) + (MEMQ (SETQ FL (CADR FL)) + '(T () FIXNUM FLONUM OBARRAY READTABLE))))))) + (AND (NOT (MEMQ FL '(FIXNUM FLONUM))) (SETQ FL 'NOTYPE)) + (SETQ X (DO ((L (CDDDR FORM) (CDR L)) (Z) (T1)) + ((NULL L) (LIST (CONS NAME (NREVERSE Z)))) + (COND ((OR (FIXP (SETQ T1 (CAR L))) + (AND (P1EQQTE T1) (FIXP (SETQ T1 (CADR T1))))) + (PUSH T1 Z)) + ('T (RETURN (LIST NAME (LENGTH (CDDDR FORM)))) )))) + (COND ((GET NAME '*ARRAY) + (PUTPROP NAME () '*ARRAY) ;To prevent spurious re-declared msgs + ((LAMBDA (T1) (AND (COND (T1 (PUTPROP NAME () 'NUMFUN) + (COND ((CADR T1) (NOT (EQ (CADR T1) FL))) + ((NOT (EQ FL 'NOTYPE))))) + ((NOT (EQ FL 'NOTYPE)))) + (PUTPROP NAME '(() () ) 'NUMFUN))) + (GET NAME 'NUMFUN)))) + (AR*1 (CONS FL X)) + (SETQ LAP-INSIGNIF () ) + (COUTPUT FORM)) + ((MEMQ (CAR FORM) '(DECLARE EVAL-WHEN)) + (SETQ X INFILE) + (LET ((COMPILER-STATE COMPILER-STATE) LOADP EVALP (L FORM)) + (AND (COND ((EQ (CAR FORM) 'DECLARE) + (SETQ EVALP 'T COMPILER-STATE 'DECLARE) + 'T) + ((PROG2 (SETQ L (CDR L)) + (MEMQ COMPILER-STATE '(MAKLAP COMPILE DECLARE))) + (SETQ LOADP (MEMQ 'LOAD (CAR L)) + EVALP (MEMQ 'COMPILE (CAR L))) + (OR EVALP LOADP)) + ;This allows for COMPILER-STATE to be () and TOPLEVEL + ((SETQ EVALP (MEMQ 'EVAL (CAR L))))) + (PROGN (AND EVALP + (ATOM (ERRSET (MAPC 'EVAL (CDR L)) 'T)) + (PDERR (COND ((NULL FILEPOSIBLE) FORM) + (`(,form (,fileposible = BEGINNING FILEPOS)))) + |Evaluation loses due to some error|)) + (AND LOADP + (SETQ PRATTSTACK + (APPEND (CDR L) PRATTSTACK))) ))) + (COND ((NOT (EQ INFILE X)) + (MAPC '(LAMBDA (DATA) + (AND (FILEP DATA) + (SETQ X (CAR (STATUS FILEM DATA))) + (EQ (CAR X) 'IN) (EQ (CADR X) 'ASCII) + (NOT (EQ (CADDR X) 'TTY)) + (EOFFN DATA 'COEFN))) + (CONS INFILE INSTACK)))) + (GO A0)) + ((COND (#%(SAILP) (MEMQ (CAR FORM) '(INCLUDE INCLUDEF REQUIRE))) + ((MEMQ (CAR FORM) '(INCLUDE INCLUDEF)))) + (cond ((eq (car form) 'includef) + (setq form `(include ,(eval (cadr form)))))) + (SETQ X INSTACK FL () ) + (AND (NOT (PROBEF (COND ((CDDR FORM) (CDR FORM)) + ((CADR FORM))))) + (DBARF (CDR FORM) |File for INCLUDEsion is missing|)) + (ERRSET (SETQ FL (EVAL FORM)) 'T) ;Try to "include" file + (COND (TTYNOTES + (PROG (^W ^R) + (INDENT-TO-INSTACK 1) + (PRINC (COND (FL '|;Including file |) + ('T '|;Failure to include file |))) + (PRIN1 (TRUENAME FL))))) + (COND (FL (EOFFN FL 'COEFN)) + ('T (AND (NOT (EQ X INSTACK)) (INPUSH -1)) + (PDERR FORM |File not included|))) + (GO A)) + ((EQ (CAR FORM) 'CGOL) (CGOL)) + ((EQ (CAR FORM) 'LAP) + (CMP-LAPFUN (CDR FORM)) + (COND ((AND RECOMPL (NOT (MEMQ (CADR FORM) RECOMPL))) + (ZAP2NIL FORM () )) + (FASLPUSH (AND LAPLL (TERFASL)) + (FASLIFY FORM 'LAP)) ;Hack the LAP code + ('T (ZAP2NIL FORM 'T) + (AND TTYNOTES ((LAMBDA (^R ^W) + (PRINT (CADR FORM)) + (PRINC '|LAP code zapped |)) + () () )))) ) + ((AND (EQ (CAR FORM) 'LAP-A-LIST) + (NOT (ATOM (CADR FORM))) + (EQ (CAADR FORM) 'QUOTE) + (SETQ X (CADADR FORM)) + (NOT (ATOM (CAR X))) + (EQ (CAAR X) 'LAP)) + (CMP-LAPFUN (CDAR X)) + (COND ((OR (NOT FASLPUSH) + (AND RECOMPL (NOT (MEMQ (CADAR X) RECOMPL)))) + (ICOUTPUT GOFOO) + (ICOUTPUT FORM)) + ('T (AND LAPLL (TERFASL)) + (FASLIFY X 'LIST)))) + ((AND (EQ (CAR FORM) 'PROGN) ;(PROGN 'COMPILE . . .) + (NOT (ATOM (CADR FORM))) + (EQ (CAADR FORM) 'QUOTE) + (EQ (CADADR FORM) 'COMPILE)) + (SETQ PRATTSTACK (APPEND (CDDR FORM) PRATTSTACK)) + (GO A)) + ((COND ((OR (NOT FORM) (NOT (SYMBOLP (CAR FORM)))) () ) + ((GET (CAR FORM) 'MACRO)) + ((AND (GET (CAR FORM) 'AUTOLOAD) + (NOT (GETL (CAR FORM) '(SUBR FSUBR LSUBR EXPR FEXPR))) + (OR (NULL (SETQ FL (GET (CAR FORM) 'FUNTYP-INFO))) + (EQ (CAR FL) 'MACRO))) + (FUNCALL AUTOLOAD (CONS (CAR FORM) (GET (CAR FORM) 'AUTOLOAD))) + (GET (CAR FORM) 'MACRO))) + (SETQ FL () ) + (COND ((OR (NULL (ERRSET (SETQ FORM (MACROEXPAND FORM) + FL 'T ) + 'T)) + (NULL FL)) + (PDERR (COND ((NULL FILEPOSIBLE) FORM) + (`(,form (,fileposible = BEGINNING FILEPOS)))) + |Error during top level MACRO expansion|) + (GO A))) + (GO B) ) ;Apply macro property and try again + ((NOT RECOMPL) + (SETQ LAP-INSIGNIF () ) + (ICOUTPUT GOFOO) + (COUTPUT FORM) + (AND (EQ (CAR FORM) 'COMMENT) LAPLL (TERFASL)) )) + (AND (NOT FASLPUSH) (ICOUTPUT GOFOO)) + (GO A) + + ICF (SETQ LAP-INSIGNIF () ) + (ICOUTPUT FORM) + (AND (NOT FASLPUSH) (PROG2 (ICOUTPUT NULFU) (ICOUTPUT GOFOO))) + (GO A) + + GH (DBARF FORM |Illegal DEFUN format| 4 4) ))) + +;; COMPREAD reads forms from INFILE until there are none, then from +;; EOF-COMPILE-QUEUE until there are none, and then returns its argument. +;; EOF-COMPILE-QUEUE can be added to by the user as "things to compile after +;; everything else in the file. It uses EOF-SEEN to keep track of whether or +;; not it has seen the end of the file or not, to avoid reading a closed file. + +(DEFUN COMPREAD (eof-val) + (LET ((form eof-val)) + (COND ((AND (OR EOF-SEEN ;If EOF or newly EOF, and stuff is on + (EQ eof-val ;the EOF-COMPILE-QUEUE, compile it + (SETQ FORM (COND (EOF-SEEN eof-val) + (READ (FUNCALL READ eof-val)) + ('T (AND FILEPOSIBLE + (SETQ FILEPOSIBLE + (FILEPOS INFILE))) + (READ eof-val)))))) + EOF-COMPILE-QUEUE) + (SETQ EOF-SEEN T) ;We've seen the end, don't read past it! + (SETQ EOF-COMPILE-QUEUE (NREVERSE EOF-COMPILE-QUEUE)) + (POP EOF-COMPILE-QUEUE FORM) + (SETQ EOF-COMPILE-QUEUE (NREVERSE EOF-COMPILE-QUEUE)) + form) + ((OR EOF-SEEN (EQ form eof-val)) eof-val) + (T form)))) + + +(eval-when (eval load) + (cond ((alphalessp (status lispv) '/2025) + (putprop 'OLD-+INTERNAL-/"-MACRO + (get '+INTERNAL-/"-MACRO 'subr) + 'subr) + (defun +INTERNAL-/"-MACRO () + ((lambda (x) + (putprop x 'T '+INTERNAL-STRING-MARKER) + (putprop x `(SPECIAL ,string) 'SPECIAL) + string) + (OLD-+INTERNAL-/"-MACRO))))) +) + + + +(DEFUN CMP1-MACRO-ENLIVEN (FORM FL) +;;; Expects input to be of form "(DEFUN name MACRO (var) . body)" + ((LAMBDA (NAME) + (COND ((NULL MACROS)) + ((NOT FL)) + ('T (ICOUTPUT FORM) + (SETQ LAP-INSIGNIF () ) )) + (COND ((LAND '(EXPR FEXPR SUBR FSUBR LSUBR AUTOLOAD) + (STATUS SYSTEM NAME)) + (OR (GET NAME 'SKIP-WARNING) + (WARN (cond ((filep infile) + `(,name FROM USER FILE ,infile)) + (name)) + |being redefined as a MACRO -- definition is pushed onto MACROLIST|)) + (PUSH (CONS NAME (CONS 'LAMBDA (CDDDR FORM))) MACROLIST)) + ('T (EVAL FORM)))) + (CADR FORM))) + + +(DEFUN TERFASL () + (FASLIFY (NREVERSE (PROG2 () LAPLL (SETQ LAPLL () ))) + 'LIST)) + +(DEFUN COEFN (FIL EOFVAL) ;Standard EOFFN for main + (AND (EQ FIL INFILE) (INPUSH -1)) ; input source file + (COND (TTYNOTES ;Pop file off stack + (PROG (^W ^R) + (INDENT-TO-INSTACK 0) + (PRINC '|;End Of File |) + (PRIN1 (NAMESTRING (TRUENAME FIL)))))) + (AND (FILEP FIL) (CLOSE FIL)) ;Close file. If more is on + (COND (INSTACK 'T) ; stack, keep reading; + ('T EOFVAL))) ; otherwise we have a real EOF + + +(DEFUN CHMP2 (L FILE) ;"CHOMP"ing also to a file + (AND (NOT (GET 'FASL-START 'SUBR)) + (DBARF () |Cant CHOMP to file without FASLOAD|)) + (FASL-START FILE () ) + (LAP-FILE-MSG (CONS '|##IN-CORE-FUNCTIONS##| L) + (CONS TYO UFFIL)) + (MAPC '(LAMBDA (X) (CHMP1 X) (FASLIFY LAPLL 'LIST)) + L) + (FASL-CLOSEOUT FILE '((|##IN-CORE-FUNCTIONS##|)) FILE)) + + +(DEFUN CMP-LAPFUN (X) + #%(LET ((TYPE (CDR (ASSQ (CADR X) '((SUBR . *EXPR) + (FSUBR . *FEXPR) + (LSUBR . *LEXPR))))) + (PROP (GETL (CAR X) '(*EXPR *FEXPR *LEXPR)))) + (SETQ LAP-INSIGNIF () + TOPFN (CAR X) ) + (COND ((AND PROP (NOT (EQ (CAR PROP) TYPE))) + (WRNTYP (CAR X))) + (TYPE (SETQ UNDFUNS (DELQ (CAR X) UNDFUNS)) + (PUTPROP (CAR X) 'T TYPE))))) + + +(DEFUN INDENT-TO-INSTACK (II) ;TERPRI and indent proportional to length of INSTACK + (TERPRI) + (DO ((N (- (LENGTH INSTACK) II 2) (1- N))) + ((MINUSP N)) + (PRINC '| |))) + +(DEFUN PRINT-LINEND (X FLAG) + (COND (FLAG (PRIN1 X)) ((PRINC X))) + (PRINC '|/) |) + (TERPRI) + 'T) + +(DEFUN LAP-FILE-MSG (REALI L) + #%(LET ((TERPRI 'T) (OUTFILES L) TEM) + (SETQ TEM (STATUS DATE)) + (SETQ ^W (SETQ ^R 'T)) + (COND (FASLPUSH (UNFASL-MSG REALI)) + ('T (TERPRI) + (PRINC '|'(THIS IS THE LAP FOR |) + (PRINT-LINEND REALI 'T))) + (PRINC '|'(COMPILED BY LISP COMPILER //|) + (PRINC COMPLRVERNO) + (PRINC '| COMAUX //|) (PRINC COMAUXVERNO) + (PRINC '| PHAS1 //|) (PRINC PHAS1VERNO) + (PRINC '| MAKLAP //|) (PRINC MAKLAPVERNO) + (PRINC '| INITIA //|) (PRINT-LINEND INITIAVERNO () ) + (COND (TEM #%(LET ((BASE 10.) (*NOPOINT 'T) (APM 'AM) (II 0)) + (TERPRI) + (PRINC '|;COMPILED ON |) + (COND ((AND #%(ITSP) (SETQ APM (STATUS DOW))) + (PRINC APM) + (SETQ APM 'AM) + (PRINC '|, |))) + (PRINC (CAR #%(NCDR '(JANUARY FEBRUARY MARCH APRIL MAY + JUNE JULY AUGUST SEPTEMBER + OCTOBER NOVEMBER DECEMBER) + (1- (CADR TEM))))) + (PRINC '| |) + (PRINC (CADDR TEM)) + (PRINC '|, |) + (PRINC (+ 1900. (CAR TEM))) + (COND ((SETQ TEM (STATUS DAYTIME)) + (PRINC '|, AT |) + (SETQ II (CAR TEM)) + (COND ((ZEROP II) + (AND (= (CADR TEM) 0) + (SETQ APM 'MIDNITE)) + (PRINC '/12)) + ((= II 12.) + (SETQ APM (COND ((= (CADR TEM) 0) + 'NOON) + ('PM))) + (PRINC '/12)) + ('T (AND (> II 12.) + (SETQ APM 'PM II (- II 12.))) + (PRINC II))) + (COND ((< (CADR TEM) 10.) (PRINC '/:/0)) + ('T (PRINC '/:))) + (PRINC (CADR TEM)) + (PRINC '/ ) + (PRINC APM))) + (TERPRI)))) + (SETQ LAP-INSIGNIF 'T))) + +(DEFUN MAKLAP FEXPR (L) + (COND (FILESCLOSEP (SETQ CMSGFILES () ) (GC) (SETQ FILESCLOSEP () ))) +#%(LET ((EOC-EVAL EOC-EVAL) (RECOMPL RECOMPL) (LINEL 120.) (READ READ) (*LOC 0) + (OCMSGFILES CMSGFILES) (IMOSAR IMOSAR) (INFILE 'T) (FILOC 0) (LITLOC 0)) + (PROG (BRKC LINE INMLS ONMLS JCLP REALI FSLNL DEFAULT-NAMELIST DEF2N TOPFN + SWITCHLIST OPNDP FASLERR COMPILER-STATE LAP-INSIGNIF CURRENTFNSYMS + CURRENTFN MAINSYMPDL UNFASLSIGNIF ENTRYNAMES ALLATOMS FBARP START-LINE + SYMPDL ATOMINDEX DDTSYMP SYMBOLSP LITERALS NOC F-NOC TEM OUTFILES + INSTACK FILEPOSIBLE UFFIL CMSGFILES FASLPUSH ^W ^Q ^R ) + B0 (SETQ UNDFUNS () COMPILER-STATE 'MAKLAP FSLNL () + REALI () FASLPUSH () LAP-INSIGNIF 'T FASLERR () + CMSGFILES OCMSGFILES F-NOC () ) + B (SETQ ^W (SETQ ^R (SETQ ^Q () ))) + (SETQ SWITCHLIST () INMLS () ) + (SETQ DEFAULT-NAMELIST (CONS (LIST 'DSK (STATUS UDIR)) + (CONS '* (COND (#%(ITSP) '(>) ) + (#%(SAILP) '(|___|) ) + ('(LSP) ))))) + (COND ((NULL L) ;Normal case + (TERPRI) + (PRINC '|_| TYO) + (AND (NUMBERP (SETQ TEM (READLINE TYI 0))) (GO B)) + (SETQ LINE (EXPLODEN TEM))) + ((AND (CAR L) (ATOM (CAR L))) ;Compilation begun from JCL + (SETQ JCLP 'T LINE L L () )) + ('T (AND TTYNOTES (NOT DISOWNED) (TERPRI)) ;JPG's case + (SETQ DEF2N (FASL-LAP-P)) + (COND ((CDR L) + (SETQ ONMLS (LIST (MERGEF (MERGEF (CAR L) DEF2N) + DEFAULT-NAMELIST)) + INMLS (MAPCAR 'NAMELIST (CDR L))) + (MAKLAP-MERGEF + INMLS + (COND ((EQ MAKLAP-DEFAULTF-STYLE 'MIDAS) + (MERGEF (CDR DEFAULT-NAMELIST) + (CAR (LAST ONMLS)))) + (DEFAULT-NAMELIST)))) + ((SETQ INMLS (LIST (MERGEF (CAR L) DEFAULT-NAMELIST)) + ONMLS (LIST (MERGEF DEF2N (CAR INMLS)))))) + (GO A))) + (AND (= (CAR LINE) #/( ) (PUSH #/ LINE)) + ;; Position START-LINE for switch parsing + (SETQ START-LINE (DO L LINE (CDR L) (NULL (CDR L)) + (COND ((OR (= (CADR L) #/) (= (CADR L) #//)) + (POP L)) + ((= (CADR L) #/( ) (RETURN L))))) + (AND (NULL START-LINE) (GO A0)) + (DO ( (OBARRAY SOBARRAY) (PARITY 'T) + (L (CDR START-LINE) (CDR L)) ) + ((NULL L)) + (COND ((= (CAR L) #/) ) ;right parens + (RPLACD START-LINE (CDR L)) ;cuts out chars for switches + (RETURN () )) + ((NOT (> (CAR L) #/ ))) ;ignore space and tab + ((OR (= (CAR L) #/I) (= (CAR L) #/i)) ;Upper and lower case I + (PUSH + (COND ((= (CADR L) #/[) ;Aha!, a "[" + (POP L) + (DO ((Z)) + ((OR (NULL L) (= (CAR L) #/])) ; so look for "]" + (MAKNAM (NREVERSE Z))) + (PUSH (POP L) Z))) + ('(T))) + INITIALIZE) + (SETQ PARITY 'T)) + ((= (CAR L) #/-) (SETQ PARITY () )) ;- means set to () + ((DO ((C (COND ((AND (NOT (< (CAR L) #/a)) + (NOT (> (CAR L) #/z))) + (- (CAR L) #.(- #/a #/A))) + ('T (CAR L)))) + (SWS SWITCHTABLE (CDR SWS))) + ((NULL SWS) () ) + (COND ((= C (GETCHARN (CAAR SWS) 1)) + (PUSH (LIST (CADAR SWS) PARITY) SWITCHLIST) + (RETURN 'T)))) + (SETQ PARITY 'T )))) + (AND (NULL INITIALIZE) (NULL SWITCHLIST) (GO IIS)) + ; Create file names from input line characters and do filename defaulting + A0 (SETQ DEF2N (FASL-LAP-P)) + ;;YOU LOSER! howcome the function which actually activates the + ;; switches in the switchlist is called FASL-LAP-P? + (AND JCLP (NOT TTYNOTES) (SSTATUS FEATURE NOLDMSG)) + (AND (OR (NULL LINE) (= (CAR LINE) #/_) (= (CAR LINE) #/,)) + (GO IIS)) + (SETQ START-LINE LINE BRKC () ) ;scan to "_" or end + (DO ( (L LINE (CDR L)) ) + ( (OR (NULL (CDR L)) (= (CADR L) #/_)) + (SETQ BRKC (CADR L) LINE (CDDR L)) + (RPLACD L () ))) + (COND ((NULL LINE) + (SETQ INMLS (RDSYL START-LINE DEFAULT-NAMELIST) + ONMLS (LIST (MERGEF DEF2N (CAR INMLS))))) + ('T (SETQ ONMLS (RDSYL START-LINE (CONS (CAR DEFAULT-NAMELIST) + DEF2N))) + (AND (OR (NULL BRKC) + (NULL LINE) + (= (CAR LINE) #/_) + (= (CAR LINE) #/,)) + (GO IIS)) + (SETQ START-LINE LINE BRKC () ) ;scan to "_" or end + (DO ( (L LINE (CDR L)) ) + ( (OR (NULL (CDR L)) (= (CADR L) #/_)) + (SETQ BRKC (CADR L) LINE (CDDR L)) + (RPLACD L () ))) + (AND (OR BRKC LINE) (GO IIS)) + (SETQ INMLS (RDSYL START-LINE + (COND ((EQ MAKLAP-DEFAULTF-STYLE 'MIDAS) + (MERGEF (CDR DEFAULT-NAMELIST) + (CAR (LAST ONMLS)))) + (DEFAULT-NAMELIST)) )) + (AND (EQ MAKLAP-DEFAULTF-STYLE 'MIDAS) + (EQ (CADAR ONMLS) '*) + (MAKLAP-MERGEF ONMLS (CAR INMLS))))) + (AND (OR (OR (NULL INMLS) (EQ (CADAR INMLS) '*)) + (OR (NULL ONMLS) (EQ (CADAR ONMLS) '*))) + (GO IIS)) + A (SETQ FASLPUSH (AND (NOT ASSEMBLE) NOLAP)) + (SETQ FILESCLOSEP 'T) + (SETQ REALI (ERRSET (EOPEN (COND (#%(SAILP) (UGREAT1 (CAR INMLS))) + ((CAR INMLS))) + 'IN) + () )) + (COND (REALI + (SETQ REALI (TRUENAME (INPUSH (CAR REALI)))) + ((LAMBDA (BASE *NOPOINT) + (SETQ GENPREFIX + (NCONC (COND ((OR #%(SAILP) #%(DEC10P)) + (NCONC (LIST '/[) + (EXPLODEC (CAR (CADAR REALI))) + (LIST '/,) + (EXPLODEC (CADR (CADAR REALI))) + (LIST '/]))) + (#%(DEC20P) + (NCONC (LIST '/<) + (EXPLODEC (CADAR REALI)) + (LIST '/>))) + ('T (NCONC (EXPLODEC (CADAR REALI)) (LIST '/;)))) + (EXPLODEC (CADR REALI)) + (LIST (COND (#%(ITSP) '/ ) ('/.))) + (EXPLODEC (CADDR REALI)) + '(/_)))) + 10. 'T)) + ((AND L (NOT JCLP)) (RETURN () )) + ('T (PRIN1 (CAR INMLS)) + (PRINC '| File Not Found - MAKLAP|) + (GO B0))) + (COND ((AND JCLP (OR TTYNOTES YESWARNTTY)) () ) + ((OR DISOWNED JCLP) (GIVUPTTY))) + (COND (ASSEMBLE (FASL-A-FILE (CAR ONMLS) INMLS) + (AND NOLAP + (NOT (MEMBER (CAR ONMLS) INMLS)) + (MAPC 'FASL-DELETEF INMLS)) + (GO ENDUP))) + (COND (FASLPUSH (FASL-START (SETQ FSLNL (CAR ONMLS)) () )) + ('T (POP ONMLS TEM) + (AND FASL (SETQ FSLNL TEM)) + (LAPOP TEM))) + (AND (OR YESWARNTTY TTYNOTES) + (NOT (MEMQ TYO CMSGFILES)) + (PUSH TYO CMSGFILES)) + (SETQ OPNDP 'T) + D2 (COND ((NULL (CAR INMLS)) (WARN () |Phooey on JPG - MAKLAP|) (GO ENDUP))) + (SETQ NOC () ) + (COND (OPNDP (SETQ OPNDP ()) + (COND (#%(SAILP) + (EOPEN INFILE 'IN))) + (SETQ REALI (LIST REALI))) + ('T (APPLY 'EREAD (CAR INMLS)) + (SETQ FILEPOSIBLE + (AND (FILEP UREAD) + (MEMQ 'FILEPOS (STATUS FILEMODE UREAD)) + '0)) + (PUSH (NAMELIST UREAD) REALI))) + (AND TTYNOTES + (PROG (^R ^W) + (TERPRI) + (PRINC '|Compilation begun on |) + (PRIN1 (CAR REALI)) + (PRINC '| |))) + (LAP-FILE-MSG (CAR REALI) (COND (FASLPUSH UFFIL) ;Sets LAP-INSIGNIF to T + ('T (CONS LAPOF UFFIL)))) ; as well as ^R ^W + + (SETQ ^Q 'T) + C (SETQ TOPFN () + TEM (COND ((OR (NOT (FILEP INFILE)) + (NULL (STATUS FILEMODE INFILE))) + CLPROGN) + ((ERRSET (CMP1 () ) 'T)))) + (COND ((ATOM TEM) + (AND (EQ TEM 'FASLAP) (SETQ FASLERR 'T)) + (COND (FASLPUSH) + ('T (PRINC '| () | LAPOF))) + (AND TOPFN (SETQ NOC (CONS TOPFN NOC))) ;NOC accumulates function names that cop out + (COND ((NULL TEM) + #%(WARN `((TOPFN ,topfn) + ,(cond ((null fileposible) '(CLOSED FILEPOS)) + (`(,fileposible = BEGINNING FILEPOS)))) + |Lisp Error during file compilation|) + (MSOUT-BRK () COBARRAY CREADTABLE 'LISP-ERROR) + (GO C)) + ((EQ TEM GOFOO) + #%(DBARF `((INFILE ,infile) + ,(cond ((null fileposible) '(CLOSED FILEPOS)) + (`(,fileposible = BEGINNING FILEPOS)))) + |EOF encountered during READ, + possibly misbalanced paresn?|)) + ('T (GO C))) )) + (SETQ TOPFN () ) + (COND (NOC + (SETQ NOC (NREVERSE NOC)) + (SETQ F-NOC (NCONC F-NOC (APPEND NOC () ))) + #%(WARN NOC |- Failed to compile|))) + (COND ((SETQ INMLS (CDR INMLS)) (GO D2))) + (COND (UNDFUNS #%(WARN UNDFUNS |have been used but remain undefined in this file|))) + (SETQ REALI (NREVERSE REALI)) + (AND TTYNOTES + (PROG (^Q ^R ^W) + (TERPRI) + (PRINT (COND ((CDR REALI) REALI) ((CAR REALI)))) + (PRINC '| Finished compilation|) + (COND (F-NOC (PRINC '|, but |) + (PRIN1 F-NOC) + (PRINC '| Failed to compile|))) + (PRINC '| |) )) + (COND (FASLERR + #%(WARN () |/ + **ERROR** FASL file aborted due to errors during FASLAP|) + (AND FASLPUSH (FASL-CLOSEOUT () () FSLNL))) + (FASLPUSH + (FASL-CLOSEOUT (CAR ONMLS) + (AND (NOT LAP-INSIGNIF) REALI) + FSLNL)) + ('T (LAPCL (CAR ONMLS)) + (SETQ ONMLS (NREVERSE ONMLS)) + (AND FSLNL (FASL-A-FILE FSLNL ONMLS)))) + (AND (FILEP INFILE) (CLOSE INFILE)) + (SETQ FILESCLOSEP () ) + ENDUP (MAPC 'EVAL EOC-EVAL) + (AND (OR JCLP DISOWNED) (QUIT)) + EXIT (AND L (RETURN () )) + (GO B0) + IIS (PRINC '|INCORRECT COMMAND SYNTAX - MAKLAP|) (GO EXIT) ))) + + +(DEFUN FASL-LAP-P () + (AND INITIALIZE + (MAPC '(LAMBDA (X) (COND ((SYMBOLP X) (ELOAD X)) + ('T (INITIALIZE)))) + INITIALIZE)) + (MAPC 'SETQ SWITCHLIST) + (COND ((OR ASSEMBLE NOLAP FASL) '(* FASL)) + ('(* LAP)))) + ;Returns "LAP" iff this run is compile-only + +;;; HOW TO DISOWN FROM A ^B BREAK +(DEFUN DISOWN FEXPR (X) (SETQ DISOWNED 'T) (GIVUPTTY) (*THROW 'BREAK X)) + +(DEFUN GIVUPTTY () + (SETQ GAG-ERRBREAKS (SETQ ^W 'T) TTYNOTES () YESWARNTTY () ) + (SSTATUS FEATURE NOLDM) + (AND (MEMQ TYO CMSGFILES) + (SETQ CMSGFILES (DELQ TYO (APPEND CMSGFILES () )))) + (AND (MEMQ TYO MSGFILES) + (SETQ MSGFILES (DELQ TYO (APPEND MSGFILES () )))) + (AND (STATUS TTY) + (EQ (STATUS OPSYSTEM-TYPE) 'ITS) + (STATUS HACTRN) + (VALRET (COND (DISOWNED '|:PROCED :DISOWN |) ('|:PROCED |)))) + (AND RUNTIME-LIMITP + (NUMBERP RUNTIME-LIMIT) + (> (SETQ RUNTIME-LIMIT (FLOAT RUNTIME-LIMIT)) 2.0) + (SETQ ALARMCLOCK 'STOP-RUNAWAYS) + (ALARMCLOCK 'RUNTIME RUNTIME-LIMIT))) + +(DEFUN STOP-RUNAWAYS (()) + (MSOUT-BRK RUNTIME-LIMIT COBARRAY CREADTABLE 'RUNTIME-LIMITP)) + + +;; SPLITFILE/EOF-COMPILE-QUEUE/PRATTSTACK interaction works as follows. +;; If there are no forms on EOF-COMPILE-QUEUE, the SPLITFILE splits the file. +;; Otherwise, a call to SPLITFILE is put onto the PRATTSTACK so we get called +;; again, and one form from the EOF-COMPILE-QUEUE is pushed onto the PRATTSTACK +;; to be run. We will be re-called with the same argument when the PRATTSTACK +;; is popped down to the (DECLARE (SPLITFILE ...)) we pushed. +;; Once the new splitfile has been done, the forms on SPLITFILE-HOOK are +;; compiled in reverse order, as if withing a (PROGN 'COMPILE ...) + +(DEFUN SPLITFILE FEXPR (L) + (cond (EOF-COMPILE-QUEUE + (PUSH `(DECLARE (SPLITFILE ,@L)) PRATTSTACK) + (PUSH (CAR (LAST EOF-COMPILE-QUEUE)) PRATTSTACK) + (SETQ EOF-COMPILE-QUEUE (DELQ (CAR PRATTSTACK) EOF-COMPILE-QUEUE))) + (T + (COND ((OR ASSEMBLE (NULL L) (CDR L)) + (PUSH 'SPLITFILE L) + (COND (ASSEMBLE + (PDERR L |SPLITFILE not yet implemented for A switch|)) + ((PDERR L |Lose lose - SPLITFILE|))))) + (SETQ L (LIST (CAAR ONMLS) (CAR L) (CADDAR ONMLS))) + (COND (FASLPUSH + (FASL-CLOSEOUT (CAR ONMLS) + (COND (LAP-INSIGNIF (POP ONMLS) () ) + ;() FLUSHES NULL FASL FILE + ('T (TERFASL) (CAR ONMLS))) + () ) ;Dont close unfasl file + (FASL-START L 'T) ;but do continue it + (UNFASL-MSG L) + (PUSH L ONMLS)) + ('T (LAPCL (CAR ONMLS)) ;SETS LAP-INSIGNIF TO T + (COND (LAP-INSIGNIF ; AS WELL AS ^R ^W + (FASL-DELETEF (CAR ONMLS)) + (POP ONMLS))) + (LAP-FILE-MSG (LAPOP L) (LIST LAPOF)))) + (SETQ PRATTSTACK (REVERSE SPLITFILE-HOOK)) + (SETQ SPLITFILE-HOOK ())))) + +(SETQ SPLITFILE-HOOK ()) + +(DEFUN LAPCL (F) + (SETQ CMSGFILES (DELQ LAPOF CMSGFILES)) + (SETQ OUTFILES (DELQ LAPOF OUTFILES)) + (COND (F (AND (PROBEF F) (FASL-DELETEF F)) + (AND (FILEP LAPOF) (FASL-RENAMEF LAPOF F)))) + (AND (FILEP LAPOF) (CLOSE LAPOF)) + F) + +(DEFUN LAPOP (F) + (SETQ F (MERGEF '((DSK *) * LAP) F)) + (SETQ LAPOF (EOPEN (MERGEF '(* _LAP_) F) 'OUT)) + (LINEL LAPOF 80.) + (PUSH LAPOF OUTFILES) + (PUSH LAPOF CMSGFILES) + (PUSH F ONMLS) + F) + + +(DEFUN RDSYL (L DF) + (PROG (LL BRAKP ANS CH) + (SETQ DF (MERGEF DF '((* *) * *))) + AA (SETQ LL (SETQ BRAKP () )) + A (SETQ CH (OR (CAR L) #/_)) + (COND ((OR (= CH #/) (= CH #//)) ;"/", "" + (POP L) + (SETQ CH (CAR L))) + ((AND (= CH #/[) (NOT #%(ITSP))) ;"[" + (SETQ BRAKP 'T)) + ((AND (= CH #/]) (NOT #%(ITSP))) (SETQ BRAKP () )) ;"]" + ((OR (= CH #/( ) (= CH #/) )) (RETURN () )) ;Cant have parens here + ((= CH #/,) ;Comma + (COND ((NOT BRAKP) + (POP L) + (GO RET)))) + ((= CH #/_) (GO RET))) + (PUSH CH LL) + (POP L) + (GO A) + RET (SETQ DF (MERGEF (NAMELIST (MAKNAM (NREVERSE LL))) DF)) + (SETQ ANS (NCONC ANS (LIST DF))) + (AND (= CH #/,) (GO AA)) + (RETURN ANS) )) + +(DEFUN MAKLAP-MERGEF (LL DFNL) + (MAP '(LAMBDA (L) (RPLACA L (SETQ DFNL (MERGEF (CAR L) DFNL)))) + LL) + () ) + + + +;;;(DEFUN FNCP (II) ;File-Name-Character-Predicate +;;; (OR (LESSP 59. II 95.) ;Gets <, ?, @, A-Z, [, \, ], ^ +;;; (LESSP 47. II 58.) ;Gets 0 - 9 +;;; (LESSP 32. II 40.) ;Gets ! to ' (Tops of 1 to 4) +;;; (= II 43.) (= II 45.) ;Gets + and - +;;; (COND ((NOT #%(ITSP)) () ) +;;; ((OR (= II 42.) ;Gets * +;;; (= II 46.)))))) ;Gets . + + + +(DEFUN ZAP2NIL (DATA FL) + (DECLARE (SPECIAL LINEL) (FIXNUM LINEL CHAR)) + (PROG (CHAR FLAG N LINEL ^R ^W) + (SETQ LINEL (LINEL LAPOF)) + (SETQ ^R (SETQ ^W 'T)) + (COND (FL (TERPRI) + (LINEL LAPOF 0.) + (PRINT DATA))) + A (SETQ CHAR (ZTYI)) + (COND ((= CHAR #\CR ) ; + (AND (= #\LF (TYIPEEK)) (TYI)) ;flush any following line-feed + (SETQ FLAG () )) + (FLAG) + ((= CHAR #//) (AND FL (TYO CHAR)) (SETQ CHAR (ZTYI))) ; + ((= CHAR #/;) (SETQ FLAG 'T)) ; + ((= CHAR #/( ) ; + (AND (ZEROP N) + (= (TYIPEEK) #/) ) ; + (PROG2 (AND FL (PRINC '|() |) (TERPRI) (TYO #\FORMFEED)) + (GO XIT))) + (SETQ N (1+ N))) + ((= CHAR #/) ) (SETQ N (1- N))) ; + ((AND (OR (= CHAR #/N) (= CHAR #/n)) (ZEROP N)) ; |N|, |n| + (AND FL (TYO CHAR)) + (COND ((OR (= (SETQ CHAR (ZTYI)) #/I) (= CHAR #/i)) ; |I|, |i| + (AND FL (TYO CHAR)) + (COND ((OR (= (SETQ CHAR (ZTYI)) #/L) ; |L|, |l| + (= CHAR #/l)) + (AND FL (TYO CHAR)) + (COND ((= (SETQ CHAR (ZTYI)) #/ ) + (AND FL (PRINC '| |) + (TERPRI) + (TYO #\FORMFEED )) + (GO XIT))))))))) + (AND FL (TYO CHAR)) + (GO A) + XIT (LINEL LAPOF LINEL) )) + + +(DEFUN ZTYI () + ((LAMBDA (CHAR) + (AND (OR (= CHAR -1) + (AND #%(ITSP) + (= CHAR 3) + (OR (NOT (FILEP INFILE)) + (AND (MEMQ 'FILEPOS (CDR (STATUS FILEM INFILE))) + (> (FILEPOS INFILE) (- (LENGTHF INFILE) 6))) ))) + (SETQ TOPFN (CADR DATA)) ;set up name of losing LAP function + (DBARF '? |End-Of-File in middle of LAP code - check for misbalanced parens|)) + CHAR) + (TYI -1))) + + +;;; FASL-A-FILE SHOULD ONLY BE CALLED BY MAKLAP, FOR MAKLAP BINDS LOTS OF LOSING SPECIAL VARIABLES +;;; HOWEVER, FASLTRY TRYES TO SIMULATE THIS CALL FOR A TEST CASE + +(DEFUN FASL-A-FILE (TARGETFILE SOURCEFILES) + ((LAMBDA (BASE IBASE OBARRAY READTABLE MSDIR EOF WINP REALSFS TOPFN) + (ERRSET + (PROGN + (GCTWA T) + (FASL-START TARGETFILE () ) + (DO SFS SOURCEFILES (CDR SFS) (NULL SFS) + (APPLY 'EREAD (CAR SFS)) ;OPEN LAP SOURCE FILE + (PUSH (STATUS UREAD) REALSFS) + (UNFASL-MSG (CAR REALSFS)) + (SETQ ^Q T) + (DO Y + (READ EOF) + (AND ^Q (READ EOF)) + (OR (NULL ^Q) (EQ Y EOF)) + (FASLIFY Y ()))) + (SETQ WINP T))) + (GCTWA ()) + (COND ((OR (NULL WINP) FBARP) ;IF SOME ERROR OCCURRED, + (SETQ TOPFN CURRENTFN) + (PDERR (LIST *LOC FILOC) |Faslization aborted after so many words| ) + (AND ^Q (DO () ((EQ EOF (READ EOF))))) ;CLEAN OUT TO END OF FILE + (SETQ REALSFS ()) ;IDENTIFY LOSER TO FASL-CLOSEOUT + (ERR 'FASLAP))) + (FASL-CLOSEOUT TARGETFILE REALSFS TARGETFILE) + (AND TTYNOTES + (PROG (^W ^R) + (INDENT-TO-INSTACK 0) + (PRIN1 (COND ((NULL (CDR SOURCEFILES)) (CAR SOURCEFILES)) + (SOURCEFILES))) + (PRINC '| assembled - |) + (PRIN1 FILOC) + (PRINC '| Words|))) + (GCTWA) + WINP) + 8. BASE COBARRAY CREADTABLE MSDIR (LIST ()) () () ())) + + +(DEFUN FASL-START (FILE CONTINUEP) + ((LAMBDA (UNFASL-DIR) + (SETQ USERATOMS-INTERN () ) + (SETQ IMOSAR (EOPEN (MERGEF '(* /_FASL/_) FILE) '(OUT FIXNUM))) ;Open FASL output file + (COND ((NOT CONTINUEP) + (SETQ UFFIL (EOPEN (MERGEF (CONS (LIST '* UNFASL-DIR) ;Open UNFASL file + '(* /_UNFA/_)) + FILE) + '(OUT))) + (PUSH UFFIL CMSGFILES) + (LINEL UFFIL 80.) + (AND (SETQ UNFASL-DIR (PROBEF IMOSAR)) (FASL-DELETEF UNFASL-DIR)) + (AND (SETQ UNFASL-DIR (PROBEF UFFIL)) (FASL-DELETEF UNFASL-DIR)) + (SETQ UFFIL (LIST UFFIL)) )) + (FASLOUT #.(CAR (PNGET '|*FASL+| 6))) ;First of two word header + (FASLOUT LDFNM) ; is SIXBIT |*FASL+| + (SETQ ALLATOMS (SETQ ENTRYNAMES (SETQ SYMPDL + (SETQ MAINSYMPDL (SETQ CURRENTFNSYMS ()))))) + (SETQ BINCT 0) + (FILLARRAY 'NUMBERTABLE '(()) ) + (SETQ FILOC (SETQ LITLOC (SETQ *LOC (SETQ ATOMINDEX 0)))) + (SETQ ^W (SETQ ^R T))) + (COND (MSDIR) + ((CADAR FILE)) + ('*)))) + + +(DEFUN FASL-CLOSEOUT (TARGETFILE SOURCEFILES UNFASLNAM) + (AND UNFASLNAM (SETQ UNFASLNAM (MERGEF '(* UNFASL) UNFASLNAM))) + (BUFFERBIN 17 0 ()) ;End of file flag + (COND ((NOT SOURCEFILES) + (SETQ TARGETFILE (MERGEF '(/_FASL_/ OUTPUT) TARGETFILE))) + ((NOT #%(DEC20P)) ) + ((LET ((SRC (PROBEF (CAR SOURCEFILES))) + (F)) + (COND ((NULL SRC) () ) ;Cant win if no real sourcefile? + (T (AND (SETQ F (RENAMEVERNOP TARGETFILE SRC)) + (SETQ TARGETFILE F)) + (AND UNFASLNAM + (SETQ F (RENAMEVERNOP UNFASLNAM SRC)) + (SETQ UNFASLNAM F))))))) + (FASL-RENAMEF IMOSAR TARGETFILE) + (SETQ IMOSAR ()) ;Close binary output file + (COND (SOURCEFILES + (AND UNFASLCOMMENTS + (NOTE-IN-UNFASL '|TOTAL = | FILOC '| WORDS|)) ;Close UNFASL file + (COND ((NULL UNFASLNAM)) ;If kill-flag permits, and + ('T (FASL-RENAMEF (CAR UFFIL) UNFASLNAM) + (AND (NULL UNFASLSIGNIF) + (SETQ SOURCEFILES (PROBEF (CAR UFFIL))) + (FASL-DELETEF SOURCEFILES)) + (SETQ UFFIL () )))) + ('T (FASL-DELETEF TARGETFILE) ;Kill FASL file, if + (COND ((AND UFFIL UNFASLNAM) ; wrong or INSIGNIF + (FASL-RENAMEF (CAR UFFIL) UNFASLNAM) + (SETQ UFFIL () ))) + (MOBYSYMPOP MAINSYMPDL) + (REMPROPL 'SYM CURRENTFNSYMS))) + (AND #%(SAILP) + (NOT UNFASLCOMMENTS) + (SETQ UNFASLNAM (PROBEF UNFASLNAM)) + (DELETEF UNFASLNAM)) + (REMPROPL 'ENTRY ENTRYNAMES) ;Flush no-longer-needed props + (REMPROPL 'ARGSINFO ENTRYNAMES) + (REMPROPL 'ATOMINDEX ALLATOMS) + (FILLARRAY 'BSAR '(()) ) + (FILLARRAY 'NUMBERTABLE '(()) ) + (SETQ SYMPDL (SETQ MAINSYMPDL (SETQ CURRENTFNSYMS () ))) + (SETQ USERATOMS-INTERN () ) + (SETQ ALLATOMS (SETQ ENTRYNAMES () ))) + + +(DEFUN RENAMEVERNOP (MAINFILE SRC) + (IF (OR (ATOM MAINFILE) (ATOM (CAR MAINFILE))) ;Normalize inputs as + (SETQ MAINFILE (NAMELIST MAINFILE))) ; namelists + (IF (AND (OR (NULL (CDDDR MAINFILE)) (EQ (CADDDR MAINFILE) '*)) + ;If the mainfile didn't already get supplied a version number + ; and if such a versioned file doesn't already forcibly exist + (PROGN (IF (OR (ATOM SRC) (ATOM (CAR SRC))) + (SETQ SRC (NAMELIST SRC))) + (SETQ MAINFILE (MERGEF `((* *) * * ,(cadddr src)) MAINFILE)) + (OR (NULL (PROBEF MAINFILE)) + (ERRSET (DELETEF MAINFILE) () )))) + MAINFILE)) + + + +(eval-when (eval compile) +(defsimplemac NULDEVP (x) + `(AND (NOT (ATOM (CAR ,x))) (EQ (CAAR ,x) 'NUL))) +) + +(DEFUN FASL-DELETEF (X) + (IF (OR (NOT #%(ITSP)) (NOT #%(NULDEVP X))) (DELETEF X))) + +(DEFUN FASL-RENAMEF (X Y) + (AND (NOT #%(ITSP)) (NOT #%(DEC20P)) (PROBEF Y) (FASL-DELETEF Y)) + (IF (OR (NOT #%(ITSP)) + (AND (NOT #%(NULDEVP X)) (NOT #%(NULDEVP Y)))) + (RENAMEF X Y))) + + + +(DEFUN UNFASL-MSG (FILE) + #%(LET ((^W 'T) (^R 'T) (TERPRI 'T) (OUTFILES UFFIL)) + (TERPRI) + (PRINC '|'/(THIS IS THE UNFASL FOR |) ;BARF OUT HEADER + (PRINT-LINEND FILE 'T) ; FOR UNFASL FILE + (PRINC '|'(ASSEMBLED BY FASLAP //|) + (PRINT-LINEND FASLVERNO () ))) + + + +(DEFUN NOTE-IN-UNFASL (MSG W FL) + #%(LET ((^R 'T) (^W 'T) (TERPRI 'T) (OUTFILES UFFIL) + (BASE 10.) (*NOPOINT () ) + (FUNAME (AND (NOT (ATOM W)) + (SYMBOLP (CADR W)) + (CADR W))) + TTN-FUN) + (COND ((COND ((AND FUNAME + (SETQ TTN-FUN (GET FUNAME 'TTYNOTES-FUNCTION))) + (IF (SETQ FUNAME (FUNCALL TTN-FUN FUNAME)) + (SETQ W `(,(car w) ,funame ,.(cddr w))))) + ('T)) + (TERPRI) ;TERPRI before comment + (PRINC '| (COMMENT **FASL** |) + (PRINC MSG) + (AND W (PRINC '| |) (PRIN1 W)) + (AND FL (PRINC FL)) + (PRINC '|) |) )) + (AND ^R (SETQ UNFASLSIGNIF ^R)))) + + + + diff --git a/src/comlap/phas1.86 b/src/comlap/phas1.86 new file mode 100755 index 00000000..17db9cb0 --- /dev/null +++ b/src/comlap/phas1.86 @@ -0,0 +1,2573 @@ +;;; PHAS1 -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ***** LISP COMPILER (PHASE 1) ****************** +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + + +(SETQ PHAS1VERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/86))))) + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + + +(EVAL-WHEN (COMPILE) + (ALLOC '(LIST (55296. 65536. 0.2) FIXNUM (4096. 6144. 0.2))) + (COMPDECLARE) + (GENPREFIX |/|p1-|)) + + + +(COMMENT P1 - BASIC PHASE 1 FUNCTION) + + +(DEFUN P1 (X) + (PROG (FTYP 2NDP Z Y TEM MODE) + P1-START + (COND ((NULL X) (GO P1NIL)) + ((EQ X 'T) (RETURN (COND (ARITHP '('T)) (''T)))) + ((MEMQ (SETQ Z (TYPEP X)) '(BIGNUM FIXNUM FLONUM)) + (SETQ X (LIST 'QUOTE X) MODE (COND ((EQ Z 'BIGNUM) () ) (Z))) + (GO P1XIT)) + ((EQ Z 'SYMBOL) + (COND ((SETQ Z (ASSQ X RNL)) + (SETQ X (CDR Z)) + (GO P1-START)) + ((GET X '+INTERNAL-STRING-MARKER) + (SETQ X `(QUOTE ,X) MODE () ) + (GO P1-START))) + (SETQ CNT (ADD1 CNT)) + (P1SPECIAL X) + (AND ARITHP (SETQ MODE (VARMODE X))) + (GO P1XIT)) + ((NOT (EQ Z 'LIST)) + (COND ((AND (HUNKP X) (NOT (EQ (SETQ Z (P1MACROGET X)) NULFU))) + (SETQ X Z) + (GO P1-START))) + (PDERR X |Random piece of data - () will be substituted|) + (GO P1NIL)) + ((EQ (SETQ Z (TYPEP (CAR X))) 'LIST) + (COND ((EQ (CAAR X) 'LAMBDA) (RETURN (P1LAM (CAR X) (CDR X)))) + ((EQ (CAAR X) 'LABEL) + (PDERR X |LABEL is no longer supported|) + (GO P1NIL)) + ((EQ (CAAR X) CARCDR) + (SETQ X (LIST (CAR X) (P1VN (CADR X)))) + (GO P1XIT)) + ((MEMQ (CAAR X) '(QUOTE FUNCTION)) + (SETQ X (CONS (CADAR X) (CDR X))) + (GO P1-START)) + ((EQ (CAAR X) COMP) + (P1SQV PROGN) + (SETQ X ((LAMBDA (EFFS ARITHP KTYPE PNOB) + (RPLACD (CDAR X) (P1 (CDDAR X))) + (COND ((> (LENGTH (CDR X)) #%(NACS)) + (P1FAKE X)) + ('T (CONS (CAR X) (MAPCAR 'P1 (CDR X)))))) + () () () 'T)) + (SETQ MODE (AND (MEMQ (CADAR X) '(FIXNUM FLONUM)) (CADAR X))) + (GO P1XIT)) + ((EQ (CAAR X) MAKUNBOUND) (GO P1XIT)) + ((NOT (EQ (SETQ Z (P1MACROGET (CAR X))) NULFU)) + (SETQ X (CONS Z (CDR X))) + (GO P1-START)) + ('T (P1SQV PROGN) + (SETQ X ((LAMBDA (EFFS ARITHP KTYPE PNOB) + (SETQ Z (P1 (CAR X)) ARITHP () ) + (COND ((CDR Z) + (PDERR X |Computed function cant be numeric|) + (GO P1NIL)) + ('T (WARN X |Computed functions are not generally supported,/ + This code is being rewritten using FUNCALL|))) + (AND (ATOM (CAR Z)) + (SYSP (CAR Z)) + (SETQ X (CONS (CAR Z) (CDR X))) + (GO P1-START)) + (SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CAR Z))) + (MAPCAR 'P1 (CDR X))))) + () 'T () 'T)) + (GO P1XIT)))) + ((NOT (EQ Z 'SYMBOL)) + (PDERR X |Unlikely crufft used in functional position|) + (GO P1NIL)) + ((OR (NULL (CAR X)) (EQ (CAR X) 'T)) + (WARN X |T and NIL are verry poor choices for function names - +you will most likely lose badly!|)) + ((EQ (CAR X) 'QUOTE) ;Certain QUOTEs are trivial + (COND ((OR (NULL (CDR X)) (CDDR X)) (GO WNA)) + ((OR (EQ (CADR X) 'T) (NULL (CADR X))) + (SETQ X (CADR X)) + (GO P1-START)) + ((MEMQ (SETQ TEM (TYPEP (CADR X))) '(FIXNUM FLONUM)) + (SETQ MODE TEM))) + (GO P1XIT)) + ((EQ (CAR X) NULFU) (GO P1-CALL)) ;Placeholder for pseudo-SUBR + ((and (setq z (get (car x) 'SOURCE-TRANS)) + (do ((l z (cdr l))) + ((null l) () ) + (multiple-value (y z) (funcall (car l) x)) + (if z (return 'T)))) + (setq x y) + (go p1-start)) + ((NOT (EQ (SETQ Z (P1MACROGET X)) NULFU)) + (SETQ X Z) + (GO P1-START))) ;Try again after MACRO expansion + + ;Here, we analyze a symbol used in functional position, + ; obtaining the relevant information from property list flags + + B-? (SETQ FTYP (FUNTYP-DECODE (CAR X))) + (COND ((NULL FTYP) + ;Each wing of this COND will GO someplace + (COND ((GET (CAR X) '*ARRAY) (GO P1-CALL)) + ((EQ (CAR X) GOFOO) (GO P1XIT)) +;;; ((SETQ Y (ASSQ (CAR X) RNL)) +;;; (SETQ X (CONS (CDR Y) (CDR X))) +;;; (GO P1-START)) + ('T (P1SQV PROGN) + (AND (MEMQ (CAR X) BVARS) + #%(WARN X |Bound variable used as Function name|)) +;;; (COND ((AND (NULL NFUNVARS) +;;; (OR (SETQ TEM (SPECIALP (CAR X))) +;;; (MEMQ (CAR X) BVARS))) +;;; (COND ((NOT (SETQ Y (ASSQ (CAR X) FFVL))) +;;; (COND (TEM #%(WARN (CAR X) |Used as free functional variable|)) +;;; ('T (CKCFV (CAR X)) +;;; #%(WARN (CAR X) |Used as bound functional variable|))) +;;; (PUSH (LIST (CAR X) TOPFN) FFVL)) +;;; ((NOT (MEMQ TOPFN (CDR Y))) +;;; (RPLACD Y (CONS TOPFN (CDR Y))))) +;;; (SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CAR X))) (CDR X))) +;;; (GO P1-START))) + (PUSH (CAR X) UNDFUNS) + (PUTPROP (CAR X) + 'T + (COND ((> (SETQ Z (LENGTH (CDR X))) #%(NACS)) + (SETQ Z (CONS Z Z)) + '*LEXPR) + ('T (SETQ Z (CONS () Z)) + '*EXPR))) + (P1ACK (CAR X) () Z (CDR Z)) + (COND ((CAR Z) (RETURN (P1FAKE X))) + ('T (GO P1-CALL))) )) ) + ((EQ FTYP 'JSP) + (AND (P1ACK (CAR X) 'SUBR () (CDR X)) (GO WNA)) + (GO P1-CALL)) + ((EQ FTYP 'CARCDR) (RETURN (P1CARCDR X))) + ((MEMQ FTYP '(*EXPR *FEXPR *LEXPR)) + (P1SQV PROGN) + (COND ((EQ FTYP '*EXPR) + ((LAMBDA (ZZ) + (COND ((OR (> ZZ #%(NACS)) (GET (CAR X) '*LEXPR)) + (LREMPROP (CAR X) '(*EXPR *LEXPR)) + (PUTPROP (CAR X) 'T '*LEXPR) + (AND (P1ACK (CAR X) 'LSUBR (CONS ZZ ZZ) ZZ) + (GO WNA)) + (RETURN (P1FAKE X))) + ((P1ACK (CAR X) 'SUBR (CONS () ZZ) ZZ) + (GO WNA)) + ('T (GO P1-CALL)))) + (LENGTH (CDR X)))) + ((EQ FTYP '*LEXPR) + (AND (P1ACK (CAR X) 'LSUBR () (CDR X)) (GO WNA)) + (RETURN (P1FAKE X))) + ((EQ FTYP '*FEXPR) (RETURN (P1MODESET X)))) ) + ((EQ FTYP 'SUBR) + (COND ((EQ (CAR X) 'PAIRP) + (SETQ X `(EQ (TYPEP ,(cadr x)) 'LIST))) + ((MEMQ (CAR X) '(SORT SORTCAR)) + (AND (SETQ Y (P1FUNGET (CADDR X))) + (SETQ X (LIST (CAR X) (CADR X) Y))))) + (GO DISPATCH)) + ((MEMQ FTYP '(FSUBR LSUBR)) (GO DISPATCH)) + ('T (BARF () |Bad function type - P1|) )) + + B-SUBR (SETQ 2NDP (SETQ FTYP 'SUBR)) (GO DISPATCH) + + B-LSUBR (SETQ 2NDP (SETQ FTYP 'LSUBR)) (GO DISPATCH) + + B-FSUBR (SETQ 2NDP (SETQ FTYP 'FSUBR)) (GO DISPATCH) + + DISPATCH ;It is assumed that FTYP will be among SUBR, FSUBR, and LSUBR + (SETQ TEM () Z () ) + (COND ((AND (NOT 2NDP) ;"2NDP" non-null means + (OR (SETQ TEM (GET (CAR X) 'ARITHP)) ; already half dispatched + (SETQ Z (GET (CAR X) 'NUMBERP)))) ;Throw numeric stuff to P1ARITH + (AND (P1ACK (CAR X) FTYP () (CDR X)) (GO WNA)) + (COND ((AND Z (MEMQ (CAR X) '(EQ EQUAL))) + (AND (COND ((OR (NULL (CADR X)) (QNILP (CADR X))) ;But trap-out "(EQ MUMBLE () )" + (SETQ TEM (CADDR X)) + 'T) + ((OR (NULL (CADDR X)) (QNILP (CADDR X))) + (SETQ TEM (CADR X)) + 'T)) + (PROG2 (SETQ X (LIST 'NULL TEM)) (GO B-SUBR))))) + (RETURN (P1ARITH X TEM Z))) + ((EQ FTYP 'FSUBR) + (COND ((EQ (CAR X) 'SETQ) (RETURN (P1SETQ X))) + ((EQ (CAR X) 'PROG) (RETURN (P1PROG (CDR X)))) + ((EQ (CAR X) 'COND) (RETURN (P1COND (CAR X) (CDR X)))) + ((MEMQ (CAR X) '(AND OR)) + (COND ((NULL (CDDR X)) + (WARN X |There are not two or more clauses here - do you really want this?|) + (SETQ X (COND ((CDR X) (CADR X)) + ((EQ (CAR X) 'AND)))) + (GO P1-START)) + (EFFS (RETURN (P1COND (CAR X) (CDR X)))) + ((EQ (CAR X) 'OR) (SETQ TEM (MAPCAR 'NCONS (CDR X)))) + ('T (SETQ TEM (L2F (CDR X))) + (SETQ TEM (LIST (LIST (COND ((NULL (CDDR TEM)) (CADR TEM)) + ((CONS 'AND (CDR TEM)))) + (CAR TEM)))))) + (RETURN (P1COND 'COND TEM))) + ((EQ (CAR X) 'GO) (SETQ X (P1GO X)) (GO P1XIT)) + ((EQ (CAR X) 'DO) ;DO expands into a LAMBDA application + (SETQ X (P1DO (SETQ TEM X))) ; and hence this must be dispatched + (AND (NULL X) (DBARF TEM |Bad DO format|)) + (GO P1-START)) ; from the start again. + ((EQ (CAR X) 'CASEQ) + (SETQ X (P1CASEQ (SETQ TEM X))) ;Might expand into a COND, or + (AND (NULL X) (DBARF TEM |Bad CASEQ format|)) + (GO P1-START)) ; a LAMBDA application + ((EQ (CAR X) 'PUSH) + (SETQ X (+INTERNAL-PUSH-X (CDR X) EFFS)) ;Expand + (GO P1-START)) ;and try again + ((EQ (CAR X) 'POP) + (SETQ X (+INTERNAL-POP-X (CDR X) EFFS)) ;Expand + (GO P1-START)) ;and try again + ((EQ (CAR X) 'SETF) + (SETQ X (+INTERNAL-SETF-X (CDR X) EFFS)) ;Expand + (GO P1-START)) ;and try again + ((EQ (CAR X) 'STORE) + ((LAMBDA (EFFS ARITHP KTYPE PNOB) + (SETQ Z (P1 (CADDR X))) + (SETQ MODE (CDR Z) Z (CAR Z) ARITHP () ) + (AND KTYPE MODE (NOT (EQ MODE KTYPE)) (P1ARG-WRNTYP X)) + (SETQ X (LIST 'STORE (P1 (CADR X)) Z))) + () 'T (CDR (NUMTYP (CADR X) () )) () ) + (GO P1XIT)) + ((COND ((EQ (CAR X) 'ARRAYCALL) + (AND (NOT ARRAYOPEN) + (SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CADDR X))) (CDDDR X))) + (GO P1-START)) + (AND (NULL (CDDDR X)) (GO WNA)) + 'T) + ((MEMQ (CAR X) '(SUBRCALL LSUBRCALL)) + (P1SQV PROGN) + 'T)) + (COND ((OR (NULL (CDR X)) (NULL (CDDR X))) (GO WNA)) + ((EQ (SETQ TEM (TYPEP (CADR X))) 'SYMBOL)) + ('T (PDERR X |Wrong functional designator|))) + (COND ((SETQ MODE (ASSQ (CADR X) COMAL)) + (SETQ MODE (AND (NOT (EQ (CAR MODE) 'T)) (CAR MODE)))) + ('T (WARN X |Non-standard type info| 3 5) (SETQ MODE () ))) + (AND KTYPE MODE (NOT (EQ MODE KTYPE)) (P1ARG-WRNTYP X)) + (AND (COND ((EQ (SETQ TEM (TYPEP (CADDR X))) 'SYMBOL) + (MEMQ (CADDR X) '(T NIL))) + ((EQ TEM 'LIST) + (MEMQ (CAADDR X) '(QUOTE FUNCTION *FUNCTION))) + (T)) + (PDERR X |The function pointer can't be right|)) + #%(LET (EFFS ARITHP KTYPE (PNOB 'T)) + (COND ((EQ (CAR X) 'LSUBRCALL) + (SETQ X (P1FAKE (CONS (CAR X) (CDDR X)))) + (RPLACD (SETQ TEM (CADDDR (CDDAR X))) + (CONS MODE (CDR TEM)))) + ('T (AND (> (LENGTH (CDDDR X)) 5) + (PDERR X |Too many args for SUBRCALL or ARRAYCALL|)) + (SETQ ARITHP 'T) + (SETQ Z (P1 (CADDR X))) + (COND ((NULL (CDR Z))) + ('T (PDERR X |Numeric function-ptr?|))) + (AND (EQ (CAR X) 'ARRAYCALL) (SETQ KTYPE 'FIXNUM)) + (SETQ ARITHP () ) + (SETQ Z (CONS (CAR Z) (MAPCAR 'P1 (CDDDR X)))) + (SETQ X (COND ((EQ (CAR X) 'ARRAYCALL) + `(,(car x) ,mode ,. z)) + ('T (RPLACA + Z + `(,comp ,mode ,. (car z))) + Z)))))) + (GO P1XIT)) + ((EQ (CAR X) 'ARRAY) + (SETQ X (CONS '*ARRAY + (CONS (LIST 'QUOTE (CADR X)) + (CONS (LIST 'QUOTE (CADDR X)) (CDDDR X))))) + (GO B-LSUBR)) + ((MEMQ (CAR X) '(STATUS SSTATUS)) + (SETQ X (CONS (CONS MAKUNBOUND (CONS 'FSUBR (CAR X))) + (P1STATUS X))) + (GO P1XIT)) + ((MEMQ (CAR X) '(ERRSET *CATCH CATCH-BARRIER CATCHALL + UNWIND-PROTECT CATCH PASS-THRU)) + #%(LET ((P1VARS LOCVARS) (P1CNT CNT)) + (SETQ Z + (P1FAKE + (CASEQ (CAR X) + (ERRSET (LIST 'ERRSET + (LIST 'NCONS (CADR X)) + (COND ((NULL (CDDR X))) + ((CADDR X))))) + ((*CATCH CATCH-BARRIER) X) + (CATCHALL (CONS '%CATCHALL + (CONS (CONS 'FUNCALL + (CONS (CADR X) + CAAGL)) + (CDDR X)))) + (UNWIND-PROTECT (CONS '%PASS-THRU + (CONS (CONS 'PROGN + (CDDR X)) + (LIST (CADR X))))) + (PASS-THRU (CONS '%PASS-THRU + (CONS (LIST 'FUNCALL (CADR X)) + (CDDR X)))) + (CATCH (AND (EQ X 'CATCH) + (WARN X | Obsolete form - please use *CATCH|)) + (LIST '*CATCH + (LIST 'QUOTE (CADDR X)) + (CADR X))) ))) + (P1SYNCHRONIZE-CNTS P1CNT P1VARS)) + (RETURN Z)) + ((EQ (CAR X) 'THROW) + (WARN X | Obsolete form - please use *THROW|) + (SETQ X (LIST '*THROW + (LIST 'QUOTE (CADDR X)) + (P1VN (CADR X)))) + (GO P1XIT)) + ((SETQ TEM (ASSQ (CAR X) '((FUNCTION . QUOTE) (*FUNCTION . *FUNCTION)))) + (COND ((OR (NULL (CDR X)) (CDDR X)) (GO WNA))) + (SETQ X (LIST (CDR TEM) (P1GFY (CADR X) 'EXPR))) + (GO P1XIT)) + ((EQ (CAR X) 'SIGNP) (SETQ X (P1SIGNP X)) (GO P1XIT)) + ((EQ (CAR X) 'BREAK) + (AND (OR (NULL (CDR X)) (CDDDR X)) (GO WNA)) + (SETQ X (LIST '*BREAK + (COND ((CDDR X) (CADDR X)) + ('(QUOTE T))) + (LIST 'QUOTE (CADR X)))) + (P1SQV PROGN) + (GO B-SUBR)) + ((EQ (CAR X) 'PROGV) + (AND (NULL (CDDDR X)) (GO WNA)) + (RETURN (P1PROGN (CDR X) 'PROGV))) + ((EQ (CAR X) 'ERR) + (SETQ X (COND ((NULL (CDR X)) '(ERR '() ) ) + ((OR (NULL (CDDR X)) + (AND (CADDR X) (NOT (QNILP (CADDR X))))) + (LIST 'ERR (P1VN (CADR X)))) + (X))) + (GO P1XIT)) + ((MEMQ (CAR X) '(DECLARE EVAL-WHEN)) + (PDERR X |Local declaration at wrong place|) + (RETURN X)) + ('T (AND (NOT (GET X 'ACS)) (P1SQV PROGN)) + (RETURN (P1MODESET X))))) + ((EQ FTYP 'LSUBR) + (COND ((MEMQ (CAR X) '(LIST LIST*)) + (COND ((NULL (CDR X)) (GO P1NIL)) + ((AND (NULL (CDDR X)) (EQ (CAR X) 'LIST*)) + (SETQ X (CADR X)) + (GO P1-START))) + (SETQ X (P1ITERLIST (CDR X) (EQ (CAR X) 'LIST*))) + (COND (ARITHP (RETURN (NCONS (P1VN X)))) + ((ATOM X) (GO P1-START)) + ('T (GO B-SUBR))))) + (AND (P1ACK (CAR X) 'LSUBR () (CDR X)) (GO WNA)) + (AND (EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU)) + (AND (EQ (CAR X) 'PRINC) + (CDR X) + (SYMBOLP (CADR X)) + (GET (CADR X) '+INTERNAL-STRING-MARKER) + (SETQ X `(PRINC ',(cadr x) ,.(cddr x)))) + (COND ((EQ (CAR X) 'PROG2) (RETURN (P1PROG2 (CDR X)))) + ((EQ (CAR X) 'PROG1) + (RETURN (P1PROG2 (CONS () (CDR X))))) + ((EQ (CAR X) 'PROGN) + (RETURN (P1PROGN (COND ((CDR X)) ( '( () ) )) PROGN))) + ((COND ((AND (NULL (CDR X)) + (SETQ Z (ASSQ (CAR X) '((READ . *READ) + (READCH . *READCH) + (TYI . *TYI) + (TERPRI . *TERPRI)))))) + ((AND (CDR X) (NULL (CDDR X)) + (SETQ Z (ASSQ (CAR X) '((PRINT . *PRINT) + (PRIN1 . *PRIN1) + (PRINC . *PRINC) + (TYO . *TYO))))) + 'T) + ((AND (CDR X) (CDDR X) (NULL (CDDDR X)) + (OR (SETQ Z (ASSQ (CAR X) '((APPEND . *APPEND) + (NCONC . *NCONC) + (DELETE . *DELETE) + (DELQ . *DELQ)))) + (AND (NOT CLOSED) + (SETQ Z (ASSQ (CAR X) '((GREATERP . *GREAT) + (LESSP . *LESS) + (PLUS . *PLUS) + (DIFFERENCE . *DIF) + (TIMES . *TIMES) + (QUOTIENT . *QUO))))))))) + ;Fall thru for normal CALL processing after this + (SETQ X (CONS (CDR Z) (CDR X)))) + ((SETQ Z (ASSQ (CAR X) '((MAPCAN (*MAP 0) MAPCON CAR) + (MAPCON (*MAP 1) MAPCON LIST) + (MAPC (*MAP 2) MAP CAR) + (MAP (*MAP 3) MAP LIST) + (MAPCAR (*MAP 4) MAPLIST CAR) + (MAPLIST (*MAP 5) MAPLIST LIST) + (MAPATOMS)))) + (RETURN (P1MAP X Z))) + ((EQ (CAR X) 'FUNCALL) + (COND ((NULL (CDR X)) (GO WNA))) + (SETQ X (COND + ((AND + (NOT (ATOM (SETQ Z (CADR X)))) + (SETQ Z (P1FUNGET (CADR X))) + (SETQ Z (COND + ((AND (ATOM (CADR Z)) + (OR (GET (CADR Z) '*FEXPR) + (EQ (SYSP (CADR Z)) 'FSUBR))) + `(APPLY ,.(cdr x))) + ((OR (ATOM (CADR Z)) + (EQ (CAADR Z) 'LAMBDA)) + `(,(cadr z) ,.(cddr x)))))) + Z) + (`((,COMP . (FUNCALL . ,(cadr x))) + ,.(cddr x))))) + (GO P1-START)) + ((AND (EQ (CAR X) 'BOOLE) + (SETQ Z (COND ((ATOM (CADR X)) (CADR X)) + ((EQ (CAADR X) 'QUOTE) (CADADR X)) + ((NOT (EQ (SETQ Z (P1MACROGET (CADR X))) + NULFU)) + (SETQ X (CONS 'BOOLE (CONS Z (CDDR X)))) + (GO P1-START)))) + (FIXP Z) + (NOT (< Z 0)) + (< Z 1_4))) + ;Dont need to P1FAKE explicit BOOLE since will be open coded anyway + + ((EQ (CAR X) '*ARRAY) + (COND ((AND (NOT (ATOM (CADR X))) (EQ (CAADR X) 'QUOTE)) + (AND (COND ((NOT (SYMBOLP (SETQ Z (CADADR X))))) + ((AND (GET Z '*ARRAY) + (SETQ Z (GET Z 'NUMFUN))) + (SETQ Y (COND ((MEMQ (CADDR X) '(T NIL)) (CADDR X)) + ((AND (P1EQQTE (CADDR X)) + (MEMQ (CADR (CADDR X)) + '(T NIL FIXNUM FLONUM OBARRAY))) + (CADR (CADDR X))))) + (COND ((MEMQ Y '(FIXNUM FLONUM)) (NOT (EQ Y (CADR Z)))) + ((MEMQ (CADR Z) '(FIXNUM FLONUM)))))) + (PDERR X |Contradicts declared type of array|)))) + (P1SQV PROGN) + (RETURN (P1FAKE X))) + ((AND (EQ (CAR X) 'HUNK) (< (SETQ TEM (LENGTH (CDR X))) 5)) + (AND (= TEM 0) (GO P1NIL)) + (SETQ X (CONS (CASEQ TEM + (1 (COND (HUNK2-TO-CONS 'NCONS) + ('%HUNK1))) + (2 (COND (HUNK2-TO-CONS 'CONS) + ('%HUNK2))) + (3 '%HUNK3) + (4 '%HUNK4)) + (CDR X))) + (GO B-SUBR)) + ((AND (EQ (CAR X) 'APPLY) + (NULL (CDDDR X)) + (RETURN (PWTNTPTFN (CDR X))))) + ((AND (EQ (CAR X) 'EVAL) (NULL (CDDR X))) + (P1SQV PROGN) + (SETQ Z (LIST (P1VN (CADR X)))) + (COND ((AND (NOT (ATOM (CAR Z))) ;hac for + (EQ (CAAR Z) 'CONS) ;(EVAL (CONS 'FSUBR L)) + (SETQ X (P1F (CADAR Z) (CADDAR Z))))) + ('T (SETQ X (CONS '*EVAL Z)))) + (GO P1XIT)) + ('T (COND ((GET (CAR X) 'ACS) ;Pass on out the + (AND (EQ (GET (CAR X) 'NOTNUMP) 'EFFS) ; severity info, if there + (P1SQV NULFU))) ; really are side effects + ('T (P1SQV PROGN))) + (RETURN (P1FAKE X))))) + ((EQ FTYP 'SUBR) + (AND (P1ACK (CAR X) 'SUBR () (CDR X)) (GO WNA)) + (AND (EQ (CAR X) 'NOT) (SETQ X `(NULL ,.(cdr x)))) + (SETQ Y 'T) + (COND ((EQ (CAR X) 'NULL) + (p1nonumck (cadr x)) + (SETQ X #%(let ((EFFS EFFS) ARITHP KTYPE) + (COND ((AND (P1BOOL1ABLE (CADR X)) + (OR EFFS (NOT (EQ (CAADR X) 'MEMQ)))) + (COND (EFFS (LIST 'NULL (P1 (CADR X)))) + ((P1COND 'COND + `((,x ',*:truth)))))) + ('T (SETQ EFFS () ) (LIST 'NULL (P1 (CADR X))))))) + (GO P1XIT)) + ((EQ (CAR X) 'RETURN) (RETURN (P1RETURN X))) + ((NOT (GET (CAR X) 'ACS)) + (COND ((EQ (CAR X) 'BOUNDP) + (SETQ X (LIST 'NOT + (CONS 'EQ (CONS (LIST 'SYMEVAL (CADR X)) + QSM)))) + (GO B-?)) + ((MEMQ (CAR X) '(ROT LSH ASH FSC)) + (SETQ MODE (COND ((EQ (CAR X) 'FSC) 'FLONUM) + ('FIXNUM))) + #%(LET ((KTYPE (COND ((CDR (NUMTYP (CADR X) 'T))) + (MODE))) + ARITHP EFFS) + (SETQ X (LIST (CAR X) + (P1 (CADR X)) + (PROG2 (SETQ KTYPE 'FIXNUM) + (P1 (CADDR X)))))) + (AND (NOT (ATOM (SETQ TEM (CADDR X)))) + (EQ (CAR TEM) 'QUOTE) + (NOT (NUMBERP (CADR TEM))) + (PDERR X |Invalid 2nd arg - must be numeric|)) + (GO P1XIT)) + ((GET (CAR X) 'P1BOOL1ABLE) + (AND (MEMQ (CAR X) '(NUMBERP FIXP FLOATP)) + (SETQ TEM (NUMTYPEP (CADR X) () )) + (COND ((EQ (CAR X) 'FIXP) (EQ (CDR TEM) 'FIXNUM)) + ((EQ (CAR X) 'FLOATP) (EQ (CDR TEM) 'FLONUM)) + ((EQ (CAR X) 'NUMBERP) (CDR TEM))) + (PROG2 (WARN X |Numeric predicate applied + to numeric type datum is a constant| 4 5) + (SETQ X `(PROG2 ,(cadr x) ',*:truth)) + (GO B-LSUBR)))) + ((EQ (CAR X) 'SET) + (AND (NOT (ATOM (CADR X))) + (EQ (CAADR X) 'QUOTE) + (ATOM (CADADR X)) + (RETURN (P1 (APPEND (LIST 'SETQ (CADADR X)) (CDDR X)))))) + ((MEMQ (CAR X) '(CXR RPLACX)) + (AND (COND ((ATOM (SETQ TEM (CADR X)))) + ((QNP TEM) (SETQ TEM (CADR TEM)) 'T)) + (FIXP TEM) + (COND ((= TEM 0) (SETQ TEM '(CDR . RPLACD)) 'T) + ((= TEM 1) (SETQ TEM '(CAR . RPLACA)) 'T)) + (SETQ X (CONS (COND ((EQ (CAR X) 'CXR) (CAR TEM)) + ((CDR TEM))) + (CDDR X))) + (GO B-?))) + ((EQ (CAR X) 'SYMEVAL) + (RETURN (P1CARCDR (CONS 'CDDAR (CDR X))))) + ('T (P1SQV PROGN)))) + ((MEMQ (CAR X) '(MEMBER ASSOC SASSOC EQUAL MEMQ)) + (RETURN (P1LST X))) + ((MEMQ (CAR X) '(NTH NTHCDR)) + (SETQ Y (CDR X)) + ((LAMBDA (EFFS ARITHP KTYPE PNOB) + (SETQ TEM (P1 (CAR Y)) + ARITHP (SETQ KTYPE (SETQ PNOB () )) + Y (LIST (CAR TEM) (P1 (CADR Y))))) + () 'T 'FIXNUM 'T) + (SETQ X (COND ((AND (CDR TEM) + (QNP (CAR Y)) + (FIXP (SETQ Z (CADAR Y))) + (< Z 6)) + (AND (< Z 0) + (SETQ Z 0) + #%(PDERR X |Negative count to NTH|)) + (SETQ Z #%(NCDR '(D D D D D) (- 5 Z))) + (AND (EQ (CAR X) 'NTH) (PUSH 'A Z)) + + (COND ((NULL Z) (CADR Y)) + ('T (LIST (CONS CARCDR (REVERSE Z)) + (CADR Y))))) + ((CONS (CAR X) Y)))) + (GO P1XIT)) + ((EQ (CAR X) 'MAKNUM) + (AND (CDR (SETQ TEM (P1VAP (CADR X) 'T))) + (WARN X |MAKNUM on numeric quantity?| 4 5)) + (SETQ X (LIST (CONS MAKUNBOUND '(MAKNUM)) + (CAR TEM)) + MODE 'FIXNUM) + (GO P1XIT)) +;;;; ######## At one time, some losing code for *FUNCTION was here. + ((EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU)))) + ('T (BARF X |Lost function - P1|)) ) + + P1-CALL + ;This is for the general function-application (CALL) + ((LAMBDA (PNOB EFFS ARITHP KTYPE MAPP) + (COND ((AND (NOT (EQ FTYP 'JSP)) + (SETQ TEM (GET (CAR X) 'NUMFUN)) + (CDDR TEM)) + (SETQ MODE (CADR TEM) TEM (CDDR TEM) + Z () ARITHP 'T) + (SETQ Z (MAPCAR + '(LAMBDA (ITEM) + (SETQ MAPP (COND ((ATOM ITEM) () ) + ((MEMQ (CAR ITEM) + '(MAP MAPC MAPLIST MAPCAR + MAPCAN MAPCON MAPATOMS))))) + (SETQ KTYPE (CAR TEM) TEM (CDR TEM)) + (SETQ ITEM (P1 ITEM)) ;TEM IS LIST OF DECLARED ARG TYPES + (COND (Z ITEM) ;Z IS FLAG TO INDICATE MIS-MATCH + ((COND ((NULL KTYPE) () ) + ((CDR ITEM) (NOT (EQ KTYPE (CDR ITEM)))) + (MAPP) + ((NOTNUMP (CAR ITEM)))) + (P1ARG-WRNTYP X) + (SETQ Z 'T ARITHP () ) + (CAR ITEM)) + ((CAR ITEM)))) + (CDR X))) + (SETQ X (CONS (CAR X) Z)) + (GO P1XIT)) + ('T (AND (EQ FTYP 'SUBR) (NULL Y) (SETQ PNOB () )) + (SETQ Z (MAPCAR 'P1 (CDR X)))))) + 'T () () () () ) + (RETURN (P1MODESET (CONS (CAR X) Z))) + + + WNA #%(PDERR X |Wrong number of args|) + P1NIL (RETURN (COND (ARITHP '('() . () ) ) ( ''() ))) + P1XIT (RETURN (COND (ARITHP (CONS X MODE)) (X))) )) + + + + +(DEFUN PWTNTPTFN (X) ;Page Width Too Narrow To Print This Function's Name + #%(LET ((NARGS 0) (FUN (P1FUNGET (CAR X))) VAR FL FORM) + (COND ((COND ((OR (NULL FUN) (NULL (SETQ FUN (CADR FUN)))) ;Find form like + () ) ;(APPLY (FUNCTION + ((NOT (ATOM FUN)) ; (LAMBDA (A B) FOO)) + (COND ((NOT (EQ (CAR FUN) 'LAMBDA)) () ) ; BAR) + ((OR (NOT (ATOM (SETQ FORM (CADR FUN)))) ;LAMBDA list + (NULL FORM)) + (SETQ NARGS (LENGTH FORM)) + 'T))) + ((AND (EQ (SYSP FUN) 'SUBR) (SETQ FORM (ARGS FUN))) + (SETQ NARGS (CDR FORM)) ;# of args to function + 'T)) + (SETQ VAR (CADR X)) + (AND (> NARGS 1) ;2 or more LAMBDA vars in + (NOT (ATOM VAR)) ;some complexly-computed list + (NOT (EQ (CAR VAR) 'QUOTE)) + (NOT (P1CARCDR-CHASE VAR)) + (SETQ VAR (GENSYM) FL 'T)) + (SETQ FORM (CONS FUN + (DO ((A VAR (LIST 'CDDDDR A)) (Z)) + ((NOT (> NARGS 0)) (NREVERSE Z)) + (DO ((N (COND ((> NARGS 4) 4) (NARGS)) (1- N)) + (FUN '(CAR CADR CADDR CADDDR) (CDR FUN))) + ((NOT (> N 0))) + (SETQ NARGS (1- NARGS)) + (PUSH (LIST (CAR FUN) A) Z))))) + (AND FL (SETQ FORM (LIST (LIST 'LAMBDA (LIST VAR) FORM) + (CADR X)))) + (P1 FORM)) + ('T (P1SQV PROGN) + (SETQ FORM (MAPCAR 'P1VN X)) + (SETQ FORM (COND ((P1F (CAR FORM) (CADR FORM))) + ((CONS '*APPLY FORM)))) + (COND (ARITHP (NCONS FORM)) (FORM)))))) + + + +(DEFUN P1ACK (NAME TYPE FL L) ;P1 args check + #%(LET ((AARGS (OR (ARGS NAME) (GET NAME 'ARGS))) TEM) + (COND ((NULL AARGS) + (AND FL (PUTPROP NAME FL 'ARGS)) + () ) + ('T (AND (OR (NULL L) (NOT (ATOM L))) (SETQ L (LENGTH L))) + (SETQ TEM (COND ((NULL (CAR AARGS)) + (OR (AND TYPE (NOT (EQ TYPE 'SUBR))) + (NOT (= (CDR AARGS) L)))) + ((OR (AND TYPE (NOT (EQ TYPE 'LSUBR))) + (< L (CAR AARGS)) + (> L (CDR AARGS))) + 'T))) + (AND (AND FL TEM) + #%(WARN NAME |Has been previously used with wrong number of arguments|)) + TEM )))) + + + +(DEFUN P1ARG-WRNTYP (X) + #%(PDERR (LIST X 'NOT-OF-TYPE KTYPE) + |First item in list is an argument somewhere, but is of the wrong type|)) + + +(COMMENT P1ANDOR and P1ARITH) + +(DEFUN P1ANDOR (X ORP) + (PROG (Z) + (COND ((NULL (CDR X)) (RETURN (P1 (NOT ORP)))) + ((NULL (CDDR X)) (RETURN (P1 (CADR X)))) + (EFFS (RETURN (P1COND (CAR X) (CDR X))))) + (SETQ Z (COND (ORP (MAPCAR 'NCONS (CDR X))) + ('T (SETQ Z (L2F (CDR X))) ;Convert (AND A B C) + (LIST (LIST (CONS 'AND (CDR Z)) (CAR Z)))))) ; into (COND ((AND B) C)) + (RETURN (P1COND 'COND Z)))) + + +(DEFUN P1ARITH (XPR ARITHFUNP NUMBERP) + (P1SQE (PROG (TYP TEMP TEM FUN SAVXPR KNOW-ALL-TYPES P1LSQ LMBP CONDP P1LL PNOB) + (SETQ FUN (CAR XPR) LMBP T SAVXPR XPR) + (AND NUMBERP (MEMQ FUN '(EQ EQUAL)) (GO EXAMINE-ARGS)) + (AND NUMBERP + (SETQ TEM (ASSQ FUN '((*PLUS . PLUS) + (*TIMES . TIMES) + (*DIF . DIFFERENCE) + (*QUO . QUOTIENT) + (*LESS . LESSP) + (*GREAT . GREATERP)))) + (SETQ FUN (CDR TEM))) + (AND (NULL (CDDR XPR)) + (NULL (ARGS FUN)) + (SETQ TEM (COND ((OR (AND NUMBERP (MEMQ FUN '(PLUS DIFFERENCE))) + (AND ARITHFUNP (MEMQ FUN '(+ +$ - -$)))) + '('0 . '0.0)) + ((OR (AND NUMBERP (MEMQ FUN '(TIMES QUOTIENT))) + (AND ARITHFUNP (MEMQ FUN '(* *$ // //$)))) + '('1 . '1.0)))) + ;Case of 0 or 1 arguments to rational function + ;Note that "(car tem)" and "(cdr tem)" can be used as P1 output + (COND ((AND ARITHFUNP (CDR XPR)) + (COND ((MEMQ FUN '(- -$ // //$)) + (SETQ XPR `(,fun ,(cond ((memq fun '(-$ //$)) + (cdr tem)) + ((car tem))) + ,(cadr xpr)))) + ('T + (SETQ TYP (CADR ARITHFUNP) + XPR (P1VN `(,(cond ((eq typ 'FIXNUM) + 'FIXNUM-IDENTITY) + ('FLONUM-IDENTITY)) + ,(cadr xpr)))) + (GO XITF) ))) + ('T + (SETQ XPR (COND ((CDR XPR) (P1VN (CADR XPR))) + ((MEMQ FUN '(+$ -$ *$ //$)) + (CDR TEM)) ;Constants appear to be + ((CAR TEM)))) ; Already P1'd! + (GO XITF)))) + (COND ((SETQ TEMP (COND ((AND ARITHFUNP (NULL (CADR ARITHFUNP))) + (GO EXAMINE-ARGS)) + (ARITHFUNP) ;type is pre-determined + ((AND NUMBERP CLOSED) () ) ;so processing is easy + (FIXSW `(,fun FIXNUM)) + (FLOSW `(,fun FLONUM)) )) + (SETQ TYP (CADR TEMP)) + (SETQ XPR `(,(car temp) ,typ + ,. #%(let (arithp effs (ktype typ)) + (mapcar 'p1 (cdr xpr))))) + (AND (EQ NUMBERP 'NOTYPE) (SETQ TYP () )) + (COND ((EQ (CAR XPR) IDENTITY)) + ((SETQ TEM (P1AEVAL FUN (CDDR XPR) SAVXPR TYP (CADR ARITHFUNP))) + (COND ((EQ (CAR TEM) 'QUOTE) + (SETQ XPR (CDR TEM)) + (GO XITF)) + ('T (SETQ XPR `(,(car xpr) ,(cadr xpr) ,.(cdr tem))))))) + (SETQ KNOW-ALL-TYPES 'T) + (AND (EQ FUN 'DIFFERENCE) ; (DIFFERENCE 0 X) ==> + (Q0P+0P (CAR (SETQ TEMP (CDDR XPR)))) ; (MINUS X) + (NULL (CDDR TEMP)) + (SETQ XPR `(MINUS ,typ ,.(cdr temp)))) + (GO XITF))) + (AND (GET FUN 'LSUBR) (SETQ PNOB 'T)) + + EXAMINE-ARGS + #%(LET ((ARITHP 'T) EFFS KTYPE) + (COND ((AND ARITHFUNP (NULL (CADR ARITHFUNP))) ;Seek special action + (SETQ KTYPE (CDR (NUMTYP (CADR XPR) 'T)) ; on =, >, and < + TYP (CDR (NUMTYP (CADDR XPR) 'T))) + (COND ((AND (NULL KTYPE) (NULL TYP)) ;Sigh! No info + #%(LET ((P1CNT CNT) (LL LOCVARS) ; from numtypep! + (LLL (MAPCAR 'CDR LOCVARS)) + ARG1 ARG2 T1 T2) + (SETQ ARG1 (P1 (CADR XPR)) + T1 (CDR ARG1)) + (COND (T1 (SETQ KTYPE T1 + ARG2 (P1 (CADDR XPR)))) + ('T (SETQ ARG2 (P1 (CADDR XPR)) + T2 (CDR ARG2) + KTYPE + (COND (T2) + (FLOSW 'FLONUM) + (FIXSW 'FIXNUM) + ('FIXNUM))) + (SETQ CNT P1CNT LOCVARS LL) + (MAPC 'RPLACD LOCVARS LLL) + (SETQ ARG1 (P1 (CADR XPR)) + ARG2 (P1 (CADDR XPR))))) + (AND (NOT (MEMQ KTYPE '(FIXNUM FLONUM))) + #%(PDERR SAVXPR |Mixed modes|)) + (SETQ XPR (LIST (CAR ARITHFUNP) + KTYPE + (CAR ARG1) + (CAR ARG2))) ) + (SETQ TYP () ) ;Resultant is of NOTYPE + (GO XITF)) + ('T (SETQ KTYPE (COND ((NULL KTYPE) TYP) ;KTYPE is set to () + ((NULL TYP) KTYPE) ; only if a conflict is found + ((EQ KTYPE TYP) + (SETQ TEM + (CDR (P1AEVAL + FUN + (CDR XPR) + SAVXPR + () + () ))) + (AND TEM + (SETQ XPR TEM) + (GO XITF)) + KTYPE)))))) + ((AND (EQ NUMBERP 'NOTYPE) + (MEMQ FUN '(PLUSP MINUSP ZEROP))) + (SETQ KTYPE (OR (CDR (NUMTYP (CADR XPR) 'T)) + 'FIXNUM)))) + (SETQ TYP () ) + (SETQ XPR (MAPCAR '(LAMBDA (X) + (SETQ X (P1 X)) + (PUSH (OR (CDR X) KTYPE) TYP) + (CAR X)) + (CDR XPR)) + TYP (SAMETYPES TYP)) + (OR (MEMQ TYP '(() FIXNUM FLONUM)) + (SETQ TYP (NREVERSE TYP))) ) + (SETQ XPR (CONS FUN (CONS TYP XPR))) + (COND (ARITHFUNP ;Catches =, <, > + (AND (CADR ARITHFUNP) + (BARF SAVXPR |ARITHP function came too far - P1ARITH|)) + (AND (NOT (MEMQ TYP '(FIXNUM FLONUM))) + #%(PDERR SAVXPR |Mixed modes|)) + (RPLACA XPR (CAR ARITHFUNP)) + (RPLACA (CDR XPR) TYP) + (SETQ TYP () ) + (GO XITF))) + (SETQ KNOW-ALL-TYPES #%(KNOW-ALL-TYPES TYP)) + A-EQ + (CASEQ FUN + (EQUAL + (COND ((COND (KNOW-ALL-TYPES (NOT (ATOM TYP))) + ((NULL TYP) () ) + ((NOTNUMP (COND ((CADDR TYP) (CADDDR XPR)) + ('T (CADDR XPR)))) + (RPLACA (CDR XPR) () ) + 'T)) + (WARN SAVXPR |This EQUAL test will never come up true| 4 5)) + ((AND (NOT KNOW-ALL-TYPES) TYP) + (RPLACA (CDR XPR) () )) + ((OR (P1EQQTE (CADDR XPR)) (P1EQQTE (CADDDR XPR))) + (RPLACA XPR 'EQ) + (RPLACA (CDR XPR) (SETQ TYP () )))) + (GO XIT)) + (EQ + (COND (TYP (WARN SAVXPR |EQ of a number - EQUAL assumed| 4 5) + (RPLACA XPR (SETQ FUN 'EQUAL)) + (GO A-EQ))) + (GO XIT)) + (FLOAT + (COND ((EQ TYP 'FLONUM) (SETQ XPR (CADDR XPR))) + ((EQ TYP 'FIXNUM) + (SETQ TEM (P1AEVAL FUN (CDDR XPR) SAVXPR () () )) + (AND TEM (SETQ XPR (CDR TEM))))) + (SETQ TYP 'FLONUM) + (GO XITF)) + ((FIX IFIX) + (AND (EQ KTYPE 'FLONUM) + (PROG2 (P1ARG-WRNTYP SAVXPR) (SETQ TYP () ))) + (COND ((EQ TYP 'FIXNUM) (SETQ XPR (CADDR XPR)) (GO XITF)) + ((EQ TYP 'FLONUM) + (SETQ TEM (P1AEVAL FUN (CDDR XPR) SAVXPR () () )) + (AND TEM + (EQ (TYPEP (CADR (SETQ TEM (CDR TEM)))) + 'FIXNUM) + (SETQ XPR TEM TYP 'FIXNUM) + (GO XITF)))) + (SETQ TYP (COND ((OR (EQ KTYPE 'FIXNUM) FIXSW) + (RPLACA XPR (SETQ FUN 'IFIX)) + 'FIXNUM) + ((EQ FUN 'IFIX) 'FIXNUM))) + (GO XITF))) + (AND (COND ((EQ FUN 'REMAINDER) + (COND ((EQ TYP 'FIXNUM) () ) + ('T (SETQ KNOW-ALL-TYPES () TYP () ) + (RPLACA (CDR XPR) () ) + 'T))) + ((AND (NOT KNOW-ALL-TYPES) (NOT CLOSED)))) + (NOT MUZZLED) + #%(WARN SAVXPR |Closed compilation forced| 4 5)) + (COND ((AND (NOT KNOW-ALL-TYPES) ;Convert (PLUS A B) + (CDDDR XPR) ;into (*PLUS A B) + (NULL (CDDDDR XPR)) ;If not open-coded + (SETQ TEMP (MEMASSQR (CAR XPR) '((*PLUS . PLUS) + (*TIMES . TIMES) + (*DIF . DIFFERENCE) + (*QUO . QUOTIENT) + (*LESS . LESSP) + (*GREAT . GREATERP))))) + (SETQ XPR (CONS (CAAR TEMP) (CDR XPR)))) + ((AND (NOT KNOW-ALL-TYPES) ;This should exclude + (GET (CAR XPR) 'LSUBR)) ; PLUS TIMES etc. + (SETQ XPR (P1GLM1 () + XPR + 0 + (COND ((MEMQ 'FLONUM TYP) 'FLONUM) ;CONTAGIOUS FLOATING + (KTYPE)) + () )) + (SETQ CNT (1+ CNT)) + (SETQ TYP (AND ARITHP (PROG2 () (CDR XPR) (SETQ XPR (CAR XPR))))) + (SETQ XPR (LIST XPR)) + (GO XITF)) + ((AND KNOW-ALL-TYPES + (SETQ TEM (P1AEVAL FUN (CDDR XPR) SAVXPR () () ))) + (SETQ XPR (CDR TEM)) + (GO XITF))) + (COND ((AND (CDR (SETQ TEM (CDDR XPR))) ;Precisely 2 args + (NULL (CDDR TEM)) + (MEMQ FUN '(*DIF DIFFERENCE *PLUS PLUS ; to rational op + *TIMES TIMES *QUO QUOTIENT)) + (OR (Q0P+0P (CAR TEM)) + (Q0P+0P (CADR TEM)) + (Q1P+1P-1P (CAR TEM)) + (Q1P+1P-1P (CADR TEM)))) + (COND ((AND (NOT KNOW-ALL-TYPES) ;rational op, merely + (MEMQ 'FLONUM TYP)) ;to cause FLOATing, + (AND (COND ((COND ((NOT (EQ (CAR TYP) 'FLONUM)) + () ) + ((MEMQ FUN '(*PLUS PLUS)) + (Q0P+0P (CAR TEM))) + ((MEMQ FUN '(*TIMES TIMES)) + (AND (Q1P+1P-1P (CAR TEM)) + (= (CADR (CAR TEM)) 1.0)))) + (SETQ XPR (CADR TEM) TYP (CADR TYP)) + 'T) + ((COND ((NOT (EQ (CADR TYP) 'FLONUM)) + () ) + ((MEMQ FUN '(*PLUS PLUS *DIF DIFFERENCE)) + (Q0P+0P (CADR TEM))) + ((MEMQ FUN '(*TIMES TIMES *QUO QUOTIENT)) + (AND (Q1P+1P-1P (CADR TEM)) + (= (CADR (CADR TEM)) 1.0)))) + (SETQ XPR (CAR TEM) TYP (CAR TYP)) + 'T)) + (SETQ XPR `(FLOAT ,typ ,xpr) FUN 'FLOAT) + (GO A-EQ)) ) + ((AND KNOW-ALL-TYPES (MEMQ TYP '(FIXNUM FLONUM))) + (AND (COND ((COND ((NOT (MEMQ FUN '(*DIF DIFFERENCE))) () ) + ((Q0P+0P (CAR TEM)) + (SETQ FUN 'MINUS TEM (CADR TEM)) + 'T) + ((SETQ TEMP (Q1P+1P-1P (CADR TEM))) + (SETQ FUN (COND ((PLUSP TEMP) 'SUB1) ('ADD1)) + TEM (CAR TEM)) + 'T))) + ((COND ((NOT (MEMQ FUN '(*PLUS PLUS))) () ) + ((SETQ TEMP (Q1P+1P-1P (CADR TEM))) + (SETQ TEM (CAR TEM)) + 'T) + ((SETQ TEMP (Q1P+1P-1P (CAR TEM))) + (SETQ TEM (CADR TEM)) + 'T)) + (SETQ FUN (COND ((PLUSP TEMP) 'ADD1) ('SUB1))) + 'T)) + (SETQ XPR `(,fun ,typ ,tem)) + (GO XITF)))))) + + XIT (SETQ TYP (COND ((EQ FUN 'HAULONG) 'FIXNUM) + ((EQ NUMBERP 'NOTYPE) + (AND (NULL EFFS) KTYPE (P1ARG-WRNTYP SAVXPR)) + ()) + (CLOSED (RPLACA (CDR XPR) () ) () ) ;All ARITHP types taken earlier + ((ATOM TYP) (OR TYP KTYPE)) ;Only NUMBERP types come here + ((MEMQ 'FLONUM TYP) 'FLONUM) + ((AND (MEMQ 'FIXNUM TYP) + (OR (EQ FUN 'REMAINDER) + (AND (EQ FUN 'GCD) (CAR TYP) (CADR TYP)))) + 'FIXNUM) + (KTYPE))) + XITF (AND ARITHP (SETQ XPR (CONS XPR TYP))) + (RETURN P1LSQ))) + XPR) + + +(DEFUN P1AEVAL (FUN ARGL SAVXPR TYP ARITHFUNP) ;Called only + (PROG (TEM VAL OTHERS ALL-CNSTNTS-P LOSERP COMMUP NO-CNSTNTS) ; by "P1ARITH" + (DECLARE (FIXNUM NO-CNSTNTS)) + (SETQ NO-CNSTNTS 0 + ALL-CNSTNTS-P 'T + COMMUP (MEMQ FUN '(TIMES PLUS))) + (MAPC '(LAMBDA (X) + (COND ((OR (ATOM X) (NOT (EQ (CAR X) 'QUOTE))) ;Already P1'd + (SETQ ALL-CNSTNTS-P () )) + ((OR (NOT (NUMBERP (CADR X))) + (AND ARITHFUNP (NOT (EQ (TYPEP (CADR X)) TYP)))) + (AND (NOT (EQ (CAADR X) SQUID)) + (SETQ LOSERP 'T)) + (SETQ ALL-CNSTNTS-P () )) + ('T (SETQ NO-CNSTNTS (1+ NO-CNSTNTS))))) + ARGL) + (COND ((AND (NOT LOSERP) + ALL-CNSTNTS-P + (ERRSET (SETQ LOSERP 'T + TEM (EVAL (CONS FUN ARGL))) + () ) + (OR (NULL TYP) (EQ (TYPEP TEM) TYP))) + (RETURN `(QUOTE . ',tem))) + ((AND (NOT LOSERP) ;Partial computations of + (NOT ALL-CNSTNTS-P) ; constants - like (+ 3 x 4) + TYP ; but dont try on predicates + (> NO-CNSTNTS 1) ; or mixed modes. + (NOT (MEMQ FUN '(// //$ QUOTIENT *QUO))) + (ERRSET + (PROGN + (cond ((setq tem (cdr (assq fun '((- . +) + (-$ . +$) + (DIFFERENCE . PLUS) + (*DIF . PLUS))))) + (setq tem (P1AEVAL tem (cdr argl) savxpr typ arithfunp)) + (cond ((and (eq (car tem) 'QUOTE) + (eq (typep (caddr tem)) typ)) + (setq tem (list (cdr tem)))) + ((eq (car tem) 'ARGS) + (setq tem (cdr tem)))) + (and tem + (setq argl `(,(car argl) ,.tem)))) + ('T (SETQ LOSERP 'T OTHERS () TEM ()) + (MAPC + '(LAMBDA (X) + (COND ((OR (ATOM X) + (NOT (EQ (CAR X) 'QUOTE)) + (NOT (NUMBERP (CADR X)))) + (PUSH X OTHERS)) + ((NULL TEM) (SETQ TEM (CADR X))) + ('T (SETQ TEM (FUNCALL FUN TEM (CADR X)))))) + ARGL) + (cond ((EQ (TYPEP TEM) TYP) + (setq argl `(',tem ,.(nreverse others))) + (setq tem 'T)) + ('T (setq tem () ))))) + 'T) + () ) + tem) + (RETURN `(ARGS ,.argl))) + (LOSERP + (PDERR SAVXPR |Illegal arithmetic construction|) + (RETURN (OR (CDR (ASSQ TYP '((FIXNUM . (QUOTE . '0)) + (FLONUM . (QUOTE . '0.0))))) + '(QUOTE . '() ))))))) + + + + +(COMMENT P1BINDARG and P1BOOL1ABLE) + +(DEFUN P1BINDARG (SPFL VAR OARG KTYPE) + ((LAMBDA (TYP ARG ARITHP PNOB EFFS) + (COND ((GET VAR '+INTERNAL-STRING-MARKER) + (PDERR (LIST VAR OARG) + |Pseudo-strings aren't good lambda variables|))) + (SETQ TYP KTYPE) + (COND ((AND SPFL (NULL TYP)) (SETQ ARITHP () ) (P1 OARG)) ;SPECIAL, non-numeric var + (TYP + (SETQ ARG (P1 OARG)) + (COND ((COND ((CDR ARG) (NOT (EQ (CDR ARG) TYP))) + ((QNILP (CAR ARG)) + #%(WARN (LIST VAR OARG) + |Binding number variable to NIL may be a bug|) + () ) + ((NOTNUMP (CAR ARG)))) + (PDERR (LIST VAR OARG) + |Binding number variable to quantity of wrong type|) + (COND ((EQ TYP 'FIXNUM) ''1) (''1.0))) + ((CAR ARG)))) + ((COND ((NULL (SETQ ARG (NUMTYP OARG () ))) () ) ;Local-list-type-var being + ((EQ (SETQ TYP (TYPEP (CAR ARG))) 'SYMBOL) ; bound to something that + (NOT (SPECIALP (CAR ARG)))) ; just might be a PDLNUM + ((EQ TYP 'LIST) (NOT (EQ (CAAR ARG) 'COND))) + ((NOT (MEMQ TYP '(FIXNUM FLONUM))))) + (SETQ ARG (P1 OARG)) + (NLNVEX VAR + (COND ((CDR ARG) + (SETQ CNT (+ CNT 2)) + (CADR (SETQ ARG (LIST 'SETQ (NLNVCR VAR (CDR ARG)) (CAR ARG))))) + ('T (P2UNSAFEP (SETQ ARG (CAR ARG)))))) + ARG) + ('T (SETQ PNOB VAR ARG (P1 OARG) OARG (P2UNSAFEP (CAR ARG))) + (AND OARG + (OR (NOT (ATOM OARG)) (NUMERVARP OARG)) ;See note below + (NLNVEX VAR OARG)) + (CAR ARG)))) + () () 'T () () )) + +;;; Note: We dont want a var X to get unsafe just because it occurs somewhere (SETQ X Y) +;;; and Y is unsafe [where both X and Y are LLTVS + +(DEFUN P1BOOL1ABLE (X) + (COND ((OR (ATOM X) (NOT (ATOM (CAR X)))) () ) + ((EQ (CAR X) 'PROG2) (AND (NULL (CDDDR X)) (P1BOOL1ABLE (CADDR X)))) + (((LAMBDA (PROP) + (COND ((NULL PROP) () ) + ((EQ PROP 'NUMBERP) + (COND ((AND P2P (MEMQ (CADR X) '(FIXNUM FLONUM))) X) + (CLOSED () ) + ((NULL P2P) X))) + ('T X))) ;PROP must be either T or A fixnum here + (GET (CAR X) 'P1BOOL1ABLE))))) +;;; On P1, when it is the "numberp" case such as "PLUSP, or "GREATERP", +;;; this may answer yes falsely, since we dont know whether or not +;;; all the arithmetics are of the same type + +(DEFUN P1BASICBOOL1ABLE (X) (AND (SETQ X (P1BOOL1ABLE X)) (NOT (MEMQ (CAR X) '(AND OR MEMQ COND))))) + + + + +(COMMENT P1CARCDR) + +(DEFUN P1CARCDR (X) + (PROG (Y TEM) + (COND ((OR (NULL (CDR X)) (CDDR X)) + #%(PDERR X |Wrong number of arguments|) + (SETQ Y ''() ) (GO XIT))) + (SETQ Y (P1VAP (CADR X) () )) + (AND (CDR Y) + (PDERR X |Attempt to take CAR or CDR of a numeric quantity|)) + (SETQ Y (CAR Y)) + (COND ((AND (SETQ TEM (NOT (ATOM Y))) ;(CAR (CDR X)) + (NOT (ATOM (CAR Y))) ;GOES FIRST INTO + (EQ (CAAR Y) CARCDR)) ;(CAR ((CARCDR D) X)) THEN TO + (NCONC (CAR Y) (P1CCEXPLODE (CAR X)))) ;((CARCDR D A) X) + ((AND TEM (EQ (CAR X) 'CDR) (EQ (CAR Y) 'RPLACD)) + (SETQ Y (CONS (CONS MAKUNBOUND '(RPLACD)) (CDR Y)))) + ('T (SETQ Y (LIST (CONS CARCDR (P1CCEXPLODE (CAR X))) Y)))) + XIT (RETURN (COND (ARITHP (NCONS Y)) (Y))))) + +(DEFUN P1CARCDR-CHASE (X) + (COND ((ATOM X) X) + ((NULL (CDR X)) () ) + ((CDDR X) () ) + ((AND (SYMBOLP (CAR X)) (|carcdrp/|| (CAR X))) + (P1CARCDR-CHASE (CADR X))))) + +(DEFUN P1CCEXPLODE (FUN) + (DO ((FUN (|carcdrp/|| FUN) (|carcdrp/|| FUN)) (L)) + ((NULL FUN) L) + (PUSH (CAR FUN) L) + (SETQ FUN (CADR FUN)))) + + +(DEFUN P1ITERLIST (L FL) + (COND ((NULL (CDR L)) (COND (FL (CAR L)) ((LIST 'NCONS (CAR L))))) + ('T (LIST 'CONS (CAR L) (P1ITERLIST (CDR L) FL))))) + + +(COMMENT P1COND) + +;;; The CONDTYPE var has a rigid format - see P1TYPE-ADD + +(DEFUN P1COND (FUN X) + (PROG (P1VARS P1CNT BODY CONDTYPE CONDUNSF CONDPNOB + CONDP P1CSQ LMBP P1LSQ P1CCX ARITHP) + (SETQ P1VARS LOCVARS P1CNT CNT CONDP 'T P1CCX 0) + (SETQ BODY (XCONS (MAPLIST '(LAMBDA (X) + (IF (EQ FUN 'COND) + (P1CDC (CAR X) X) + (P1AOC X))) + X) + (COND ((NOT (EQ FUN 'COND)) () ) + ((NULL (CDR CONDTYPE)) KTYPE) + ((NULL KTYPE) + (COND ((CDDR CONDTYPE) () ) + ((AND (CAR CONDTYPE) + (EQ (CAR CONDTYPE) (CADR CONDTYPE))) + (CAR CONDTYPE)) + (CONDTYPE))) + ((OR (CDDR CONDTYPE) + (NOT (EQ KTYPE (CADR CONDTYPE))) + (AND (CAR CONDTYPE) + (NOT (EQ KTYPE (CAR CONDTYPE))))) + (PDERR (CONS FUN X) |COND has clause of wrong numeric type|) + () ) + (KTYPE)))) + (SETQ X (CONS FUN (CONS P1CCX (CONS P1CSQ (CONS CONDUNSF BODY))))) + (P1SYNCHRONIZE-CNTS P1CNT P1VARS)) + (P1SQE (CADDR X)) + (COND (ARITHP (OR (ATOM (SETQ FUN (CADDDR (CDR X)))) (SETQ FUN () )) (CONS X FUN)) + (X))) + +(DEFUN P1AOC (J) +;;; Compile a piece in an AND-OR clause, or the first part of a COND clause + (COND ((P1BOOL1ABLE (CAR J)) (P1E (CAR J))) + ;If MEMQ is not BOOL1ABLE, then it would need a special check in + ; order for (MEMQ X '(A B)) to go into (OR (EQ X A) (EQ X B)). + ('T (and (cdr j) (p1nonumck (car j))) + (P1VN (car J))))) + +(defun p1nonumck (j) + (if (numtypep j () ) + (WARN j |Using this numeric quantity in a predicate position| 3 5)) + () ) + +(DEFUN P1CDC (J clauses) ;P1s COND clause analyzer + (COND ((NOT (EQ (TYPEP J) 'LIST)) + (PDERR J |Random COND clause|) + '( '() ) ) + ((COND ((NULL (CDR J))) + ((CDDR J) () ) ;Singleton COND clause, or + ((AND (OR (EQ (CADR J) 'T) ; like ((EQ X Y) T) or + (AND (NOT (ATOM (CADR J))) ; ((NULL BARF) (QUOTE T)) + (EQ (CAADR J) 'QUOTE) + (EQ (CADADR J) 'T))) ;All converted to singleton + (P1BASICBOOL1ABLE (CAR J))) ; like (foobar) + (SETQ J (LIST (CAR J))) + 'T)) + (COND ((ATOM (CAR J)) + (if (cdr clauses) (p1nonumck (car j))) + (P1CJ J)) + ((MEMQ (CAAR J) '(GO RETURN)) (P1CDC (CONS 'T J) clauses)) + (EFFS (if (cdr clauses) (p1nonumck (car j))) + ;; Note that P1AOC wont check here, since (null (cdr j)) + (LIST (P1AOC J))) + ((OR (P1BASICBOOL1ABLE (CAR J)) + (AND (EQ (CAAR J) 'OR) + (CDAR J) + (CDDAR J) + (P1BASICBOOL1ABLE (CADDAR J)) + (P1BASICBOOL1ABLE (CADR J)))) + (CONS (P1E (CAR J)) (P1CJ '(T)))) + ('T (P1CJ J)))) + ((AND (NOT EFFS) + (NULL (CDDR J)) ;((NULL FOO) () ) + (OR (EQ (CAAR J) 'NULL) (EQ (CAAR J) 'NOT)) + (OR (NULL (CADR J)) (QNILP (CAAR J))) + (OR (NOT (P1BOOL1ABLE (CADAR J))) (EQ (CAADAR J) 'MEMQ))) + (p1nonumck (cadar j)) + (NREVERSE (CONS NULFU (P1CJ (CDAR J))))) + ('T + (IF (AND (NULL (CDR CLAUSES)) (NUMBERP (CAR J))) + (SETQ J `(',(car j) ,. (cdr j)))) + (CONS (P1AOC J) + (COND ((NULL (CDDR J)) (P1CJ (CDR J))) + ('T (SETQ J (L2F (CDR J))) + (NRECONC (DO ((LL (CDR J) (CDR LL)) + (Z) (ARITHP) (EFFS 'T) (KTYPE)) + ((NULL LL) Z ) + (PUSH (P1 (CAR LL)) Z)) + (P1CJ J)))))))) + + +(DEFUN P1CJ (J) + ((LAMBDA (ARITHP MODE FL) + (SETQ J (P1 (CAR J))) + (COND (ARITHP + (SETQ MODE (CDR J) J (CAR J)) + (SETQ P1CCX (PLUS P1CCX (P1TRESS J))) + (COND ((NOT (SETQ FL (P2UNSAFEP J)))) + ((NOT (ATOM FL)) (SETQ CONDUNSF (LADD FL CONDUNSF) FL 'T)) + ((NULL (VARMODE FL)) (PUSH FL CONDUNSF) (SETQ FL () )) + ('T (SETQ FL GOFOO) ;Local numeric type vars are always unsafe + (PUSH 'T CONDUNSF))) ; so dont need to put explicitly on UNSFLST + (SETQ CONDTYPE (P1TYPE-ADD CONDTYPE MODE)))) + (COND ((AND PNOB ;If a PDL number is in order + MODE ; and val is numeric, + (NOT (EQ FL GOFOO)) ; but not fixnumvar + (OR FL (P1CJ-NUMVALP J))) ; then might need NLNVTHTBP + (AND (NULL CONDPNOB) (SETQ CONDPNOB (CONS () () ))) + (SETQ CNT (+ CNT 2) FL () ) + (SETQ MODE (COND ((EQ MODE 'FIXNUM) + (AND (NULL (CAR CONDPNOB)) + (RPLACA CONDPNOB (SETQ FL (NLNVFINDCR MODE 'COND)))) + (CAR CONDPNOB)) + ((EQ MODE 'FLONUM) + (AND (NULL (CDR CONDPNOB)) + (RPLACD CONDPNOB (SETQ FL (NLNVFINDCR MODE 'COND)))) + (CDR CONDPNOB)))) + ;MODE now has name of NLNVTHTBP, either FIXNUM or FLONUM, for the wings of the COND + ;FL is non-null if name is newly created + (AND FL (NOT (EQ CONDUNSF 'T)) (PUSH MODE CONDUNSF)) + (SETQ J (CONS 'SETQ (LIST MODE J))))) + (NCONS J)) + (NOT EFFS) () () )) + + +;;; Basically, a PHASE2 type analyzer, except that quoted numbers +;;; and variables are ignored. Called only by P1CJ. + +(DEFUN P1CJ-NUMVALP (FORM) + (COND ((ATOM FORM) () ) + ((NOT (ATOM (CAR FORM))) + (COND ((EQ (CAAR FORM) 'LAMBDA) (P1CJ-NUMVALP (CADDDR (CDDAR FORM)))) + ((EQ (CAAR FORM) COMP) + (AND (MEMQ (CADAR FORM) '(FIXNUM FLONUM)) (CADAR FORM))))) + ((MEMQ (CAR FORM) '(SETQ QUOTE)) () ) + ((EQ (CAR FORM) 'PROG2) (P1CJ-NUMVALP (CADDR FORM))) + ((OR (EQ (CAR FORM) 'PROGN) (EQ (CAR FORM) PROGN) (EQ (CAR FORM) 'PROGV)) + (P1CJ-NUMVALP (CAR (LAST (CDR FORM))))) + ((AND (SETQ FORM (NUMFUNP FORM () )) (NOT (EQ FORM 'T))) FORM))) + +(COMMENT P1CASEQ) + +(defvar *:TRUTH 'T "NACOMPLR will override this") + +(DEFUN P1CASEQ (X) + (PROG (KEYFORM LFORM EXP TYPE-PRED TEM LL CLAUSES) + (DECLARE (SPECIAL KEYFORM TYPE-PRED)) + (SETQ EXP (CDR X)) + (POP EXP KEYFORM) + (AND (OR (NULL KEYFORM) (NUMBERP KEYFORM) (ATOM EXP) (ATOM (CAR EXP))) + (RETURN () )) + (COND ((NOT (PAIRP KEYFORM))) + ((OR (NOT (P1CARCDR-CHASE KEYFORM)) ;Wrap a LAMBDA around it + (> (FLATC (CAR KEYFORM)) 4) ; if not "simple". + (NOT (ATOM (CADR KEYFORM)))) + (SETQ TEM (GENSYM)) + (SETQ LFORM (LIST (LIST 'LAMBDA (LIST TEM) NULFU) KEYFORM)) + (SETQ KEYFORM TEM))) + (SETQ TYPE-PRED (ASSQ (TYPEP (COND ((PAIRP (CAAR EXP)) (CAAAR EXP)) + ('T (CAAR EXP)))) + '((SYMBOL . EQ) (FIXNUM . =) (FLONUM . =)))) + (AND (NULL TYPE-PRED) (RETURN () )) + (SETQ LL EXP CLAUSES () ) + A (COND (LL (PUSH (CONS (COND ((ATOM (CAR LL)) (RETURN () )) + ((EQ (CAAR LL) *:TRUTH) ''T) + ((NOT (PAIRP (CAAR LL))) + (COND ((EQ (CAAR LL) 'T) + ''T) + ((P1CASEQ-CLAUSE (CAAR LL))) + ('T (RETURN () )))) + ('T (SETQ TEM (MAPCAR 'P1CASEQ-CLAUSE + (CAAR LL))) + (AND (MEMQ () TEM) (RETURN () )) + (COND ((NULL (CDR TEM)) (CAR TEM)) + ((CONS 'OR TEM))) )) + (CDAR LL)) + CLAUSES) + (POP LL) + (GO A))) + (SETQ EXP (CONS 'COND (NREVERSE CLAUSES))) + (RETURN (COND (LFORM (RPLACA (CDDAR LFORM) EXP) LFORM) + (EXP))) )) + + +(DEFUN P1CASEQ-CLAUSE (X) + (DECLARE (SPECIAL TYPE-PRED KEYFORM)) + (COND ((NOT (EQ (TYPEP X) (CAR TYPE-PRED))) () ) + ('T (LIST (CDR TYPE-PRED) KEYFORM (LIST 'QUOTE X))))) + + + +(COMMENT P1DO) + +(DEFUN P1DO (XX) + (PROG (INDXL ENDTST ENDVAL TG1 TAG3 PVARS LVARS STEPDVARS LVALS BODY DECL X) + (SETQ X (CDR XX)) + (COND ((AND (CAR X) (ATOM (CAR X))) + (SETQ INDXL (LIST (LIST (POP X) (POP X) (POP X))) + ENDTST (POP X) + ENDVAL () + TG1 (LIST (GENSYM)))) + ('T (SETQ INDXL (REVERSE (POP X))) + (COND ((SETQ ENDTST (POP X)) + (SETQ ENDVAL (COND ((OR (NULL (CDR ENDTST)) + (NULL (CADR ENDTST)) + (AND (NOT (ATOM (CADR ENDTST))) + (QNILP (CADR ENDTST)))) + () ) + ('T (REVERSE (CDR ENDTST)))) + ENDTST (CAR ENDTST) + TG1 (LIST (GENSYM)))) + ('T (SETQ ENDTST CLPROGN))))) + (MAPC '(LAMBDA (X) (COND ((COND ((ATOM X)) + ((NULL (CDR X)) (SETQ X (CAR X)) 'T)) + (PUSH X PVARS)) + ('T (PUSH (CAR X) LVARS) + (PUSH (CADR X) LVALS) + (AND (CDDR X) (PUSH X STEPDVARS)) + (AND (CDDDR X) (SETQ XX () )) + (SETQ X (CAR X)))) + (AND (NOT (SYMBOLP X)) (SETQ XX () ))) + INDXL) + (AND (NULL XX) (RETURN () )) + (AND (NOT (ATOM (CAR X))) + (EQ (CAAR X) 'DECLARE) + (POP X DECL)) + (SETQ BODY (LIST + (NCONC (LIST 'PROG PVARS) + TG1 + (AND (AND TG1 ENDTST) + (OR (ATOM ENDTST) (NOT (QNILP ENDTST))) + (LIST + (LIST + 'COND + (CONS ENDTST + (COND ((NULL ENDVAL) '((RETURN () ))) + (TAG3 (LIST (LIST 'GO TAG3))) + ('T (P1DO-RETURN ENDVAL))))))) + (APPEND X () ) + (AND STEPDVARS (LIST (P1DO-STEPPER STEPDVARS))) + (LIST (COND (TG1 (LIST 'GO (CAR TG1))) + ((EQ ENDTST CLPROGN) '(RETURN () )) + ((DBARF XX |Bad DO format|)) )) + (AND TAG3 (CONS TAG3 (P1DO-RETURN ENDVAL)))))) + (AND DECL (SETQ BODY (CONS DECL BODY))) + (RETURN (CONS (CONS 'LAMBDA (CONS LVARS BODY)) LVALS)))) + + +(DEFUN P1DO-RETURN (ENDVAL) + (NREVERSE (CONS (LIST 'RETURN (CAR ENDVAL)) (CDR ENDVAL)))) + +(DEFUN P1DO-STEPPER (L) + (LIST 'SETQ + (CAAR L) + (COND ((NULL (CDR L)) (CADDAR L)) + ((LIST 'PROG2 () (CADDAR L) (P1DO-STEPPER (CDR L))))))) + +(COMMENT Random P1 helper funs in the E and F range) + +(DEFUN P1EQQTE (Z) + (AND (NOT (ATOM Z)) + (EQ (CAR Z) 'QUOTE) + (SYMBOLP (CADR Z)))) + +(DEFUN P1E (X) ((LAMBDA (EFFS) (P1 X)) 'T)) + +(DEFUN P1E1 (X) +; Called only from P1PROG +; Tries to factor out a SETQ from a COND - for example, +; (COND ((AND (SETQ X (FOO)) ALPHA) (RETURN () ))) +; goes into +; (PROG2 (SETQ X (FOO)) (COND ((AND X ALPHA) (RETURN () )))) + (COND ((OR PRSSL (NOT (MEMQ (CAR X) '(COND AND OR)))) (P1 X)) + (((LAMBDA (DATA TEM F) + (AND (SETQ DATA (P1HUNOZ (SETQ TEM (COND (F (CADR X)) + ((CDR X)))))) + (OR (MEMQ (CADR DATA) BVARS) + (ASSQ (CADR DATA) RNL)) + (P1 (PROG2 (SETQ TEM (P1HUNOZ TEM)) + (LIST 'PROG2 + DATA + (CONS (CAR X) + (COND (F (CONS TEM (CDDR X))) + (TEM)))))))) + () () (EQ (CAR X) 'COND))) + ((P1 X)))) + +(DEFUN P1HUNOZ (Y) (COND ((OR (ATOM (CAR Y)) + (NULL (CDAR Y)) + (NOT (ATOM (CAAR Y))) + (ASSQ (CAAR Y) MACROLIST)) + (AND DATA Y)) + ((EQ (CAAR Y) 'SETQ) (COND (DATA (CONS (P1FV (CDAR Y)) (CDR Y))) + ('T (CAR Y)))) + ((GETL (CAAR Y) '(FEXPR FSUBR *FEXPR MACRO)) (AND DATA Y)) + (DATA (CONS (CONS (CAAR Y) (P1HUNOZ (CDAR Y))) (CDR Y))) + ((P1HUNOZ (CDAR Y))))) + +(DEFUN P1F (F L) +; PATCH UP FOR FORMS OF (EVAL (CONS 'FSUBR LIST)) + (AND (P1KNOWN F '(FSUBR *FEXPR)) (CONS (CONS MAKUNBOUND (CONS 'FSUBR (CADR F))) L))) + +(DEFUN P1FAKE (X) +; Convert FOO into ((LAMBDA () FOO)) so that +; the setq count and clearing action of LAMBDA +; form will be done for FOO + ((LAMBDA (F ZZ) + (SETQ ZZ (CDDAR F)) + (RPLACA ZZ (ADD PROGN (CAR ZZ))) ;Make it appear as though + (RPLACA (CADDDR ZZ) (CAR X)) ; the unknown function is + (P1MODESET F)) ; of high "severity" + (P1VN (LIST (LIST 'LAMBDA () (CONS NULFU (CDR X))))) + () )) + +(DEFUN P1FV (X) + (COND ((AND (CDR X) (CDDR X)) (P1FV (CDDR X))) + ((CAR X)))) + + +(DEFUN P1FUNGET (FUN) ;Idea is to convert '(LAMBDA . . .) + (PROG () ; to (FUNCTION (LAMBDA . . .)) + A (COND ((ATOM FUN)) + ((EQ (CAR FUN) 'FUNCTION) (RETURN FUN)) + ((EQ (CAR FUN) 'QUOTE) (RETURN (CONS 'FUNCTION (CDR FUN)))) + ((NOT (EQ (SETQ FUN (P1MACROGET FUN)) NULFU)) (GO A))))) + +(DEFUN P1GFY (X FL) + (COND ((ATOM X) + (OR (FUNTYP-DECODE X) (PUSH X UNDFUNS)) + X) + ('T (SETQ X (COMPILE (P1PFX) FL X () 'T)) + (AND (NOT FASLPUSH) (ICOUTPUT GOFOO)) + X))) + + +(DEFUN P1PFX () (MAKNAM (APPEND GENPREFIX (EXPLODEC (SETQ GFYC (ADD1 GFYC)))))) + + +(COMMENT P1LAM and P1GLM) + +(DEFUN P1LAM (F AARGS) + #%(LET ((LMBP 'T) (P1LLCEK P1LLCEK) + P1LL P1LSQ NEW-NLNVS BIND-ANALYZE-IN-OLD-ENV) + (SETQ BIND-ANALYZE-IN-OLD-ENV + (*FUNCTION (LAMBDA (VSS LL AARGS VMS) + (MAPCAR 'P1BINDARG VSS LL AARGS VMS)))) + #%(LET ((BVARS BVARS) (SPECVARS SPECVARS) (IGNOREVARS IGNOREVARS) + (MODELIST MODELIST) (RNL RNL) (NLNVS () ) + CONDP NLNVTHTBP TEM VSS VMS) + ;Binding BVARS MODELIST, SPECVARS, RNL, NLNVS, and NLNVTHTBP + ; after making the funarg protects against spurious propogation + ; of local declarations, and spurious NLNVASG warnings + ;WARNING! WARNING! Any variable augmented by local declaration + ; part of P1LMBIFY must be so bound here. + (SETQ F (P1LMBIFY (CADR F) () (CDDR F))) + (SETQ P1LL (CAR F) F (CDR F)) + ;This has caused P1LL to be set up properly (after RNL'd) + (AND P1LL (PUSH P1LL P1LLCEK)) + (COND ((NOT (ZEROP (SETQ TEM (- (LENGTH AARGS) (LENGTH P1LL))))) + (PDERR (CONS (CONS 'LAMBDA (CONS P1LL F)) AARGS) + |Wrong number of args to LAMBDA|) + (DO ((Z) (I TEM (1- I))) + ((SIGNP LE I) + (COND (Z + ;Following code taken from P1LMBIFY + (MAPC '(LAMBDA (Y) + (PUTPROP Y () 'OHOME) + (PUSH (CONS Y 0) LOCVARS) + (PUSH Y BVARS)) + Z) + (SETQ P1LL (NCONC Z P1LL))))) + (PUSH (GENSYM) Z)))) + (SETQ VSS (MAPCAR '(LAMBDA (X) (PUSH (VARMODE X) VMS) + (SPECIALP X)) + P1LL) + VMS (NREVERSE VMS)) + (SETQ AARGS (FUNCALL BIND-ANALYZE-IN-OLD-ENV VSS P1LL AARGS VMS)) + (SETQ TEM (P1GLM P1LL F)) + (P1SPECIALIZEDVS) ;Check for screw case + (SETQ CNT (1+ CNT)) + (SETQ AARGS (COND (ARITHP (RPLACA TEM (CONS (CAR TEM) AARGS))) + ((CONS TEM AARGS)))) + (AND (SETQ F (UUVP 'P1LL)) (WARN F |Unused LAMBDA variables|)) + (SETQ NEW-NLNVS NLNVS F P1LSQ)) + (COND ((NULL NLNVS) (SETQ NLNVS NEW-NLNVS)) + (NEW-NLNVS (SETQ NLNVS (NCONC NEW-NLNVS NLNVS)))) + (NLNVASG P1LL)) + (P1SQE F) + AARGS) + +(DEFUN P1GLM (LL BODY) + ((LAMBDA (T1 MODE FL) + (COND ((NULL (CDR BODY)) + (SETQ T1 (P1 (CAR BODY))) + (SETQ BODY (COND (ARITHP (CAR T1)) (T1)))) + ('T (SETQ BODY (P1L BODY EFFS ARITHP KTYPE)) + (SETQ T1 (CAR (SETQ FL (LAST BODY)))) + (AND ARITHP (RPLACA FL (CAR T1))) + (SETQ BODY (CONS PROGN BODY)))) + (AND ARITHP (SETQ MODE (CDR T1) T1 (CAR T1))) + (P1GLM1 LL + BODY + (COND ((OR EFFS (ZEROP (P1TRESS T1))) 0) (1)) + (OR MODE KTYPE) + (COND ((NULL (SETQ FL (P2UNSAFEP T1))) () ) + ((ATOM FL) (LIST FL)) + (FL)))) + () () () )) + +(DEFUN P1GLM1 (LL BODY N MODE UNSAFEP) + ((LAMBDA (T1) + (COND ((NOT ARITHP) T1) + ((CONS T1 MODE)))) + (LIST 'LAMBDA N P1LSQ (LIST SPECVARS MODELIST IGNOREVARS) + LL BODY CNT UNSAFEP NLNVTHTBP))) + + + + + +(DEFUN P1KNOWN (F L) + (AND (NOT (ATOM F)) + (MEMQ (CAR F) '(QUOTE FUNCTION)) + (ATOM (SETQ F (CADR F))) + (SETQ L (GETL F L)) + (IF (MEMQ (CAR L) '(SUBR FSUBR LSUBR)) + (SYSP (CADR L)) + 'T))) + + +(DEFUN P1L (X OEFFS OARITHP OKTYPE) + ((LAMBDA (EFFS ARITHP KTYPE) + (MAPLIST '(LAMBDA (X) + (AND (NULL (CDR X)) + (SETQ EFFS OEFFS ARITHP OARITHP KTYPE OKTYPE)) + (P1 (CAR X))) + X)) + 'T () () )) + + +(DEFUN P1LST (X) + (PROG (Z LL V) + (SETQ Z (CDR X)) + (COND ((MEMQ (CAR X) '(MEMBER ASSOC SASSOC)) ;CONVERT TO MEMQ, ASSQ, SASSQ IF POSSIBLE + (AND (OR (NULL (CADR Z)) (QNILP (CADR Z))) + (RETURN (P1 (LIST 'PROG2 (CAR Z) () )))) + (AND (COND ((P1EQQTE (CAR Z))) + ((NULL (SETQ LL (P1LST-LSTGET (CADR Z)))) () ) + ((NOT (DO Y LL (CDR Y) (NULL Y) + (AND (NOT (SYMBOLP (COND ((EQ (CAR X) 'MEMBER) (CAR Y)) + ('T (CAAR Y))))) + (RETURN 'T)))))) + (SETQ X (CONS (CDR (ASSQ (CAR X) '((MEMBER . MEMQ) + (ASSOC . ASSQ) + (SASSOC . SASSQ)))) + (CDR X)))))) + (COND ((NOT (AND EFFS + (EQ (CAR X) 'MEMQ) + (OR LL (SETQ LL (P1LST-LSTGET (CADR Z)))) + (LESSP (LENGTH LL) 5)))) + ((P1CARCDR-CHASE (SETQ V (CAR Z))) + (RETURN (P1 (CONS 'OR (MAPCAR '(LAMBDA (X) (LIST 'EQ V (LIST 'QUOTE X))) LL))))) + ((COND ((EQ (CAR V) 'SETQ) (SETQ LL V V (NX2LAST V)) 'T) + ((AND (EQ (CAR V) 'PROG2) + (AND (CDDR V) (NULL (CDDDR V))) + (P1CARCDR-CHASE (CADDR V))) + (SETQ LL (CADR V) V (CADDR V)) + 'T)) + (RETURN (P1 (LIST 'PROG2 LL (CONS 'MEMQ (CONS V (CDR Z)))))))) + (SETQ X (CONS (CAR X) (MAPCAR 'P1VN (CDR X)))) + (RETURN (COND (ARITHP (NCONS X)) (X))))) + +(DEFUN P1LST-LSTGET (Z) + (COND ((OR (ATOM Z) (NOT (EQ (CAR Z) 'QUOTE))) () ) + ((NULL (CADR Z)) () ) + ((NOT (EQ (TYPEP (CADR Z)) 'LIST)) (PDERR Z |Cant use this as 2nd arg to MEMQ|)) + ((CADR Z)))) + + +(COMMENT P1LMBIFY) +;Process an optional declaration in the body of a LAMBDA or PROG +; and process the lambda list, returning cons of new lambda-list onto +; a possibly truncated body. + +;WARNING WARNING!! P1LAM must bind any global lists which are augmented here. + +(DEFUN P1LMBIFY (LL TYPEL EXP) + (COND ((AND (NOT (ATOM (CAR EXP))) (EQ (CAAR EXP) 'DECLARE)) + ;Do the local declarations - augment SPECVARS, MODELIST + (MAPC '(LAMBDA (DATA) + (DO ((X (CDR DATA) (CDR X)) (TEMP) (ATOMP)) ;fix up for renamings of variables + ((NULL X)) + (COND ((SETQ TEMP (ASSQ (COND ((SETQ ATOMP (ATOM (CAR X))) + (CAR X)) + ((CAAR X))) + RNL)) + (RPLACA (COND (ATOMP X) ((CAR X))) (CDR TEMP))))) + (AND (COND ((MEMQ (CAR DATA) '(SPECIAL IGNORE FIXNUM FLONUM NOTYPE))) + ('T (PDERR DATA |Illegal local declaration|) () )) + (MAPC '(LAMBDA (X) + (COND ((ATOM X) + (COND ((AND (MEMQ X BVARS) + (NOT (MEMQ X LL))) + (PDERR DATA |Local declaration occurs too late in function|) + () ) + ((EQ (CAR DATA) 'SPECIAL) + (REMPROP X 'OHOME) + (AND (NOT (GET X 'SPECIAL)) + (PUSH (CONS X (LIST 'SPECIAL X)) + SPECVARS))) + ((EQ (CAR DATA) 'IGNORE) + (PUSH X IGNOREVARS)) + ((AND (GET X 'NUMVAR) + (EQ (GET X 'NUMVAR) (CAR DATA)))) + ((PUSH (CONS X (COND ((EQ (CAR DATA) 'NOTYPE) () ) + ((CAR DATA)))) + MODELIST)))) + ((VARMODE (CAR X)) + (PDERR DATA |Cant locally redeclare function|)) + ((AND (NULL (CDR X)) (EQ (CAR DATA) 'NOTYPE))) + ((PUSH `((,(car x)) ,. (nmpsubst (cdr x) (car data))) + MODELIST)))) + (CDR DATA)))) + (CDAR EXP)) + (SETQ EXP (CDR EXP)))) + (DO ((LLL LL (CDR LLL)) ;Process the LAMBDA-list + (TYP TYPEL (CDR TYP)) ;TYPEL comes from NUMFUN property + (ANS () (CONS VAR ANS)) + VAR ) + ((NULL LLL) (CONS (NREVERSE ANS) EXP) ) ;Return ((LAMBDA-list) . body) + (COND ((NULL (SETQ VAR (CAR LLL)))) + ((OR (MEMQ VAR '(T QUOTE)) (NOT (SYMBOLP VAR))) + (PDERR (LIST VAR 'FROM LL) |Not permissible in bound variable list|)) + ((MEMQ VAR (CDR LLL)) + (WARN (LIST VAR 'FROM LL) + |- Repeated in bound variable list| + 3 6))) + (COND ((NULL VAR)) + ((SPECIALP VAR)) + ((AND SPECIALS (NOT (GET VAR ':LOCAL-VAR))) + (PUTPROP VAR (LIST 'SPECIAL VAR) 'SPECIAL)) + ('T (COND ((ASSQ VAR LOCVARS) + (PUSH (CONS VAR (GENSYM)) RNL) + (AND (SETQ VAR (VARMODE VAR)) + (PUSH (CONS (CDAR RNL) VAR) MODELIST)) + (SETQ VAR (CDAR RNL)))) + (PUTPROP VAR () 'OHOME) ;Just to be sure that OHOME prop exists + (PUSH (CONS VAR 0) LOCVARS))) + (COND (VAR (PUSH VAR BVARS) + (AND TYP (CAR TYP) + (NOT (EQ (CAR TYP) (VARMODE VAR))) + (PUSH (CONS VAR (CAR TYP)) MODELIST)) )) )) + + + +(COMMENT P1MODESET and P1MACROGET) + +(DEFUN P1MODESET (XPR) + (COND ((NOT ARITHP) XPR) + ('T ((LAMBDA (TEMP FORM) + (CONS XPR + (COND ((ATOM FORM) (VARMODE FORM)) + ((AND (NOT (SETQ TEMP (ATOM (CAR FORM)))) + (NOT (EQ (CAAR FORM) 'LAMBDA))) + () ) + ((COND ((NOT TEMP) ;Implies a LAMBDA + (SETQ FORM (CADDR (CDDDAR FORM))) + (AND (NOT (ATOM FORM)) + (EQ (CAR FORM) PROGN) + (SETQ FORM (CAR (LAST FORM)))) + (COND ((ATOM FORM) (SETQ TEMP (VARMODE FORM)) 'T) + ((NOT (ATOM (CAR FORM))) (SETQ TEMP () ) 'T)))) + TEMP) + ((SETQ TEMP (OR (GET (CAR FORM) 'NUMFUN) (FUNMODE (CAR FORM)))) + (CADR TEMP))))) + () XPR)))) + + +(defun P1MACROGET (x) + ;;(NOT (ATOM X)) This has been ascertained in all the places of call + (if (or (not (symbolp (car x))) + (getl (car x) '(*EXPR *LEXPR *FEXPR)) + (and (get (car x) 'FUNTYP-INFO) + (not (eq (car (get (car x) 'FUNTYP-INFO)) 'MACRO)))) + NULFU + #%(let ((fun (find-macro-definition (car x)))) + (if (null fun) + NULFU + (let (fl) + (errset #%(let ((*RSET 'T)) + (setq fun (funcall fun x) + fl 'T)) + 'T) + (cond + (fl fun) + ('T (PDERR X |LISP error during MACRO expansion|) ''() ))))))) + + + +(COMMENT P1MAP) + +(DEFUN P1MAP (OX Z) + (PROG (KNOWN-CONSTANT-FUN? FUN-SYMBOL? CCSLD FUN X) + (SETQ X (CDR OX)) + A (SETQ KNOWN-CONSTANT-FUN? () CCSLD 'T) + (COND ((ATOM (SETQ FUN (CAR X)))) ;Random variable function + ((MEMQ (CAR FUN) '(QUOTE FUNCTION)) + #%(let (errfl) + (cond ((and (cadr fun) (symbolp (cadr fun))) + (setq fun-symbol? (cadr fun) + CCSLD (not (p1known fun-symbol? + '(SUBR FSUBR LSUBR))) + known-constant-fun? 'T) + (and (or (get fun-symbol? 'MACRO) + (assq fun-symbol? MACROLIST)) + (not (get fun-symbol? 'DEFCOMPLRMAC)) + (setq errfl 'T))) + ((setq known-constant-fun? (eq (caadr fun) 'LAMBDA))) + ('T (setq errfl 'T))) + (if errfl + (pderr ox |Function to MAP is macro, or randomness|)))) + ((NOT (EQ (SETQ FUN (P1MACROGET FUN)) NULFU)) + (SETQ X (CONS FUN (CDR X))) + (GO A))) + (AND KNOWN-CONSTANT-FUN? ;Convert '(LAMBDA FOO) + (NULL FUN-SYMBOL?) ; into #'(LAMBDA FOO) + (EQ (CAAR X) 'QUOTE) + (SETQ X `((FUNCTION ,(cadar x)) ,. (cdr x)))) + (and known-constant-fun? + (or (and mapex + (if fun-symbol? + (not (getl fun-symbol? '(FSUBR *FEXPR))) + 'T)) + (and (not fun-symbol?) + (eq (*catch 'CFVFL + (setq x `((QUOTE + ,#%(let ((CFVFL `((,BVARS . ,RNL) . ,CFVFL))) + (p1gfy (cadar x) 'LEXPR))) + ,.(CDR X)))) + 'CFVFL))) + (go MAPEXPAND)) + (AND CCSLD (P1SQV PROGN)) + (RETURN + (P1FAKE + (CONS (CONS + MAKUNBOUND + (CONS '*MAP (CONS CCSLD + (COND ((OR (CDDR X) (NULL (CDR Z))) Z) + ('T (CADR Z)))))) + X))) + + MAPEXPAND + (COND ((EQ (CAR Z) 'MAPATOMS) + (AND (NULL (CDR X)) (SETQ X (CONS (CAR X) '(OBARRAY)))) + #%(let ((tem (SUBLIS (LIST (CONS 'PVR (CAR X)) + (CONS 'STSL (CADR X)) + (CONS 'VL (GENSYM))) + '(DO VL (- (CADR (ARRAYDIMS STSL)) 129.) + (1- VL) (MINUSP VL) + (DECLARE (FIXNUM VL)) + (MAPC PVR (ARRAYCALL T STSL VL)))))) + (return #%(let ((MAPEX 'T)) (p1 tem)))))) + #%(let ((form) + (tem () ) ;To look for MAPC's for value!! + (y () ) + (indicl (MAPCAR #'(LAMBDA (Z) + #%(let ((local (local-var))) + `(,LOCAL ,Z (CDR ,local)))) + (CDR X)))) + (COND (EFFS (setq form ;not for value, simple DO + '(DO VL EXIT EXITN))) + ((EQ (CADDR Z) 'MAP) + (SETQ TEM ;This will be value for PVR below + (CONS (LOCAL-VAR) (CADR X))) + (SETQ X (CONS (CAR X) (CONS (CAR TEM) (CDDR X)))) + ;;STSL will become the first of the list being mapped + ;; Must not evaluate the list-arg twice! + (rplaca (cdar indicl) (car tem)) + (setq form '((LAMBDA (PVR) (DO VL EXIT EXITN) PVR) STSL))) + ((EQ (CADDR Z) 'MAPCON) + (setq form + '((LAMBDA (PVR STSL) (GOFOO PVR STSL) + (DO VL EXIT + (SETQ STSL (LAST (RPLACD STSL EXITN)))) + PVR) + () () ))) + ((setq form + '((LAMBDA (PVR STSL) (GOFOO PVR STSL) + (DO VL EXIT + (SETQ STSL + (CDR (RPLACD STSL (LIST EXITN))))) + PVR) + () () )))) + + (RPLACD (CAR MAPSB) INDICL) ;Install indices list in subst list + (RPLACD (CADR MAPSB) ;Install the exit test + (LIST (COND ((NULL (CDR INDICL)) + (LIST 'NULL (CAAR INDICL))) + ((CONS 'OR + (MAPCAR #'(LAMBDA (X) + (LIST 'NULL (CAR X))) + INDICL)))))) + (RPLACD (CAR (SETQ Y (CDDR MAPSB))) + (CONS (CADAR X) + (MAPCAR #'(LAMBDA (X) + (COND ((EQ (CADDDR Z) 'LIST) (CAR X)) + ((LIST 'CAR (CAR X))))) + INDICL))) + (COND ((NOT EFFS) + (SETQ Y (CDR Y)) ;POSITION Y OVER ((PVR) (STSL) . . .) + (COND (TEM (RPLACD (CAR Y) (CAR TEM)) + (RPLACD (CADR Y) (CDR TEM))) + ('T (RPLACD (CAR Y) (LOCAL-VAR)) + (RPLACD (CADR Y) (LOCAL-VAR)))))) + ;Format of MAPSB is ((VL . NIL) (EXIT . NIL) (EXITN . NIL) + ; (PVR . NIL) (STSL . NIL) (GOFOO . GOFOO)) + (SETQ X (SUBLIS MAPSB FORM)) ;Substitute into the expander + ;form + + (RETURN (P1 X))))) + + +(DEFUN LOCAL-VAR () + #%(LET ((X (GENSYM))) + (AND SPECIALS (PUTPROP X 'T ':LOCAL-VAR)) + X)) + + +(COMMENT P1PROG) + +(DEFUN P1PROG (X) + (PROG2 (AND (OR (NULL (CDR X)) (AND (CAR X) (ATOM (CAR X)))) + (DBARF X |Is this a PROG?|)) + ((LAMBDA (OPVRL SPECVARS MODELIST RNL BVARS IGNOREVARS PROGP EFFS P1PCX OARITHP PKTYP) + (PROG (CONDP P1CSQ LMBP P1LSQ PVRL P1VARS GL P1CNT KTYPE + ARITHP GONE2 P1PSQ BODY PRSSL PROGTYPE PROGUNSF NLNVTHTBP) + (AND P1LL (NOT (MEMQ P1LL OPVRL)) (PUSH P1LL OPVRL)) + (SETQ X (P1LMBIFY (SETQ P1VARS (CAR X)) () (CDR X) )) + (SETQ PVRL (DELQ () (CAR X)) X (CDR X)) + (SETQ P1VARS LOCVARS) + (SETQ P1CNT (SETQ CNT (ADD1 CNT))) + (SETQ BODY + (MAPCAR + '(LAMBDA (Y) + (PROG () + (SETQ CNT (ADD1 CNT)) + A (COND ((SETQ BODY (ATOM Y))) + ((EQ (SETQ BODY (P1MACROGET Y)) NULFU) + (SETQ BODY () )) + ((QNILP BODY) (SETQ BODY () )) + ('T (SETQ Y BODY) (GO A))) + (COND (BODY + (SETQ PRSSL 'T) + (SETQ Y (P1TAG Y)) + (SETQ GL (PUSH (CONS Y (GENSYM)) GL)) + (AND (ASSQ Y (CDR GL)) + (NOT (EQ Y GOFOO)) + (WARN Y |Repeated GO tag|)) + (RETURN Y)) + ('T (RETURN (P1E1 Y)))))) + X)) + (P1SPECIALIZEDVS) ;CHECK FOR SCREW CASE + (P1SYNCHRONIZE-CNTS P1CNT P1VARS) + (AND (SETQ X (UUVP 'PVRL)) (WARN X |Unused PROG variables|)) + (COND ((MEMQ GOFOO GONE2)) ;GOFOO ON GONE2 SAYS THERE IS A COMPUTED GO + ('T (MAPC '(LAMBDA (TAG) (AND (NOT (MEMQ (CAR TAG) GONE2)) + (SETQ GL (DELETE TAG GL)))) + GL))) + (SETQ GL (NREVERSE GL)) + (MAPC '(LAMBDA (TAG) (COND ((NOT (ATOM TAG)) + (MAPC 'P1TAGDEFP (CAR TAG))) + ('T (P1TAGDEFP TAG)))) + GONE2) + (SETQ X P1PSQ) + (NLNVASG PVRL) +; HERE IS RETURN VALUE, PUT IN GONE2 + (SETQ GONE2 (LIST 'PROG P1PCX X GL + (LIST SPECVARS MODELIST IGNOREVARS) + PVRL BODY PROGUNSF NLNVTHTBP)) + (RETURN (COND ((NULL OARITHP) GONE2) + ((CONS GONE2 (COND ((NULL (CAR PROGTYPE)) PKTYP) + ((EQ (CAR PROGTYPE) (CADR PROGTYPE)) + (CAR PROGTYPE)) + (PKTYP)))))))) + (COND (PVRL (CONS PVRL OPVRL)) (OPVRL)) + SPECVARS MODELIST RNL BVARS IGNOREVARS 'T 'T 0 ARITHP KTYPE) + (P1SQE X) + (COND (PROGP (SETQ P1PSQ (LADD (LSUB X PVRL) P1PSQ)))))) + + +(DEFUN P1GO (X) + (P1SQG X) + (COND ((ATOM (CADR X)) + (AND (NOT (SYMBOLP (CADR X))) + (SETQ X (CONS 'GO (CONS (P1TAG (CADR X)) (CDDR X))))) + (PUSH (CADR X) GONE2) + X) + ('T (COND ((ATOM (CADDR X)) (PUSH GOFOO GONE2)) + ('T (SETQ GONE2 (APPEND (CADDR X) GONE2)))) + (CONS 'GO (CONS (P1VN (CADR X)) (CDDR X))) ))) + +(DEFUN P1RETURN (X) + (P1SQG X) + (COND ((OR (NULL (CDR X)) (NULL (CADR X)) (QNILP (CADR X))) + (SETQ PROGTYPE (P1TYPE-ADD PROGTYPE () )) + (COND (ARITHP '( (RETURN '() ) . () )) + ('T '(RETURN '() )))) + (((LAMBDA (T1 MODE UNSAFEP) + (SETQ T1 ((LAMBDA (ARITHP PNOB EFFS KTYPE) + (P1 (CADR X))) + 'T () () PKTYP)) + (SETQ MODE (CDR T1) T1 (CAR T1)) + (AND (NOT (ZEROP (P1TRESS T1))) + (SETQ P1PCX (ADD1 P1PCX))) + (SETQ PROGTYPE (P1TYPE-ADD PROGTYPE MODE)) + (COND ((NULL (SETQ UNSAFEP (P2UNSAFEP T1))) + (SETQ UNSAFEP (AND (NOT (QNP T1)) (NOT (SYMBOLP T1)) 'T))) + ((SETQ PROGUNSF (COND ((ATOM T1) + (OR (MEMQ T1 PVRL) ;If returning a PROG number var + (SETQ UNSAFEP () )) ; then allow NLNFINDCR below + (ADD T1 PROGUNSF)) + ('T (AND (LAND T1 PROGUNSF) + (SETQ PROGUNSF (ADD PROGN PROGUNSF))) + (LADD T1 PROGUNSF)))))) + (SETQ T1 (LIST 'RETURN T1)) + (COND (ARITHP (CONS T1 () )) (T1))) + () () () )))) + +(DEFUN P1TAG (X) + ((LAMBDA (TYPE) + (COND ((EQ TYPE 'SYMBOL) X) + ((MEMQ TYPE '(FIXNUM FLONUM)) + ((LAMBDA (*NOPOINT BASE) (IMPLODE (EXPLODEC X))) 'T 10.)) + ('T (PDERR X |Not acceptable as GO tag|) GOFOO))) + (TYPEP X))) + +(DEFUN P1TAGDEFP (TAG) + (AND (NOT (ASSQ TAG GL)) + (NOT (EQ TAG GOFOO)) + (PDERR (LIST 'GO TAG) |GO to non-existent tag|))) + +(COMMENT P1PROG2 and P1PROGN) + +(DEFUN P1PROG2 (XPR) + (DO ((TYPE) (T1) (T2) (OEFFS EFFS) (EFFS 'T) (OARITHP ARITHP) (ARITHP)) + () + (SETQ T1 (P1 (CAR XPR))) + (COND ((NULL OEFFS) + (SETQ ARITHP OARITHP EFFS () ) + (SETQ T2 (P1 (CADR XPR))) + (AND ARITHP (SETQ TYPE (CDR T2) T2 (CAR T2) ARITHP () )) + (SETQ EFFS 'T)) + ('T (SETQ T2 (P1 (CADR XPR))))) + (SETQ T2 (CONS 'PROG2 (CONS T1 (CONS T2 (MAPCAR 'P1 (CDDR XPR)))))) + (RETURN (COND ((NOT OARITHP) T2) ((CONS T2 TYPE)))))) + +(DEFUN P1PROGN (X FUN) + (SETQ X (CONS FUN (P1L X EFFS ARITHP KTYPE))) + (AND ARITHP + ((LAMBDA (LL MODE) + (SETQ MODE (CDAR LL)) + (RPLACA LL (CAAR LL)) + (SETQ X (CONS X MODE))) + (LAST X) () )) + X) + + +(DEFUN P1SETQ (X) + (PROG (VAR VAL LCP SPFL) + (SETQ LCP () ) + (DO ((ZZ (CDR X) (CDDR ZZ)) (ARITHP)) ((NULL ZZ)) + (COND ((NULL (CDR ZZ)) (RETURN (SETQ LCP () ))) + ((COND ((NOT (SYMBOLP (CAR ZZ))) + (PDERR X |Non-SYMBOL for assignment in SETQ|) + (SETQ VAR (GENSYM)) + 'T) + ((GET (CAR ZZ) '+INTERNAL-STRING-MARKER) + (PDERR X |Don't SETQ a pseudo-STRING|) + (SETQ VAR (COPYSYMBOL (CAR ZZ) () )) + 'T) + ((MEMQ (CAR ZZ) '(T NIL)) + (PDERR X |Dont SETQ T or NIL|) + (SETQ VAR (COPYSYMBOL (CAR ZZ) () )) + 'T)) + (SETQ ZZ (CONS VAR (CDR ZZ))))) + (COND ((AND (NULL (CDDR ZZ)) + (OR (EQ (CAR ZZ) (CADR ZZ)) + (AND (NOT (ATOM (CADR ZZ))) + (EQ (CAADR ZZ) 'PROG2) + (EQ (CAR ZZ) (CADDR (CADR ZZ)))))) + (SETQ X '(PROG2)) + (SETQ LCP (LIST (COND ((NULL LCP) ''() ) + ((CONS 'SETQ (NREVERSE LCP)))) + (P1 (CADR ZZ)))) ;(SETQ Y Y) => (PROG2 () Y) + (RETURN () ))) ;(SETQ A B Y Y) => (PROG2 (SETQ A B) Y) + (SETQ VAR (COND ((CDR (ASSQ (CAR ZZ) RNL))) ;(SETQ Y (PROG2 C Y D)) ==> + ((CAR ZZ)))) ; (PROG2 () (PROG2 C Y D)) + ;(SETQ A B Y (PROG2 C Y D)) => + (P1SQV VAR) ; (PROG2 (SETQ A B) (PROG2 C Y D)) + (SETQ VAL (P1BINDARG (SETQ SPFL (P1SPECIAL VAR)) VAR (CADR ZZ) (VARMODE VAR))) + (SETQ CNT (PLUS 2 CNT)) + (AND (NOT SPFL) (RPLACD (ASSQ VAR LOCVARS) CNT)) + (SETQ LCP (CONS VAL (CONS VAR LCP)))) + (AND (NULL LCP) (PDERR X |Wrong number of args to SETQ|)) + (SETQ VAR (CADR LCP)) ;REGARDLESS OF CONDITION BELOW, THIS GETS THE NAME OF + (AND (NOT (EQ (CAR X) 'PROG2)) ;THE VARIABLE WHOSE VALUE IS BEING RETURNED + (SETQ LCP (NREVERSE LCP))) + (SETQ LCP (CONS (CAR X) LCP)) + (RETURN (COND ((NOT ARITHP) LCP) + ((CONS LCP (VARMODE VAR))))))) + + + +(COMMENT P1SPECIAL and funs to hack SETQ flow) + +(DEFUN P1SPECIAL (X) + (COND + ((EQ X 'QUOTE) + (DBARF X |Can't be used as a variable - you lose.|)) + ((SPECIALP X)) + ((COND ((NOT (MEMQ X BVARS)) + (CKCFV X) + (COND ((GET X ':LOCAL-VAR) + (BARF X |Trying to specialize internal temporary|)) + ((NULL SPECIALS) + #%(WARN X |Undeclared - taken as SPECIAL|) + (PUSH X P1SPECIALIZEDVS) + (AND (REMPROP X 'OHOME) + #%(LET ((Y (ASSQ X LOCVARS))) + (AND Y (SETQ LOCVARS (DELQ Y LOCVARS))))))) + 'T) + (SPECIALS (NOT (GET X ':LOCAL-VAR)))) + ((LAMBDA (Z) (PUTPROP X Z 'SPECIAL) Z) + (LIST 'SPECIAL X))) + ('T (RPLACD (COND ((ASSQ X LOCVARS)) ((BARF X |Lost LOCVAR - P1SPECIAL|))) + CNT) + () ))) + +(DEFUN P1SPECIALIZEDVS () + (DO ((LL P1SPECIALIZEDVS (CDR LL)) (TEM) (Z)) + ((NULL LL) + (AND Z (DBARF Z |These variables must be declared special by user +- the code for this function will probably not be correct|)) + (SETQ P1SPECIALIZEDVS () ) + Z) + (COND ((SETQ TEM (ASSQ (CAR LL) LOCVARS)) + (SETQ LOCVARS (DELQ TEM LOCVARS)) + (COND ((SETQ TEM (ASSQ (CAR LL) RNL)) + (SETQ RNL (DELQ TEM RNL)) + (PUSH (CONS (CDR TEM) (LIST 'SPECIAL (CDR TEM))) + SPECVARS) + (AND (SETQ TEM (ASSQ (CDR TEM) LOCVARS)) + (SETQ LOCVARS (DELQ TEM LOCVARS))))) + (PUSH (CAR LL) Z))))) + + +(DEFUN P1SQE (L) +; Extend SETQ vars from inner PROG, COND, or LAMBDA to +; the outer CONDs and any outer LAMBDAs + (COND (L (COND (CONDP (SETQ P1CSQ (LADD L P1CSQ)))) + (COND (LMBP (SETQ P1LSQ (LADD (LSUB L P1LL) P1LSQ)))))) + () ) + +(DEFUN P1SQG (Z) + (COND ((NOT PROGP) (PDERR Z |GO or RETURN not in PROG|))) + (SETQ PRSSL 'T) + (P1SQV GOFOO)) + +(DEFUN P1SQV (Y) + (COND (CONDP (SETQ P1CSQ (ADD Y P1CSQ)))) + (COND ((AND LMBP (NOT (MEMQ Y P1LL))) (SETQ P1LSQ (ADD Y P1LSQ)))) + (COND ((AND PROGP (NOT (EQ Y GOFOO)) (NOT (MEMQ Y PVRL))) + (SETQ P1PSQ (ADD Y P1PSQ))))) + +(DEFUN P1SYNCHRONIZE-CNTS (P1CNT P1VARS) + (SETQ CNT (ADD1 CNT)) + (DO X P1VARS (CDR X) (NULL X) + (COND ((> (CDAR X) P1CNT) (RPLACD (CAR X) CNT)))) + (SETQ CNT (ADD1 CNT))) + + +(COMMENT P1SIGNP and P1STATUS) + +(DEFUN P1SIGNP (X) + #%(LET ((TEST (ASSQ ((LAMBDA (OBARRAY) (INTERN (CADR X))) SOBARRAY) + '((N . ZEROP) (E . ZEROP) (G . PLUSP) (LE . PLUSP) + (L . MINUSP) (GE . MINUSP) (- . NIL) (A . T)))) + (ARG (CADDR X))) + (COND ((NULL TEST) (PDERR X |Bad args to SIGNP|) ''() ) + ((NOT (MEMQ (CDR TEST) '(T NIL))) + (SETQ ARG (P1VAP ARG 'T)) + (COND ((NULL (CDR ARG)) + (LIST 'SIGNP (CAR TEST) (CAR ARG))) + ('T (SETQ ARG (LIST (CDR TEST) (CDR ARG) (CAR ARG))) + (AND (MEMQ (CAR TEST) '(N GE LE)) + (SETQ ARG (LIST 'NULL ARG))) + ARG))) + ('T (P1 (LIST 'PROG2 ARG (CDR TEST))))))) + + +(DEFUN P1STATUS (X) + (PROG (Z Y TEM) + (COND ((ZEROP (GETCHARN (CADR X) 6)) (SETQ TEM () )) + ((SETQ TEM (EXPLODEN (CADR X))) + (AND (CDDDDR TEM) (RPLACD (CDDDDR TEM) () )))) + (AND (NOT (MEMQ #%(LET ((OBARRAY SOBARRAY)) + (SETQ Y (COND (TEM (IMPLODE TEM)) + ((INTERN (CADR X)))))) + (COND ((EQ (CAR X) 'STATUS) (CAR STSL)) + ((CADR STSL))))) + (WARN X |Possibly illegal STATUS call| 3 5)) + (COND ((AND (SETQ TEM (CDDR X)) + (SETQ Z (GET Y 'STATUS)) + (SETQ Z (COND ((EQ (CAR X) 'STATUS) (CAR Z)) + ((CDR Z)))) + (COND ((AND (EQ Z 'A) (MAPCAN 'P1STVAL TEM (CAR COMAL))) + (SETQ TEM (MAPCAR 'P1STQLIFY TEM)) + 'T) + ;LIKE ([S]STATUS FOO VALUE1) + ;OR ([S]STATUS FOO VALUE1 VALUE2) + ((AND (EQ Z 'B) + (OR (P1STVAL (CAR TEM) 'T) + (MAPCAN 'P1STVAL (CDR TEM) (CAR COMAL)))) + (SETQ TEM (CONS (COND ((SYMBOLP (CAR TEM)) + (LIST 'QUOTE (CAR TEM))) + ('T (P1VN (CAR TEM)))) + (AND (CDR TEM) + (CONS (P1STQLIFY (CADR TEM)) + (AND (CDDR TEM) + (LIST (LIST 'QUOTE + (CADDR TEM)))))))) + T))) + ;LIKE (SSTATUS MACRO D VALUE1) + (SETQ Z (CONS 'CONS (CONS (LIST 'QUOTE (CADR X)) + (LIST (P1ITERLIST TEM () )))))) + ('T (SETQ Z (LIST 'QUOTE (CDR X))))) + (RETURN Z))) + +(DEFUN P1STVAL (X IPN) + #%(LET ((Y (TYPEP X))) + (COND ((EQ Y 'SYMBOL) + (COND ((OR IPN (MEMQ X '(T NIL)) (SPECIALP X)) () ) + ('T (AND (SETQ Y (ASSQ X RNL)) (SETQ X (CDR Y))) + (COND ((MEMQ X BVARS) (LIST 'T)) + ('T (P1SPECIAL X) () ))))) + ((EQ Y 'LIST) + (AND (NOT (MEMQ (CAR X) '(QUOTE FUNCTION))) + (LIST 'T)))))) + +(DEFUN P1STQLIFY (X) + (P1VN (SUBST X 'X (COND ((NOT (P1STVAL X () )) '(QUOTE X)) + ('(LIST 'QUOTE X)))))) + +(COMMENT P1TYPE-ADD and P1TRESS) +(comment for TYPE and complexity maintenance of COND and PROG) + +;;; CONDTYPE AND PROGTYPE HAVE A VERY RIGID FORMAT: +;;; () +;;; ( () ) +;;; (FIXNUM FIXNUM) +;;; (FLONUM FLONUM) +;;; (FIXNUM FLONUM) +;;; (() FIXNUM) +;;; (() FLONUM) +;;; (() FIXNUM FLONUM) + +(DEFUN P1TYPE-ADD (TYPEL TYP) + (COND ((NULL TYPEL) + (SETQ TYPEL (COND ((EQ TYP 'FIXNUM) '(FIXNUM FIXNUM)) + ((EQ TYP 'FLONUM) '(FLONUM FLONUM)) + ( '( () ) )))) + ((CDDR TYPEL)) + ((NULL (CAR TYPEL)) + (COND ((NULL TYP)) + ((CDR TYPEL) (AND (NOT (EQ TYP (CADR TYPEL))) + (SETQ TYPEL '(() FIXNUM FLONUM)))) + ('T (SETQ TYPEL (COND ((EQ TYP 'FIXNUM) '(() FIXNUM)) + ('(() FLONUM))))))) + ((NOT (EQ (CAR TYPEL) (CADR TYPEL))) + (AND (NULL TYP) (SETQ TYPEL '(() FIXNUM FLONUM)))) + (TYP (AND (NOT (EQ (CAR TYPEL) TYP)) (SETQ TYPEL '(FIXNUM FLONUM)))) + ('T (SETQ TYPEL (COND ((EQ (CADR TYPEL) 'FIXNUM) '(() FIXNUM)) + ('(() FLONUM)))))) + TYPEL) + + + +(DEFUN P1TRESS (F) ;F HAS ALREADY BEEN P1'D + (COND ((OR (ATOM F) + (MEMQ (CAR F) '(QUOTE FUNCTION *FUNCTION EQ GO RETURN)) + (COND ((NOT (ATOM (CAR F))) + (AND (EQ (CAAR F) CARCDR) + (< (LENGTH (CDAR F)) 3))) + ((SYMBOLP (CAR F)) + (AND (|carcdrp/|| (CAR F)) + (< (FLATC (CAR F)) 5))))) + 0) + ((MEMQ (CAR F) '(RPLACD RPLACA)) + (COND ((AND (NOT (ZEROP (P1TRESS (CADR F)))) + (ZEROP (P1TRESS (CADDR F)))) + 1) + (0))) + ((MEMQ (CAR F) '(MEMQ SETQ)) + (COND ((NOT (ZEROP (P1TRESS (CADDR F)))) 1) (0))) + ((MEMQ (CAR F) '(COND PROG)) (CADR F)) + ((EQ (CAAR F) 'LAMBDA) (CADAR F)) + ((AND (EQ (CAR F) 'NULL) (P1BOOL1ABLE (CADR F))) 0) + ((MEMQ (CAR F) '(AND OR)) (BARF F |AND or OR loss - P1TRESS|)) + (1))) + + +(DEFUN P1VAP (XPR OPNOB) ;P1 for value, arithmetics, and PNOB supplied + ((LAMBDA (ARITHP PNOB EFFS KTYPE) (P1 XPR)) 'T OPNOB () () )) + +(DEFUN P1VN (XPR) ;P1 for value, no arithmetics + ((LAMBDA (ARITHP EFFS KTYPE) (P1 XPR)) () () () )) + + + + +(COMMENT NLNVTHTBP VARIABLE HACKERY) + +(DEFUN NLNVASG (VARS) + (DO ((X NLNVS (CDR X)) (FL)) + ((NULL X) (AND FL (SETQ NLNVS (DELQ () NLNVS)))) + (COND ((MEMQ (CAAR X) VARS) + (PUSH (CDAR X) NLNVTHTBP) + (PUTPROP (CDAR X) () 'OHOME) + (PUSH (CONS (CDAR X) CNT) LOCVARS) + (SETQ FL 'T) + (RPLACA X () )) + ((AND (NOT (MEMQ (CAAR X) BVARS)) + (NOT (MEMQ (CAAR X) ROSENCEK)) + (DO ((Y P1LLCEK (CDR Y))) + ((NULL Y) 'T) + (AND (MEMQ (CAAR X) (CAR Y)) (RETURN () ))) ) + (WARN (CAR X) |Show JONL - NLNVASG|))))) + +(DEFUN NLNVFINDCR (MODE TYPE) + (NLNVCR (COND ((AND (NOT (EQ PNOB 'T)) PNOB)) + ((COND ((NULL PNOB) () ) + ((AND (NOT (EQ TYPE 'PROG)) (CAR (OR P1LL PVRL)))) + ((CAAR OPVRL)))) + ((CAR (PUSH (LOCAL-VAR) ROSENCEK)))) + MODE)) + +(DEFUN NLNVCR (VAR MODE) + ((LAMBDA (NAME) + (PUTPROP NAME MODE 'NUMVAR) + (PUSH (CONS VAR NAME) NLNVS) + NAME) + (LOCAL-VAR))) + + +(DEFUN NLNVEX (VAR ITEM) ;CALLED ONLY BY P1BINDARG + (COND ((AND ITEM (NOT (EQ ITEM 'T))) ;ONLY CALLED WHERE ITEM IS RESULT OF P2UNSAFEP + (SETQ UNSFLST (ADD VAR UNSFLST)) + (COND ((ATOM ITEM) (NLNV1 VAR ITEM NLNVS)) + ('T (MAPC '(LAMBDA (OLDVAR) (NLNV1 VAR OLDVAR NLNVS)) ITEM)))))) + +(DEFUN NLNV1 (NEWVAR OLDVAR SHEE-IT) + (AND (MEMQ NEWVAR (MEMQ OLDVAR BVARS)) + (DO ((Y SHEE-IT (CDR Y)) (ITEM)) + ((NULL Y)) + (COND ((EQ (CAAR Y) OLDVAR) + (PUTPROP OLDVAR NEWVAR 'NLNVS) + (RPLACA (CAR Y) NEWVAR)) + ((EQ (CAAR Y) (SETQ ITEM (GET OLDVAR 'NLNVS))) + (NLNV1 NEWVAR ITEM Y)))))) + + + + +(COMMENT SOME TYPE ANALYZERS USED BY PHASE 1) + +;Basically, P1 type analyzers, where XPR has not yet been P1'd + +(DEFUN NUMTYP (XPR NUMBERP) + (SETQ XPR (NUMTYPEP XPR NUMBERP)) + (AND (MEMQ (CDR XPR) '(FIXNUM FLONUM)) XPR)) + +(DEFUN NUMTYPEP (XPR NUMBERP) ;Returns form actually found to be of numeric type [except for + ; a numeric constant, in which case 1 or 1.0 is used] CONS'd to type + #%(LET ((TYPE (TYPEP XPR))) + (COND ((EQ TYPE 'FIXNUM) '(1 . FIXNUM)) + ((EQ TYPE 'FLONUM) '(1.0 . FLONUM)) + ((EQ TYPE 'SYMBOL) (AND (SETQ TYPE (VARMODE XPR)) (CONS XPR TYPE))) + ((NOT (EQ TYPE 'LIST)) () ) + ((EQ (SETQ TYPE (TYPEP (CAR XPR))) 'LIST) + (COND ((EQ (CAAR XPR) 'LAMBDA) ;### this fails when ret val depends on + (NUMTYPEP (CAR (LAST (CDDAR XPR))) NUMBERP)) ; local vars and declarations + ((EQ (CAAR XPR) COMP) + (WARN XPR |Let JONL see this code - NUMTYPEP|) + (AND (MEMQ (CADAR XPR) '(FIXNUM FLONUM)) + (CONS XPR (CADAR XPR)))))) + ((NOT (EQ TYPE 'SYMBOL)) () ) + ((EQ (CAR XPR) 'SETQ) + (SETQ XPR (NX2LAST (CDR XPR))) + (AND (SETQ TYPE (NUMERVARP XPR)) (CONS XPR TYPE))) + ((EQ (CAR XPR) 'QUOTE) + (COND ((EQ (SETQ XPR (TYPEP (CADR XPR))) 'FIXNUM) '(1 . FIXNUM)) + ((EQ XPR 'FLONUM) '(1.0 .FLONUM)))) + ((EQ (CAR XPR) 'PROG2) (NUMTYPEP (CADDR XPR) NUMBERP)) + ((MEMQ (CAR XPR) '(PROGN PROGV)) + (NUMTYPEP (CAR (LAST (CDR XPR))) NUMBERP)) + ((EQ (CAR XPR) 'DO) ;### SEE THE CAVEAT ON LAMBDAS ABOVE + (AND (NOT (ATOM (CADR XPR))) ;### ALSO FAILS ON PROGS TOO + (SETQ TYPE (CAR (LAST (CADDR XPR)))) + (OR (ATOM TYPE) (NOT (QNILP TYPE))) + (NUMTYPEP TYPE NUMBERP))) + ((EQ (CAR XPR) 'COND) + (COND (NUMBERP (DO ((Y (CDR XPR) (CDR Y))) + ((NULL Y) (SETQ TYPE () )) + (AND (SETQ TYPE (CDR (NUMTYP (CAR (LAST (CAR Y))) 'T))) + (RETURN () )))) + ('T (SETQ TYPE () ) + (DO ((Y (CDR XPR) (CDR Y)) (FL)) + ((NULL Y)) + (SETQ FL + (CDR (NUMTYPEP (CAR (LAST (CAR Y))) + () ))) + (COND ((NULL FL) (RETURN (SETQ TYPE () ))) + ((NULL TYPE) (SETQ TYPE FL)) + ((NOT (MEMQ TYPE '(FIXNUM FLONUM)))) + ((EQ TYPE FL)) + ('T (SETQ TYPE 'T)))))) + (AND TYPE (CONS XPR TYPE))) + ((SETQ TYPE (NUMFUNP XPR 'T)) (CONS XPR TYPE)) + ((NOT (EQ (SETQ TYPE (P1MACROGET XPR)) NULFU)) + (NUMTYPEP TYPE NUMBERP))))) + + + + +;;;A subroutine for P1CJ-NUMVALP and NUMTYPEP - argument must be a list with +;;; a SYMBOL as first element. +;;; Wants to ascertain if the "function" is guaranteed to producee a manageable +;;; numerical result. Thus PLUS isn't generally so, since it can produce a +;;; BIGNUM, or perhaps the type is not fixable at compile time. + +(DEFUN NUMFUNP (FORM P1P) + (COND ((MEMQ (CAR FORM) '(ARRAYCALL LSUBRCALL SUBRCALL)) + (AND (MEMQ (CADR FORM) '(FIXNUM FLONUM)) (CADR FORM))) + (((LAMBDA (PROP) + (COND ((NULL PROP) + (SETQ PROP (ASSQ (CAR FORM) RNL)) + (AND (SETQ PROP (FUNMODE (OR (CDR PROP) (CAR FORM)))) + (CADR PROP))) + ((OR (EQ (CAR PROP) 'ARITHP) (EQ (CAR PROP) 'NUMFUN)) + (CADADR PROP)) + ((EQ (CAR PROP) 'NUMBERP) + (COND ((EQ (CADR PROP) 'NOTYPE) () ) + ((NOT P1P) + (COND ((OR (EQ (CAR FORM) 'FIX) (NULL (CADR FORM))) + () ) ;For NUMVALP, we dont care to know the "T" types + ((MEMQ (CADR FORM) '(FIXNUM FLONUM)) + (CADR FORM)) + ((OR FIXSW (EQ (CAR FORM) 'HAULONG)) 'FIXNUM) + ((OR FLOSW (EQ (CAR FORM) 'FLOAT)) 'FLONUM) + (CLOSED () ) + ((GET (CAR FORM) 'CONTAGIOUS) + (AND (MEMQ 'FLONUM (CADR FORM)) 'FLONUM)))) + ((OR FIXSW (EQ (CAR FORM) 'HAULONG)) 'FIXNUM) + ((OR FLOSW (EQ (CAR FORM) 'FLOAT)) 'FLONUM) + (CLOSED () ) + ((GET (CAR FORM) 'CONTAGIOUS) + (DO ((Y (CDR FORM) (CDR Y)) + (ANS 'FIXNUM)) + ((NULL Y) ANS) + (SETQ PROP (CDR (NUMTYPEP (CAR Y) 'T))) + (COND ((EQ PROP 'FLONUM) (RETURN 'FLONUM)) + ((NOT (EQ PROP 'FIXNUM)) (SETQ ANS 'T))))) + ('T (SETQ PROP (CDR (NUMTYPEP (CADR FORM) 'T))) + (COND ((AND (EQ (CAR FORM) 'FIX) + (NOT (EQ PROP 'FIXNUM))) + 'T) + (PROP))) )))) + (GETL (CAR FORM) '(ARITHP NUMFUN NUMBERP)))))) + +(DEFUN NUMERVARP (VAR) (AND (SYMBOLP VAR) (VARMODE VAR))) + + +;; PHASE2 analyzer for something proveably not a FIXNUM or FLONUM + +(DEFUN NOTNUMP (X) + (COND ((ATOM X) () ) + ((NOT (ATOM (CAR X))) + (COND ((EQ (CAAR X) '*MAP)) + ((EQ (CAAR X) 'LAMBDA) (NOTNUMP (CADDDR (CDDAR X)))))) + ((EQ (CAR X) 'QUOTE) + #%(LET ((TYP (TYPEP (CADR X)))) + (CASEQ TYP + ((FIXNUM FLONUM) () ) + (LIST (NOT (EQ (CAADR X) SQUID))) + (T T)))) + ((EQ (CAR X) 'PROG2) (NOTNUMP (CADDR X))) + ((OR (EQ (CAR X) 'PROGN) + (EQ (CAR X) PROGN) + (EQ (CAR X) 'PROGV)) + (NOTNUMP (CAR (LAST (CDR X))))) + (#%(LET ((FL (GETL (CAR X) '(NOTNUMP NUMBERP ARITHP FSUBR MACRO)))) + (COND ((NULL FL) () ) + ((EQ (CAR FL) 'NOTNUMP)) + ((EQ (CAR FL) 'NUMBERP) (EQ (CADR FL) 'NOTYPE)) + ((EQ (CAR FL) 'ARITHP) (NULL (CADADR FL))) + ((EQ (CAR FL) 'FSUBR) + (COND ((MEMQ (CAR X) + '(FASLOAD STORE STATUS SSTATUS SETQ GO THROW + ERR COND PROG POP ARRAYCALL SUBRCALL *THROW + LSUBRCALL)) + () ) + ('T))) + ((NOT (EQ (CAR FL) 'MACRO)) () ) + ((EQ (CAR X) SQUID) () ) + ((NOT (EQ (SETQ FL (P1MACROGET X)) NULFU)) + (NOTNUMP FL))))))) + + + +(DEFUN SAMETYPES (TYPEL) ;Will take a types list, e.g. + ((LAMBDA (TYPE) ; (FIXNUM () FLONUM () FLONUM) + (DO L (CDR TYPEL) (CDR L) ; and convert it to an atom [one of + (COND ((NULL L) (SETQ TYPEL TYPE) 'T) ; (), FIXNUM, FLONUM] if all types + ((NOT (EQ TYPE (CAR L))))))) ; are the same + (CAR TYPEL)) + TYPEL) + + +(DEFUN P2UNSAFEP (XPR) ;PHASE2 analyzer, for something that might be a PDL number + (COND ((ATOM XPR) + (AND (COND ((MEMQ XPR UNSFLST)) + ((NOT (NUMERVARP XPR)) () ) + ((NOT (SPECIALP XPR)))) + XPR)) + ((NOT (ATOM (CAR XPR))) + (AND (EQ (CAAR XPR) 'LAMBDA) (CADDDR (CDDDDR (CAR XPR))))) + ((EQ (CAR XPR) 'PROG) (CADDDR (CDDDDR XPR))) + ((MEMQ (CAR XPR) '(AND OR COND)) (CADDDR XPR)) + ((EQ (CAR XPR) 'SETQ) (P2UNSAFEP (NX2LAST (CDR XPR)))) + ((EQ (CAR XPR) 'PROG2) (P2UNSAFEP (CADDR XPR))) + ((OR (EQ (CAR XPR) 'PROGN) (EQ (CAR XPR) PROGN)) + (P2UNSAFEP (CAR (LAST (CDR XPR))))) + ((EQ (CAR XPR) 'ARG) ARGLOC))) + + +(COMMENT VARIOUS ARG AND VARIABLE CHECKERS) + +(DEFUN UUVP (VAR) + #%(let* ((ll (symeval var)) + (tem) + (l (mapcan + #'(lambda (x) + (cond ((and x (setq x (assq x locvars)) (= (cdr x) 0)) + (list (cond ((setq tem (memassqr (car x) RNL)) + (setq RNL (delq (car tem) RNL)) + (caar tem)) + ('T (car x))))))) + ll))) + (cond (l (set var (lsub ll (cons () l)))) + ((memq () ll) (set var (lsub ll '(()) ))) ) + (do ((z l (cdr z)) (fl) (x)) + ((null z) + (and fl (setq l (delq () l)))) + (setq x (car z)) + (cond ((or (eq x 'IGNORE) + (get x 'IGNORE) + (memq x IGNOREVARS) + (and (symbolp x) + (= (getcharn x 1) #/I) + (= (getcharn x 2) #/G) + (= (getcharn x 3) #/N) + (= (getcharn x 4) #/O) + (= (getcharn x 5) #/R) + (= (getcharn x 6) #/E))) + (rplaca z () ) + (setq fl 'T)))) + l)) + + +(DEFUN CKARGS (NAME M) + ((LAMBDA (AARGS) + (COND ((NULL AARGS) (PUTPROP NAME (CONS () M) 'ARGS)) + ((AND (NULL (CAR AARGS)) (= (CDR AARGS) M))) + (#%(WARN NAME |Has been previously used with incorrect +number of args -- Discovered while |)))) + (OR (ARGS NAME) (GET NAME 'ARGS)))) + +(DEFUN CKCFV (X) + (COND (SPECIALS) + (CFVFL (MAPC '(LAMBDA (Y) (AND (OR (MEMQ X (CAR Y)) (ASSQ X (CDR Y))) + (*THROW 'CFVFL 'CFVFL))) + CFVFL) + () ) + ((AND P1GFY (OR (MEMQ X BVARS) (ASSQ X RNL))) + (DBARF X |Used free inside a LAMBDA form - must be declared special|)))) + +(DEFUN WRNTYP (NAME) + #%(WARN NAME |Has been incorrectly declared *EXPR or *FEXPR -- Discovered while |) + (LREMPROP NAME '(*EXPR *FEXPR *LEXPR ARGS))) + diff --git a/src/comlap/srctrn.20 b/src/comlap/srctrn.20 new file mode 100755 index 00000000..7cf4b7b4 --- /dev/null +++ b/src/comlap/srctrn.20 @@ -0,0 +1,287 @@ +;;; SRCTRN -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ***** (Initialization for COMPLR) ************* +;;; ************************************************************** +;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** This is a Read-Only file! (All writes reserved) ******* +;;; ************************************************************** + + +(setq SRCTRNVERNO '#.(let* ((file (caddr (truename infile))) + (x (readlist (exploden file)))) + (setq |verno| (cond ((fixp x) file) ('/20))))) + +(eval-when (eval compile) + (load '((lisp) subload))) + + +(EVAL-WHEN (COMPILE) + (AND (OR (NOT (GET 'COMPDECLARE 'MACRO)) + (NOT (GET 'OUTFS 'MACRO))) + (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP)) + ('(LISP))) + CDMACS + FASL))) +) + + +(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|st|) ) + + + + +;;;; SOURCE-TRANS for LISTP, < and > + + +(defun LISTP-FERROR-expander (x &aux (arg (cadr x))) + (setq x (cond ((eq (car x) 'FERROR) `(CERROR () () ,.(cdr x))) + ((not (eq (car x) 'LISTP)) (barf x LISTP-FERROR-expander)) + ((|no-funp/|| (setq arg (macroexpand arg))) + `(OR (NULL ,arg) (EQ (TYPEP ,arg) 'LIST))) + ('T (|non-simple-x/|| (car x) arg)))) + (values x 'T)) + + +(defun ML-<>-expander (form &aux op ex?) + (cond + ((setq op (assq (car form) '((< . () ) + (> . () ) + (>= . <) + (<= . >)))) + (let ((nargs (length (cdr form)))) + (declare (fixnum nargs)) + (if (not (<= 2 nargs 510.)) (dbarf form WRNG-NO-ARGS)) + ;; << is the name of the function -- >> is name of its inversion, + ;; if an inversion must be used instead of the name directly. + (let (((<< . >>) op) + ((a b) (cdr form)) + c) + (cond ((= nargs 2) + ;; Simple case -- 2 args only + (if >> (setq form `(NOT (,>> ,a ,b)) ex? 'T))) + ((and (= nargs 3) + (not (|side-effectsp/|| a)) + (not (|side-effectsp/|| b)) + (not (|side-effectsp/|| (setq c (cadddr form))))) + ;; Remember |side-effectsp/|| may macroexpand. "between-p", + (let* ((bb (if (+INTERNAL-DUP-P b) b (si:gen-local-var))) + (body `(AND (,<< ,a ,bb) (,<< ,bb ,c)))) + ;; Maybe a 'lambda' wrapper? + (if (not (eq bb b)) + (setq body `((LAMBDA (,bb) ,body) ,b))) + (setq form body ex? 'T))) + ('T ;; Must bind all args, even though each one appears only + ;; once; otherwise its code will not get run when a>b. + ;; "a" must be EVAL'd first! + (let ((arglist (cdr form)) ga gb letlist body) + (si:gen-local-var ga) + (setq letlist `((,ga ,(car arglist)))) + (mapc #'(lambda (ll) + (si:gen-local-var gb) + (push `(,gb ,ll) letlist) + (push (cond (>> `(NOT (,>> ,ga ,gb))) + ('T `(,<< ,ga ,gb))) + body) + (setq ga gb)) + (cdr arglist)) + (setq form `(LET ,(nreverse letlist) + (AND ,.(nreverse body))) + ex? 'T)))))))) + (values form ex?)) + + +;;;; LOAD-BYTE, LDB, etc + +(defmacro SI:PICK-A-MASK (size) `(LSH -1 (- ,size 36.))) + +(defun SI:EVALUATE-NUMBER? (x) + (prog (cnst-fl) + A (if (atom (setq x (macroexpand x))) + (return (if (numberp x) x)) + (if (eq (car x) 'QUOTE) + (progn (setq x (cadr x)) (go A)))) + (cond ((memq (car x) '(+ - * // +$ -$ *$ //$ \ 1+ 1- 1+$ 1-$ ^ ^$ + PLUS DIFFERENCE TIMES QUOTIENT SUB1 ADD1 + REMAINDER EXPT ASH LSH ROT BOOLE FIX IFIX + FLOAT FSC SQRT SIN COS LOG EXP ATAN + LDB LOAD-BYTE DEPOSIT-BYTE DPB HAULONG HAIPART)) + () ) + ((memq (car x) '(LENGTH GETCHARN FLATC FLATSIZE SXHASH)) + (setq cnst-fl 'T)) + ('T (return () ))) + (if (do ((l (cdr x) (cdr l)) (y)) + ((null l) 'T) + (setq y (macroexpand (car l))) + (or (if cnst-fl + (|constant-p/|| y) + (si:evaluate-number? y)) + (return () ))) + (return (eval x))))) + + +;; LOAD-BYTE is similar to PDP-10 LDB, but "position" and "size" are separate + +(defun FOO-BYTE-EXPANDER (l) + (let (((name word position size val) l) + (fl 'T) + byte-len byte-displ (byte-mask 0) ldbp nval) + (declare (fixnum byte-mask)) + (setq word (macroexpand word) + position (macroexpand position) + size (macroexpand size)) + (if val (setq val (macroexpand val))) + (setq ldbp (eq name 'LOAD-BYTE)) + (cond + ((setq byte-len (si:evaluate-number? size)) + (or (and (fixnump byte-len) + (not (< byte-len 0)) + (not (> byte-len 36.))) + (dbarf l |Bad 'byte-length'|)) + (setq byte-mask (si:pick-a-mask byte-len)) + (setq l + (cond + ((= byte-len 0) (if ldbp ''0 `(PROG2 () ,word ,val))) + ((= byte-len 36.) (if ldbp `,word `(PROG2 ,word ,val))) + ((setq byte-displ (si:evaluate-number? position)) + (or (and (fixnump byte-displ) + (not (< byte-displ 0)) + (not (> (+ byte-displ byte-len) 36.))) + (dbarf l |Bad 'position'|)) + (let ((nword (si:evaluate-number? word)) + (shift-mask (lsh byte-mask position))) + (declare (fixnum shift-mask)) + (cond + (ldbp + (cond (nword (load-byte nword position byte-len)) + ('T (and (not (= 0 position)) + (setq word `(LSH ,word ,(- position)))) + `(BOOLE 1 ,word ,byte-mask)))) + ('T (if (setq nval (si:evaluate-number? val)) + (setq nval (logand nval byte-mask))) + (cond + ((and nword nval) + (deposit-byte nword position byte-len nval)) + (nword + (let ((lsher `(LSH ,val ,position))) + (if (= 0 (setq nword (boole 4 nword shift-mask))) + lsher + `(BOOLE 7 ,nword ,lsher)))) + ((let ((masked-word `(BOOLE 4 ,word ,shift-mask))) + (if (and nval (= nval 0)) + masked-word + `(BOOLE 7 ,masked-word + ,(if nval + (lsh nval position) + `(BOOLE 1 ,val ,shift-mask))))))))))) + (ldbp `(BOOLE 1 (LSH ,word (- ,position)) ,byte-mask)) + ('T (setq l () fl () ))))) + ((not (+internal-permutible-p (list word position size val))) + (setq l () fl () )) + (ldbp + (setq l `(BOOLE 1 (LSH ,word (- ,position)) (SI:PICK-A-MASK ,size)))) + ((prog (byte-masker bindings more-decls + shifted-mask shifted-byte deposit-zero? action) + (si:gen-local-var byte-masker) + (setq byte-displ (si:evaluate-number? position) + nval (si:evaluate-number? val) + deposit-zero? (and (fixnump nval) (= nval 0)) + bindings `((,byte-masker (SI:PICK-A-MASK ,size))) + shifted-byte (if deposit-zero? + 0 + (progn (if nval (setq val nval)) + `(BOOLE 1 ,val ,byte-masker))) + shifted-mask byte-masker ) + (cond ((null byte-displ) + (si:gen-local-var byte-displ) + (setq more-decls (list byte-displ)) + (push `(,BYTE-DISPL ,position) bindings))) + (cond ((or (not (fixnump byte-displ)) + (not (= byte-displ 0))) + (setq shifted-mask `(LSH ,shifted-mask ,BYTE-DISPL)) + (if (not deposit-zero?) + (setq shifted-byte `(LSH ,shifted-byte ,BYTE-DISPL))))) + (setq action `(BOOLE 4 ,word ,shifted-mask)) + (if (not deposit-zero?) + (setq action `(BOOLE 7 ,action ,shifted-byte))) + (setq l `(LET ,bindings + (DECLARE (FIXNUM ,BYTE-MASKER ,.more-decls)) + ,action))))) + (values l fl))) + + +(defun LDB-expander (l) + (let ((ldbp (eq (car l) 'LDB)) + (more? (cdr l)) + (fl 'T) + word val nval bp num-bp? tem) + (if (not ldbp) (setq val (macroexpand (car more?)) more? (cdr more?))) + (setq bp (macroexpand (car more?)) word (macroexpand (cadr more?))) + (setq num-bp? (si:evaluate-number? bp)) + (values + (cond + ((not num-bp?) + ;;Non-constant 'bp' case -- don't even try optimizations + (setq fl () )) + ((let ((pos (load-byte bp 6 6)) + (size (load-byte bp 0 6))) + (declare (fixnum pos size)) + (cond (ldbp `(LOAD-BYTE ,word ,pos ,size)) + ((cond ((setq tem (si:evaluate-number? val)) + (setq nval tem) + 'T) + ((setq tem (si:evaluate-number? word)) + (setq word tem) + 'T)) + `(DEPOSIT-BYTE ,word ,pos ,size ,val)) + ('T ;;When both the 'word' and 'newbyte' are computed up, then + ;; must worry about order of evaluation and side-effects + (let ((g (si:gen-local-var))) + `(LET ((,g ,val)) + (DECLARE (FIXNUM ,g)) + (DEPOSIT-BYTE ,word ,pos ,size ,g)))))))) + fl))) + + + +;;;; bitwise logical operations. + +(defun ML-trans-expander (form &aux (ex? 'T)) + (let ((fun (car form)) + (nargs (length (cdr form))) + (oform form) + (interval '(1 . 1)) + op) + (declare (fixnum nargs)) + (cond ((eq fun 'LOGNOT) + (setq form `(BOOLE 10. ,(cadr form) -1))) + ((setq op (cdr (assq fun '((LOGAND . 1) + (LOGIOR . 7) + (LOGXOR . 6))))) + (setq interval '(2 . 510.) + form `(BOOLE ,op ,.(cdr form)))) + ((setq op (cdr (assq fun '((FLONUMP . (FLOATP X)) + (EVENP . (NOT (ODDP X))))))) + (setq form (subst (cadr form) 'X op))) + ('T (setq ex? () ))) + (and ex? + (not (<= (car interval) nargs (cdr interval))) + ;; (or (< nargs (car interval)) (> nargs (cdr interval))) + (dbarf oform WRNG-NO-ARGS))) + (values form ex?)) + + +(mapc + #'(lambda (y) + (let (((fun . l) y) z) + (mapc #'(lambda (x) + (or (memq fun (setq z (get x 'SOURCE-TRANS))) + (putprop x (cons fun z) 'SOURCE-TRANS)) + (or (getl x '(SUBR LSUBR)) + (equal (get x 'AUTOLOAD) #%(autoload-filename MLSUB)) + (putprop x #%(autoload-filename MLSUB) 'AUTOLOAD))) + l))) + '((ML-trans-expander LOGAND LOGIOR LOGXOR LOGNOT FLONUMP EVENP) + (ML-<>-expander < > <= >= ) + (LISTP-FERROR-expander LISTP FERROR) + (foo-byte-expander LOAD-BYTE DEPOSIT-BYTE) + (LDB-expander LDB DPB)))