1 2% RLISP to LISP converter. A C Norman 2004 3 4 5%% 6%% Copyright (C) 2017, following the master REDUCE source files. * 7%% * 8%% Redistribution and use in source and binary forms, with or without * 9%% modification, are permitted provided that the following conditions are * 10%% met: * 11%% * 12%% * Redistributions of source code must retain the relevant * 13%% copyright notice, this list of conditions and the following * 14%% disclaimer. * 15%% * Redistributions in binary form must reproduce the above * 16%% copyright notice, this list of conditions and the following * 17%% disclaimer in the documentation and/or other materials provided * 18%% with the distribution. * 19%% * 20%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * 21%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * 22%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * 23%% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * 24%% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * 25%% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * 26%% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * 27%% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * 28%% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * 29%% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * 30%% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * 31%% DAMAGE. * 32%% 33 34 35% $Id: compiler.lsp 5739 2021-03-16 22:57:25Z arthurcnorman $ 36 37(global (quote (s!:opcodelist))) 38 39 40 41(setq s!:opcodelist (quote (LOADLOC LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 42LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11 43LOC0LOC1 LOC1LOC2 LOC2LOC3 LOC1LOC0 LOC2LOC1 LOC3LOC2 VNIL LOADLIT LOADLIT1 44LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7 LOADFREE LOADFREE1 45LOADFREE2 LOADFREE3 LOADFREE4 STORELOC STORELOC0 STORELOC1 STORELOC2 46STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7 STOREFREE STOREFREE1 47STOREFREE2 STOREFREE3 LOADLEX STORELEX CLOSURE CARLOC0 CARLOC1 CARLOC2 48CARLOC3 CARLOC4 CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11 49CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 CDRLOC5 CAARLOC0 CAARLOC1 CAARLOC2 50CAARLOC3 CALL0 CALL1 CALL2 CALL2R CALL3 CALL4 CALL0_0 CALL0_1 CALL0_2 CALL0_3 51CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5 CALL2_0 CALL2_1 CALL2_2 52CALL2_3 CALL2_4 BUILTIN0 BUILTIN1 BUILTIN2 BUILTIN2R BUILTIN3 APPLY1 APPLY2 53APPLY3 APPLY4 JCALL spare66 JUMP JUMP_B JUMP_L JUMP_BL JUMPNIL JUMPNIL_B 54JUMPNIL_L JUMPNIL_BL JUMPT JUMPT_B JUMPT_L JUMPT_BL JUMPATOM JUMPATOM_B 55JUMPATOM_L JUMPATOM_BL JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL JUMPEQ 56JUMPEQ_B JUMPEQ_L JUMPEQ_BL JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL JUMPEQUAL 57JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L 58JUMPNEQUAL_BL JUMPL0NIL JUMPL0T JUMPL1NIL JUMPL1T JUMPL2NIL JUMPL2T JUMPL3NIL 59JUMPL3T JUMPL4NIL JUMPL4T JUMPST0NIL JUMPST0T JUMPST1NIL JUMPST1T JUMPST2NIL 60JUMPST2T JUMPL0ATOM JUMPL0NATOM JUMPL1ATOM JUMPL1NATOM JUMPL2ATOM 61JUMPL2NATOM JUMPL3ATOM JUMPL3NATOM JUMPFREE1NIL JUMPFREE1T JUMPFREE2NIL 62JUMPFREE2T JUMPFREE3NIL JUMPFREE3T JUMPFREE4NIL JUMPFREE4T JUMPFREENIL 63JUMPFREET JUMPLIT1EQ JUMPLIT1NE JUMPLIT2EQ JUMPLIT2NE JUMPLIT3EQ JUMPLIT3NE 64JUMPLIT4EQ JUMPLIT4NE JUMPLITEQ JUMPLITNE JUMPB1NIL JUMPB1T JUMPB2NIL JUMPB2T 65JUMPFLAGP JUMPNFLAGP JUMPEQCAR JUMPNEQCAR CATCH CATCH_B CATCH_L CATCH_BL 66UNCATCH THROW PROTECT UNPROTECT PVBIND PVRESTORE FREEBIND FREERSTR EXIT 67NILEXIT LOC0EXIT LOC1EXIT LOC2EXIT PUSH PUSHNIL PUSHNIL2 PUSHNIL3 PUSHNILS 68POP LOSE LOSE2 LOSE3 LOSES SWOP EQ EQCAR EQUAL NUMBERP CAR CDR CAAR CADR CDAR 69CDDR CONS NCONS XCONS ACONS LENGTH LIST2 LIST2STAR LIST3 PLUS2 ADD1 70DIFFERENCE SUB1 TIMES2 GREATERP LESSP FLAGP GET LITGET GETV QGETV QGETVN 71BIGSTACK BIGCALL ICASE FASTGET ONEVALUE SPARE))) 72 73(prog (n) (setq n 0) (prog (var1001) (setq var1001 s!:opcodelist) lab1000 ( 74cond ((null var1001) (return nil))) (prog (v) (setq v (car var1001)) (progn ( 75put v (quote s!:opcode) n) (setq n (plus n 1)))) (setq var1001 (cdr var1001)) 76(go lab1000)) (return (list n (quote opcodes) (quote allocated)))) 77 78(setq s!:opcodelist nil) 79 80(fluid (quote (s!:env_alist))) 81 82(de s!:vecof (l) (prog (w) (setq w (assoc l s!:env_alist)) (cond (w (return ( 83cdr w)))) (setq w (s!:vecof1 l)) (setq s!:env_alist (cons (cons l w) 84s!:env_alist)) (return w))) 85 86(de s!:vecof1 (l) (prog (v n) (setq v (mkvect (sub1 (length l)))) (setq n 0) 87(prog (var1003) (setq var1003 l) lab1002 (cond ((null var1003) (return nil))) 88(prog (x) (setq x (car var1003)) (progn (putv v n x) (setq n (plus n 1)))) ( 89setq var1003 (cdr var1003)) (go lab1002)) (return v))) 90 91(progn (put (quote batchp) (quote s!:builtin0) 0) (put (quote date) (quote 92s!:builtin0) 1) (put (quote eject) (quote s!:builtin0) 2) (put (quote error1) 93(quote s!:builtin0) 3) (put (quote gctime) (quote s!:builtin0) 4) (put ( 94quote lposn) (quote s!:builtin0) 6) (put (quote posn) (quote s!:builtin0) 8) 95(put (quote read) (quote s!:builtin0) 9) (put (quote readch) (quote 96s!:builtin0) 10) (put (quote terpri) (quote s!:builtin0) 11) (put (quote time 97) (quote s!:builtin0) 12) (put (quote tyi) (quote s!:builtin0) 13) (put ( 98quote load!-spid) (quote s!:builtin0) 14) (put (quote abs) (quote s!:builtin1 99) 0) (put (quote add1) (quote s!:builtin1) 1) (put (quote !1!+) (quote 100s!:builtin1) 1) (put (quote atan) (quote s!:builtin1) 2) (put (quote apply0) 101(quote s!:builtin1) 3) (put (quote atom) (quote s!:builtin1) 4) (put (quote 102boundp) (quote s!:builtin1) 5) (put (quote char!-code) (quote s!:builtin1) 6) 103(put (quote close) (quote s!:builtin1) 7) (put (quote codep) (quote 104s!:builtin1) 8) (put (quote compress) (quote s!:builtin1) 9) (put (quote 105constantp) (quote s!:builtin1) 10) (put (quote digit) (quote s!:builtin1) 11) 106(put (quote endp) (quote s!:builtin1) 12) (put (quote eval) (quote 107s!:builtin1) 13) (put (quote evenp) (quote s!:builtin1) 14) (put (quote evlis 108) (quote s!:builtin1) 15) (put (quote explode) (quote s!:builtin1) 16) (put ( 109quote explode2lc) (quote s!:builtin1) 17) (put (quote explode2) (quote 110s!:builtin1) 18) (put (quote explodec) (quote s!:builtin1) 18) (put (quote 111fixp) (quote s!:builtin1) 19) (put (quote float) (quote s!:builtin1) 20) (put 112(quote floatp) (quote s!:builtin1) 21) (put (quote symbol!-specialp) (quote 113s!:builtin1) 22) (put (quote gc) (quote s!:builtin1) 23) (put (quote gensym1) 114(quote s!:builtin1) 24) (put (quote getenv) (quote s!:builtin1) 25) (put ( 115quote symbol!-globalp) (quote s!:builtin1) 26) (put (quote iadd1) (quote 116s!:builtin1) 27) (put (quote symbolp) (quote s!:builtin1) 28) (put (quote 117iminus) (quote s!:builtin1) 29) (put (quote iminusp) (quote s!:builtin1) 30) 118(put (quote indirect) (quote s!:builtin1) 31) (put (quote integerp) (quote 119s!:builtin1) 32) (put (quote intern) (quote s!:builtin1) 33) (put (quote 120isub1) (quote s!:builtin1) 34) (put (quote length) (quote s!:builtin1) 35) ( 121put (quote lengthc) (quote s!:builtin1) 36) (put (quote linelength) (quote 122s!:builtin1) 37) (put (quote liter) (quote s!:builtin1) 38) (put (quote 123load!-module) (quote s!:builtin1) 39) (put (quote lognot) (quote s!:builtin1) 12440) (put (quote macroexpand) (quote s!:builtin1) 41) (put (quote 125macroexpand!-1) (quote s!:builtin1) 42) (put (quote macro!-function) (quote 126s!:builtin1) 43) (put (quote make!-bps) (quote s!:builtin1) 44) (put (quote 127make!-global) (quote s!:builtin1) 45) (put (quote make!-simple!-string) ( 128quote s!:builtin1) 46) (put (quote make!-special) (quote s!:builtin1) 47) ( 129put (quote minus) (quote s!:builtin1) 48) (put (quote minusp) (quote 130s!:builtin1) 49) (put (quote mkvect) (quote s!:builtin1) 50) (put (quote 131modular!-minus) (quote s!:builtin1) 51) (put (quote modular!-number) (quote 132s!:builtin1) 52) (put (quote modular!-reciprocal) (quote s!:builtin1) 53) ( 133put (quote null) (quote s!:builtin1) 54) (put (quote oddp) (quote s!:builtin1 134) 55) (put (quote onep) (quote s!:builtin1) 56) (put (quote pagelength) ( 135quote s!:builtin1) 57) (put (quote pairp) (quote s!:builtin1) 58) (put (quote 136plist) (quote s!:builtin1) 59) (put (quote plusp) (quote s!:builtin1) 60) ( 137put (quote prin) (quote s!:builtin1) 61) (put (quote princ) (quote 138s!:builtin1) 62) (put (quote print) (quote s!:builtin1) 63) (put (quote 139printc) (quote s!:builtin1) 64) (put (quote rds) (quote s!:builtin1) 68) (put 140(quote remd) (quote s!:builtin1) 69) (put (quote reverse) (quote s!:builtin1 141) 70) (put (quote reversip) (quote s!:builtin1) 71) (put (quote seprp) (quote 142s!:builtin1) 72) (put (quote set!-small!-modulus) (quote s!:builtin1) 73) ( 143put (quote spaces) (quote s!:builtin1) 74) (put (quote xtab) (quote 144s!:builtin1) 74) (put (quote special!-char) (quote s!:builtin1) 75) (put ( 145quote special!-form!-p) (quote s!:builtin1) 76) (put (quote spool) (quote 146s!:builtin1) 77) (put (quote stop) (quote s!:builtin1) 78) (put (quote 147stringp) (quote s!:builtin1) 79) (put (quote sub1) (quote s!:builtin1) 80) ( 148put (quote !1!-) (quote s!:builtin1) 80) (put (quote symbol!-env) (quote 149s!:builtin1) 81) (put (quote symbol!-function) (quote s!:builtin1) 82) (put ( 150quote symbol!-name) (quote s!:builtin1) 83) (put (quote symbol!-value) (quote 151s!:builtin1) 84) (put (quote system) (quote s!:builtin1) 85) (put (quote fix 152) (quote s!:builtin1) 86) (put (quote ttab) (quote s!:builtin1) 87) (put ( 153quote tyo) (quote s!:builtin1) 88) (put (quote remob) (quote s!:builtin1) 89) 154(put (quote unmake!-global) (quote s!:builtin1) 90) (put (quote 155unmake!-special) (quote s!:builtin1) 91) (put (quote upbv) (quote s!:builtin1 156) 92) (put (quote vectorp) (quote s!:builtin1) 93) (put (quote verbos) (quote 157s!:builtin1) 94) (put (quote wrs) (quote s!:builtin1) 95) (put (quote zerop) 158(quote s!:builtin1) 96) (put (quote car) (quote s!:builtin1) 97) (put (quote 159cdr) (quote s!:builtin1) 98) (put (quote caar) (quote s!:builtin1) 99) (put 160(quote cadr) (quote s!:builtin1) 100) (put (quote cdar) (quote s!:builtin1) 161101) (put (quote cddr) (quote s!:builtin1) 102) (put (quote qcar) (quote 162s!:builtin1) 103) (put (quote qcdr) (quote s!:builtin1) 104) (put (quote 163qcaar) (quote s!:builtin1) 105) (put (quote qcadr) (quote s!:builtin1) 106) ( 164put (quote qcdar) (quote s!:builtin1) 107) (put (quote qcddr) (quote 165s!:builtin1) 108) (put (quote ncons) (quote s!:builtin1) 109) (put (quote 166numberp) (quote s!:builtin1) 110) (put (quote is!-spid) (quote s!:builtin1) 167111) (put (quote spid!-to!-nil) (quote s!:builtin1) 112) (put (quote 168mv!-list!*) (quote s!:builtin1) 113) (put (quote append) (quote s!:builtin2) 1690) (put (quote ash) (quote s!:builtin2) 1) (put (quote assoc) (quote 170s!:builtin2) 2) (put (quote assoc!*!*) (quote s!:builtin2) 2) (put (quote 171atsoc) (quote s!:builtin2) 3) (put (quote deleq) (quote s!:builtin2) 4) (put 172(quote delete) (quote s!:builtin2) 5) (put (quote divide) (quote s!:builtin2) 1736) (put (quote eqcar) (quote s!:builtin2) 7) (put (quote eql) (quote 174s!:builtin2) 8) (put (quote eqn) (quote s!:builtin2) 9) (put (quote expt) ( 175quote s!:builtin2) 10) (put (quote flag) (quote s!:builtin2) 11) (put (quote 176flagpcar) (quote s!:builtin2) 12) (put (quote gcdn) (quote s!:builtin2) 13) ( 177put (quote geq) (quote s!:builtin2) 14) (put (quote getv) (quote s!:builtin2) 17815) (put (quote greaterp) (quote s!:builtin2) 16) (put (quote idifference) ( 179quote s!:builtin2) 17) (put (quote igreaterp) (quote s!:builtin2) 18) (put ( 180quote ilessp) (quote s!:builtin2) 19) (put (quote imax) (quote s!:builtin2) 18120) (put (quote imin) (quote s!:builtin2) 21) (put (quote iplus2) (quote 182s!:builtin2) 22) (put (quote iquotient) (quote s!:builtin2) 23) (put (quote 183iremainder) (quote s!:builtin2) 24) (put (quote irightshift) (quote 184s!:builtin2) 25) (put (quote itimes2) (quote s!:builtin2) 26) (put (quote leq 185) (quote s!:builtin2) 28) (put (quote lessp) (quote s!:builtin2) 29) (put ( 186quote max2) (quote s!:builtin2) 31) (put (quote member) (quote s!:builtin2) 18732) (put (quote member!*!*) (quote s!:builtin2) 32) (put (quote memq) (quote 188s!:builtin2) 33) (put (quote min2) (quote s!:builtin2) 34) (put (quote mod) ( 189quote s!:builtin2) 35) (put (quote modular!-difference) (quote s!:builtin2) 19036) (put (quote modular!-expt) (quote s!:builtin2) 37) (put (quote 191modular!-plus) (quote s!:builtin2) 38) (put (quote modular!-quotient) (quote 192s!:builtin2) 39) (put (quote modular!-times) (quote s!:builtin2) 40) (put ( 193quote nconc) (quote s!:builtin2) 41) (put (quote neq) (quote s!:builtin2) 42) 194(put (quote orderp) (quote s!:builtin2) 43) (put (quote quotient) (quote 195s!:builtin2) 44) (put (quote remainder) (quote s!:builtin2) 45) (put (quote 196remflag) (quote s!:builtin2) 46) (put (quote remprop) (quote s!:builtin2) 47) 197(put (quote rplaca) (quote s!:builtin2) 48) (put (quote rplacd) (quote 198s!:builtin2) 49) (put (quote schar) (quote s!:builtin2) 50) (put (quote set) 199(quote s!:builtin2) 51) (put (quote smemq) (quote s!:builtin2) 52) (put ( 200quote subla) (quote s!:builtin2) 53) (put (quote sublis) (quote s!:builtin2) 20154) (put (quote symbol!-set!-definition) (quote s!:builtin2) 55) (put (quote 202symbol!-set!-env) (quote s!:builtin2) 56) (put (quote times2) (quote 203s!:builtin2) 57) (put (quote xcons) (quote s!:builtin2) 58) (put (quote equal 204) (quote s!:builtin2) 59) (put (quote eq) (quote s!:builtin2) 60) (put (quote 205cons) (quote s!:builtin2) 61) (put (quote list2) (quote s!:builtin2) 62) ( 206put (quote get) (quote s!:builtin2) 63) (put (quote qgetv) (quote s!:builtin2 207) 64) (put (quote flagp) (quote s!:builtin2) 65) (put (quote apply1) (quote 208s!:builtin2) 66) (put (quote difference) (quote s!:builtin2) 67) (put (quote 209plus2) (quote s!:builtin2) 68) (put (quote times2) (quote s!:builtin2) 69) ( 210put (quote equalcar) (quote s!:builtin2) 70) (put (quote iequal) (quote 211s!:builtin2) 71) (put (quote nreverse) (quote s!:builtin2) 72) (put (quote 212bps!-putv) (quote s!:builtin3) 0) (put (quote errorset) (quote s!:builtin3) 1 213) (put (quote list2!*) (quote s!:builtin3) 2) (put (quote list3) (quote 214s!:builtin3) 3) (put (quote putprop) (quote s!:builtin3) 4) (put (quote putv) 215(quote s!:builtin3) 5) (put (quote putv!-char) (quote s!:builtin3) 6) (put ( 216quote subst) (quote s!:builtin3) 7) (put (quote apply2) (quote s!:builtin3) 8 217) (put (quote acons) (quote s!:builtin3) 9) nil) 218 219(de s!:prinhex1 (n) (princ (schar "0123456789abcdef" (logand n 15)))) 220 221(de s!:prinhex2 (n) (progn (s!:prinhex1 (truncate n 16)) (s!:prinhex1 n))) 222 223(de s!:prinhex4 (n) (progn (s!:prinhex2 (truncate n 256)) (s!:prinhex2 n))) 224 225(flag (quote (comp plap pgwd pwrds notailcall ord nocompile carcheckflag 226savedef r2i)) (quote switch)) 227 228(cond ((not (boundp (quote !*comp))) (progn (fluid (quote (!*comp))) (setq 229!*comp t)))) 230 231(cond ((not (boundp (quote !*nocompile))) (progn (fluid (quote (!*nocompile)) 232) (setq !*nocompile nil)))) 233 234(cond ((not (boundp (quote !*plap))) (progn (fluid (quote (!*plap))) (setq 235!*plap nil)))) 236 237(cond ((not (boundp (quote !*pgwd))) (progn (fluid (quote (!*pgwd))) (setq 238!*pgwd nil)))) 239 240(cond ((not (boundp (quote !*pwrds))) (progn (fluid (quote (!*pwrds))) (setq 241!*pwrds t)))) 242 243(cond ((not (boundp (quote !*notailcall))) (progn (fluid (quote (!*notailcall 244))) (setq !*notailcall nil)))) 245 246(cond ((not (boundp (quote !*ord))) (progn (fluid (quote (!*ord))) (setq 247!*ord t)))) 248 249(cond ((not (boundp (quote !*savedef))) (progn (fluid (quote (!*savedef))) ( 250setq !*savedef nil)))) 251 252(cond ((not (boundp (quote !*carcheckflag))) (progn (fluid (quote ( 253!*carcheckflag))) (setq !*carcheckflag t)))) 254 255(cond ((not (boundp (quote !*r2i))) (progn (fluid (quote (!*r2i))) (setq 256!*r2i t)))) 257 258(fluid (quote (s!:current_function s!:current_label s!:current_block 259s!:current_size s!:current_procedure s!:other_defs s!:lexical_env 260s!:has_closure s!:recent_literals s!:used_lexicals s!:a_reg_values 261s!:current_count s!:maybe_values))) 262 263(de s!:start_procedure (nargs nopts restarg) (progn (setq 264s!:current_procedure nil) (setq s!:current_label (gensym)) (setq 265s!:a_reg_values nil) (cond ((or (not (zerop nopts)) restarg) (progn (setq 266s!:current_block (list (list (quote OPTARGS) nopts) nopts (list (quote 267ARGCOUNT) nargs) nargs)) (setq s!:current_size 2))) (t (cond ((greaterp nargs 2683) (progn (setq s!:current_block (list (list (quote ARGCOUNT) nargs) nargs)) 269(setq s!:current_size 1))) (t (progn (setq s!:current_block nil) (setq 270s!:current_size 0)))))))) 271 272(de s!:set_label (x) (progn (cond (s!:current_label (prog (w) (setq w (cons 273s!:current_size s!:current_block)) (prog (var1005) (setq var1005 274s!:recent_literals) lab1004 (cond ((null var1005) (return nil))) (prog (x) ( 275setq x (car var1005)) (rplaca x w)) (setq var1005 (cdr var1005)) (go lab1004) 276) (setq s!:recent_literals nil) (setq s!:current_procedure (cons (cons 277s!:current_label (cons (list (quote JUMP) x) w)) s!:current_procedure)) (setq 278s!:current_block nil) (setq s!:current_size 0)))) (setq s!:current_label x) 279(setq s!:a_reg_values nil))) 280 281(de s!:outjump (op lab) (prog (g w) (cond ((not (flagp op (quote 282s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) 283(return nil))) (cond ((equal op (quote JUMP)) (setq op (list op lab))) (t ( 284cond ((equal op (quote ICASE)) (setq op (cons op lab))) (t (setq op (list op 285lab (setq g (gensym)))))))) (setq w (cons s!:current_size s!:current_block)) 286(prog (var1007) (setq var1007 s!:recent_literals) lab1006 (cond ((null 287var1007) (return nil))) (prog (x) (setq x (car var1007)) (rplaca x w)) (setq 288var1007 (cdr var1007)) (go lab1006)) (setq s!:recent_literals nil) (setq 289s!:current_procedure (cons (cons s!:current_label (cons op w)) 290s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0) ( 291setq s!:current_label g) (return op))) 292 293(de s!:outexit nil (prog (w op) (setq op (quote (EXIT))) (cond ((null 294s!:current_label) (return nil))) (setq w (cons s!:current_size 295s!:current_block)) (prog (var1009) (setq var1009 s!:recent_literals) lab1008 296(cond ((null var1009) (return nil))) (prog (x) (setq x (car var1009)) (rplaca 297x w)) (setq var1009 (cdr var1009)) (go lab1008)) (setq s!:recent_literals 298nil) (setq s!:current_procedure (cons (cons s!:current_label (cons op w)) 299s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0) ( 300setq s!:current_label nil))) 301 302(flag (quote (PUSH PUSHNIL PUSHNIL2 PUSHNIL3 LOSE LOSE2 LOSE3 LOSES STORELOC 303STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 304STORELOC7 JUMP JUMPT JUMPNIL JUMPEQ JUMPEQUAL JUMPNE JUMPNEQUAL JUMPATOM 305JUMPNATOM)) (quote s!:preserves_a)) 306 307(de s!:outopcode0 (op doc) (prog nil (cond ((not (flagp op (quote 308s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) 309(return nil))) (setq s!:current_block (cons op s!:current_block)) (setq 310s!:current_size (plus s!:current_size 1)) (cond ((or !*plap !*pgwd) (setq 311s!:current_block (cons doc s!:current_block)))))) 312 313(de s!:outopcode1 (op arg doc) (prog nil (cond ((not (flagp op (quote 314s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) 315(return nil))) (setq s!:current_block (cons arg (cons op s!:current_block))) 316(setq s!:current_size (plus s!:current_size 2)) (cond ((or !*plap !*pgwd) ( 317setq s!:current_block (cons (list op doc) s!:current_block)))))) 318 319(deflist (quote ((LOADLIT 1) (LOADFREE 2) (CALL0 2) (CALL1 2) (LITGET 2) ( 320JUMPLITEQ 2) (JUMPLITNE 2) (JUMPLITEQ!* 2) (JUMPLITNE!* 2) (JUMPFREET 2) ( 321JUMPFREENIL 2))) (quote s!:short_form_bonus)) 322 323(de s!:record_literal (env) (prog (w extra) (setq w (gethash (car 324s!:current_block) (car env))) (cond ((null w) (setq w (cons 0 nil)))) (setq 325extra (get (cadr s!:current_block) (quote s!:short_form_bonus))) (cond ((null 326extra) (setq extra 10)) (t (setq extra (plus extra 10)))) (setq 327s!:recent_literals (cons (cons nil s!:current_block) s!:recent_literals)) ( 328puthash (car s!:current_block) (car env) (cons (plus (car w) extra) (cons ( 329car s!:recent_literals) (cdr w)))))) 330 331(de s!:record_literal_for_jump (x env lab) (prog (w extra) (cond ((null 332s!:current_label) (return nil))) (setq w (gethash (cadr x) (car env))) (cond 333((null w) (setq w (cons 0 nil)))) (setq extra (get (car x) (quote 334s!:short_form_bonus))) (cond ((null extra) (setq extra 10)) (t (setq extra ( 335plus extra 10)))) (setq x (s!:outjump x lab)) (puthash (cadar x) (car env) ( 336cons (plus (car w) extra) (cons (cons nil x) (cdr w)))))) 337 338(de s!:outopcode1lit (op arg env) (prog nil (cond ((not (flagp op (quote 339s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) 340(return nil))) (setq s!:current_block (cons arg (cons op s!:current_block))) 341(s!:record_literal env) (setq s!:current_size (plus s!:current_size 2)) ( 342cond ((or !*plap !*pgwd) (setq s!:current_block (cons (list op arg) 343s!:current_block)))))) 344 345(de s!:outopcode2 (op arg1 arg2 doc) (prog nil (cond ((not (flagp op (quote 346s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) 347(return nil))) (setq s!:current_block (cons arg2 (cons arg1 (cons op 348s!:current_block)))) (setq s!:current_size (plus s!:current_size 3)) (cond (( 349or !*plap !*pgwd) (setq s!:current_block (cons (cons op doc) s!:current_block 350)))))) 351 352(de s!:outlexref (op arg1 arg2 arg3 doc) (prog (arg4) (cond ((null 353s!:current_label) (return nil))) (cond ((or (greaterp arg1 255) (greaterp 354arg2 255) (greaterp arg3 255)) (progn (cond ((or (greaterp arg1 2047) ( 355greaterp arg2 31) (greaterp arg3 2047)) (error 0 356"stack frame > 2047 or > 31 deep nesting"))) (setq doc (list op doc)) (setq 357arg4 (logand arg3 255)) (setq arg3 (plus (truncate arg3 256) (times 16 ( 358logand arg1 15)))) (cond ((equal op (quote LOADLEX)) (setq op (plus 192 arg2) 359)) (t (setq op (plus 224 arg2)))) (setq arg2 (truncate arg1 16)) (setq arg1 360op) (setq op (quote BIGSTACK)))) (t (setq doc (list doc)))) (setq 361s!:current_block (cons arg3 (cons arg2 (cons arg1 (cons op s!:current_block)) 362))) (setq s!:current_size (plus s!:current_size 4)) (cond (arg4 (progn (setq 363s!:current_block (cons arg4 s!:current_block)) (setq s!:current_size (plus 364s!:current_size 1))))) (cond ((or !*plap !*pgwd) (setq s!:current_block (cons 365(cons op doc) s!:current_block)))))) 366 367(put (quote LOADLIT) (quote s!:shortform) (cons (quote (1 . 7)) (s!:vecof ( 368quote (!- LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7))))) 369 370(put (quote LOADFREE) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( 371quote (!- LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4))))) 372 373(put (quote STOREFREE) (quote s!:shortform) (cons (quote (1 . 3)) (s!:vecof ( 374quote (!- STOREFREE1 STOREFREE2 STOREFREE3))))) 375 376(put (quote CALL0) (quote s!:shortform) (cons (quote (0 . 3)) (s!:vecof ( 377quote (CALL0_0 CALL0_1 CALL0_2 CALL0_3))))) 378 379(put (quote CALL1) (quote s!:shortform) (cons (quote (0 . 5)) (s!:vecof ( 380quote (CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5))))) 381 382(put (quote CALL2) (quote s!:shortform) (cons (quote (0 . 4)) (s!:vecof ( 383quote (CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4))))) 384 385(put (quote JUMPFREET) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( 386quote (!- JUMPFREE1T JUMPFREE2T JUMPFREE3T JUMPFREE4T))))) 387 388(put (quote JUMPFREENIL) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof 389(quote (!- JUMPFREE1NIL JUMPFREE2NIL JUMPFREE3NIL JUMPFREE4NIL))))) 390 391(put (quote JUMPLITEQ) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( 392quote (!- JUMPLIT1EQ JUMPLIT2EQ JUMPLIT3EQ JUMPLIT4EQ))))) 393 394(put (quote JUMPLITNE) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( 395quote (!- JUMPLIT1NE JUMPLIT2NE JUMPLIT3NE JUMPLIT4NE))))) 396 397(put (quote JUMPLITEQ!*) (quote s!:shortform) (get (quote JUMPLITEQ) (quote 398s!:shortform))) 399 400(put (quote JUMPLITNE!*) (quote s!:shortform) (get (quote JUMPLITNE) (quote 401s!:shortform))) 402 403(put (quote CALL0) (quote s!:longform) 0) 404 405(put (quote CALL1) (quote s!:longform) 16) 406 407(put (quote CALL2) (quote s!:longform) 32) 408 409(put (quote CALL3) (quote s!:longform) 48) 410 411(put (quote CALL4) (quote s!:longform) 64) 412 413(put (quote CALL2R) (quote s!:longform) 80) 414 415(put (quote LOADFREE) (quote s!:longform) 96) 416 417(put (quote STOREFREE) (quote s!:longform) 112) 418 419(put (quote JCALL0) (quote s!:longform) 128) 420 421(put (quote JCALL1) (quote s!:longform) 144) 422 423(put (quote JCALL2) (quote s!:longform) 160) 424 425(put (quote JCALL3) (quote s!:longform) 176) 426 427(put (quote JCALL4) (quote s!:longform) 192) 428 429(put (quote FREEBIND) (quote s!:longform) 208) 430 431(put (quote LITGET) (quote s!:longform) 224) 432 433(put (quote LOADLIT) (quote s!:longform) 240) 434 435(de s!:literal_order (a b) (cond ((equal (cadr a) (cadr b)) (orderp (car a) ( 436car b))) (t (greaterp (cadr a) (cadr b))))) 437 438(de s!:resolve_literals (env checksum) (prog (w op opspec n litbytes) (setq w 439(hashcontents (car env))) (setq w (sort w (function s!:literal_order))) ( 440setq w (append w (list (list checksum 0)))) (setq n (length w)) (setq 441litbytes (times 4 n)) (cond ((greaterp n 4096) (setq w (s!:too_many_literals 442w n)))) (setq n 0) (prog (var1011) (setq var1011 w) lab1010 (cond ((null 443var1011) (return nil))) (prog (x) (setq x (car var1011)) (progn (rplaca (cdr 444x) n) (setq n (plus n 1)))) (setq var1011 (cdr var1011)) (go lab1010)) (prog 445(var1015) (setq var1015 w) lab1014 (cond ((null var1015) (return nil))) (prog 446(x) (setq x (car var1015)) (progn (setq n (cadr x)) (prog (var1013) (setq 447var1013 (cddr x)) lab1012 (cond ((null var1013) (return nil))) (prog (y) ( 448setq y (car var1013)) (progn (cond ((null (car y)) (progn (setq op (caadr y)) 449(setq opspec (get op (quote s!:shortform))) (cond ((and opspec (leq (caar 450opspec) n) (leq n (cdar opspec))) (rplaca (cdr y) (getv (cdr opspec) n))) (t 451(rplaca (cdadr y) n))))) (t (progn (setq op (caddr y)) (cond ((greaterp n 255 452) (progn (rplaca (car y) (plus (caar y) 1)) (setq op (plus (get op (quote 453s!:longform)) (truncate n 256))) (rplaca (cdr y) (ilogand n 255)) (rplaca ( 454cddr y) (quote BIGCALL)) (rplacd (cdr y) (cons op (cddr y))))) (t (cond ((and 455(setq opspec (get op (quote s!:shortform))) (leq (caar opspec) n) (leq n ( 456cdar opspec))) (progn (rplaca (car y) (difference (caar y) 1)) (rplaca (cdr y 457) (getv (cdr opspec) n)) (rplacd (cdr y) (cdddr y)))) (t (rplaca (cdr y) n))) 458))))))) (setq var1013 (cdr var1013)) (go lab1012)))) (setq var1015 (cdr 459var1015)) (go lab1014)) (prog (var1017) (setq var1017 w) lab1016 (cond ((null 460var1017) (return nil))) (prog (x) (setq x (car var1017)) (rplacd x (cadr x)) 461) (setq var1017 (cdr var1017)) (go lab1016)) (rplaca env (cons (reversip w) 462litbytes)))) 463 464(de s!:only_loadlit (l) (cond ((null l) t) (t (cond ((null (caar l)) nil) (t 465(cond ((not (eqcar (cddar l) (quote LOADLIT))) nil) (t (s!:only_loadlit (cdr 466l))))))))) 467 468(de s!:too_many_literals (w n) (prog (k xvecs l r newrefs uses z1) (setq k 0) 469(setq n (plus n 1)) (prog nil lab1018 (cond ((null (and (greaterp n 4096) ( 470not (null w)))) (return nil))) (progn (cond ((and (not (equal (cadar w) 47110000000)) (s!:only_loadlit (cddar w))) (progn (setq l (cons (car w) l)) ( 472setq n (difference n 1)) (setq k (plus k 1)) (cond ((equal k 256) (progn ( 473setq xvecs (cons l xvecs)) (setq l nil) (setq k 0) (setq n (plus n 1))))))) ( 474t (setq r (cons (car w) r)))) (setq w (cdr w))) (go lab1018)) (cond (( 475greaterp n 4096) (error 0 "function uses too many literals (4096 is limit)")) 476) (setq xvecs (cons l xvecs)) (prog nil lab1019 (cond ((null r) (return nil)) 477) (progn (setq w (cons (car r) w)) (setq r (cdr r))) (go lab1019)) (prog ( 478var1025) (setq var1025 xvecs) lab1024 (cond ((null var1025) (return nil))) ( 479prog (v) (setq v (car var1025)) (progn (setq newrefs nil) (setq uses 0) (setq 480r nil) (setq k 0) (prog (var1023) (setq var1023 v) lab1022 (cond ((null 481var1023) (return nil))) (prog (q) (setq q (car var1023)) (progn (prog ( 482var1021) (setq var1021 (cddr q)) lab1020 (cond ((null var1021) (return nil))) 483(prog (z) (setq z (car var1021)) (progn (cond ((car z) (rplaca (car z) (plus 484(caar z) 2)))) (setq z1 (cons (quote QGETVN) (cons nil (cddr z)))) (rplaca ( 485cdr z) k) (rplacd (cdr z) z1) (rplacd z (cdr z1)) (setq newrefs (cons z 486newrefs)) (setq uses (plus uses 11)))) (setq var1021 (cdr var1021)) (go 487lab1020)) (setq r (cons (car q) r)) (setq k (plus k 1)))) (setq var1023 (cdr 488var1023)) (go lab1022)) (setq newrefs (cons uses newrefs)) (setq newrefs ( 489cons (s!:vecof (reversip r)) newrefs)) (setq w (cons newrefs w)))) (setq 490var1025 (cdr var1025)) (go lab1024)) (return (sort w (function 491s!:literal_order))))) 492 493(fluid (quote (s!:into_c))) 494 495(de s!:endprocedure (name env checksum) (prog (pc labelvals w vec) ( 496s!:outexit) (cond (s!:into_c (return (cons s!:current_procedure env)))) ( 497s!:resolve_literals env checksum) (setq s!:current_procedure ( 498s!:tidy_flowgraph s!:current_procedure)) (cond ((and (not !*notailcall) (not 499s!:has_closure)) (setq s!:current_procedure (s!:try_tailcall 500s!:current_procedure)))) (setq s!:current_procedure (s!:tidy_exits 501s!:current_procedure)) (setq labelvals (s!:resolve_labels)) (setq pc (car 502labelvals)) (setq labelvals (cdr labelvals)) (setq vec (make!-bps pc)) (setq 503pc 0) (cond ((or !*plap !*pgwd) (progn (terpri) (ttab 23) (princ "+++ ") ( 504prin name) (princ " +++") (terpri)))) (prog (var1027) (setq var1027 505s!:current_procedure) lab1026 (cond ((null var1027) (return nil))) (prog (b) 506(setq b (car var1027)) (progn (cond ((and (car b) (flagp (car b) (quote 507used_label)) (or !*plap !*pgwd)) (progn (ttab 20) (prin (car b)) (princ ":") 508(terpri)))) (setq pc (s!:plant_basic_block vec pc (reverse (cdddr b)))) (setq 509b (cadr b)) (cond ((and b (neq (car b) (quote ICASE)) (cdr b) (cddr b)) ( 510setq b (list (car b) (cadr b))))) (setq pc (s!:plant_exit_code vec pc b 511labelvals)))) (setq var1027 (cdr var1027)) (go lab1026)) (cond (!*pwrds ( 512progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin name) (princ 513" compiled, ") (princ pc) (princ " + ") (princ (cdar env)) (princ " bytes") ( 514terpri)))) (setq env (caar env)) (cond ((null env) (setq w nil)) (t (progn ( 515setq w (mkvect (cdar env))) (prog nil lab1028 (cond ((null env) (return nil)) 516) (progn (putv w (cdar env) (caar env)) (setq env (cdr env))) (go lab1028)))) 517) (return (cons vec w)))) 518 519(de s!:add_pending (lab pend blocks) (prog (w) (cond ((not (atom lab)) ( 520return (cons (list (gensym) lab 0) pend)))) (setq w (atsoc lab pend)) (cond ( 521w (return (cons w (deleq w pend)))) (t (return (cons (atsoc lab blocks) pend) 522))))) 523 524(de s!:invent_exit (x blocks) (prog (w) (setq w blocks) scan (cond ((null w) 525(go not_found)) (t (cond ((and (eqcar (cadar w) x) (equal (caddar w) 0)) ( 526return (cons (caar w) blocks))) (t (setq w (cdr w)))))) (go scan) not_found ( 527setq w (gensym)) (return (cons w (cons (list w (list x) 0) blocks))))) 528 529(de s!:destination_label (lab blocks) (prog (n w x) (setq w (atsoc lab blocks 530)) (cond ((s!:is_lose_and_exit w blocks) (return (quote (EXIT))))) (setq x ( 531cadr w)) (setq n (caddr w)) (setq w (cdddr w)) (cond ((neq n 0) (return lab)) 532) (cond ((or (null x) (null (cdr x))) (return x)) (t (cond ((equal (cadr x) 533lab) (return lab)) (t (cond ((null (cddr x)) (return (s!:destination_label ( 534cadr x) blocks))) (t (return lab))))))))) 535 536(de s!:remlose (b) (prog (w) (setq w b) (prog nil lab1029 (cond ((null (and w 537(not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1029)) (cond ( 538(null w) (return (cons 0 b)))) (cond ((and (numberp (car w)) (eqcar (cdr w) ( 539quote LOSES))) (setq w (cons 2 (cddr w)))) (t (cond ((or (equal (car w) ( 540quote LOSE)) (equal (car w) (quote LOSE2)) (equal (car w) (quote LOSE3))) ( 541setq w (cons 1 (cdr w)))) (t (return (cons 0 b)))))) (setq b (s!:remlose (cdr 542w))) (return (cons (plus (car w) (car b)) (cdr b))))) 543 544(put (quote CALL0_0) (quote s!:shortcall) (quote (0 . 0))) 545 546(put (quote CALL0_1) (quote s!:shortcall) (quote (0 . 1))) 547 548(put (quote CALL0_2) (quote s!:shortcall) (quote (0 . 2))) 549 550(put (quote CALL0_3) (quote s!:shortcall) (quote (0 . 3))) 551 552(put (quote CALL1_0) (quote s!:shortcall) (quote (1 . 0))) 553 554(put (quote CALL1_1) (quote s!:shortcall) (quote (1 . 1))) 555 556(put (quote CALL1_2) (quote s!:shortcall) (quote (1 . 2))) 557 558(put (quote CALL1_3) (quote s!:shortcall) (quote (1 . 3))) 559 560(put (quote CALL1_4) (quote s!:shortcall) (quote (1 . 4))) 561 562(put (quote CALL1_5) (quote s!:shortcall) (quote (1 . 5))) 563 564(put (quote CALL2_0) (quote s!:shortcall) (quote (2 . 0))) 565 566(put (quote CALL2_1) (quote s!:shortcall) (quote (2 . 1))) 567 568(put (quote CALL2_2) (quote s!:shortcall) (quote (2 . 2))) 569 570(put (quote CALL2_3) (quote s!:shortcall) (quote (2 . 3))) 571 572(put (quote CALL2_4) (quote s!:shortcall) (quote (2 . 4))) 573 574(de s!:remcall (b) (prog (w cmnt nargs lvoff callsize) (prog nil lab1030 ( 575cond ((null (and b (not (atom (car b))))) (return nil))) (progn (setq cmnt ( 576car b)) (setq b (cdr b))) (go lab1030)) (cond ((null b) (return nil)) (t ( 577cond ((numberp (car b)) (progn (setq lvoff (car b)) (setq callsize 2) (setq b 578(cdr b)) (cond ((null b) (return nil)) (t (cond ((numberp (car b)) (progn ( 579setq nargs lvoff) (setq lvoff (car b)) (setq callsize 3) (setq b (cdr b)) ( 580cond ((eqcar b (quote BIGCALL)) (progn (setq w (truncate lvoff 16)) (setq 581lvoff (plus (times 256 (logand lvoff 15)) nargs)) (setq nargs w) (cond (( 582equal nargs 5) (progn (setq nargs 2) (setq callsize (difference callsize 1)) 583(setq b (cons (quote BIGCALL) (cons (quote SWOP) (cdr b))))))) (cond (( 584greaterp nargs 4) (return nil))))) (t (return nil))))) (t (cond ((equal (car 585b) (quote CALL0)) (setq nargs 0)) (t (cond ((equal (car b) (quote CALL1)) ( 586setq nargs 1)) (t (cond ((equal (car b) (quote CALL2)) (setq nargs 2)) (t ( 587cond ((equal (car b) (quote CALL2R)) (progn (setq nargs 2) (setq callsize ( 588difference callsize 1)) (setq b (cons (quote CALL2) (cons (quote SWOP) (cdr b 589)))))) (t (cond ((equal (car b) (quote CALL3)) (setq nargs 3)) (t (cond (( 590equal (car b) (quote CALL4)) (setq nargs 4)) (t (return nil))))))))))))))))) 591(setq b (cdr b)))) (t (cond ((setq nargs (get (car b) (quote s!:shortcall))) 592(progn (setq lvoff (cdr nargs)) (setq nargs (car nargs)) (setq callsize 1) ( 593setq b (cdr b)))) (t (return nil))))))) (return (cons cmnt (cons nargs (cons 594lvoff (cons callsize b))))))) 595 596(de s!:is_lose_and_exit (b blocks) (prog (lab exit) (setq lab (car b)) (setq 597exit (cadr b)) (setq b (cdddr b)) (cond ((null exit) (return nil))) (setq b ( 598s!:remlose b)) (setq b (cdr b)) (prog nil lab1031 (cond ((null (and b (not ( 599atom (car b))))) (return nil))) (setq b (cdr b)) (go lab1031)) (cond (b ( 600return nil)) (t (cond ((equal (car exit) (quote EXIT)) (return t)) (t (cond ( 601(equal (car exit) (quote JUMP)) (progn (cond ((equal (cadr exit) lab) nil) (t 602(return (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)))))) (t ( 603return nil))))))))) 604 605(de s!:try_tail_1 (b blocks) (prog (exit size body w nargs litoff w2 op) ( 606setq exit (cadr b)) (cond ((null exit) (return b)) (t (cond ((not (equal (car 607exit) (quote EXIT))) (progn (cond ((equal (car exit) (quote JUMP)) (progn ( 608cond ((not (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)) (return b 609))))) (t (return b)))))))) (setq size (caddr b)) (setq body (cdddr b)) (setq 610body (s!:remlose body)) (setq size (difference size (car body))) (setq body ( 611cdr body)) (setq w (s!:remcall body)) (cond ((null w) (return b))) (setq 612nargs (cadr w)) (setq litoff (caddr w)) (setq body (cddddr w)) (cond ((and ( 613leq nargs 4) (leq litoff 31)) (progn (setq body (cons (quote JCALL) body)) ( 614setq body (cons (plus (times 32 nargs) litoff) body)) (setq size (difference 615size 1)))) (t (progn (setq body (cons (quote BIGCALL) body)) (setq w2 (logand 616litoff 255)) (setq litoff (truncate litoff 256)) (setq body (cons w2 (cons ( 617plus litoff (times 16 nargs) 128) body)))))) (cond ((car w) (setq body (cons 618(append (car w) (list (quote TAIL))) body)))) (rplaca (cdr b) nil) (rplaca ( 619cddr b) (plus (difference size (cadddr w)) 3)) (rplacd (cddr b) body) (return 620b))) 621 622(de s!:try_tailcall (b) (prog (var1033 var1034) (setq var1033 b) lab1032 ( 623cond ((null var1033) (return (reversip var1034)))) (prog (v) (setq v (car 624var1033)) (setq var1034 (cons (s!:try_tail_1 v b) var1034))) (setq var1033 ( 625cdr var1033)) (go lab1032))) 626 627(de s!:tidy_exits_1 (b blocks) (prog (exit size body comm w op) (setq exit ( 628cadr b)) (cond ((null exit) (return b)) (t (cond ((not (equal (car exit) ( 629quote EXIT))) (progn (cond ((equal (car exit) (quote JUMP)) (progn (cond (( 630not (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)) (return b))))) ( 631t (return b)))))))) (setq size (caddr b)) (setq body (cdddr b)) (setq body ( 632s!:remlose body)) (setq size (difference size (car body))) (setq body (cdr 633body)) (prog nil lab1035 (cond ((null (and body (not (atom (car body))))) ( 634return nil))) (progn (setq comm (car body)) (setq body (cdr body))) (go 635lab1035)) (cond ((eqcar body (quote VNIL)) (setq w (quote NILEXIT))) (t (cond 636((eqcar body (quote LOADLOC0)) (setq w (quote LOC0EXIT))) (t (cond ((eqcar 637body (quote LOADLOC1)) (setq w (quote LOC1EXIT))) (t (cond ((eqcar body ( 638quote LOADLOC2)) (setq w (quote LOC2EXIT))) (t (setq w nil))))))))) (cond (w 639(progn (rplaca (cdr b) (list w)) (setq body (cdr body)) (setq size ( 640difference size 1)))) (t (cond (comm (setq body (cons comm body)))))) (rplaca 641(cddr b) size) (rplacd (cddr b) body) (return b))) 642 643(de s!:tidy_exits (b) (prog (var1037 var1038) (setq var1037 b) lab1036 (cond 644((null var1037) (return (reversip var1038)))) (prog (v) (setq v (car var1037) 645) (setq var1038 (cons (s!:tidy_exits_1 v b) var1038))) (setq var1037 (cdr 646var1037)) (go lab1036))) 647 648(de s!:tidy_flowgraph (b) (prog (r pending) (setq b (reverse b)) (setq 649pending (list (car b))) (prog nil lab1040 (cond ((null pending) (return nil)) 650) (prog (c x l1 l2 done1 done2) (setq c (car pending)) (setq pending (cdr 651pending)) (flag (list (car c)) (quote coded)) (setq x (cadr c)) (cond ((or ( 652null x) (null (cdr x))) (setq r (cons c r))) (t (cond ((equal (car x) (quote 653ICASE)) (progn (rplacd x (reversip (cdr x))) (prog (ll) (setq ll (cdr x)) 654lab1039 (cond ((null ll) (return nil))) (progn (setq l1 (s!:destination_label 655(car ll) b)) (cond ((not (atom l1)) (progn (setq l1 (s!:invent_exit (car l1) 656b)) (setq b (cdr l1)) (setq l1 (cadr l1))))) (rplaca ll l1) (setq done1 ( 657flagp l1 (quote coded))) (flag (list l1) (quote used_label)) (cond ((not 658done1) (setq pending (s!:add_pending l1 pending b))))) (setq ll (cdr ll)) (go 659lab1039)) (rplacd x (reversip (cdr x))) (setq r (cons c r)))) (t (cond (( 660null (cddr x)) (progn (setq l1 (s!:destination_label (cadr x) b)) (cond ((not 661(atom l1)) (setq c (cons (car c) (cons l1 (cddr c))))) (t (cond ((flagp l1 ( 662quote coded)) (progn (flag (list l1) (quote used_label)) (setq c (cons (car c 663) (cons (list (car x) l1) (cddr c)))))) (t (progn (setq c (cons (car c) (cons 664nil (cddr c)))) (setq pending (s!:add_pending l1 pending b))))))) (setq r ( 665cons c r)))) (t (progn (setq l1 (s!:destination_label (cadr x) b)) (setq l2 ( 666s!:destination_label (caddr x) b)) (setq done1 (and (atom l1) (flagp l1 ( 667quote coded)))) (setq done2 (and (atom l2) (flagp l2 (quote coded)))) (cond ( 668done1 (progn (cond (done2 (progn (flag (list l1) (quote used_label)) (rplaca 669(cdadr c) l1) (setq pending (cons (list (gensym) (list (quote JUMP) l2) 0) 670pending)))) (t (progn (flag (list l1) (quote used_label)) (rplaca (cdadr c) 671l1) (setq pending (s!:add_pending l2 pending b))))))) (t (progn (cond (done2 672(progn (flag (list l2) (quote used_label)) (rplaca (cadr c) (s!:negate_jump ( 673car x))) (rplaca (cdadr c) l2) (setq pending (s!:add_pending l1 pending b)))) 674(t (progn (cond ((not (atom l1)) (progn (setq l1 (s!:invent_exit (car l1) b) 675) (setq b (cdr l1)) (setq l1 (car l1))))) (flag (list l1) (quote used_label)) 676(rplaca (cdadr c) l1) (cond ((not (flagp l1 (quote coded))) (setq pending ( 677s!:add_pending l1 pending b)))) (setq pending (s!:add_pending l2 pending b))) 678))))) (setq r (cons c r)))))))))) (go lab1040)) (return (reverse r)))) 679 680(deflist (quote ((JUMPNIL JUMPT) (JUMPT JUMPNIL) (JUMPATOM JUMPNATOM) ( 681JUMPNATOM JUMPATOM) (JUMPEQ JUMPNE) (JUMPNE JUMPEQ) (JUMPEQUAL JUMPNEQUAL) ( 682JUMPNEQUAL JUMPEQUAL) (JUMPL0NIL JUMPL0T) (JUMPL0T JUMPL0NIL) (JUMPL1NIL 683JUMPL1T) (JUMPL1T JUMPL1NIL) (JUMPL2NIL JUMPL2T) (JUMPL2T JUMPL2NIL) ( 684JUMPL3NIL JUMPL3T) (JUMPL3T JUMPL3NIL) (JUMPL4NIL JUMPL4T) (JUMPL4T JUMPL4NIL 685) (JUMPL0ATOM JUMPL0NATOM) (JUMPL0NATOM JUMPL0ATOM) (JUMPL1ATOM JUMPL1NATOM) 686(JUMPL1NATOM JUMPL1ATOM) (JUMPL2ATOM JUMPL2NATOM) (JUMPL2NATOM JUMPL2ATOM) ( 687JUMPL3ATOM JUMPL3NATOM) (JUMPL3NATOM JUMPL3ATOM) (JUMPST0NIL JUMPST0T) ( 688JUMPST0T JUMPST0NIL) (JUMPST1NIL JUMPST1T) (JUMPST1T JUMPST1NIL) (JUMPST2NIL 689JUMPST2T) (JUMPST2T JUMPST2NIL) (JUMPFREE1NIL JUMPFREE1T) (JUMPFREE1T 690JUMPFREE1NIL) (JUMPFREE2NIL JUMPFREE2T) (JUMPFREE2T JUMPFREE2NIL) ( 691JUMPFREE3NIL JUMPFREE3T) (JUMPFREE3T JUMPFREE3NIL) (JUMPFREE4NIL JUMPFREE4T) 692(JUMPFREE4T JUMPFREE4NIL) (JUMPFREENIL JUMPFREET) (JUMPFREET JUMPFREENIL) ( 693JUMPLIT1EQ JUMPLIT1NE) (JUMPLIT1NE JUMPLIT1EQ) (JUMPLIT2EQ JUMPLIT2NE) ( 694JUMPLIT2NE JUMPLIT2EQ) (JUMPLIT3EQ JUMPLIT3NE) (JUMPLIT3NE JUMPLIT3EQ) ( 695JUMPLIT4EQ JUMPLIT4NE) (JUMPLIT4NE JUMPLIT4EQ) (JUMPLITEQ JUMPLITNE) ( 696JUMPLITNE JUMPLITEQ) (JUMPLITEQ!* JUMPLITNE!*) (JUMPLITNE!* JUMPLITEQ!*) ( 697JUMPB1NIL JUMPB1T) (JUMPB1T JUMPB1NIL) (JUMPB2NIL JUMPB2T) (JUMPB2T JUMPB2NIL 698) (JUMPFLAGP JUMPNFLAGP) (JUMPNFLAGP JUMPFLAGP) (JUMPEQCAR JUMPNEQCAR) ( 699JUMPNEQCAR JUMPEQCAR))) (quote negjump)) 700 701(de s!:negate_jump (x) (cond ((atom x) (get x (quote negjump))) (t (rplaca x 702(get (car x) (quote negjump)))))) 703 704(de s!:resolve_labels nil (prog (w labelvals converged pc x) (prog nil 705lab1043 (progn (setq converged t) (setq pc 0) (prog (var1042) (setq var1042 706s!:current_procedure) lab1041 (cond ((null var1042) (return nil))) (prog (b) 707(setq b (car var1042)) (progn (setq w (assoc!*!* (car b) labelvals)) (cond (( 708null w) (progn (setq converged nil) (setq w (cons (car b) pc)) (setq 709labelvals (cons w labelvals)))) (t (cond ((neq (cdr w) pc) (progn (rplacd w 710pc) (setq converged nil)))))) (setq pc (plus pc (caddr b))) (setq x (cadr b)) 711(cond ((null x) nil) (t (cond ((null (cdr x)) (setq pc (plus pc 1))) (t ( 712cond ((equal (car x) (quote ICASE)) (setq pc (plus pc (times 2 (length x))))) 713(t (progn (setq w (assoc!*!* (cadr x) labelvals)) (cond ((null w) (progn ( 714setq w 128) (setq converged nil))) (t (setq w (difference (cdr w) pc)))) ( 715setq w (s!:expand_jump (car x) w)) (setq pc (plus pc (length w)))))))))))) ( 716setq var1042 (cdr var1042)) (go lab1041))) (cond ((null converged) (go 717lab1043)))) (return (cons pc labelvals)))) 718 719(de s!:plant_basic_block (vec pc b) (prog (tagged) (prog (var1047) (setq 720var1047 b) lab1046 (cond ((null var1047) (return nil))) (prog (i) (setq i ( 721car var1047)) (progn (cond ((atom i) (progn (cond ((symbolp i) (setq i (get i 722(quote s!:opcode))))) (cond ((and (not tagged) (or !*plap !*pgwd)) (progn ( 723s!:prinhex4 pc) (princ ":") (ttab 8) (setq tagged t)))) (cond ((or (not (fixp 724i)) (lessp i 0) (greaterp i 255)) (error 0 (list "bad byte to put" i)))) ( 725bps!-putv vec pc i) (cond ((or !*plap !*pgwd) (progn (s!:prinhex2 i) (princ 726" ")))) (setq pc (plus pc 1)))) (t (cond ((or !*plap !*pgwd) (progn (ttab 23) 727(princ (car i)) (prog (var1045) (setq var1045 (cdr i)) lab1044 (cond ((null 728var1045) (return nil))) (prog (w) (setq w (car var1045)) (progn (princ " ") ( 729prin w))) (setq var1045 (cdr var1045)) (go lab1044)) (terpri) (setq tagged 730nil)))))))) (setq var1047 (cdr var1047)) (go lab1046)) (return pc))) 731 732(de s!:plant_bytes (vec pc bytelist doc) (prog nil (cond ((or !*plap !*pgwd) 733(progn (s!:prinhex4 pc) (princ ":") (ttab 8)))) (prog (var1049) (setq var1049 734bytelist) lab1048 (cond ((null var1049) (return nil))) (prog (v) (setq v ( 735car var1049)) (progn (cond ((symbolp v) (setq v (get v (quote s!:opcode))))) 736(cond ((or (not (fixp v)) (lessp v 0) (greaterp v 255)) (error 0 (list 737"bad byte to put" v)))) (bps!-putv vec pc v) (cond ((or !*plap !*pgwd) (progn 738(cond ((greaterp (posn) 50) (progn (terpri) (ttab 8)))) (s!:prinhex2 v) ( 739princ " ")))) (setq pc (plus pc 1)))) (setq var1049 (cdr var1049)) (go 740lab1048)) (cond ((or !*plap !*pgwd) (progn (cond ((greaterp (posn) 23) ( 741terpri))) (ttab 23) (princ (car doc)) (prog (var1051) (setq var1051 (cdr doc) 742) lab1050 (cond ((null var1051) (return nil))) (prog (w) (setq w (car var1051 743)) (progn (cond ((greaterp (posn) 65) (progn (terpri) (ttab 23)))) (princ " " 744) (prin w))) (setq var1051 (cdr var1051)) (go lab1050)) (terpri)))) (return 745pc))) 746 747(de s!:plant_exit_code (vec pc b labelvals) (prog (w loc low high r) (cond (( 748null b) (return pc)) (t (cond ((null (cdr b)) (return (s!:plant_bytes vec pc 749(list (get (car b) (quote s!:opcode))) b))) (t (cond ((equal (car b) (quote 750ICASE)) (progn (setq loc (plus pc 3)) (prog (var1053) (setq var1053 (cdr b)) 751lab1052 (cond ((null var1053) (return nil))) (prog (ll) (setq ll (car var1053 752)) (progn (setq w (difference (cdr (assoc!*!* ll labelvals)) loc)) (setq loc 753(plus loc 2)) (cond ((lessp w 0) (progn (setq w (minus w)) (setq low (ilogand 754w 255)) (setq high (plus 128 (truncate (difference w low) 256))))) (t (progn 755(setq low (ilogand w 255)) (setq high (truncate (difference w low) 256))))) 756(setq r (cons low (cons high r))))) (setq var1053 (cdr var1053)) (go lab1052) 757) (setq r (cons (get (quote ICASE) (quote s!:opcode)) (cons (length (cddr b)) 758(reversip r)))) (return (s!:plant_bytes vec pc r b))))))))) (setq w ( 759difference (cdr (assoc!*!* (cadr b) labelvals)) pc)) (setq w (s!:expand_jump 760(car b) w)) (return (s!:plant_bytes vec pc w b)))) 761 762(deflist (quote ((JUMPL0NIL ((LOADLOC0) JUMPNIL)) (JUMPL0T ((LOADLOC0) JUMPT) 763) (JUMPL1NIL ((LOADLOC1) JUMPNIL)) (JUMPL1T ((LOADLOC1) JUMPT)) (JUMPL2NIL (( 764LOADLOC2) JUMPNIL)) (JUMPL2T ((LOADLOC2) JUMPT)) (JUMPL3NIL ((LOADLOC3) 765JUMPNIL)) (JUMPL3T ((LOADLOC3) JUMPT)) (JUMPL4NIL ((LOADLOC4) JUMPNIL)) ( 766JUMPL4T ((LOADLOC4) JUMPT)) (JUMPL0ATOM ((LOADLOC0) JUMPATOM)) (JUMPL0NATOM ( 767(LOADLOC0) JUMPNATOM)) (JUMPL1ATOM ((LOADLOC1) JUMPATOM)) (JUMPL1NATOM (( 768LOADLOC1) JUMPNATOM)) (JUMPL2ATOM ((LOADLOC2) JUMPATOM)) (JUMPL2NATOM (( 769LOADLOC2) JUMPNATOM)) (JUMPL3ATOM ((LOADLOC3) JUMPATOM)) (JUMPL3NATOM (( 770LOADLOC3) JUMPNATOM)) (JUMPST0NIL ((STORELOC0) JUMPNIL)) (JUMPST0T (( 771STORELOC0) JUMPT)) (JUMPST1NIL ((STORELOC1) JUMPNIL)) (JUMPST1T ((STORELOC1) 772JUMPT)) (JUMPST2NIL ((STORELOC2) JUMPNIL)) (JUMPST2T ((STORELOC2) JUMPT)) ( 773JUMPFREE1NIL ((LOADFREE1) JUMPNIL)) (JUMPFREE1T ((LOADFREE1) JUMPT)) ( 774JUMPFREE2NIL ((LOADFREE2) JUMPNIL)) (JUMPFREE2T ((LOADFREE2) JUMPT)) ( 775JUMPFREE3NIL ((LOADFREE3) JUMPNIL)) (JUMPFREE3T ((LOADFREE3) JUMPT)) ( 776JUMPFREE4NIL ((LOADFREE4) JUMPNIL)) (JUMPFREE4T ((LOADFREE4) JUMPT)) ( 777JUMPFREENIL ((LOADFREE !*) JUMPNIL)) (JUMPFREET ((LOADFREE !*) JUMPT)) ( 778JUMPLIT1EQ ((LOADLIT1) JUMPEQ)) (JUMPLIT1NE ((LOADLIT1) JUMPNE)) (JUMPLIT2EQ 779((LOADLIT2) JUMPEQ)) (JUMPLIT2NE ((LOADLIT2) JUMPNE)) (JUMPLIT3EQ ((LOADLIT3) 780JUMPEQ)) (JUMPLIT3NE ((LOADLIT3) JUMPNE)) (JUMPLIT4EQ ((LOADLIT4) JUMPEQ)) ( 781JUMPLIT4NE ((LOADLIT4) JUMPNE)) (JUMPLITEQ ((LOADLIT !*) JUMPEQ)) (JUMPLITNE 782((LOADLIT !*) JUMPNE)) (JUMPLITEQ!* ((LOADLIT !* SWOP) JUMPEQ)) (JUMPLITNE!* 783((LOADLIT !* SWOP) JUMPNE)) (JUMPB1NIL ((BUILTIN1 !*) JUMPNIL)) (JUMPB1T (( 784BUILTIN1 !*) JUMPT)) (JUMPB2NIL ((BUILTIN2 !*) JUMPNIL)) (JUMPB2T ((BUILTIN2 785!*) JUMPT)) (JUMPFLAGP ((LOADLIT !* FLAGP) JUMPT)) (JUMPNFLAGP ((LOADLIT !* 786FLAGP) JUMPNIL)) (JUMPEQCAR ((LOADLIT !* EQCAR) JUMPT)) (JUMPNEQCAR ((LOADLIT 787!* EQCAR) JUMPNIL)))) (quote s!:expand_jump)) 788 789(fluid (quote (s!:backwards_jump s!:longer_jump))) 790 791(progn (setq s!:backwards_jump (make!-simple!-string 256)) (setq 792s!:longer_jump (make!-simple!-string 256)) nil) 793 794(prog (var1055) (setq var1055 (quote ((JUMP JUMP_B JUMP_L JUMP_BL) (JUMPNIL 795JUMPNIL_B JUMPNIL_L JUMPNIL_BL) (JUMPT JUMPT_B JUMPT_L JUMPT_BL) (JUMPATOM 796JUMPATOM_B JUMPATOM_L JUMPATOM_BL) (JUMPNATOM JUMPNATOM_B JUMPNATOM_L 797JUMPNATOM_BL) (JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL) (JUMPNE JUMPNE_B JUMPNE_L 798JUMPNE_BL) (JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL) (JUMPNEQUAL 799JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL) (CATCH CATCH_B CATCH_L CATCH_BL)))) 800lab1054 (cond ((null var1055) (return nil))) (prog (op) (setq op (car var1055 801)) (progn (putv!-char s!:backwards_jump (get (car op) (quote s!:opcode)) (get 802(cadr op) (quote s!:opcode))) (putv!-char s!:backwards_jump (get (caddr op) 803(quote s!:opcode)) (get (cadddr op) (quote s!:opcode))) (putv!-char 804s!:longer_jump (get (car op) (quote s!:opcode)) (get (caddr op) (quote 805s!:opcode))) (putv!-char s!:longer_jump (get (cadr op) (quote s!:opcode)) ( 806get (cadddr op) (quote s!:opcode))))) (setq var1055 (cdr var1055)) (go 807lab1054)) 808 809(de s!:expand_jump (op offset) (prog (arg low high opcode expanded) (cond (( 810not (atom op)) (progn (setq arg (cadr op)) (setq op (car op)) (setq offset ( 811difference offset 1))))) (setq expanded (get op (quote s!:expand_jump))) ( 812cond ((and expanded (not (and (leq 2 offset) (lessp offset (plus 256 2)) (or 813(null arg) (lessp arg 256))))) (progn (setq op (cadr expanded)) (setq 814expanded (car expanded)) (cond (arg (progn (cond ((greaterp arg 2047) (error 8150 "function uses too many literals (2048 limit)")) (t (cond ((greaterp arg 816255) (prog (high low) (setq low (ilogand arg 255)) (setq high (truncate ( 817difference arg low) 256)) (setq expanded (cons (quote BIGCALL) (cons (plus ( 818get (car expanded) (quote s!:longform)) high) (cons low (cddr expanded))))))) 819(t (setq expanded (subst arg (quote !*) expanded)))))) (setq offset (plus 820offset 1))))) (setq offset (difference offset (length expanded))) (setq arg 821nil))) (t (setq expanded nil))) (setq opcode (get op (quote s!:opcode))) ( 822cond ((null opcode) (error 0 (list op offset "invalid block exit")))) (cond ( 823(and (lessp (plus (minus 256) 2) offset) (lessp offset (plus 256 2))) (setq 824offset (difference offset 2))) (t (progn (setq high t) (setq offset ( 825difference offset 3))))) (cond ((lessp offset 0) (progn (setq opcode ( 826byte!-getv s!:backwards_jump opcode)) (setq offset (minus offset))))) (cond ( 827high (progn (setq low (logand offset 255)) (setq high (truncate (difference 828offset low) 256)))) (t (cond ((greaterp (setq low offset) 255) (error 0 829"Bad offset in expand_jump"))))) (cond (arg (return (list opcode arg low))) ( 830t (cond ((not high) (return (append expanded (list opcode low)))) (t (return 831(append expanded (list (byte!-getv s!:longer_jump opcode) high low))))))))) 832 833(de s!:comval (x env context) (prog (helper) (setq x (s!:improve x)) (cond (( 834atom x) (return (s!:comatom x env context))) (t (cond ((eqcar (car x) (quote 835lambda)) (return (s!:comlambda (cadar x) (cddar x) (cdr x) env context))) (t 836(cond ((eq (car x) s!:current_function) (s!:comcall x env context)) (t (cond 837((setq helper (s!:local_macro (car x))) (progn (cond ((atom (cdr helper)) ( 838s!:comval (cons (quote funcall) (cons (cdr helper) (cdr x))) env context)) (t 839(s!:comval (funcall (cons (quote lambda) (cdr helper)) x) env context))))) ( 840t (cond ((and (setq helper (get (car x) (quote s!:compilermacro))) (setq 841helper (funcall helper x env context))) (return (s!:comval helper env context 842))) (t (cond ((setq helper (get (car x) (quote s!:newname))) (return ( 843s!:comval (cons helper (cdr x)) env context))) (t (cond ((setq helper (get ( 844car x) (quote s!:compfn))) (return (funcall helper x env context))) (t (cond 845((setq helper (macro!-function (car x))) (return (s!:comval (funcall helper x 846) env context))) (t (return (s!:comcall x env context)))))))))))))))))))) 847 848(de s!:comspecform (x env context) (error 0 (list "special form" x))) 849 850(cond ((null (get (quote and) (quote s!:compfn))) (progn (put (quote 851compiler!-let) (quote s!:compfn) (function s!:comspecform)) (put (quote de) ( 852quote s!:compfn) (function s!:comspecform)) (put (quote defun) (quote 853s!:compfn) (function s!:comspecform)) (put (quote eval!-when) (quote 854s!:compfn) (function s!:comspecform)) (put (quote flet) (quote s!:compfn) ( 855function s!:comspecform)) (put (quote labels) (quote s!:compfn) (function 856s!:comspecform)) (put (quote macrolet) (quote s!:compfn) (function 857s!:comspecform)) (put (quote multiple!-value!-call) (quote s!:compfn) ( 858function s!:comspecform)) (put (quote multiple!-value!-prog1) (quote 859s!:compfn) (function s!:comspecform)) (put (quote prog!*) (quote s!:compfn) ( 860function s!:comspecform)) (put (quote progv) (quote s!:compfn) (function 861s!:comspecform)) nil))) 862 863(de s!:improve (u) (prog (w) (cond ((atom u) (return u)) (t (cond ((setq w ( 864get (car u) (quote s!:tidy_fn))) (return (funcall w u))) (t (cond ((setq w ( 865get (car u) (quote s!:newname))) (return (s!:improve (cons w (cdr u))))) (t ( 866return u))))))))) 867 868(de s!:imp_minus (u) (prog (a) (setq a (s!:improve (cadr u))) (return (cond ( 869(numberp a) (minus a)) (t (cond ((or (eqcar a (quote minus)) (eqcar a (quote 870iminus))) (cadr a)) (t (cond ((eqcar a (quote difference)) (s!:improve (list 871(quote difference) (caddr a) (cadr a)))) (t (cond ((eqcar a (quote 872idifference)) (s!:improve (list (quote idifference) (caddr a) (cadr a)))) (t 873(list (car u) a)))))))))))) 874 875(put (quote minus) (quote s!:tidy_fn) (quote s!:imp_minus)) 876 877(put (quote iminus) (quote s!:tidy_fn) (quote s!:imp_minus)) 878 879(de s!:imp_1!+ (u) (s!:improve (cons (quote add1) (cdr u)))) 880 881(put (quote !1!+) (quote s!:tidy_fn) (quote s!:imp_1!+)) 882 883(de s!:imp_1!- (u) (s!:improve (cons (quote sub1) (cdr u)))) 884 885(put (quote !1!-) (quote s!:tidy_fn) (quote s!:imp_1!-)) 886 887(de s!:imp_times (u) (prog (a b) (cond ((not (equal (length u) 3)) (return ( 888cons (car u) (prog (var1057 var1058) (setq var1057 (cdr u)) lab1056 (cond (( 889null var1057) (return (reversip var1058)))) (prog (v) (setq v (car var1057)) 890(setq var1058 (cons (s!:improve v) var1058))) (setq var1057 (cdr var1057)) ( 891go lab1056)))))) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u) 892)) (return (cond ((equal a 1) b) (t (cond ((equal b 1) a) (t (cond ((equal a 893(minus 1)) (s!:imp_minus (list (quote minus) b))) (t (cond ((equal b (minus 1 894)) (s!:imp_minus (list (quote minus) a))) (t (list (car u) a b)))))))))))) 895 896(put (quote times) (quote s!:tidy_fn) (quote s!:imp_times)) 897 898(de s!:imp_itimes (u) (prog (a b) (cond ((not (equal (length u) 3)) (return ( 899cons (car u) (prog (var1060 var1061) (setq var1060 (cdr u)) lab1059 (cond (( 900null var1060) (return (reversip var1061)))) (prog (v) (setq v (car var1060)) 901(setq var1061 (cons (s!:improve v) var1061))) (setq var1060 (cdr var1060)) ( 902go lab1059)))))) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u) 903)) (return (cond ((equal a 1) b) (t (cond ((equal b 1) a) (t (cond ((equal a 904(minus 1)) (s!:imp_minus (list (quote iminus) b))) (t (cond ((equal b (minus 9051)) (s!:imp_minus (list (quote iminus) a))) (t (list (car u) a b)))))))))))) 906 907(put (quote itimes) (quote s!:tidy_fn) (quote s!:imp_itimes)) 908 909(de s!:imp_difference (u) (prog (a b) (setq a (s!:improve (cadr u))) (setq b 910(s!:improve (caddr u))) (return (cond ((equal a 0) (s!:imp_minus (list (quote 911minus) b))) (t (cond ((equal b 0) a) (t (list (car u) a b)))))))) 912 913(put (quote difference) (quote s!:tidy_fn) (quote s!:imp_difference)) 914 915(de s!:imp_idifference (u) (prog (a b) (setq a (s!:improve (cadr u))) (setq b 916(s!:improve (caddr u))) (return (cond ((equal a 0) (s!:imp_minus (list ( 917quote iminus) b))) (t (cond ((equal b 0) a) (t (list (car u) a b)))))))) 918 919(put (quote idifference) (quote s!:tidy_fn) (quote s!:imp_idifference)) 920 921(de s!:boolean_jumpable (u) (or (null u) (equal u t) (and (not (atom u)) ( 922atom (car u)) (or (flagp (car u) (quote s!:bool_opcode)) (and (or (equal (car 923u) (quote and)) (equal (car u) (quote or))) (s!:boolean_jumpable_list (cdr u 924))))))) 925 926(de s!:boolean_jumpable_list (u) (or (atom u) (and (s!:boolean_jumpable (car 927u)) (s!:boolean_jumpable_list (cdr u))))) 928 929(flag (quote (null not eq equal neq eqcar atom flagp)) (quote s!:bool_opcode) 930) 931 932(de s!:imp_or (u) (prog (w x) (setq w (cdr u)) (cond ((atom w) (return nil))) 933(setq x (car w)) (cond ((atom (cdr w)) (return (s!:improve x))) (t (cond (( 934s!:boolean_jumpable x) (return (list (quote cond) (list x t) (list t ( 935s!:imp_or (cons (quote or) (cdr w))))))) (t (return (list (quote or) ( 936s!:improve x) (s!:imp_or (cons (quote or) (cdr w))))))))))) 937 938(put (quote or) (quote s!:tidy_fn) (quote s!:imp_or)) 939 940(de s!:imp_and (u) (prog (w x) (setq w (cdr u)) (cond ((atom w) (return t))) 941(setq x (car w)) (cond ((atom (cdr w)) (return x)) (t (cond (( 942s!:boolean_jumpable x) (return (list (quote cond) (list x (s!:imp_and (cons ( 943quote and) (cdr w)))) (list t nil)))) (t (return (list (quote and) ( 944s!:improve x) (s!:imp_and (cons (quote and) (cdr w))))))))))) 945 946(put (quote and) (quote s!:tidy_fn) (quote s!:imp_and)) 947 948(de s!:alwayseasy (x) t) 949 950(put (quote quote) (quote s!:helpeasy) (function s!:alwayseasy)) 951 952(put (quote function) (quote s!:helpeasy) (function s!:alwayseasy)) 953 954(de s!:easyifarg (x) (or (null (cdr x)) (and (null (cddr x)) (s!:iseasy (cadr 955x))))) 956 957(put (quote ncons) (quote s!:helpeasy) (function s!:easyifarg)) 958 959(put (quote car) (quote s!:helpeasy) (function s!:easyifarg)) 960 961(put (quote cdr) (quote s!:helpeasy) (function s!:easyifarg)) 962 963(put (quote qcar) (quote s!:helpeasy) (function s!:easyifarg)) 964 965(put (quote qcdr) (quote s!:helpeasy) (function s!:easyifarg)) 966 967(put (quote caar) (quote s!:helpeasy) (function s!:easyifarg)) 968 969(put (quote cadr) (quote s!:helpeasy) (function s!:easyifarg)) 970 971(put (quote cdar) (quote s!:helpeasy) (function s!:easyifarg)) 972 973(put (quote cddr) (quote s!:helpeasy) (function s!:easyifarg)) 974 975(put (quote caaar) (quote s!:helpeasy) (function s!:easyifarg)) 976 977(put (quote caadr) (quote s!:helpeasy) (function s!:easyifarg)) 978 979(put (quote cadar) (quote s!:helpeasy) (function s!:easyifarg)) 980 981(put (quote caddr) (quote s!:helpeasy) (function s!:easyifarg)) 982 983(put (quote cdaar) (quote s!:helpeasy) (function s!:easyifarg)) 984 985(put (quote cdadr) (quote s!:helpeasy) (function s!:easyifarg)) 986 987(put (quote cddar) (quote s!:helpeasy) (function s!:easyifarg)) 988 989(put (quote cdddr) (quote s!:helpeasy) (function s!:easyifarg)) 990 991(put (quote caaaar) (quote s!:helpeasy) (function s!:easyifarg)) 992 993(put (quote caaadr) (quote s!:helpeasy) (function s!:easyifarg)) 994 995(put (quote caadar) (quote s!:helpeasy) (function s!:easyifarg)) 996 997(put (quote caaddr) (quote s!:helpeasy) (function s!:easyifarg)) 998 999(put (quote cadaar) (quote s!:helpeasy) (function s!:easyifarg)) 1000 1001(put (quote cadadr) (quote s!:helpeasy) (function s!:easyifarg)) 1002 1003(put (quote caddar) (quote s!:helpeasy) (function s!:easyifarg)) 1004 1005(put (quote cadddr) (quote s!:helpeasy) (function s!:easyifarg)) 1006 1007(put (quote cdaaar) (quote s!:helpeasy) (function s!:easyifarg)) 1008 1009(put (quote cdaadr) (quote s!:helpeasy) (function s!:easyifarg)) 1010 1011(put (quote cdadar) (quote s!:helpeasy) (function s!:easyifarg)) 1012 1013(put (quote cdaddr) (quote s!:helpeasy) (function s!:easyifarg)) 1014 1015(put (quote cddaar) (quote s!:helpeasy) (function s!:easyifarg)) 1016 1017(put (quote cddadr) (quote s!:helpeasy) (function s!:easyifarg)) 1018 1019(put (quote cdddar) (quote s!:helpeasy) (function s!:easyifarg)) 1020 1021(put (quote cddddr) (quote s!:helpeasy) (function s!:easyifarg)) 1022 1023(de s!:easygetv (x) (prog (a2) (setq a2 (caddr x)) (cond ((and (null 1024!*carcheckflag) (fixp a2) (geq a2 0) (lessp a2 256)) (return (s!:iseasy (cadr 1025x)))) (t (return nil))))) 1026 1027(put (quote getv) (quote s!:helpeasy) (function s!:easygetv)) 1028 1029(put (quote svref) (quote s!:heapeasy) (function s!:easygetv)) 1030 1031(de s!:easyqgetv (x) (prog (a2) (setq a2 (caddr x)) (cond ((and (fixp a2) ( 1032geq a2 0) (lessp a2 256)) (return (s!:iseasy (cadr x)))) (t (return nil))))) 1033 1034(put (quote qgetv) (quote s!:helpeasy) (function s!:easyqgetv)) 1035 1036(put (quote qsvref) (quote s!:heapeasy) (function s!:easyqgetv)) 1037 1038(de s!:iseasy (x) (prog (h) (cond ((atom x) (return t))) (cond ((not (atom ( 1039car x))) (return nil))) (cond ((setq h (get (car x) (quote s!:helpeasy))) ( 1040return (funcall h x))) (t (return nil))))) 1041 1042(de s!:instate_local_decs (v d w) (prog (fg) (cond ((fluidp v) (return w))) ( 1043prog (var1063) (setq var1063 d) lab1062 (cond ((null var1063) (return nil))) 1044(prog (z) (setq z (car var1063)) (cond ((and (eqcar z (quote special)) (memq 1045v (cdr z))) (setq fg t)))) (setq var1063 (cdr var1063)) (go lab1062)) (cond ( 1046fg (progn (make!-special v) (setq w (cons v w))))) (return w))) 1047 1048(de s!:residual_local_decs (d w) (prog nil (prog (var1067) (setq var1067 d) 1049lab1066 (cond ((null var1067) (return nil))) (prog (z) (setq z (car var1067)) 1050(cond ((eqcar z (quote special)) (prog (var1065) (setq var1065 (cdr z)) 1051lab1064 (cond ((null var1065) (return nil))) (prog (v) (setq v (car var1065)) 1052(cond ((and (not (fluidp v)) (not (globalp v)) (not (keywordp v))) (progn ( 1053make!-special v) (setq w (cons v w)))))) (setq var1065 (cdr var1065)) (go 1054lab1064))))) (setq var1067 (cdr var1067)) (go lab1066)) (return w))) 1055 1056(de s!:cancel_local_decs (w) (unfluid w)) 1057 1058(de s!:find_local_decs (body isprog) (prog (w local_decs) (cond ((and (not 1059isprog) body (null (cdr body)) (eqcar (car body) (quote progn))) (setq body ( 1060cdar body)))) (prog nil lab1068 (cond ((null (and body (or (eqcar (car body) 1061(quote declare)) (stringp (car body))))) (return nil))) (progn (cond (( 1062stringp (car body)) (setq w (cons (car body) w))) (t (setq local_decs (append 1063local_decs (cdar body))))) (setq body (cdr body))) (go lab1068)) (prog nil 1064lab1069 (cond ((null w) (return nil))) (progn (setq body (cons (car w) body)) 1065(setq w (cdr w))) (go lab1069)) (return (cons local_decs body)))) 1066 1067(de s!:comlambda (bvl body args env context) (prog (s nbvl fluids fl1 w 1068local_decs) (cond ((and (equal context 0) s!:maybe_values) (s!:outopcode0 ( 1069quote ONEVALUE) (quote (onevalue))))) (setq nbvl (setq s (cdr env))) (setq 1070body (s!:find_local_decs body nil)) (setq local_decs (car body)) (setq body ( 1071cdr body)) (cond ((atom body) (setq body nil)) (t (cond ((atom (cdr body)) ( 1072setq body (car body))) (t (setq body (cons (quote progn) body)))))) (setq w 1073nil) (prog (var1071) (setq var1071 bvl) lab1070 (cond ((null var1071) (return 1074nil))) (prog (v) (setq v (car var1071)) (setq w (s!:instate_local_decs v 1075local_decs w))) (setq var1071 (cdr var1071)) (go lab1070)) (prog (var1073) ( 1076setq var1073 bvl) lab1072 (cond ((null var1073) (return nil))) (prog (v) ( 1077setq v (car var1073)) (progn (cond ((or (globalp v) (keywordp v)) (error 0 ( 1078list "attempt to bind global" v)))) (cond ((fluidp v) (prog (g) (setq g ( 1079gensym)) (setq nbvl (cons g nbvl)) (setq fl1 (cons v fl1)) (setq fluids (cons 1080(cons v g) fluids)))) (t (setq nbvl (cons v nbvl)))) (cond ((equal (car args 1081) nil) (s!:outstack 1)) (t (progn (s!:comval (car args) env 1) (s!:outopcode0 1082(quote PUSH) (quote (PUSH)))))) (rplacd env (cons 0 (cdr env))) (setq args ( 1083cdr args)))) (setq var1073 (cdr var1073)) (go lab1072)) (rplacd env nbvl) ( 1084cond (fluids (progn (setq fl1 (s!:vecof fl1)) (s!:outopcode1lit (quote 1085FREEBIND) fl1 env) (prog (var1075) (setq var1075 (cons nil fluids)) lab1074 ( 1086cond ((null var1075) (return nil))) (prog (v) (setq v (car var1075)) (rplacd 1087env (cons 0 (cdr env)))) (setq var1075 (cdr var1075)) (go lab1074)) (rplacd 1088env (cons (plus 2 (length fluids)) (cdr env))) (prog (var1077) (setq var1077 1089fluids) lab1076 (cond ((null var1077) (return nil))) (prog (v) (setq v (car 1090var1077)) (s!:comval (list (quote setq) (car v) (cdr v)) env 2)) (setq 1091var1077 (cdr var1077)) (go lab1076))))) (setq w (s!:residual_local_decs 1092local_decs w)) (s!:comval body env 1) (s!:cancel_local_decs w) (cond (fluids 1093(s!:outopcode0 (quote FREERSTR) (quote (FREERSTR))))) (s!:outlose (length bvl 1094)) (rplacd env s))) 1095 1096(de s!:loadliteral (x env) (cond ((member!*!* (list (quote quote) x) 1097s!:a_reg_values) nil) (t (progn (cond ((equal x nil) (s!:outopcode0 (quote 1098VNIL) (quote (loadlit nil)))) (t (s!:outopcode1lit (quote LOADLIT) x env))) ( 1099setq s!:a_reg_values (list (list (quote quote) x))))))) 1100 1101(de s!:comquote (x env context) (progn (cond ((and (equal context 0) 1102s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) (quote (onevalue))))) (cond 1103((leq context 1) (s!:loadliteral (cadr x) env))))) 1104 1105(put (quote quote) (quote s!:compfn) (function s!:comquote)) 1106 1107(fluid (quote (s!:current_exitlab s!:current_proglabels s!:local_macros))) 1108 1109(de s!:comval_m (x env context s!:local_macros) (s!:comval x env context)) 1110 1111(de s!:comflet (x env context) (prog (w r g save) (setq save (cdr env)) (prog 1112(var1079) (setq var1079 (cadr x)) lab1078 (cond ((null var1079) (return nil) 1113)) (prog (d) (setq d (car var1079)) (progn (setq g (gensym)) (s!:comval (list 1114(quote function) (cons (quote lambda) (cdr d))) env context) (s!:outopcode0 1115(quote PUSH) (quote (PUSH))) (rplacd env (cons g (cdr env))) (setq r (cons ( 1116cons (car d) g) r)))) (setq var1079 (cdr var1079)) (go lab1078)) (s!:comval_m 1117(cons (quote progn) (cddr x)) env context (append r s!:local_macros)) ( 1118s!:outlose (length (cadr x))) (rplacd env save))) 1119 1120(put (quote flet) (quote s!:compfn) (function s!:comflet)) 1121 1122(de s!:comlabels (x env context) (prog (w w1 r g) (prog (var1081) (setq 1123var1081 (cadr x)) lab1080 (cond ((null var1081) (return nil))) (prog (d) ( 1124setq d (car var1081)) (progn (setq g (gensym)) (setq w (cons (list (quote 1125setq) g (list (quote function) (cons (quote lambda) (cdr d)))) w)) (setq w1 ( 1126cons (list g) w1)) (setq r (cons (cons (car d) g) r)))) (setq var1081 (cdr 1127var1081)) (go lab1080)) (setq x (cons (quote let) (cons (reverse w1) (append 1128w (cddr x))))) (return (s!:comval_m x env context (append r s!:local_macros)) 1129))) 1130 1131(put (quote labels) (quote s!:compfn) (function s!:comlabels)) 1132 1133(de s!:commacrolet (x env context) (s!:comval_m (cons (quote progn) (cddr x)) 1134env context (append (cadr x) s!:local_macros))) 1135 1136(put (quote macrolet) (quote s!:compfn) (function s!:commacrolet)) 1137 1138(de s!:local_macro (fn) (prog (w y) (setq w (cons (list nil nil nil 1139s!:local_macros) s!:lexical_env)) (prog nil lab1082 (cond ((null w) (return 1140nil))) (progn (setq y (atsoc fn (cadddr (car w)))) (cond (y (setq w nil)) (t 1141(setq w (cdr w))))) (go lab1082)) (return y))) 1142 1143(de s!:comfunction (x env context) (progn (cond ((and (equal context 0) 1144s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) (quote (onevalue))))) (cond 1145((leq context 1) (progn (setq x (cadr x)) (cond ((eqcar x (quote lambda)) ( 1146prog (g w s!:used_lexicals) (setq s!:has_closure t) (setq g (hashtagged!-name 1147(quote lambda) (cdr x))) (setq w (s!:compile1 g (cadr x) (cddr x) (cons ( 1148list (cdr env) s!:current_exitlab s!:current_proglabels s!:local_macros) 1149s!:lexical_env))) (cond (s!:used_lexicals (setq w (s!:compile1 g (cons ( 1150gensym) (cadr x)) (cddr x) (cons (list (cdr env) s!:current_exitlab 1151s!:current_proglabels s!:local_macros) s!:lexical_env))))) (setq 1152s!:other_defs (append w s!:other_defs)) (s!:loadliteral g env) (setq w ( 1153length (cdr env))) (cond (s!:used_lexicals (progn (setq s!:has_closure t) ( 1154cond ((greaterp w 4095) (error 0 "stack frame > 4095")) (t (cond ((greaterp w 1155255) (s!:outopcode2 (quote BIGSTACK) (plus 128 (truncate w 256)) (logand w 1156255) (list (quote CLOSURE) w))) (t (s!:outopcode1 (quote CLOSURE) w x)))))))) 1157)) (t (cond ((setq context (s!:local_macro x)) (progn (cond ((atom (cdr 1158context)) (s!:comatom (cdr context) env 1)) (t (error 0 1159"(function <local macro>) is illegal"))))) (t (s!:loadliteral x env)))))))))) 1160 1161(put (quote function) (quote s!:compfn) (function s!:comfunction)) 1162 1163(de s!:should_be_fluid (x) (cond ((not (or (fluidp x) (globalp x) (keywordp x 1164))) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) (princ 1165"+++ ") (prin x) (princ " declared fluid") (terpri)))) (fluid (list x)) nil)) 1166)) 1167 1168(de s!:find_lexical (x lex n) (prog (p) (cond ((null lex) (return nil))) ( 1169setq p (memq x (caar lex))) (cond (p (progn (cond ((not (memq x 1170s!:used_lexicals)) (setq s!:used_lexicals (cons x s!:used_lexicals)))) ( 1171return (list n (length p))))) (t (return (s!:find_lexical x (cdr lex) (plus n 11721))))))) 1173 1174(global (quote (s!:loadlocs))) 1175 1176(setq s!:loadlocs (s!:vecof (quote (LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 1177LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11)))) 1178 1179(de s!:comatom (x env context) (prog (n w) (cond ((and (equal context 0) 1180s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) (quote (onevalue))))) (cond 1181((greaterp context 1) (return nil)) (t (cond ((or (null x) (not (symbolp x))) 1182(return (s!:loadliteral x env)))))) (setq n 0) (setq w (cdr env)) (prog nil 1183lab1083 (cond ((null (and w (not (eqcar w x)))) (return nil))) (progn (setq n 1184(add1 n)) (setq w (cdr w))) (go lab1083)) (cond (w (progn (setq w (cons ( 1185quote loc) w)) (cond ((member!*!* w s!:a_reg_values) (return nil)) (t (progn 1186(cond ((lessp n 12) (s!:outopcode0 (getv s!:loadlocs n) (list (quote LOADLOC) 1187x))) (t (cond ((greaterp n 4095) (error 0 "stack frame > 4095")) (t (cond (( 1188greaterp n 255) (s!:outopcode2 (quote BIGSTACK) (truncate n 256) (logand n 1189255) (list (quote LOADLOC) x))) (t (s!:outopcode1 (quote LOADLOC) n x))))))) 1190(setq s!:a_reg_values (list w)) (return nil))))))) (cond ((setq w ( 1191s!:find_lexical x s!:lexical_env 0)) (progn (cond ((member!*!* (cons (quote 1192lex) w) s!:a_reg_values) (return nil))) (s!:outlexref (quote LOADLEX) (length 1193(cdr env)) (car w) (cadr w) x) (setq s!:a_reg_values (list (cons (quote lex) 1194w))) (return nil)))) (s!:should_be_fluid x) (cond ((flagp x (quote 1195constant!?)) (return (s!:loadliteral (eval x) env)))) (setq w (cons (quote 1196free) x)) (cond ((member!*!* w s!:a_reg_values) (return nil))) ( 1197s!:outopcode1lit (quote LOADFREE) x env) (setq s!:a_reg_values (list w)))) 1198 1199(flag (quote (t !$EOL!$ !$EOF!$)) (quote constant!?)) 1200 1201(de s!:islocal (x env) (prog (n w) (cond ((or (null x) (not (symbolp x)) (eq 1202x t)) (return 99999))) (setq n 0) (setq w (cdr env)) (prog nil lab1084 (cond 1203((null (and w (not (eqcar w x)))) (return nil))) (progn (setq n (add1 n)) ( 1204setq w (cdr w))) (go lab1084)) (cond (w (return n)) (t (return 99999))))) 1205 1206(de s!:load2 (a b env) (progn (cond ((s!:iseasy b) (prog (wa wb w) (setq wa ( 1207s!:islocal a env)) (setq wb (s!:islocal b env)) (cond ((and (lessp wa 4) ( 1208lessp wb 4)) (progn (cond ((and (equal wa 0) (equal wb 1)) (setq w (quote 1209LOC0LOC1))) (t (cond ((and (equal wa 1) (equal wb 2)) (setq w (quote LOC1LOC2 1210))) (t (cond ((and (equal wa 2) (equal wb 3)) (setq w (quote LOC2LOC3))) (t ( 1211cond ((and (equal wa 1) (equal wb 0)) (setq w (quote LOC1LOC0))) (t (cond (( 1212and (equal wa 2) (equal wb 1)) (setq w (quote LOC2LOC1))) (t (cond ((and ( 1213equal wa 3) (equal wb 2)) (setq w (quote LOC3LOC2)))))))))))))) (cond (w ( 1214progn (s!:outopcode0 w (list (quote LOCLOC) a b)) (return nil))))))) ( 1215s!:comval a env 1) (setq s!:a_reg_values nil) (s!:comval b env 1) (return nil 1216))) (t (cond (!*ord (progn (s!:comval a env 1) (s!:outopcode0 (quote PUSH) ( 1217quote (PUSH))) (rplacd env (cons 0 (cdr env))) (setq s!:a_reg_values nil) ( 1218s!:comval b env 1) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd env ( 1219cddr env)) t)) (t (cond ((s!:iseasy a) (progn (s!:comval b env 1) (setq 1220s!:a_reg_values nil) (s!:comval a env 1) t)) (t (progn (s!:comval b env 1) ( 1221s!:outopcode0 (quote PUSH) (quote (PUSH))) (rplacd env (cons 0 (cdr env))) ( 1222setq s!:a_reg_values nil) (s!:comval a env 1) (s!:outopcode0 (quote POP) ( 1223quote (POP))) (rplacd env (cddr env)) nil))))))))) 1224 1225(global (quote (s!:carlocs s!:cdrlocs s!:caarlocs))) 1226 1227(setq s!:carlocs (s!:vecof (quote (CARLOC0 CARLOC1 CARLOC2 CARLOC3 CARLOC4 1228CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11)))) 1229 1230(setq s!:cdrlocs (s!:vecof (quote (CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 1231CDRLOC5)))) 1232 1233(setq s!:caarlocs (s!:vecof (quote (CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3)))) 1234 1235(flag (quote (plus2 times2 eq equal)) (quote s!:symmetric)) 1236 1237(flag (quote (qcar qcdr car cdr caar cadr cdar cddr ncons add1 sub1 numberp 1238length)) (quote s!:onearg)) 1239 1240(flag (quote (cons xcons list2 get flagp plus2 difference times2 greaterp 1241lessp apply1 eq equal getv qgetv eqcar)) (quote s!:twoarg)) 1242 1243(flag (quote (apply2 list2!* list3 acons)) (quote s!:threearg)) 1244 1245(de s!:comcall (x env context) (prog (fn args nargs op s w1 w2 w3 sw) (setq 1246fn (car x)) (cond ((not (symbolp fn)) (error 0 1247"non-symbol used in function position"))) (setq args (prog (var1086 var1087) 1248(setq var1086 (cdr x)) lab1085 (cond ((null var1086) (return (reversip 1249var1087)))) (prog (v) (setq v (car var1086)) (setq var1087 (cons (s!:improve 1250v) var1087))) (setq var1086 (cdr var1086)) (go lab1085))) (setq nargs (length 1251args)) (setq s (cdr env)) (cond ((and (equal context 0) s!:maybe_values) ( 1252s!:outopcode0 (quote ONEVALUE) (quote (onevalue))))) (cond ((equal nargs 0) ( 1253cond ((setq w2 (get fn (quote s!:builtin0))) (s!:outopcode1 (quote BUILTIN0) 1254w2 fn)) (t (progn (s!:outopcode1lit (quote CALL0) fn env) (cond ((neq fn 1255s!:current_function) (setq s!:maybe_values t))))))) (t (cond ((equal nargs 1) 1256(progn (cond ((and (or (equal fn (quote car)) (equal fn (quote qcar))) ( 1257lessp (setq w2 (s!:islocal (car args) env)) 12)) (s!:outopcode0 (getv 1258s!:carlocs w2) (list (quote carloc) (car args)))) (t (cond ((and (or (equal 1259fn (quote cdr)) (equal fn (quote qcdr))) (lessp (setq w2 (s!:islocal (car 1260args) env)) 6)) (s!:outopcode0 (getv s!:cdrlocs w2) (list (quote cdrloc) (car 1261args)))) (t (cond ((and (equal fn (quote caar)) (lessp (setq w2 (s!:islocal 1262(car args) env)) 4)) (s!:outopcode0 (getv s!:caarlocs w2) (list (quote 1263caarloc) (car args)))) (t (progn (s!:comval (car args) env 1) (cond ((flagp 1264fn (quote s!:onearg)) (s!:outopcode0 fn (list fn))) (t (cond ((setq w2 (get 1265fn (quote s!:builtin1))) (s!:outopcode1 (quote BUILTIN1) w2 fn)) (t (progn ( 1266cond ((and (equal context 0) s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) 1267(quote (onevalue))))) (s!:outopcode1lit (quote CALL1) fn env) (cond ((neq fn 1268s!:current_function) (setq s!:maybe_values t))))))))))))))))) (t (cond (( 1269equal nargs 2) (progn (setq sw (s!:load2 (car args) (cadr args) env)) (cond ( 1270(flagp fn (quote s!:symmetric)) (setq sw nil))) (cond ((flagp fn (quote 1271s!:twoarg)) (progn (cond (sw (s!:outopcode0 (quote SWOP) (quote (SWOP))))) ( 1272s!:outopcode0 fn (list fn)))) (t (progn (setq w3 (get fn (quote s!:builtin2)) 1273) (cond (sw (progn (cond (w3 (s!:outopcode1 (quote BUILTIN2R) w3 fn)) (t ( 1274s!:outopcode1lit (quote CALL2R) fn env))))) (t (cond (w3 (s!:outopcode1 ( 1275quote BUILTIN2) w3 fn)) (t (progn (cond ((and (equal context 0) 1276s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) (quote (onevalue))))) ( 1277s!:outopcode1lit (quote CALL2) fn env) (cond ((neq fn s!:current_function) ( 1278setq s!:maybe_values t))))))))))))) (t (cond ((equal nargs 3) (progn (cond (( 1279equal (car args) nil) (s!:outstack 1)) (t (progn (s!:comval (car args) env 1) 1280(s!:outopcode0 (quote PUSH) (quote (PUSHA3)))))) (rplacd env (cons 0 (cdr 1281env))) (setq s!:a_reg_values nil) (cond ((s!:load2 (cadr args) (caddr args) 1282env) (s!:outopcode0 (quote SWOP) (quote (SWOP))))) (cond ((flagp fn (quote 1283s!:threearg)) (s!:outopcode0 (cond ((equal fn (quote list2!*)) (quote 1284list2star)) (t fn)) (list fn))) (t (cond ((setq w2 (get fn (quote s!:builtin3 1285))) (s!:outopcode1 (quote BUILTIN3) w2 fn)) (t (progn (cond ((and (equal 1286context 0) s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) (quote (onevalue) 1287)))) (s!:outopcode1lit (quote CALL3) fn env) (cond ((neq fn 1288s!:current_function) (setq s!:maybe_values t)))))))) (rplacd env (cddr env))) 1289) (t (prog (largs) (cond ((and (not (and (equal fn (quote apply3)) (equal 1290nargs 4))) (not (and (equal fn (quote apply4)) (equal nargs 5)))) (progn ( 1291setq w1 (car args)) (setq args (cdr args)) (setq w2 (car args)) (setq args ( 1292cdr args)) (setq w3 (car args)) (setq args (cdr args)) (setq args (list w1 w2 1293w3 (cons (quote list) args))) (setq nargs 4)))) (setq largs (reverse args)) 1294(prog (var1089) (setq var1089 (reverse (cddr largs))) lab1088 (cond ((null 1295var1089) (return nil))) (prog (a) (setq a (car var1089)) (progn (cond ((null 1296a) (s!:outstack 1)) (t (progn (s!:comval a env 1) (cond ((equal nargs 4) ( 1297s!:outopcode0 (quote PUSH) (quote (PUSHA4)))) (t (s!:outopcode0 (quote PUSH) 1298(quote (PUSHARG)))))))) (rplacd env (cons 0 (cdr env))) (setq s!:a_reg_values 1299nil))) (setq var1089 (cdr var1089)) (go lab1088)) (cond ((s!:load2 (cadr 1300largs) (car largs) env) (s!:outopcode0 (quote SWOP) (quote (SWOP))))) (cond ( 1301(and (equal fn (quote apply3)) (equal nargs 4)) (s!:outopcode0 (quote APPLY3) 1302(quote (APPLY3)))) (t (cond ((and (equal fn (quote apply4)) (equal nargs 5)) 1303(s!:outopcode0 (quote APPLY4) (quote (APPLY4)))) (t (progn (cond ((and ( 1304equal context 0) s!:maybe_values) (s!:outopcode0 (quote ONEVALUE) (quote ( 1305onevalue))))) (s!:outopcode1lit (quote CALL4) fn env) (cond ((neq fn 1306s!:current_function) (setq s!:maybe_values t)))))))) (rplacd env s))))))))))) 1307) 1308 1309(de s!:ad_name (l) (cond ((equal (car l) (quote a)) (cond ((equal (cadr l) ( 1310quote a)) (quote caar)) (t (quote cadr)))) (t (cond ((equal (cadr l) (quote a 1311)) (quote cdar)) (t (quote cddr)))))) 1312 1313(de s!:comcarcdr3 (x env context) (prog (name outer c1 c2) (setq name (cdr ( 1314explode2 (car x)))) (setq x (list (s!:ad_name name) (list (cond ((equal ( 1315caddr name) (quote a)) (quote car)) (t (quote cdr))) (cadr x)))) (return ( 1316s!:comval x env context)))) 1317 1318(put (quote caaar) (quote s!:compfn) (function s!:comcarcdr3)) 1319 1320(put (quote caadr) (quote s!:compfn) (function s!:comcarcdr3)) 1321 1322(put (quote cadar) (quote s!:compfn) (function s!:comcarcdr3)) 1323 1324(put (quote caddr) (quote s!:compfn) (function s!:comcarcdr3)) 1325 1326(put (quote cdaar) (quote s!:compfn) (function s!:comcarcdr3)) 1327 1328(put (quote cdadr) (quote s!:compfn) (function s!:comcarcdr3)) 1329 1330(put (quote cddar) (quote s!:compfn) (function s!:comcarcdr3)) 1331 1332(put (quote cdddr) (quote s!:compfn) (function s!:comcarcdr3)) 1333 1334(de s!:comcarcdr4 (x env context) (prog (name outer c1 c2) (setq name (cdr ( 1335explode2 (car x)))) (setq x (list (s!:ad_name name) (list (s!:ad_name (cddr 1336name)) (cadr x)))) (return (s!:comval x env context)))) 1337 1338(put (quote caaaar) (quote s!:compfn) (function s!:comcarcdr4)) 1339 1340(put (quote caaadr) (quote s!:compfn) (function s!:comcarcdr4)) 1341 1342(put (quote caadar) (quote s!:compfn) (function s!:comcarcdr4)) 1343 1344(put (quote caaddr) (quote s!:compfn) (function s!:comcarcdr4)) 1345 1346(put (quote cadaar) (quote s!:compfn) (function s!:comcarcdr4)) 1347 1348(put (quote cadadr) (quote s!:compfn) (function s!:comcarcdr4)) 1349 1350(put (quote caddar) (quote s!:compfn) (function s!:comcarcdr4)) 1351 1352(put (quote cadddr) (quote s!:compfn) (function s!:comcarcdr4)) 1353 1354(put (quote cdaaar) (quote s!:compfn) (function s!:comcarcdr4)) 1355 1356(put (quote cdaadr) (quote s!:compfn) (function s!:comcarcdr4)) 1357 1358(put (quote cdadar) (quote s!:compfn) (function s!:comcarcdr4)) 1359 1360(put (quote cdaddr) (quote s!:compfn) (function s!:comcarcdr4)) 1361 1362(put (quote cddaar) (quote s!:compfn) (function s!:comcarcdr4)) 1363 1364(put (quote cddadr) (quote s!:compfn) (function s!:comcarcdr4)) 1365 1366(put (quote cdddar) (quote s!:compfn) (function s!:comcarcdr4)) 1367 1368(put (quote cddddr) (quote s!:compfn) (function s!:comcarcdr4)) 1369 1370(de s!:comgetv (x env context) (cond (!*carcheckflag (s!:comcall x env 1371context)) (t (s!:comval (cons (quote qgetv) (cdr x)) env context)))) 1372 1373(put (quote getv) (quote s!:compfn) (function s!:comgetv)) 1374 1375(de s!:comqgetv (x env context) (cond ((and (fixp (caddr x)) (geq (caddr x) 0 1376) (lessp (caddr x) 256)) (progn (s!:comval (cadr x) env 1) (s!:outopcode1 ( 1377quote QGETVN) (caddr x) (caddr x)))) (t (s!:comcall x env context)))) 1378 1379(put (quote qgetv) (quote s!:compfn) (function s!:comqgetv)) 1380 1381(de s!:comget (x env context) (prog (a b c w) (setq a (cadr x)) (setq b ( 1382caddr x)) (setq c (cdddr x)) (cond ((eqcar b (quote quote)) (progn (setq b ( 1383cadr b)) (setq w (symbol!-make!-fastget b nil)) (cond (c (progn (cond (w ( 1384progn (cond ((s!:load2 a b env) (s!:outopcode0 (quote SWOP) (quote (SWOP))))) 1385(s!:outopcode1 (quote FASTGET) (logor w 64) b))) (t (s!:comcall x env 1386context))))) (t (progn (s!:comval a env 1) (cond (w (s!:outopcode1 (quote 1387FASTGET) w b)) (t (s!:outopcode1lit (quote LITGET) b env)))))))) (t ( 1388s!:comcall x env context))))) 1389 1390(put (quote get) (quote s!:compfn) (function s!:comget)) 1391 1392(de s!:comflagp (x env context) (prog (a b) (setq a (cadr x)) (setq b (caddr 1393x)) (cond ((eqcar b (quote quote)) (progn (setq b (cadr b)) (s!:comval a env 13941) (setq a (symbol!-make!-fastget b nil)) (cond (a (s!:outopcode1 (quote 1395FASTGET) (logor a 128) b)) (t (s!:comcall x env context))))) (t (s!:comcall x 1396env context))))) 1397 1398(put (quote flagp) (quote s!:compfn) (function s!:comflagp)) 1399 1400(de s!:complus (x env context) (s!:comval (expand (cdr x) (quote plus2)) env 1401context)) 1402 1403(put (quote plus) (quote s!:compfn) (function s!:complus)) 1404 1405(put (quote !+) (quote s!:compfn) (function s!:complus)) 1406 1407(de s!:comtimes (x env context) (s!:comval (expand (cdr x) (quote times2)) 1408env context)) 1409 1410(put (quote times) (quote s!:compfn) (function s!:comtimes)) 1411 1412(put (quote !*) (quote s!:compfn) (function s!:comtimes)) 1413 1414(de s!:comiplus (x env context) (s!:comval (expand (cdr x) (quote iplus2)) 1415env context)) 1416 1417(put (quote iplus) (quote s!:compfn) (function s!:comiplus)) 1418 1419(de s!:comitimes (x env context) (s!:comval (expand (cdr x) (quote itimes2)) 1420env context)) 1421 1422(put (quote itimes) (quote s!:compfn) (function s!:comitimes)) 1423 1424(de s!:complus2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( 1425setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( 1426s!:comval (plus a b) env context)) (t (cond ((equal a 0) (s!:comval b env 1427context)) (t (cond ((equal a 1) (s!:comval (list (quote add1) b) env context) 1428) (t (cond ((equal b 0) (s!:comval a env context)) (t (cond ((equal b 1) ( 1429s!:comval (list (quote add1) a) env context)) (t (cond ((equal b (minus 1)) ( 1430s!:comval (list (quote sub1) a) env context)) (t (s!:comcall x env context))) 1431))))))))))))) 1432 1433(put (quote plus2) (quote s!:compfn) (function s!:complus2)) 1434 1435(de s!:comdifference (x env context) (prog (a b) (setq a (s!:improve (cadr x) 1436)) (setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b 1437)) (s!:comval (difference a b) env context)) (t (cond ((equal a 0) (s!:comval 1438(list (quote minus) b) env context)) (t (cond ((equal b 0) (s!:comval a env 1439context)) (t (cond ((equal b 1) (s!:comval (list (quote sub1) a) env context) 1440) (t (cond ((equal b (minus 1)) (s!:comval (list (quote add1) a) env context) 1441) (t (s!:comcall x env context)))))))))))))) 1442 1443(put (quote difference) (quote s!:compfn) (function s!:comdifference)) 1444 1445(de s!:comiplus2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( 1446setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( 1447s!:comval (plus a b) env context)) (t (cond ((equal a 1) (s!:comval (list ( 1448quote iadd1) b) env context)) (t (cond ((equal b 1) (s!:comval (list (quote 1449iadd1) a) env context)) (t (cond ((equal b (minus 1)) (s!:comval (list (quote 1450isub1) a) env context)) (t (s!:comcall x env context)))))))))))) 1451 1452(put (quote iplus2) (quote s!:compfn) (function s!:comiplus2)) 1453 1454(de s!:comidifference (x env context) (prog (a b) (setq a (s!:improve (cadr x 1455))) (setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp 1456b)) (s!:comval (difference a b) env context)) (t (cond ((equal b 1) ( 1457s!:comval (list (quote isub1) a) env context)) (t (cond ((equal b (minus 1)) 1458(s!:comval (list (quote iadd1) a) env context)) (t (s!:comcall x env context) 1459))))))))) 1460 1461(put (quote idifference) (quote s!:compfn) (function s!:comidifference)) 1462 1463(de s!:comtimes2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( 1464setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( 1465s!:comval (times a b) env context)) (t (cond ((equal a 1) (s!:comval b env 1466context)) (t (cond ((equal a (minus 1)) (s!:comval (list (quote minus) b) env 1467context)) (t (cond ((equal b 1) (s!:comval a env context)) (t (cond ((equal 1468b (minus 1)) (s!:comval (list (quote minus) a) env context)) (t (s!:comcall x 1469env context)))))))))))))) 1470 1471(put (quote times2) (quote s!:compfn) (function s!:comtimes2)) 1472 1473(put (quote itimes2) (quote s!:compfn) (function s!:comtimes2)) 1474 1475(de s!:comminus (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( 1476return (cond ((numberp a) (s!:comval (minus a) env context)) (t (cond ((eqcar 1477a (quote minus)) (s!:comval (cadr a) env context)) (t (s!:comcall x env 1478context)))))))) 1479 1480(put (quote minus) (quote s!:compfn) (function s!:comminus)) 1481 1482(de s!:comminusp (x env context) (prog (a) (setq a (s!:improve (cadr x))) ( 1483cond ((eqcar a (quote difference)) (return (s!:comval (cons (quote lessp) ( 1484cdr a)) env context))) (t (return (s!:comcall x env context)))))) 1485 1486(put (quote minusp) (quote s!:compfn) (function s!:comminusp)) 1487 1488(de s!:comlessp (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( 1489setq b (s!:improve (caddr x))) (cond ((equal b 0) (return (s!:comval (list ( 1490quote minusp) a) env context))) (t (return (s!:comcall x env context)))))) 1491 1492(put (quote lessp) (quote s!:compfn) (function s!:comlessp)) 1493 1494(de s!:comiminusp (x env context) (prog (a) (setq a (s!:improve (cadr x))) ( 1495cond ((eqcar a (quote difference)) (return (s!:comval (cons (quote ilessp) ( 1496cdr a)) env context))) (t (return (s!:comcall x env context)))))) 1497 1498(put (quote iminusp) (quote s!:compfn) (function s!:comiminusp)) 1499 1500(de s!:comilessp (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( 1501setq b (s!:improve (caddr x))) (cond ((equal b 0) (return (s!:comval (list ( 1502quote iminusp) a) env context))) (t (return (s!:comcall x env context)))))) 1503 1504(put (quote ilessp) (quote s!:compfn) (function s!:comilessp)) 1505 1506(de s!:comprogn (x env context) (progn (setq x (cdr x)) (cond ((null x) ( 1507s!:comval nil env context)) (t (prog (a) (setq a (car x)) (prog nil lab1090 ( 1508cond ((null (setq x (cdr x))) (return nil))) (progn (s!:comval a env (cond (( 1509geq context 4) context) (t 2))) (setq a (car x))) (go lab1090)) (s!:comval a 1510env context)))))) 1511 1512(put (quote progn) (quote s!:compfn) (function s!:comprogn)) 1513 1514(de s!:comprog1 (x env context) (prog nil (setq x (cdr x)) (cond ((null x) ( 1515return (s!:comval nil env context)))) (s!:comval (car x) env context) (cond ( 1516(null (setq x (cdr x))) (return nil))) (s!:outopcode0 (quote PUSH) (quote ( 1517PUSH))) (rplacd env (cons 0 (cdr env))) (prog (var1092) (setq var1092 x) 1518lab1091 (cond ((null var1092) (return nil))) (prog (a) (setq a (car var1092)) 1519(s!:comval a env (cond ((geq context 4) context) (t 2)))) (setq var1092 (cdr 1520var1092)) (go lab1091)) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd 1521env (cddr env)))) 1522 1523(put (quote prog1) (quote s!:compfn) (function s!:comprog1)) 1524 1525(de s!:comprog2 (x env context) (prog (a) (setq x (cdr x)) (cond ((null x) ( 1526return (s!:comval nil env context)))) (setq a (car x)) (s!:comval a env (cond 1527((geq context 4) context) (t 2))) (s!:comprog1 x env context))) 1528 1529(put (quote prog2) (quote s!:compfn) (function s!:comprog2)) 1530 1531(de s!:outstack (n) (prog (w a) (setq w s!:current_block) (prog nil lab1093 ( 1532cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go 1533lab1093)) (cond ((eqcar w (quote PUSHNIL)) (setq a 1)) (t (cond ((eqcar w ( 1534quote PUSHNIL2)) (setq a 2)) (t (cond ((eqcar w (quote PUSHNIL3)) (setq a 3)) 1535(t (cond ((and w (numberp (setq a (car w))) (not (equal a 255)) (eqcar (cdr 1536w) (quote PUSHNILS))) (progn (setq w (cdr w)) (setq s!:current_size ( 1537difference s!:current_size 1)))) (t (setq a nil))))))))) (cond (a (progn ( 1538setq s!:current_block (cdr w)) (setq s!:current_size (difference 1539s!:current_size 1)) (setq n (plus n a))))) (cond ((equal n 1) (s!:outopcode0 1540(quote PUSHNIL) (quote (PUSHNIL)))) (t (cond ((equal n 2) (s!:outopcode0 ( 1541quote PUSHNIL2) (quote (PUSHNIL2)))) (t (cond ((equal n 3) (s!:outopcode0 ( 1542quote PUSHNIL3) (quote (PUSHNIL3)))) (t (cond ((greaterp n 255) (progn ( 1543s!:outopcode1 (quote PUSHNILS) 255 255) (s!:outstack (difference n 255)))) (t 1544(cond ((greaterp n 3) (s!:outopcode1 (quote PUSHNILS) n n))))))))))))) 1545 1546(de s!:outlose (n) (prog (w a) (setq w s!:current_block) (prog nil lab1094 ( 1547cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go 1548lab1094)) (cond ((eqcar w (quote LOSE)) (setq a 1)) (t (cond ((eqcar w ( 1549quote LOSE2)) (setq a 2)) (t (cond ((eqcar w (quote LOSE3)) (setq a 3)) (t ( 1550cond ((and w (numberp (setq a (car w))) (not (equal a 255)) (eqcar (cdr w) ( 1551quote LOSES))) (progn (setq w (cdr w)) (setq s!:current_size (difference 1552s!:current_size 1)))) (t (setq a nil))))))))) (cond (a (progn (setq 1553s!:current_block (cdr w)) (setq s!:current_size (difference s!:current_size 1 1554)) (setq n (plus n a))))) (cond ((equal n 1) (s!:outopcode0 (quote LOSE) ( 1555quote (LOSE)))) (t (cond ((equal n 2) (s!:outopcode0 (quote LOSE2) (quote ( 1556LOSE2)))) (t (cond ((equal n 3) (s!:outopcode0 (quote LOSE3) (quote (LOSE3))) 1557) (t (cond ((greaterp n 255) (progn (s!:outopcode1 (quote LOSES) 255 255) ( 1558s!:outlose (difference n 255)))) (t (cond ((greaterp n 3) (s!:outopcode1 ( 1559quote LOSES) n n))))))))))))) 1560 1561(de s!:comprog (x env context) (prog (labs s bvl fluids n body local_decs w) 1562(setq body (s!:find_local_decs (cddr x) t)) (setq local_decs (car body)) ( 1563setq body (cdr body)) (setq n 0) (prog (var1096) (setq var1096 (cadr x)) 1564lab1095 (cond ((null var1096) (return nil))) (prog (v) (setq v (car var1096)) 1565(setq w (s!:instate_local_decs v local_decs w))) (setq var1096 (cdr var1096) 1566) (go lab1095)) (prog (var1098) (setq var1098 (cadr x)) lab1097 (cond ((null 1567var1098) (return nil))) (prog (v) (setq v (car var1098)) (progn (cond ((or ( 1568globalp v) (keywordp v)) (error 0 (list "attempt to bind global or keyword" v 1569)))) (cond ((fluidp v) (setq fluids (cons v fluids))) (t (progn (setq n (plus 1570n 1)) (setq bvl (cons v bvl))))))) (setq var1098 (cdr var1098)) (go lab1097) 1571) (setq s (cdr env)) (setq s!:current_exitlab (cons (cons nil (cons (gensym) 1572s)) s!:current_exitlab)) (s!:outstack n) (rplacd env (append bvl (cdr env))) 1573(cond (fluids (prog (fl1) (setq fl1 (s!:vecof fluids)) (s!:outopcode1lit ( 1574quote FREEBIND) fl1 env) (prog (var1100) (setq var1100 (cons nil fluids)) 1575lab1099 (cond ((null var1100) (return nil))) (prog (v) (setq v (car var1100)) 1576(rplacd env (cons 0 (cdr env)))) (setq var1100 (cdr var1100)) (go lab1099)) 1577(rplacd env (cons (plus 2 (length fluids)) (cdr env))) (cond ((equal context 15780) (setq context 1)))))) (prog (var1102) (setq var1102 body) lab1101 (cond (( 1579null var1102) (return nil))) (prog (a) (setq a (car var1102)) (cond ((atom a) 1580(progn (cond ((atsoc a labs) (progn (cond ((not (null a)) (progn (cond ((neq 1581(posn) 0) (terpri))) (princ "+++++ label ") (prin a) (princ 1582" multiply defined") (terpri)))))) (t (setq labs (cons (cons a (cons (cons ( 1583gensym) (cdr env)) nil)) labs)))))))) (setq var1102 (cdr var1102)) (go 1584lab1101)) (setq s!:current_proglabels (cons labs s!:current_proglabels)) ( 1585setq w (s!:residual_local_decs local_decs w)) (prog (var1104) (setq var1104 1586body) lab1103 (cond ((null var1104) (return nil))) (prog (a) (setq a (car 1587var1104)) (cond ((not (atom a)) (progn (cond ((not (eqcar a (quote quote))) ( 1588s!:comval a env (plus context 4)))))) (t (prog (d) (setq d (atsoc a labs)) ( 1589cond ((null (cddr d)) (progn (rplacd (cdr d) t) (s!:set_label (caadr d))))))) 1590)) (setq var1104 (cdr var1104)) (go lab1103)) (s!:cancel_local_decs w) ( 1591s!:comval nil env context) (cond (fluids (s!:outopcode0 (quote FREERSTR) ( 1592quote (FREERSTR))))) (s!:outlose n) (rplacd env s) (s!:set_label (cadar 1593s!:current_exitlab)) (setq s!:current_exitlab (cdr s!:current_exitlab)) (setq 1594s!:current_proglabels (cdr s!:current_proglabels)))) 1595 1596(put (quote prog) (quote s!:compfn) (function s!:comprog)) 1597 1598(de s!:comtagbody (x env context) (prog (labs) (prog (var1106) (setq var1106 1599(cdr x)) lab1105 (cond ((null var1106) (return nil))) (prog (a) (setq a (car 1600var1106)) (cond ((atom a) (progn (cond ((atsoc a labs) (progn (cond ((not ( 1601null a)) (progn (cond ((neq (posn) 0) (terpri))) (princ "+++++ label ") (prin 1602a) (princ " multiply defined") (terpri)))))) (t (setq labs (cons (cons a ( 1603cons (cons (gensym) (cdr env)) nil)) labs)))))))) (setq var1106 (cdr var1106) 1604) (go lab1105)) (setq s!:current_proglabels (cons labs s!:current_proglabels) 1605) (prog (var1108) (setq var1108 (cdr x)) lab1107 (cond ((null var1108) ( 1606return nil))) (prog (a) (setq a (car var1108)) (cond ((not (atom a)) (progn ( 1607cond ((not (eqcar a (quote quote))) (s!:comval a env (plus context 4)))))) (t 1608(prog (d) (setq d (atsoc a labs)) (cond ((null (cddr d)) (progn (rplacd (cdr 1609d) t) (s!:set_label (caadr d))))))))) (setq var1108 (cdr var1108)) (go 1610lab1107)) (s!:comval nil env context) (setq s!:current_proglabels (cdr 1611s!:current_proglabels)))) 1612 1613(put (quote tagbody) (quote s!:compfn) (function s!:comtagbody)) 1614 1615(de s!:comprogv (x env context) (prog nil (setq x (cdr x)) (cond ((s!:load2 ( 1616car x) (cadr x) env) (s!:outopcode0 (quote SWOP) (quote (SWOP))))) ( 1617s!:outopcode0 (quote PVBIND) (quote (PVBIND))) (rplacd env (cons (quote ( 1618pvbind)) (cons 0 (cdr env)))) (s!:comval (cons (quote progn) (cddr x)) env 1) 1619(s!:outopcode0 (quote PVRESTORE) (quote (PVRESTORE))) (rplacd env (cdddr env 1620)))) 1621 1622(put (quote progv) (quote s!:compfn) (function s!:comprogv)) 1623 1624(de s!:comprog!* (x env context) (prog (local_decs) (setq local_decs ( 1625s!:find_local_decs (cddr x) t)) (setq x (list (quote !~block) nil (list ( 1626quote let!*) (cadr x) (cons (quote declare) (car local_decs)) (cons (quote 1627tagbody) (cdr local_decs))))) (return (s!:comval x env context)))) 1628 1629(put (quote prog!*) (quote s!:compfn) (function s!:comprog!*)) 1630 1631(de s!:comprog (x env context) (prog (local_decs) (setq local_decs ( 1632s!:find_local_decs (cddr x) t)) (setq x (list (quote !~block) nil (list ( 1633quote !~let) (cadr x) (cons (quote declare) (car local_decs)) (cons (quote 1634tagbody) (cdr local_decs))))) (return (s!:comval x env context)))) 1635 1636(put (quote prog) (quote s!:compfn) (function s!:comprog)) 1637 1638(de s!:comblock (x env context) (prog nil (setq s!:current_exitlab (cons ( 1639cons (cadr x) (cons (gensym) (cdr env))) s!:current_exitlab)) (s!:comval ( 1640cons (quote progn) (cddr x)) env context) (s!:set_label (cadar 1641s!:current_exitlab)) (setq s!:current_exitlab (cdr s!:current_exitlab)))) 1642 1643(put (quote !~block) (quote s!:compfn) (function s!:comblock)) 1644 1645(de s!:comcatch (x env context) (prog (g) (setq g (gensym)) (s!:comval (cadr 1646x) env 1) (s!:outjump (quote CATCH) g) (rplacd env (cons (quote (catch)) ( 1647cons 0 (cons 0 (cdr env))))) (s!:comval (cons (quote progn) (cddr x)) env 1648context) (s!:outopcode0 (quote UNCATCH) (quote (UNCATCH))) (rplacd env ( 1649cddddr env)) (s!:set_label g))) 1650 1651(put (quote catch) (quote s!:compfn) (quote s!:comcatch)) 1652 1653(de s!:comthrow (x env context) (prog nil (cond ((null (cdr x)) (error 0 1654"throw needs to provide a tag"))) (s!:comval (cadr x) env 1) (s!:outopcode0 ( 1655quote PUSH) (quote (PUSH))) (rplacd env (cons 0 (cdr env))) (s!:comval (cond 1656((cddr x) (caddr x)) (t nil)) env 1) (s!:outopcode0 (quote THROW) (quote ( 1657THROW))) (rplacd env (cddr env)))) 1658 1659(put (quote throw) (quote s!:compfn) (quote s!:comthrow)) 1660 1661(de s!:comunwind!-protect (x env context) (prog (g) (setq g (gensym)) ( 1662s!:comval (quote (load!-spid)) env 1) (s!:outjump (quote CATCH) g) (rplacd 1663env (cons (list (quote unwind!-protect) (cddr x)) (cons 0 (cons 0 (cdr env))) 1664)) (s!:comval (cadr x) env context) (s!:outopcode0 (quote PROTECT) (quote ( 1665PROTECT))) (s!:set_label g) (rplaca (cdr env) 0) (s!:comval (cons (quote 1666progn) (cddr x)) env context) (s!:outopcode0 (quote UNPROTECT) (quote ( 1667UNPROTECT))) (rplacd env (cddddr env)))) 1668 1669(put (quote unwind!-protect) (quote s!:compfn) (quote s!:comunwind!-protect)) 1670 1671(de s!:comdeclare (x env context) (prog nil (cond (!*pwrds (progn (princ 1672"+++ ") (prin x) (princ " ignored") (terpri)))))) 1673 1674(put (quote declare) (quote s!:compfn) (function s!:comdeclare)) 1675 1676(de s!:expand_let (vl b) (prog (vars vals) (prog (var1110) (setq var1110 vl) 1677lab1109 (cond ((null var1110) (return nil))) (prog (v) (setq v (car var1110)) 1678(cond ((atom v) (progn (setq vars (cons v vars)) (setq vals (cons nil vals)) 1679)) (t (cond ((atom (cdr v)) (progn (setq vars (cons (car v) vars)) (setq vals 1680(cons nil vals)))) (t (progn (setq vars (cons (car v) vars)) (setq vals ( 1681cons (cadr v) vals)))))))) (setq var1110 (cdr var1110)) (go lab1109)) (return 1682(list (cons (cons (quote lambda) (cons vars b)) vals))))) 1683 1684(de s!:comlet (x env context) (s!:comval (cons (quote progn) (s!:expand_let ( 1685cadr x) (cddr x))) env context)) 1686 1687(put (quote !~let) (quote s!:compfn) (function s!:comlet)) 1688 1689(de s!:expand_let!* (vl local_decs b) (prog (r var val) (setq r (cons (cons ( 1690quote declare) local_decs) b)) (prog (var1114) (setq var1114 (reverse vl)) 1691lab1113 (cond ((null var1114) (return nil))) (prog (x) (setq x (car var1114)) 1692(progn (setq val nil) (cond ((atom x) (setq var x)) (t (cond ((atom (cdr x)) 1693(setq var (car x))) (t (progn (setq var (car x)) (setq val (cadr x))))))) ( 1694prog (var1112) (setq var1112 local_decs) lab1111 (cond ((null var1112) ( 1695return nil))) (prog (z) (setq z (car var1112)) (cond ((eqcar z (quote special 1696)) (cond ((memq var (cdr z)) (setq r (cons (list (quote declare) (list (quote 1697special) var)) r))))))) (setq var1112 (cdr var1112)) (go lab1111)) (setq r ( 1698list (list (cons (quote lambda) (cons (list var) r)) val))))) (setq var1114 ( 1699cdr var1114)) (go lab1113)) (cond ((eqcar (car r) (quote declare)) (setq r ( 1700list (cons (quote lambda) (cons nil r))))) (t (setq r (cons (quote progn) r)) 1701)) (return r))) 1702 1703(de s!:comlet!* (x env context) (prog (b) (setq b (s!:find_local_decs (cddr x 1704) nil)) (return (s!:comval (s!:expand_let!* (cadr x) (car b) (cdr b)) env 1705context)))) 1706 1707(put (quote let!*) (quote s!:compfn) (function s!:comlet!*)) 1708 1709(de s!:restore_stack (e1 e2) (prog (n) (setq n 0) (prog nil lab1116 (cond (( 1710null (not (equal e1 e2))) (return nil))) (progn (cond ((null e1) (error 0 1711"bad block nesting with GO or RETURN-FROM"))) (cond ((and (numberp (car e1)) 1712(greaterp (car e1) 2)) (progn (cond ((not (zerop n)) (s!:outlose n))) (setq n 1713(car e1)) (s!:outopcode0 (quote FREERSTR) (quote (FREERSTR))) (prog (i) ( 1714setq i 1) lab1115 (cond ((minusp (times 1 (difference n i))) (return nil))) ( 1715setq e1 (cdr e1)) (setq i (plus i 1)) (go lab1115)) (setq n 0))) (t (cond (( 1716equal (car e1) (quote (catch))) (progn (cond ((not (zerop n)) (s!:outlose n)) 1717) (s!:outopcode0 (quote UNCATCH) (quote (UNCATCH))) (setq e1 (cdddr e1)) ( 1718setq n 0))) (t (cond ((eqcar (car e1) (quote unwind!-protect)) (progn (cond ( 1719(not (zerop n)) (s!:outlose n))) (s!:outopcode0 (quote PROTECT) (quote ( 1720PROTECT))) (s!:comval (cons (quote progn) (cadar e1)) e1 2) (s!:outopcode0 ( 1721quote UNPROTECT) (quote (UNPROTECT))) (setq e1 (cdddr e1)) (setq n 0))) (t ( 1722cond ((equal (car e1) (quote (pvbind))) (progn (cond ((not (zerop n)) ( 1723s!:outlose n))) (s!:outopcode0 (quote PVRESTORE) (quote (PVRESTORE))) (setq 1724e1 (cddr e1)) (setq n 0))) (t (progn (setq e1 (cdr e1)) (setq n (plus n 1)))) 1725)))))))) (go lab1116)) (cond ((not (zerop n)) (s!:outlose n))))) 1726 1727(de s!:comgo (x env context) (prog (pl d) (cond ((lessp context 4) (progn ( 1728princ "go not in program context") (terpri)))) (setq pl s!:current_proglabels 1729) (prog nil lab1117 (cond ((null (and pl (null d))) (return nil))) (progn ( 1730setq d (atsoc (cadr x) (car pl))) (cond ((null d) (setq pl (cdr pl))))) (go 1731lab1117)) (cond ((null d) (progn (cond ((neq (posn) 0) (terpri))) (princ 1732"+++++ label ") (prin (cadr x)) (princ " not set") (terpri) (return nil)))) ( 1733setq d (cadr d)) (s!:restore_stack (cdr env) (cdr d)) (s!:outjump (quote JUMP 1734) (car d)))) 1735 1736(put (quote go) (quote s!:compfn) (function s!:comgo)) 1737 1738(de s!:comreturn!-from (x env context) (prog (tag) (cond ((lessp context 4) ( 1739progn (princ "+++++ return or return-from not in prog context") (terpri)))) ( 1740setq x (cdr x)) (setq tag (car x)) (cond ((cdr x) (setq x (cadr x))) (t (setq 1741x nil))) (s!:comval x env (difference context 4)) (setq x (atsoc tag 1742s!:current_exitlab)) (cond ((null x) (error 0 (list "invalid return-from" tag 1743)))) (setq x (cdr x)) (s!:restore_stack (cdr env) (cdr x)) (s!:outjump (quote 1744JUMP) (car x)))) 1745 1746(put (quote return!-from) (quote s!:compfn) (function s!:comreturn!-from)) 1747 1748(de s!:comreturn (x env context) (s!:comreturn!-from (cons (quote 1749return!-from) (cons nil (cdr x))) env context)) 1750 1751(put (quote return) (quote s!:compfn) (function s!:comreturn)) 1752 1753(global (quote (s!:jumplts s!:jumplnils s!:jumpatoms s!:jumpnatoms))) 1754 1755(setq s!:jumplts (s!:vecof (quote (JUMPL0T JUMPL1T JUMPL2T JUMPL3T JUMPL4T))) 1756) 1757 1758(setq s!:jumplnils (s!:vecof (quote (JUMPL0NIL JUMPL1NIL JUMPL2NIL JUMPL3NIL 1759JUMPL4NIL)))) 1760 1761(setq s!:jumpatoms (s!:vecof (quote (JUMPL0ATOM JUMPL1ATOM JUMPL2ATOM 1762JUMPL3ATOM)))) 1763 1764(setq s!:jumpnatoms (s!:vecof (quote (JUMPL0NATOM JUMPL1NATOM JUMPL2NATOM 1765JUMPL3NATOM)))) 1766 1767(de s!:jumpif (neg x env lab) (prog (w w1 j) top (cond ((null x) (progn (cond 1768((not neg) (s!:outjump (quote JUMP) lab))) (return nil))) (t (cond ((or (eq 1769x t) (and (eqcar x (quote quote)) (cadr x)) (and (atom x) (not (symbolp x)))) 1770(progn (cond (neg (s!:outjump (quote JUMP) lab))) (return nil))) (t (cond (( 1771lessp (setq w (s!:islocal x env)) 5) (return (s!:outjump (getv (cond (neg 1772s!:jumplts) (t s!:jumplnils)) w) lab))) (t (cond ((and (equal w 99999) ( 1773symbolp x)) (progn (s!:should_be_fluid x) (setq w (list (cond (neg (quote 1774JUMPFREET)) (t (quote JUMPFREENIL))) x x)) (return ( 1775s!:record_literal_for_jump w env lab))))))))))) (cond ((and (not (atom x)) ( 1776atom (car x)) (setq w (get (car x) (quote s!:testfn)))) (return (funcall w 1777neg x env lab)))) (cond ((not (atom x)) (progn (setq w (s!:improve x)) (cond 1778((or (atom w) (not (eqcar x (car w)))) (progn (setq x w) (go top)))) (cond (( 1779setq w1 (s!:local_macro (car w))) (progn (cond ((atom (cdr w1)) (setq x (cons 1780(quote funcall) (cons (cdr w1) (cdr w))))) (t (setq x (funcall (cons (quote 1781lambda) (cdr w1)) w)))) (go top)))) (cond ((and (setq w1 (get (car w) (quote 1782s!:compilermacro))) (setq w1 (funcall w1 w env 1))) (progn (setq x w1) (go 1783top))))))) remacro (cond ((and (not (atom w)) (setq w1 (macro!-function (car 1784w)))) (progn (setq w (funcall w1 w)) (cond ((or (atom w) (eqcar w (quote 1785quote)) (get (car w) (quote s!:testfn)) (get (car w) (quote s!:compilermacro) 1786)) (progn (setq x w) (go top)))) (go remacro)))) (s!:comval x env 1) (setq w 1787s!:current_block) (prog nil lab1118 (cond ((null (and w (not (atom (car w)))) 1788) (return nil))) (setq w (cdr w)) (go lab1118)) (setq j (quote (JUMPNIL . 1789JUMPT))) (cond (w (progn (setq w1 (car w)) (setq w (cdr w)) (cond ((equal w1 1790(quote STORELOC0)) (progn (setq s!:current_block w) (setq s!:current_size ( 1791difference s!:current_size 1)) (setq j (quote (JUMPST0NIL . JUMPST0T))))) (t 1792(cond ((equal w1 (quote STORELOC1)) (progn (setq s!:current_block w) (setq 1793s!:current_size (difference s!:current_size 1)) (setq j (quote (JUMPST1NIL . 1794JUMPST1T))))) (t (cond ((equal w1 (quote STORELOC2)) (progn (setq 1795s!:current_block w) (setq s!:current_size (difference s!:current_size 1)) ( 1796setq j (quote (JUMPST2NIL . JUMPST2T))))) (t (cond ((eqcar w (quote BUILTIN1) 1797) (progn (setq s!:current_block (cdr w)) (setq s!:current_size (difference 1798s!:current_size 2)) (setq j (cons (list (quote JUMPB1NIL) w1) (list (quote 1799JUMPB1T) w1))))) (t (cond ((eqcar w (quote BUILTIN2)) (progn (setq 1800s!:current_block (cdr w)) (setq s!:current_size (difference s!:current_size 2 1801)) (setq j (cons (list (quote JUMPB2NIL) w1) (list (quote JUMPB2T) w1)))))))) 1802))))))))) (return (s!:outjump (cond (neg (cdr j)) (t (car j))) lab)))) 1803 1804(de s!:testnot (neg x env lab) (s!:jumpif (not neg) (cadr x) env lab)) 1805 1806(put (quote null) (quote s!:testfn) (function s!:testnot)) 1807 1808(put (quote not) (quote s!:testfn) (function s!:testnot)) 1809 1810(de s!:testatom (neg x env lab) (prog (w) (cond ((lessp (setq w (s!:islocal ( 1811cadr x) env)) 4) (return (s!:outjump (getv (cond (neg s!:jumpatoms) (t 1812s!:jumpnatoms)) w) lab)))) (s!:comval (cadr x) env 1) (cond (neg (s!:outjump 1813(quote JUMPATOM) lab)) (t (s!:outjump (quote JUMPNATOM) lab))))) 1814 1815(put (quote atom) (quote s!:testfn) (function s!:testatom)) 1816 1817(de s!:testconsp (neg x env lab) (prog (w) (cond ((lessp (setq w (s!:islocal 1818(cadr x) env)) 4) (return (s!:outjump (getv (cond (neg s!:jumpnatoms) (t 1819s!:jumpatoms)) w) lab)))) (s!:comval (cadr x) env 1) (cond (neg (s!:outjump ( 1820quote JUMPNATOM) lab)) (t (s!:outjump (quote JUMPATOM) lab))))) 1821 1822(put (quote consp) (quote s!:testfn) (function s!:testconsp)) 1823 1824(de s!:comcond (x env context) (prog (l1 l2 w) (setq l1 (gensym)) (prog nil 1825lab1119 (cond ((null (setq x (cdr x))) (return nil))) (progn (setq w (car x)) 1826(cond ((atom (cdr w)) (progn (s!:comval (car w) env 1) (s!:outjump (quote 1827JUMPT) l1) (setq l2 nil))) (t (progn (cond ((equal (car w) t) (setq l2 nil)) 1828(t (progn (setq l2 (gensym)) (s!:jumpif nil (car w) env l2)))) (setq w (cdr w 1829)) (cond ((null (cdr w)) (setq w (car w))) (t (setq w (cons (quote progn) w)) 1830)) (s!:comval w env context) (cond (l2 (progn (s!:outjump (quote JUMP) l1) ( 1831s!:set_label l2))) (t (setq x (quote (nil))))))))) (go lab1119)) (cond (l2 ( 1832s!:comval nil env context))) (s!:set_label l1))) 1833 1834(put (quote cond) (quote s!:compfn) (function s!:comcond)) 1835 1836(de s!:comif (x env context) (prog (l1 l2) (setq l2 (gensym)) (s!:jumpif nil 1837(cadr x) env l2) (setq x (cddr x)) (s!:comval (car x) env context) (setq x ( 1838cdr x)) (cond ((or x (and (lessp context 2) (setq x (quote (nil))))) (progn ( 1839setq l1 (gensym)) (s!:outjump (quote JUMP) l1) (s!:set_label l2) (s!:comval ( 1840car x) env context) (s!:set_label l1))) (t (s!:set_label l2))))) 1841 1842(put (quote if) (quote s!:compfn) (function s!:comif)) 1843 1844(de s!:comwhen (x env context) (prog (l2) (setq l2 (gensym)) (cond ((lessp 1845context 2) (progn (s!:comval (cadr x) env 1) (s!:outjump (quote JUMPNIL) l2)) 1846) (t (s!:jumpif nil (cadr x) env l2))) (s!:comval (cons (quote progn) (cddr x 1847)) env context) (s!:set_label l2))) 1848 1849(put (quote when) (quote s!:compfn) (function s!:comwhen)) 1850 1851(de s!:comunless (x env context) (s!:comwhen (list!* (quote when) (list ( 1852quote not) (cadr x)) (cddr x)) env context)) 1853 1854(put (quote unless) (quote s!:compfn) (function s!:comunless)) 1855 1856(de s!:comicase (x env context) (prog (l1 labs labassoc w) (setq x (cdr x)) ( 1857prog (var1121) (setq var1121 (cdr x)) lab1120 (cond ((null var1121) (return 1858nil))) (prog (v) (setq v (car var1121)) (progn (setq w (assoc!*!* v labassoc) 1859) (cond (w (setq l1 (cons (cdr w) l1))) (t (progn (setq l1 (gensym)) (setq 1860labs (cons l1 labs)) (setq labassoc (cons (cons v l1) labassoc))))))) (setq 1861var1121 (cdr var1121)) (go lab1120)) (s!:comval (car x) env 1) (s!:outjump ( 1862quote ICASE) (reversip labs)) (setq l1 (gensym)) (prog (var1123) (setq 1863var1123 labassoc) lab1122 (cond ((null var1123) (return nil))) (prog (v) ( 1864setq v (car var1123)) (progn (s!:set_label (cdr v)) (s!:comval (car v) env 1865context) (s!:outjump (quote JUMP) l1))) (setq var1123 (cdr var1123)) (go 1866lab1122)) (s!:set_label l1))) 1867 1868(put (quote s!:icase) (quote s!:compfn) (function s!:comicase)) 1869 1870(put (quote JUMPLITEQ!*) (quote s!:opcode) (get (quote JUMPLITEQ) (quote 1871s!:opcode))) 1872 1873(put (quote JUMPLITNE!*) (quote s!:opcode) (get (quote JUMPLITNE) (quote 1874s!:opcode))) 1875 1876(de s!:jumpliteql (val lab env) (prog (w) (cond ((or (idp val) (eq!-safe val) 1877) (progn (setq w (list (quote JUMPLITEQ!*) val val)) ( 1878s!:record_literal_for_jump w env lab))) (t (progn (s!:outopcode0 (quote PUSH) 1879(quote (PUSH))) (s!:loadliteral val env) (s!:outopcode1 (quote BUILTIN2) ( 1880get (quote eql) (quote s!:builtin2)) (quote eql)) (s!:outjump (quote JUMPT) 1881lab) (flag (list lab) (quote s!:jumpliteql)) (s!:outopcode0 (quote POP) ( 1882quote (POP)))))))) 1883 1884(de s!:casebranch (sw env dflt) (prog (size w w1 r g) (setq size (plus 4 ( 1885truncate (length sw) 2))) (prog nil lab1124 (cond ((null (or (equal ( 1886remainder size 2) 0) (equal (remainder size 3) 0) (equal (remainder size 5) 0 1887) (equal (remainder size 13) 0))) (return nil))) (setq size (plus size 1)) ( 1888go lab1124)) (prog (var1126) (setq var1126 sw) lab1125 (cond ((null var1126) 1889(return nil))) (prog (p) (setq p (car var1126)) (progn (setq w (remainder ( 1890eqlhash (car p)) size)) (setq w1 (assoc!*!* w r)) (cond (w1 (rplacd (cdr w1) 1891(cons p (cddr w1)))) (t (setq r (cons (list w (gensym) p) r)))))) (setq 1892var1126 (cdr var1126)) (go lab1125)) (s!:outopcode0 (quote PUSH) (quote (PUSH 1893))) (rplacd env (cons 0 (cdr env))) (s!:outopcode1lit (quote CALL1) (quote 1894eqlhash) env) (s!:loadliteral size env) (setq g (gensym)) (s!:outopcode1 ( 1895quote BUILTIN2) (get (quote iremainder) (quote s!:builtin2)) (quote 1896iremainder)) (s!:outjump (quote ICASE) (cons g (prog (i var1128) (setq i 0) 1897lab1127 (cond ((minusp (times 1 (difference (difference size 1) i))) (return 1898(reversip var1128)))) (setq var1128 (cons (progn (setq w (assoc!*!* i r)) ( 1899cond (w (cadr w)) (t g))) var1128)) (setq i (plus i 1)) (go lab1127)))) (prog 1900(var1132) (setq var1132 r) lab1131 (cond ((null var1132) (return nil))) ( 1901prog (p) (setq p (car var1132)) (progn (s!:set_label (cadr p)) (s!:outopcode0 1902(quote POP) (quote (POP))) (prog (var1130) (setq var1130 (cddr p)) lab1129 ( 1903cond ((null var1130) (return nil))) (prog (q) (setq q (car var1130)) ( 1904s!:jumpliteql (car q) (cdr q) env)) (setq var1130 (cdr var1130)) (go lab1129) 1905) (s!:outjump (quote JUMP) dflt))) (setq var1132 (cdr var1132)) (go lab1131)) 1906(s!:set_label g) (s!:outopcode0 (quote POP) (quote (POP))) (s!:outjump ( 1907quote JUMP) dflt) (rplacd env (cddr env)))) 1908 1909(de s!:comcase (x env context) (prog (keyform blocks v w g dflt sw keys 1910nonnum) (setq x (cdr x)) (setq keyform (car x)) (prog (y) (setq y (cdr x)) 1911lab1135 (cond ((null y) (return nil))) (progn (setq w (assoc!*!* (cdar y) 1912blocks)) (cond (w (setq g (cdr w))) (t (progn (setq g (gensym)) (setq blocks 1913(cons (cons (cdar y) g) blocks))))) (setq w (caar y)) (cond ((and (null (cdr 1914y)) (or (equal w t) (equal w (quote otherwise)))) (setq dflt g)) (t (progn ( 1915cond ((atom w) (setq w (list w)))) (prog (var1134) (setq var1134 w) lab1133 ( 1916cond ((null var1134) (return nil))) (prog (n) (setq n (car var1134)) (progn ( 1917cond ((or (idp n) (characterp n) (numberp n)) (progn (cond ((not (fixp n)) ( 1918setq nonnum t))) (setq keys (cons n keys)) (setq sw (cons (cons n g) sw)))) ( 1919t (error 0 (list "illegal case label" n)))))) (setq var1134 (cdr var1134)) ( 1920go lab1133)))))) (setq y (cdr y)) (go lab1135)) (cond ((null dflt) (progn ( 1921cond ((setq w (assoc!*!* nil blocks)) (setq dflt (cdr w))) (t (setq blocks ( 1922cons (cons nil (setq dflt (gensym))) blocks))))))) (cond ((not nonnum) (progn 1923(setq keys (sort keys (function lessp))) (setq nonnum (car keys)) (setq g ( 1924lastcar keys)) (cond ((lessp (difference g nonnum) (times 2 (length keys))) ( 1925progn (cond ((not (equal nonnum 0)) (progn (setq keyform (list (quote 1926xdifference) keyform nonnum)) (setq sw (prog (var1137 var1138) (setq var1137 1927sw) lab1136 (cond ((null var1137) (return (reversip var1138)))) (prog (y) ( 1928setq y (car var1137)) (setq var1138 (cons (cons (difference (car y) nonnum) ( 1929cdr y)) var1138))) (setq var1137 (cdr var1137)) (go lab1136)))))) (s!:comval 1930keyform env 1) (setq w nil) (prog (i) (setq i 0) lab1139 (cond ((minusp ( 1931times 1 (difference g i))) (return nil))) (cond ((setq v (assoc!*!* i sw)) ( 1932setq w (cons (cdr v) w))) (t (setq w (cons dflt w)))) (setq i (plus i 1)) (go 1933lab1139)) (setq w (cons dflt (reversip w))) (s!:outjump (quote ICASE) w) ( 1934setq nonnum nil))) (t (setq nonnum t)))))) (cond (nonnum (progn (s!:comval 1935keyform env 1) (cond ((lessp (length sw) 7) (progn (prog (var1141) (setq 1936var1141 sw) lab1140 (cond ((null var1141) (return nil))) (prog (y) (setq y ( 1937car var1141)) (s!:jumpliteql (car y) (cdr y) env)) (setq var1141 (cdr var1141 1938)) (go lab1140)) (s!:outjump (quote JUMP) dflt))) (t (s!:casebranch sw env 1939dflt)))))) (setq g (gensym)) (prog (var1143) (setq var1143 blocks) lab1142 ( 1940cond ((null var1143) (return nil))) (prog (v) (setq v (car var1143)) (progn ( 1941s!:set_label (cdr v)) (cond ((flagp (cdr v) (quote s!:jumpliteql)) ( 1942s!:outlose 1))) (s!:comval (cons (quote progn) (car v)) env context) ( 1943s!:outjump (quote JUMP) g))) (setq var1143 (cdr var1143)) (go lab1142)) ( 1944s!:set_label g))) 1945 1946(put (quote case) (quote s!:compfn) (function s!:comcase)) 1947 1948(fluid (quote (!*defn dfprint!* s!:dfprintsave s!:faslmod_name))) 1949 1950(de s!:comeval!-when (x env context) (prog (y) (setq x (cdr x)) (setq y (car 1951x)) (princ "COMPILING eval-when: ") (print y) (print x) (setq x (cons (quote 1952progn) (cdr x))) (cond ((memq (quote compile) y) (eval x))) (cond ((memq ( 1953quote load) y) (progn (cond (dfprint!* (apply1 dfprint!* x)))))) (cond ((memq 1954(quote eval) y) (s!:comval x env context)) (t (s!:comval nil env context)))) 1955) 1956 1957(put (quote eval!-when) (quote s!:compfn) (function s!:comeval!-when)) 1958 1959(de s!:comthe (x env context) (s!:comval (caddr x) env context)) 1960 1961(put (quote the) (quote s!:compfn) (function s!:comthe)) 1962 1963(de s!:comand (x env context) (prog (l) (setq l (gensym)) (setq x (cdr x)) ( 1964s!:comval (car x) env 1) (prog nil lab1144 (cond ((null (setq x (cdr x))) ( 1965return nil))) (progn (s!:outjump (quote JUMPNIL) l) (s!:comval (car x) env 1) 1966) (go lab1144)) (s!:set_label l))) 1967 1968(put (quote and) (quote s!:compfn) (function s!:comand)) 1969 1970(de s!:comor (x env context) (prog (l) (setq l (gensym)) (setq x (cdr x)) ( 1971s!:comval (car x) env 1) (prog nil lab1145 (cond ((null (setq x (cdr x))) ( 1972return nil))) (progn (s!:outjump (quote JUMPT) l) (s!:comval (car x) env 1)) 1973(go lab1145)) (s!:set_label l))) 1974 1975(put (quote or) (quote s!:compfn) (function s!:comor)) 1976 1977(de s!:combool (neg x env lab) (prog (fn) (setq fn (eqcar x (quote or))) ( 1978cond ((eq fn neg) (prog nil lab1146 (cond ((null (setq x (cdr x))) (return 1979nil))) (s!:jumpif fn (car x) env lab) (go lab1146))) (t (progn (setq neg ( 1980gensym)) (prog nil lab1147 (cond ((null (setq x (cdr x))) (return nil))) ( 1981s!:jumpif fn (car x) env neg) (go lab1147)) (s!:outjump (quote JUMP) lab) ( 1982s!:set_label neg)))))) 1983 1984(put (quote and) (quote s!:testfn) (function s!:combool)) 1985 1986(put (quote or) (quote s!:testfn) (function s!:combool)) 1987 1988(de s!:testeq (neg x env lab) (prog (a b) (setq a (s!:improve (cadr x))) ( 1989setq b (s!:improve (caddr x))) (cond ((or (s!:eval_to_eq_unsafe a) ( 1990s!:eval_to_eq_unsafe b)) (progn (cond ((neq (posn) 0) (terpri))) (princ 1991"++++ EQ on number upgraded to EQUAL in ") (prin s!:current_function) (princ 1992" : ") (prin a) (princ " ") (print b) (return (s!:testequal neg (cons (quote 1993equal) (cdr x)) env lab))))) (cond ((null a) (s!:jumpif (not neg) b env lab)) 1994(t (cond ((null b) (s!:jumpif (not neg) a env lab)) (t (cond ((or (eqcar a ( 1995quote quote)) (and (atom a) (not (symbolp a)))) (progn (s!:comval b env 1) ( 1996cond ((eqcar a (quote quote)) (setq a (cadr a)))) (setq b (list (cond (neg ( 1997quote JUMPLITEQ)) (t (quote JUMPLITNE))) a a)) (s!:record_literal_for_jump b 1998env lab))) (t (cond ((or (eqcar b (quote quote)) (and (atom b) (not (symbolp 1999b)))) (progn (s!:comval a env 1) (cond ((eqcar b (quote quote)) (setq b (cadr 2000b)))) (setq a (list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) b b 2001)) (s!:record_literal_for_jump a env lab))) (t (progn (s!:load2 a b env) ( 2002cond (neg (s!:outjump (quote JUMPEQ) lab)) (t (s!:outjump (quote JUMPNE) lab) 2003))))))))))))) 2004 2005(de s!:testeq1 (neg x env lab) (prog (a b) (setq a (s!:improve (cadr x))) ( 2006setq b (s!:improve (caddr x))) (cond ((null a) (s!:jumpif (not neg) b env lab 2007)) (t (cond ((null b) (s!:jumpif (not neg) a env lab)) (t (cond ((or (eqcar a 2008(quote quote)) (and (atom a) (not (symbolp a)))) (progn (s!:comval b env 1) 2009(cond ((eqcar a (quote quote)) (setq a (cadr a)))) (setq b (list (cond (neg ( 2010quote JUMPLITEQ)) (t (quote JUMPLITNE))) a a)) (s!:record_literal_for_jump b 2011env lab))) (t (cond ((or (eqcar b (quote quote)) (and (atom b) (not (symbolp 2012b)))) (progn (s!:comval a env 1) (cond ((eqcar b (quote quote)) (setq b (cadr 2013b)))) (setq a (list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) b b 2014)) (s!:record_literal_for_jump a env lab))) (t (progn (s!:load2 a b env) ( 2015cond (neg (s!:outjump (quote JUMPEQ) lab)) (t (s!:outjump (quote JUMPNE) lab) 2016))))))))))))) 2017 2018(put (quote eq) (quote s!:testfn) (function s!:testeq)) 2019 2020(cond ((eq!-safe 0) (put (quote iequal) (quote s!:testfn) (function 2021s!:testeq1))) (t (put (quote iequal) (quote s!:testfn) (function s!:testequal 2022)))) 2023 2024(de s!:testequal (neg x env lab) (prog (a b) (setq a (cadr x)) (setq b (caddr 2025x)) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b) ( 2026s!:jumpif (not neg) a env lab)) (t (cond ((or (and (eqcar a (quote quote)) ( 2027or (symbolp (cadr a)) (eq!-safe (cadr a)))) (and (eqcar b (quote quote)) (or 2028(symbolp (cadr b)) (eq!-safe (cadr b)))) (and (not (idp a)) (eq!-safe a)) ( 2029and (not (idp b)) (eq!-safe b))) (s!:testeq1 neg (cons (quote eq) (cdr x)) 2030env lab)) (t (progn (s!:load2 a b env) (cond (neg (s!:outjump (quote 2031JUMPEQUAL) lab)) (t (s!:outjump (quote JUMPNEQUAL) lab)))))))))))) 2032 2033(put (quote equal) (quote s!:testfn) (function s!:testequal)) 2034 2035(de s!:testneq (neg x env lab) (s!:testequal (not neg) (cons (quote equal) ( 2036cdr x)) env lab)) 2037 2038(put (quote neq) (quote s!:testfn) (function s!:testneq)) 2039 2040(de s!:testeqcar (neg x env lab) (prog (a b sw promote) (setq a (cadr x)) ( 2041setq b (s!:improve (caddr x))) (cond ((s!:eval_to_eq_unsafe b) (progn (cond ( 2042(neq (posn) 0) (terpri))) (princ 2043"++++ EQCAR on number upgraded to EQUALCAR in ") (prin s!:current_function) ( 2044princ " : ") (print b) (setq promote t)))) (cond ((and (not promote) (eqcar b 2045(quote quote))) (progn (s!:comval a env 1) (setq b (cadr b)) (setq a (list ( 2046cond (neg (quote JUMPEQCAR)) (t (quote JUMPNEQCAR))) b b)) ( 2047s!:record_literal_for_jump a env lab))) (t (cond ((or (equal b nil) (equal b 2048t) (and (not (symbolp b)) (eq!-safe b))) (progn (s!:comval a env 1) (setq a ( 2049list (cond (neg (quote JUMPEQCAR)) (t (quote JUMPNEQCAR))) b b)) ( 2050s!:record_literal_for_jump a env lab))) (t (progn (setq sw (s!:load2 a b env) 2051) (cond (sw (s!:outopcode0 (quote SWOP) (quote (SWOP))))) (cond (promote ( 2052s!:outopcode1 (quote BUILTIN2) (get (quote equalcar) (quote s!:builtin2)) ( 2053quote equalcar))) (t (s!:outopcode0 (quote EQCAR) (quote (EQCAR))))) ( 2054s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab)))))))) 2055 2056(put (quote eqcar) (quote s!:testfn) (function s!:testeqcar)) 2057 2058(de s!:testflagp (neg x env lab) (prog (a b sw) (setq a (cadr x)) (setq b ( 2059caddr x)) (cond ((eqcar b (quote quote)) (progn (s!:comval a env 1) (setq b ( 2060cadr b)) (setq sw (symbol!-make!-fastget b nil)) (cond (sw (progn ( 2061s!:outopcode1 (quote FASTGET) (logor sw 128) b) (s!:outjump (cond (neg (quote 2062JUMPT)) (t (quote JUMPNIL))) lab))) (t (progn (setq a (list (cond (neg ( 2063quote JUMPFLAGP)) (t (quote JUMPNFLAGP))) b b)) (s!:record_literal_for_jump a 2064env lab)))))) (t (progn (setq sw (s!:load2 a b env)) (cond (sw ( 2065s!:outopcode0 (quote SWOP) (quote (SWOP))))) (s!:outopcode0 (quote FLAGP) ( 2066quote (FLAGP))) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) 2067lab)))))) 2068 2069(put (quote flagp) (quote s!:testfn) (function s!:testflagp)) 2070 2071(global (quote (s!:storelocs))) 2072 2073(setq s!:storelocs (s!:vecof (quote (STORELOC0 STORELOC1 STORELOC2 STORELOC3 2074STORELOC4 STORELOC5 STORELOC6 STORELOC7)))) 2075 2076(de s!:comsetq (x env context) (prog (n w var) (setq x (cdr x)) (cond ((null 2077x) (return nil))) (cond ((or (not (symbolp (car x))) (null (cdr x))) (return 2078(error 0 (list "bad args for setq" x))))) (s!:comval (cadr x) env 1) (setq 2079var (car x)) (setq n 0) (setq w (cdr env)) (prog nil lab1148 (cond ((null ( 2080and w (not (eqcar w var)))) (return nil))) (progn (setq n (add1 n)) (setq w ( 2081cdr w))) (go lab1148)) (cond (w (progn (cond ((not (member!*!* (cons (quote 2082loc) w) s!:a_reg_values)) (setq s!:a_reg_values (cons (cons (quote loc) w) 2083s!:a_reg_values)))) (cond ((lessp n 8) (s!:outopcode0 (getv s!:storelocs n) ( 2084list (quote storeloc) var))) (t (cond ((greaterp n 4095) (error 0 2085"stack frame > 4095")) (t (cond ((greaterp n 255) (s!:outopcode2 (quote 2086BIGSTACK) (plus 64 (truncate n 256)) (logand n 255) (list (quote STORELOC) 2087var))) (t (s!:outopcode1 (quote STORELOC) n var))))))))) (t (cond ((setq w ( 2088s!:find_lexical var s!:lexical_env 0)) (progn (cond ((not (member!*!* (cons ( 2089quote lex) w) s!:a_reg_values)) (setq s!:a_reg_values (cons (cons (quote lex) 2090w) s!:a_reg_values)))) (s!:outlexref (quote STORELEX) (length (cdr env)) ( 2091car w) (cadr w) var))) (t (progn (cond ((or (null var) (eq var t)) (error 0 ( 2092list "bad variable in setq" var))) (t (s!:should_be_fluid var))) (setq w ( 2093cons (quote free) var)) (cond ((not (member!*!* w s!:a_reg_values)) (setq 2094s!:a_reg_values (cons w s!:a_reg_values)))) (s!:outopcode1lit (quote 2095STOREFREE) var env)))))) (cond ((cddr x) (return (s!:comsetq (cdr x) env 2096context)))))) 2097 2098(put (quote setq) (quote s!:compfn) (function s!:comsetq)) 2099 2100(put (quote noisy!-setq) (quote s!:compfn) (function s!:comsetq)) 2101 2102(de s!:comlist (x env context) (prog (w) (cond ((null (setq x (cdr x))) ( 2103return (s!:comval nil env context)))) (setq s!:a_reg_values nil) (cond ((null 2104(setq w (cdr x))) (s!:comval (list (quote ncons) (car x)) env context)) (t ( 2105cond ((null (setq w (cdr w))) (s!:comval (list (quote list2) (car x) (cadr x) 2106) env context)) (t (cond ((null (cdr w)) (s!:comval (list (quote list3) (car 2107x) (cadr x) (car w)) env context)) (t (s!:comlonglist x env context))))))))) 2108 2109(de s!:comlonglist (x env context) (prog nil (s!:comval (list (quote list3rev 2110) (car x) (cadr x) (caddr x)) env 1) (setq x (cdddr x)) (rplacd env (cons 0 ( 2111cdr env))) (prog nil lab1149 (cond ((null (and (cdr x) (cddr x))) (return nil 2112))) (progn (setq s!:a_reg_values nil) (s!:outopcode0 (quote PUSH) (quote ( 2113PUSHA3))) (cond ((s!:load2 (car x) (cadr x) env) (s!:outopcode0 (quote SWOP) 2114(quote (SWOP))))) (s!:outopcode1lit (quote CALL3) (quote list2!*rev) env) ( 2115setq x (cddr x))) (go lab1149)) (s!:outopcode0 (quote PUSH) (quote (PUSH))) ( 2116cond ((null (cdr x)) (progn (s!:comval (car x) env 1) (s!:outopcode0 (quote 2117POP) (quote (POP))) (s!:outopcode1lit (quote CALL2) (quote nrevlist) env))) ( 2118t (progn (cond ((s!:load2 (car x) (cadr x) env) (s!:outopcode0 (quote SWOP) ( 2119quote (SWOP))))) (s!:outopcode1lit (quote CALL3) (quote nrevlist) env)))) ( 2120rplacd env (cddr env)))) 2121 2122(put (quote list) (quote s!:compfn) (function s!:comlist)) 2123 2124(de s!:comlist!* (x env context) (prog (w) (cond ((null (setq x (cdr x))) ( 2125return (s!:comval nil env context)))) (setq s!:a_reg_values nil) (cond ((null 2126(setq w (cdr x))) (s!:comval (car x) env context)) (t (cond ((null (setq w ( 2127cdr w))) (s!:comval (list (quote cons) (car x) (cadr x)) env context)) (t ( 2128cond ((null (cdr w)) (s!:comval (list (quote list2!*) (car x) (cadr x) (car w 2129)) env context)) (t (s!:comval (list (quote list2!*) (car x) (cadr x) (cons ( 2130quote list!*) w)) env context))))))))) 2131 2132(put (quote list!*) (quote s!:compfn) (function s!:comlist!*)) 2133 2134(de s!:comcons (x env context) (prog (a b) (setq a (cadr x)) (setq b (caddr x 2135)) (cond ((or (equal b nil) (equal b (quote (quote nil)))) (s!:comval (list ( 2136quote ncons) a) env context)) (t (cond ((eqcar a (quote cons)) (s!:comval ( 2137list (quote acons) (cadr a) (caddr a) b) env context)) (t (cond ((eqcar b ( 2138quote cons)) (cond ((null (caddr b)) (s!:comval (list (quote list2) a (cadr b 2139)) env context)) (t (s!:comval (list (quote list2!*) a (cadr b) (caddr b)) 2140env context)))) (t (cond ((and (not !*ord) (s!:iseasy a) (not (s!:iseasy b))) 2141(s!:comval (list (quote xcons) b a) env context)) (t (s!:comcall x env 2142context))))))))))) 2143 2144(put (quote cons) (quote s!:compfn) (function s!:comcons)) 2145 2146(de s!:commv!-call (x env context) (prog (fn args) (setq fn (cadr x)) (setq 2147args (prog (var1151 var1152) (setq var1151 (cddr x)) lab1150 (cond ((null 2148var1151) (return (reversip var1152)))) (prog (v) (setq v (car var1151)) (setq 2149var1152 (cons (list (quote mv!-list!*) v) var1152))) (setq var1151 (cdr 2150var1151)) (go lab1150))) (setq args (expand args (quote append))) (cond ((not 2151(equal fn (quote (function list)))) (setq args (list (quote apply) fn args)) 2152)) (s!:comval args env context))) 2153 2154(put (quote multiple!-value!-call) (quote s!:compfn) (function s!:commv!-call 2155)) 2156 2157(de s!:commv!-prog1 (x env context) (prog nil (setq x (cdr x)) (cond ((null x 2158) (return (s!:comval nil env context))) (t (cond ((null (cdr x)) (return ( 2159s!:comval (car x) env context)))))) (s!:comval (list (quote mv!-list!*) (car 2160x)) env context) (s!:outopcode0 (quote PUSH) (quote (PUSH))) (rplacd env ( 2161cons 0 (cdr env))) (prog (var1154) (setq var1154 x) lab1153 (cond ((null 2162var1154) (return nil))) (prog (a) (setq a (car var1154)) (s!:comval a env ( 2163cond ((geq context 4) context) (t 2)))) (setq var1154 (cdr var1154)) (go 2164lab1153)) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd env (cddr env)) ( 2165s!:loadliteral (quote values) env) (s!:outopcode1 (quote BUILTIN2) (get ( 2166quote apply1) (quote s!:builtin2)) (quote apply1)))) 2167 2168(put (quote multiple!-value!-prog1) (quote s!:compfn) (function 2169s!:commv!-prog1)) 2170 2171(de s!:comapply (x env context) (prog (a b n) (setq a (cadr x)) (setq b ( 2172caddr x)) (cond ((and (null (cdddr x)) (eqcar b (quote list))) (progn (cond ( 2173(eqcar a (quote quote)) (return (progn (setq n s!:current_function) (prog ( 2174s!:current_function) (setq s!:current_function (compress (append (explode n) 2175(cons (quote !!) (cons (quote !.) (explodec (setq s!:current_count (plus 2176s!:current_count 1)))))))) (return (s!:comval (cons (cadr a) (cdr b)) env 2177context))))))) (setq n (length (setq b (cdr b)))) (return (s!:comval (cons ( 2178quote funcall) (cons a b)) env context)))) (t (cond ((and (null b) (null ( 2179cdddr x))) (return (s!:comval (list (quote funcall) a) env context))) (t ( 2180return (s!:comcall x env context)))))))) 2181 2182(put (quote apply) (quote s!:compfn) (function s!:comapply)) 2183 2184(de s!:imp_funcall (u) (prog (n) (setq u (cdr u)) (cond ((eqcar (car u) ( 2185quote function)) (return (s!:improve (cons (cadar u) (cdr u)))))) (setq n ( 2186length (cdr u))) (setq u (cond ((equal n 0) (cons (quote apply0) u)) (t (cond 2187((equal n 1) (cons (quote apply1) u)) (t (cond ((equal n 2) (cons (quote 2188apply2) u)) (t (cond ((equal n 3) (cons (quote apply3) u)) (t (cond ((equal n 21894) (cons (quote apply4) u)) (t (cons (quote funcall) u)))))))))))) (return u 2190))) 2191 2192(put (quote funcall) (quote s!:tidy_fn) (quote s!:imp_funcall)) 2193 2194(de s!:eval_to_eq_safe (x) (or (equal x nil) (equal x t) (and (not (symbolp x 2195)) (eq!-safe x)) (and (not (atom x)) (flagp (car x) (quote eq!-safe))) (and ( 2196eqcar x (quote quote)) (or (symbolp (cadr x)) (eq!-safe (cadr x)))))) 2197 2198(de s!:eval_to_eq_unsafe (x) (or (and (atom x) (not (symbolp x)) (not ( 2199eq!-safe x))) (and (not (atom x)) (flagp (car x) (quote eq!-unsafe))) (and ( 2200eqcar x (quote quote)) (or (not (atom (cadr x))) (and (not (symbolp (cadr x)) 2201) (not (eq!-safe (cadr x)))))))) 2202 2203(de s!:list_all_eq_safe (u) (or (atom u) (and (or (symbolp (car u)) (eq!-safe 2204(car u))) (s!:list_all_eq_safe (cdr u))))) 2205 2206(de s!:eval_to_list_all_eq_safe (x) (or (null x) (and (eqcar x (quote quote)) 2207(s!:list_all_eq_safe (cadr x))) (and (eqcar x (quote list)) (or (null (cdr x 2208)) (and (s!:eval_to_eq_safe (cadr x)) (s!:eval_to_list_all_eq_safe (cons ( 2209quote list) (cddr x)))))) (and (eqcar x (quote cons)) (s!:eval_to_eq_safe ( 2210cadr x)) (s!:eval_to_list_all_eq_safe (caddr x))))) 2211 2212(de s!:list_some_eq_unsafe (u) (and (not (atom u)) (or (s!:eval_to_eq_unsafe 2213(car u)) (s!:list_some_eq_unsafe (cdr u))))) 2214 2215(de s!:eval_to_list_some_eq_unsafe (x) (cond ((atom x) nil) (t (cond ((eqcar 2216x (quote quote)) (s!:list_some_eq_unsafe (cadr x))) (t (cond ((and (eqcar x ( 2217quote list)) (cdr x)) (or (s!:eval_to_eq_unsafe (cadr x)) ( 2218s!:eval_to_list_some_eq_unsafe (cons (quote list) (cddr x))))) (t (cond (( 2219eqcar x (quote cons)) (or (s!:eval_to_eq_unsafe (cadr x)) ( 2220s!:eval_to_list_some_eq_unsafe (caddr x)))) (t nil))))))))) 2221 2222(de s!:eval_to_car_eq_safe (x) (and (or (eqcar x (quote cons)) (eqcar x ( 2223quote list))) (not (null (cdr x))) (s!:eval_to_eq_safe (cadr x)))) 2224 2225(de s!:eval_to_car_eq_unsafe (x) (and (or (eqcar x (quote cons)) (eqcar x ( 2226quote list))) (not (null (cdr x))) (s!:eval_to_eq_unsafe (cadr x)))) 2227 2228(de s!:alist_eq_safe (u) (or (atom u) (and (not (atom (car u))) (or (symbolp 2229(caar u)) (eq!-safe (caar u))) (s!:alist_eq_safe (cdr u))))) 2230 2231(de s!:eval_to_alist_eq_safe (x) (or (null x) (and (eqcar x (quote quote)) ( 2232s!:alist_eq_safe (cadr x))) (and (eqcar x (quote list)) (or (null (cdr x)) ( 2233and (s!:eval_to_car_eq_safe (cadr x)) (s!:eval_to_alist_eq_safe (cons (quote 2234list) (cddr x)))))) (and (eqcar x (quote cons)) (s!:eval_to_car_eq_safe (cadr 2235x)) (s!:eval_to_alist_eq_safe (caddr x))))) 2236 2237(de s!:alist_eq_unsafe (u) (and (not (atom u)) (not (atom (car u))) (or (not 2238(atom (caar u))) (and (not (symbolp (caar u))) (not (eq!-safe (caar u)))) ( 2239s!:alist_eq_unsafe (cdr u))))) 2240 2241(de s!:eval_to_alist_eq_unsafe (x) (cond ((null x) nil) (t (cond ((eqcar x ( 2242quote quote)) (s!:alist_eq_unsafe (cadr x))) (t (cond ((eqcar x (quote list)) 2243(and (cdr x) (or (s!:eval_to_car_eq_unsafe (cadr x)) ( 2244s!:eval_to_alist_eq_unsafe (cons (quote list) (cddr x)))))) (t (cond ((eqcar 2245x (quote cons)) (or (s!:eval_to_car_eq_unsafe (cadr x)) ( 2246s!:eval_to_alist_eq_safe (caddr x)))) (t nil))))))))) 2247 2248(flag (quote (eq eqcar null not greaterp lessp geq leq minusp atom numberp 2249consp)) (quote eq!-safe)) 2250 2251(cond ((not (eq!-safe 1)) (flag (quote (length plus minus difference times 2252quotient plus2 times2 expt fix float)) (quote eq!-unsafe)))) 2253 2254(de s!:comequal (x env context) (cond ((or (s!:eval_to_eq_safe (cadr x)) ( 2255s!:eval_to_eq_safe (caddr x))) (s!:comcall (cons (quote eq) (cdr x)) env 2256context)) (t (s!:comcall x env context)))) 2257 2258(put (quote equal) (quote s!:compfn) (function s!:comequal)) 2259 2260(de s!:comeq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( 2261s!:eval_to_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) (terpri))) ( 2262princ "++++ EQ on number upgraded to EQUAL in ") (prin s!:current_function) ( 2263princ " : ") (prin (cadr x)) (princ " ") (print (caddr x)) (s!:comcall (cons 2264(quote equal) (cdr x)) env context))) (t (s!:comcall x env context)))) 2265 2266(put (quote eq) (quote s!:compfn) (function s!:comeq)) 2267 2268(de s!:comeqcar (x env context) (cond ((s!:eval_to_eq_unsafe (caddr x)) ( 2269progn (cond ((neq (posn) 0) (terpri))) (princ 2270"++++ EQCAR on number upgraded to EQUALCAR in ") (prin s!:current_function) ( 2271princ " : ") (prin (caddr x)) (s!:comcall (cons (quote equalcar) (cdr x)) env 2272context))) (t (s!:comcall x env context)))) 2273 2274(put (quote eqcar) (quote s!:compfn) (function s!:comeqcar)) 2275 2276(de s!:comsublis (x env context) (cond ((s!:eval_to_alist_eq_safe (cadr x)) ( 2277s!:comval (cons (quote subla) (cdr x)) env context)) (t (s!:comcall x env 2278context)))) 2279 2280(put (quote sublis) (quote s!:compfn) (function s!:comsublis)) 2281 2282(de s!:comsubla (x env context) (cond ((s!:eval_to_alist_eq_unsafe (cadr x)) 2283(progn (cond ((neq (posn) 0) (terpri))) (princ 2284"++++ SUBLA on number upgraded to SUBLIS in ") (prin s!:current_function) ( 2285princ " : ") (print (cadr x)) (s!:comval (cons (quote sublis) (cdr x)) env 2286context))) (t (s!:comcall x env context)))) 2287 2288(put (quote subla) (quote s!:compfn) (function s!:comsubla)) 2289 2290(de s!:comassoc (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x)) 2291(s!:eval_to_alist_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval (cons 2292(quote atsoc) (cdr x)) env context)) (t (cond ((equal (length x) 3) ( 2293s!:comcall (cons (quote assoc!*!*) (cdr x)) env context)) (t (s!:comcall x 2294env context)))))) 2295 2296(put (quote assoc) (quote s!:compfn) (function s!:comassoc)) 2297 2298(put (quote assoc!*!*) (quote s!:compfn) (function s!:comassoc)) 2299 2300(de s!:comatsoc (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( 2301s!:eval_to_alist_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) (terpri)) 2302) (princ "++++ ATSOC on number upgraded to ASSOC in ") (prin 2303s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr 2304x)) (s!:comval (cons (quote assoc) (cdr x)) env context))) (t (s!:comcall x 2305env context)))) 2306 2307(put (quote atsoc) (quote s!:compfn) (function s!:comatsoc)) 2308 2309(de s!:commember (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x) 2310) (s!:eval_to_list_all_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval ( 2311cons (quote memq) (cdr x)) env context)) (t (s!:comcall x env context)))) 2312 2313(put (quote member) (quote s!:compfn) (function s!:commember)) 2314 2315(put (quote member!*!*) (quote s!:compfn) (function s!:commember)) 2316 2317(de s!:commemq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( 2318s!:eval_to_list_some_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) ( 2319terpri))) (princ "++++ MEMQ on number upgraded to MEMBER in ") (prin 2320s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr 2321x)) (s!:comval (cons (quote member) (cdr x)) env context))) (t (s!:comcall x 2322env context)))) 2323 2324(put (quote memq) (quote s!:compfn) (function s!:commemq)) 2325 2326(de s!:comdelete (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x) 2327) (s!:eval_to_list_all_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval ( 2328cons (quote deleq) (cdr x)) env context)) (t (s!:comcall x env context)))) 2329 2330(put (quote delete) (quote s!:compfn) (function s!:comdelete)) 2331 2332(de s!:comdeleq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( 2333s!:eval_to_list_some_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) ( 2334terpri))) (princ "++++ DELEQ on number upgraded to DELETE in ") (prin 2335s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr 2336x)) (s!:comval (cons (quote delete) (cdr x)) env context))) (t (s!:comcall x 2337env context)))) 2338 2339(put (quote deleq) (quote s!:compfn) (function s!:comdeleq)) 2340 2341(de s!:commap (fnargs env context) (prog (carp fn fn1 args var avar moveon l1 2342r s closed) (setq fn (car fnargs)) (cond ((greaterp context 1) (progn (cond 2343((equal fn (quote mapcar)) (setq fn (quote mapc))) (t (cond ((equal fn (quote 2344maplist)) (setq fn (quote map))))))))) (cond ((or (equal fn (quote mapc)) ( 2345equal fn (quote mapcar)) (equal fn (quote mapcan))) (setq carp t))) (setq 2346fnargs (cdr fnargs)) (cond ((atom fnargs) (error 0 2347"bad arguments to map function"))) (setq fn1 (cadr fnargs)) (prog nil lab1155 2348(cond ((null (or (eqcar fn1 (quote function)) (and (eqcar fn1 (quote quote)) 2349(eqcar (cadr fn1) (quote lambda))))) (return nil))) (progn (setq fn1 (cadr 2350fn1)) (setq closed t)) (go lab1155)) (setq args (car fnargs)) (setq l1 ( 2351gensym)) (setq r (gensym)) (setq s (gensym)) (setq var (gensym)) (setq avar 2352var) (cond (carp (setq avar (list (quote car) avar)))) (cond (closed (setq 2353fn1 (list fn1 avar))) (t (setq fn1 (list (quote funcall) fn1 avar)))) (setq 2354moveon (list (quote setq) var (list (quote cdr) var))) (cond ((or (equal fn ( 2355quote map)) (equal fn (quote mapc))) (setq fn (sublis (list (cons (quote l1) 2356l1) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) ( 2357cons (quote moveon) moveon)) (quote (prog (var) (setq var args) l1 (cond (( 2358not var) (return nil))) fn moveon (go l1)))))) (t (cond ((or (equal fn (quote 2359maplist)) (equal fn (quote mapcar))) (setq fn (sublis (list (cons (quote l1) 2360l1) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) ( 2361cons (quote moveon) moveon) (cons (quote r) r)) (quote (prog (var r) (setq 2362var args) l1 (cond ((not var) (return (reversip r)))) (setq r (cons fn r)) 2363moveon (go l1)))))) (t (setq fn (sublis (list (cons (quote l1) l1) (cons ( 2364quote l2) (gensym)) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote 2365args) args) (cons (quote moveon) moveon) (cons (quote r) (gensym)) (cons ( 2366quote s) (gensym))) (quote (prog (var r s) (setq var args) (setq r (setq s ( 2367list nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond (( 2368not (atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))))))))) ( 2369s!:comval fn env context))) 2370 2371(put (quote map) (quote s!:compfn) (function s!:commap)) 2372 2373(put (quote maplist) (quote s!:compfn) (function s!:commap)) 2374 2375(put (quote mapc) (quote s!:compfn) (function s!:commap)) 2376 2377(put (quote mapcar) (quote s!:compfn) (function s!:commap)) 2378 2379(put (quote mapcon) (quote s!:compfn) (function s!:commap)) 2380 2381(put (quote mapcan) (quote s!:compfn) (function s!:commap)) 2382 2383(de s!:nilargs (use) (cond ((null use) t) (t (cond ((or (equal (car use) ( 2384quote nil)) (equal (car use) (quote (quote nil)))) (s!:nilargs (cdr use))) (t 2385nil))))) 2386 2387(de s!:subargs (args use) (cond ((null use) t) (t (cond ((null args) ( 2388s!:nilargs use)) (t (cond ((not (equal (car args) (car use))) nil) (t ( 2389s!:subargs (cdr args) (cdr use))))))))) 2390 2391(fluid (quote (!*where_defined!*))) 2392 2393(de clear_source_database nil (progn (setq !*where_defined!* (mkhash (quote 2394equal))) nil)) 2395 2396(de load_source_database (filename) (prog (a b) (clear_source_database) (setq 2397a (open filename (quote input))) (cond ((null a) (return nil))) (setq a (rds 2398a)) (prog nil lab1156 (cond ((null (setq b (read))) (return nil))) (puthash 2399(car b) !*where_defined!* (cdr b)) (go lab1156)) (close (rds a)) (return nil) 2400)) 2401 2402(de save_source_database (filename) (prog (a) (setq a (open filename (quote 2403output))) (cond ((null a) (return nil))) (setq a (wrs a)) (prog (var1158) ( 2404setq var1158 (sort (hashcontents !*where_defined!*) (function orderp))) 2405lab1157 (cond ((null var1158) (return nil))) (prog (z) (setq z (car var1158)) 2406(progn (prin z) (terpri))) (setq var1158 (cdr var1158)) (go lab1157)) (princ 2407nil) (terpri) (wrs a) (setq !*where_defined!* nil) (return nil))) 2408 2409(de display_source_database nil (prog (w) (cond ((null !*where_defined!*) ( 2410return nil))) (setq w (hashcontents !*where_defined!*)) (setq w (sort w ( 2411function orderp))) (terpri) (prog (var1160) (setq var1160 w) lab1159 (cond (( 2412null var1160) (return nil))) (prog (x) (setq x (car var1160)) (progn (princ ( 2413car x)) (ttab 40) (prin (cdr x)) (terpri))) (setq var1160 (cdr var1160)) (go 2414lab1159)))) 2415 2416(fluid (quote (s!:r2i_simple_recurse s!:r2i_cons_recurse))) 2417 2418(de s!:r2i (name args body) (prog (lab v b1 s!:r2i_simple_recurse 2419s!:r2i_cons_recurse) (setq lab (gensym)) (setq v (list (gensym))) (setq b1 ( 2420s!:r2i1 name args body lab v)) (cond (s!:r2i_cons_recurse (progn (setq b1 ( 2421list (quote prog) v lab b1)) (return b1))) (t (cond (s!:r2i_simple_recurse ( 2422progn (setq v (list (gensym))) (setq b1 (s!:r2i2 name args body lab v)) (setq 2423b1 (list (quote prog) (cdr v) lab b1)) (return b1))) (t (return (s!:r2i3 2424name args body lab v)))))))) 2425 2426(de s!:r2i1 (name args body lab v) (cond ((or (null body) (equal body (quote 2427(progn)))) (list (quote return) (list (quote nreverse) (car v)))) (t (cond (( 2428and (eqcar body name) (equal (length (cdr body)) (length args))) (progn (setq 2429s!:r2i_simple_recurse t) (cons (quote progn) (append (s!:r2isteps args (cdr 2430body) v) (list (list (quote go) lab)))))) (t (cond ((eqcar body (quote cond)) 2431(cons (quote cond) (s!:r2icond name args (cdr body) lab v))) (t (cond (( 2432eqcar body (quote if)) (cons (quote if) (s!:r2iif name args (cdr body) lab v) 2433)) (t (cond ((eqcar body (quote when)) (cons (quote when) (s!:r2iwhen name 2434args (cdr body) lab v))) (t (cond ((eqcar body (quote cons)) (s!:r2icons name 2435args (cadr body) (caddr body) lab v)) (t (cond ((or (eqcar body (quote progn 2436)) (eqcar body (quote prog2))) (cons (quote progn) (s!:r2iprogn name args ( 2437cdr body) lab v))) (t (cond ((eqcar body (quote and)) (s!:r2i1 name args ( 2438s!:r2iand (cdr body)) lab v)) (t (cond ((eqcar body (quote or)) (s!:r2i1 name 2439args (s!:r2ior (cdr body)) lab v)) (t (list (quote return) (list (quote 2440nreverse) (car v) body))))))))))))))))))))) 2441 2442(de s!:r2iand (l) (cond ((null l) t) (t (cond ((null (cdr l)) (car l)) (t ( 2443list (quote cond) (list (car l) (s!:r2iand (cdr l))))))))) 2444 2445(de s!:r2ior (l) (cond ((null l) nil) (t (cons (quote cond) (prog (var1162 2446var1163) (setq var1162 l) lab1161 (cond ((null var1162) (return (reversip 2447var1163)))) (prog (x) (setq x (car var1162)) (setq var1163 (cons (list x) 2448var1163))) (setq var1162 (cdr var1162)) (go lab1161)))))) 2449 2450(de s!:r2icond (name args b lab v) (cond ((null b) (list (list t (list (quote 2451return) (list (quote nreverse) (car v)))))) (t (cond ((null (cdar b)) (progn 2452(cond ((null (cdr v)) (rplacd v (list (gensym))))) (cons (list (list (quote 2453setq) (cadr v) (caar b)) (list (quote return) (list (quote nreverse) (car v) 2454(cadr v)))) (s!:r2icond name args (cdr b) lab v)))) (t (cond ((eqcar (car b) 2455t) (list (cons t (s!:r2iprogn name args (cdar b) lab v)))) (t (cons (cons ( 2456caar b) (s!:r2iprogn name args (cdar b) lab v)) (s!:r2icond name args (cdr b) 2457lab v))))))))) 2458 2459(de s!:r2iif (name args b lab v) (cond ((null (cddr b)) (list (car b) ( 2460s!:r2i1 name args (cadr b) lab v))) (t (list (car b) (s!:r2i1 name args (cadr 2461b) lab v) (s!:r2i1 name args (caddr b) lab v))))) 2462 2463(de s!:r2iwhen (name args b lab v) (cons (car b) (s!:r2iprogn name args (cdr 2464b) lab v))) 2465 2466(de s!:r2iprogn (name args b lab v) (cond ((null (cdr b)) (list (s!:r2i1 name 2467args (car b) lab v))) (t (cons (car b) (s!:r2iprogn name args (cdr b) lab v) 2468)))) 2469 2470(de s!:r2icons (name args a d lab v) (cond ((eqcar d (quote cons)) ( 2471s!:r2icons2 name args a (cadr d) (caddr d) lab v)) (t (cond ((and (eqcar d 2472name) (equal (length (cdr d)) (length args))) (progn (setq 2473s!:r2i_cons_recurse t) (cons (quote progn) (cons (list (quote setq) (car v) ( 2474list (quote cons) a (car v))) (append (s!:r2isteps args (cdr d) v) (list ( 2475list (quote go) lab))))))) (t (list (quote return) (list (quote nreverse) ( 2476car v) (list (quote cons) a d)))))))) 2477 2478(de s!:r2icons2 (name args a ad dd lab v) (cond ((and (eqcar dd name) (equal 2479(length (cdr dd)) (length args))) (progn (setq s!:r2i_cons_recurse t) (cons ( 2480quote progn) (cons (list (quote setq) (car v) (list (quote cons) a (car v))) 2481(cons (list (quote setq) (car v) (list (quote cons) ad (car v))) (append ( 2482s!:r2isteps args (cdr dd) v) (list (list (quote go) lab)))))))) (t (list ( 2483quote return) (list (quote nreverse) (car v) (list (quote cons) a (list ( 2484quote cons) ad dd))))))) 2485 2486(de s!:r2isteps (vars vals v) (cond ((null vars) (cond ((null vals) nil) (t ( 2487error 0 "too many args in recursive call to self")))) (t (cond ((null vals) ( 2488error 0 "not enough args in recursive call to self")) (t (cond ((equal (car 2489vars) (car vals)) (s!:r2isteps (cdr vars) (cdr vals) v)) (t (cond (( 2490s!:r2i_safestep (car vars) (cdr vars) (cdr vals)) (cons (list (quote setq) ( 2491car vars) (car vals)) (s!:r2isteps (cdr vars) (cdr vals) v))) (t (prog (w) ( 2492cond ((null (cdr v)) (rplacd v (list (gensym))))) (setq v (cdr v)) (setq w ( 2493s!:r2isteps (cdr vars) (cdr vals) v)) (return (cons (list (quote setq) (car v 2494) (car vals)) (append w (list (list (quote setq) (car vars) (car v))))))))))) 2495))))) 2496 2497(de s!:r2i_safestep (x vars vals) (cond ((and (null vars) (null vals)) t) (t 2498(cond ((s!:r2i_dependson (car vals) x) nil) (t (s!:r2i_safestep x (cdr vars) 2499(cdr vals))))))) 2500 2501(de s!:r2i_dependson (e x) (cond ((equal e x) t) (t (cond ((or (atom e) ( 2502eqcar e (quote quote))) nil) (t (cond ((not (atom (car e))) t) (t (cond (( 2503flagp (car e) (quote s!:r2i_safe)) (s!:r2i_list_dependson (cdr e) x)) (t ( 2504cond ((or (fluidp x) (globalp x)) t) (t (cond ((or (flagp (car e) (quote 2505s!:r2i_unsafe)) (macro!-function (car e))) t) (t (s!:r2i_list_dependson (cdr 2506e) x)))))))))))))) 2507 2508(flag (quote (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr 2509cddar cdddr cons ncons rcons acons list list2 list3 list!* add1 sub1 plus 2510plus2 times times2 difference minus quotient append reverse nreverse null not 2511assoc atsoc member memq subst sublis subla pair prog1 prog2 progn)) (quote 2512s!:r2i_safe)) 2513 2514(flag (quote (cond if when case de defun dm defmacro prog let let!* flet and 2515or)) (quote s!:r2i_unsafe)) 2516 2517(de s!:r2i_list_dependson (l x) (cond ((null l) nil) (t (cond (( 2518s!:r2i_dependson (car l) x) t) (t (s!:r2i_list_dependson (cdr l) x)))))) 2519 2520(de s!:r2i2 (name args body lab v) (cond ((or (null body) (equal body (quote 2521(progn)))) (list (quote return) nil)) (t (cond ((and (eqcar body name) (equal 2522(length (cdr body)) (length args))) (progn (cons (quote progn) (append ( 2523s!:r2isteps args (cdr body) v) (list (list (quote go) lab)))))) (t (cond (( 2524eqcar body (quote cond)) (cons (quote cond) (s!:r2i2cond name args (cdr body) 2525lab v))) (t (cond ((eqcar body (quote if)) (cons (quote if) (s!:r2i2if name 2526args (cdr body) lab v))) (t (cond ((eqcar body (quote when)) (cons (quote 2527when) (s!:r2i2when name args (cdr body) lab v))) (t (cond ((or (eqcar body ( 2528quote progn)) (eqcar body (quote prog2))) (cons (quote progn) (s!:r2i2progn 2529name args (cdr body) lab v))) (t (cond ((eqcar body (quote and)) (s!:r2i2 2530name args (s!:r2iand (cdr body)) lab v)) (t (cond ((eqcar body (quote or)) ( 2531s!:r2i2 name args (s!:r2ior (cdr body)) lab v)) (t (list (quote return) body) 2532))))))))))))))))) 2533 2534(de s!:r2i2cond (name args b lab v) (cond ((null b) (list (list t (list ( 2535quote return) nil)))) (t (cond ((null (cdar b)) (progn (cond ((null (cdr v)) 2536(rplacd v (list (gensym))))) (cons (list (list (quote setq) (cadr v) (caar b) 2537) (list (quote return) (cadr v))) (s!:r2i2cond name args (cdr b) lab v)))) (t 2538(cond ((eqcar (car b) t) (list (cons t (s!:r2i2progn name args (cdar b) lab 2539v)))) (t (cons (cons (caar b) (s!:r2i2progn name args (cdar b) lab v)) ( 2540s!:r2i2cond name args (cdr b) lab v))))))))) 2541 2542(de s!:r2i2if (name args b lab v) (cond ((null (cddr b)) (list (car b) ( 2543s!:r2i2 name args (cadr b) lab v))) (t (list (car b) (s!:r2i2 name args (cadr 2544b) lab v) (s!:r2i2 name args (caddr b) lab v))))) 2545 2546(de s!:r2i2when (name args b lab v) (cons (car b) (s!:r2i2progn name args ( 2547cdr b) lab v))) 2548 2549(de s!:r2i2progn (name args b lab v) (cond ((null (cdr b)) (list (s!:r2i2 2550name args (car b) lab v))) (t (cons (car b) (s!:r2i2progn name args (cdr b) 2551lab v))))) 2552 2553(de s!:r2i3 (name args body lab v) (prog (v v1 v2 lab1 lab2 lab3 w P Q g R) ( 2554cond ((s!:any_fluid args) (return body))) (cond ((eqcar body (quote cond)) ( 2555progn (cond ((not (setq w (cdr body))) (return body))) (setq P (car w)) (setq 2556w (cdr w)) (cond ((null P) (return body))) (setq Q (cdr P)) (setq P (car P)) 2557(cond ((or (null Q) (cdr Q)) (return body))) (setq Q (car Q)) (cond ((or ( 2558null w) (cdr w)) (return body))) (setq w (car w)) (cond ((not (eqcar w t)) ( 2559return body))) (setq w (cdr w)) (cond ((or (not w) (cdr w)) (return body))) ( 2560setq w (car w)))) (t (cond ((eqcar body (quote if)) (progn (setq w (cdr body) 2561) (setq P (car w)) (setq w (cdr w)) (setq Q (car w)) (setq w (cdr w)) (cond ( 2562(null w) (return body))) (setq w (car w)))) (t (return body))))) (cond ((or ( 2563atom w) (atom (cdr w)) (atom (cddr w)) (cdddr w)) (return body))) (setq g ( 2564car w)) (setq R (cadr w)) (setq w (caddr w)) (cond ((not (atom g)) (return 2565body))) (cond ((member g (quote (and or progn prog1 prog2 cond if when))) ( 2566return body))) (cond ((not (eqcar w name)) (return body))) (setq w (cdr w)) ( 2567cond ((not (equal (length w) (length args))) (return body))) (setq v1 (gensym 2568)) (setq v2 (gensym)) (setq v (list v2)) (setq lab1 (gensym)) (setq lab2 ( 2569gensym)) (setq lab3 (gensym)) (setq w (s!:r2isteps args w v)) (setq w (list ( 2570quote prog) (cons v1 v) lab1 (list (quote cond) (list P (list (quote go) lab2 2571))) (list (quote setq) v1 (list (quote cons) R v1)) (cons (quote progn) w) ( 2572list (quote go) lab1) lab2 (list (quote setq) v2 Q) lab3 (list (quote cond) ( 2573list (list (quote null) v1) (list (quote return) v2))) (list (quote setq) v2 2574(list g (list (quote qcar) v1) v2)) (list (quote setq) v1 (list (quote qcdr) 2575v1)) (list (quote go) lab3))) (return w))) 2576 2577(de s!:any_fluid (l) (cond ((null l) nil) (t (cond ((fluidp (car l)) t) (t ( 2578s!:any_fluid (cdr l))))))) 2579 2580(de s!:compile1 (name args body s!:lexical_env) (prog (w aargs oargs oinit 2581restarg svars nargs nopts env fluids s!:current_function s!:current_label 2582s!:current_block s!:current_size s!:current_procedure s!:current_exitlab 2583s!:current_proglabels s!:other_defs local_decs s!:has_closure s!:local_macros 2584s!:recent_literals s!:a_reg_values w1 w2 s!:current_count s!:env_alist 2585s!:maybe_values checksum) (cond (s!:lexical_env (setq checksum 0)) (t (setq 2586checksum (md60 (cons name (cons args body)))))) (setq s!:current_function 2587name) (setq s!:current_count 0) (cond (!*where_defined!* (progn (setq w name) 2588(puthash w !*where_defined!* (where!-was!-that))))) (setq body ( 2589s!:find_local_decs body nil)) (setq local_decs (car body)) (setq body (cdr 2590body)) (cond ((atom body) (setq body nil)) (t (cond ((null (cdr body)) (setq 2591body (car body))) (t (setq body (cons (quote progn) body)))))) (setq nargs ( 2592setq nopts 0)) (prog nil lab1164 (cond ((null (and args (not (eqcar args ( 2593quote !&optional))) (not (eqcar args (quote !&rest))))) (return nil))) (progn 2594(cond ((or (equal (car args) (quote !&key)) (equal (car args) (quote !&aux)) 2595) (error 0 "&key/&aux"))) (setq aargs (cons (car args) aargs)) (setq nargs ( 2596plus nargs 1)) (setq args (cdr args))) (go lab1164)) (cond ((eqcar args ( 2597quote !&optional)) (progn (setq args (cdr args)) (prog nil lab1166 (cond (( 2598null (and args (not (eqcar args (quote !&rest))))) (return nil))) (progn ( 2599cond ((or (equal (car args) (quote !&key)) (equal (car args) (quote !&aux))) 2600(error 0 "&key/&aux"))) (setq w (car args)) (prog nil lab1165 (cond ((null ( 2601and (not (atom w)) (or (atom (cdr w)) (equal (cdr w) (quote (nil)))))) ( 2602return nil))) (setq w (car w)) (go lab1165)) (setq args (cdr args)) (setq 2603oargs (cons w oargs)) (setq nopts (plus nopts 1)) (cond ((atom w) (setq aargs 2604(cons w aargs))) (t (progn (setq oinit t) (setq aargs (cons (car w) aargs)) 2605(cond ((not (atom (cddr w))) (setq svars (cons (caddr w) svars)))))))) (go 2606lab1166))))) (cond ((eqcar args (quote !&rest)) (progn (setq w (cadr args)) ( 2607setq aargs (cons w aargs)) (setq restarg w) (setq args (cddr args)) (cond ( 2608args (error 0 "&rest arg not at end")))))) (setq args (reverse aargs)) (setq 2609oargs (reverse oargs)) (prog (var1168) (setq var1168 (append svars args)) 2610lab1167 (cond ((null var1168) (return nil))) (prog (v) (setq v (car var1168)) 2611(cond ((or (globalp v) (keywordp v)) (error 0 (list 2612"attempt to bind global or keyword" v))))) (setq var1168 (cdr var1168)) (go 2613lab1167)) (cond (oinit (return (s!:compile2 name nargs nopts args oargs 2614restarg body local_decs checksum)))) (setq w nil) (prog (var1170) (setq 2615var1170 args) lab1169 (cond ((null var1170) (return nil))) (prog (v) (setq v 2616(car var1170)) (setq w (s!:instate_local_decs v local_decs w))) (setq var1170 2617(cdr var1170)) (go lab1169)) (cond ((and !*r2i (null oargs) (null restarg)) 2618(setq body (s!:r2i name args body)))) (prog (v) (setq v args) lab1171 (cond ( 2619(null v) (return nil))) (progn (cond ((fluidp (car v)) (prog (g) (setq g ( 2620gensym)) (setq fluids (cons (cons (car v) g) fluids)) (rplaca v g))))) (setq 2621v (cdr v)) (go lab1171)) (cond (fluids (progn (setq body (list (list (quote 2622return) body))) (prog (var1173) (setq var1173 fluids) lab1172 (cond ((null 2623var1173) (return nil))) (prog (v) (setq v (car var1173)) (setq body (cons ( 2624list (quote setq) (car v) (cdr v)) body))) (setq var1173 (cdr var1173)) (go 2625lab1172)) (setq body (cons (quote prog) (cons (prog (var1175 var1176) (setq 2626var1175 fluids) lab1174 (cond ((null var1175) (return (reversip var1176)))) ( 2627prog (v) (setq v (car var1175)) (setq var1176 (cons (car v) var1176))) (setq 2628var1175 (cdr var1175)) (go lab1174)) body)))))) (setq env (cons (mkhash ( 2629quote equal)) (reverse args))) (puthash name (car env) (cons 10000000 nil)) ( 2630setq w (s!:residual_local_decs local_decs w)) (s!:start_procedure nargs nopts 2631restarg) (setq w1 body) more (cond ((atom w1) nil) (t (cond ((and (equal ( 2632car w1) (quote block)) (equal (length w1) 3)) (progn (setq w1 (caddr w1)) (go 2633more))) (t (cond ((and (equal (car w1) (quote progn)) (equal (length w1) 2)) 2634(progn (setq w1 (cadr w1)) (go more))) (t (cond ((and (atom (setq w2 (car w1 2635))) (setq w2 (get w2 (quote s!:newname)))) (progn (setq w1 (cons w2 (cdr w1)) 2636) (go more))) (t (cond ((and (atom (setq w2 (car w1))) (setq w2 ( 2637macro!-function w2))) (progn (setq w1 (funcall w2 w1)) (go more)))))))))))) ( 2638cond ((not (equal (setq w2 (s!:improve w1)) w1)) (progn (setq w1 w2) (go more 2639)))) (cond ((and (not (atom w1)) (atom (car w1)) (not (special!-form!-p (car 2640w1))) (s!:subargs args (cdr w1)) (leq nargs 3) (equal nopts 0) (not restarg) 2641(leq (length (cdr w1)) nargs)) (progn (s!:cancel_local_decs w) (cond (restarg 2642(setq nopts (plus nopts 512)))) (setq nopts (plus nopts (times 1024 (length 2643w1)))) (setq nargs (plus nargs (times 256 nopts))) (cond (!*pwrds (progn ( 2644cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin name) (princ 2645" compiled as link to ") (princ (car w1)) (terpri)))) (return (cons (cons 2646name (cons nargs (cons nil (car w1)))) s!:other_defs))))) (s!:comval body env 26470) (s!:cancel_local_decs w) (cond (restarg (setq nopts (plus nopts 512)))) ( 2648setq nargs (plus nargs (times 256 nopts))) (return (cons (cons name (cons 2649nargs (s!:endprocedure name env checksum))) s!:other_defs)))) 2650 2651(de s!:compile2 (name nargs nopts args oargs restarg body local_decs checksum 2652) (prog (fluids env penv g v init atend w) (prog (var1178) (setq var1178 args 2653) lab1177 (cond ((null var1178) (return nil))) (prog (v) (setq v (car var1178 2654)) (progn (setq env (cons 0 env)) (setq penv (cons env penv)))) (setq var1178 2655(cdr var1178)) (go lab1177)) (setq env (cons (mkhash (quote equal)) env)) ( 2656puthash name (car env) (cons 10000000 nil)) (setq penv (reversip penv)) (cond 2657(restarg (setq oargs (append oargs (quote (0)))))) (prog (i) (setq i 1) 2658lab1179 (cond ((minusp (times 1 (difference nargs i))) (return nil))) (setq 2659oargs (cons 0 oargs)) (setq i (plus i 1)) (go lab1179)) (s!:start_procedure 2660nargs nopts restarg) (prog nil lab1180 (cond ((null args) (return nil))) ( 2661progn (setq v (car args)) (setq init (car oargs)) (cond ((equal init 0) ( 2662progn (setq w (s!:instate_local_decs v local_decs w)) (cond ((fluidp v) ( 2663progn (setq g (gensym)) (rplaca (car penv) g) (s!:outopcode1lit (quote 2664FREEBIND) (s!:vecof (list v)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr 2665env))))) (setq atend (cons (quote FREERSTR) atend)) (s!:comval (list (quote 2666setq) v g) env 2))) (t (rplaca (car penv) v))))) (t (prog (ival sp l1 l2) ( 2667cond ((not (atom init)) (progn (setq init (cdr init)) (setq ival (car init)) 2668(cond ((not (atom (cdr init))) (setq sp (cadr init))))))) (setq l1 (gensym)) 2669(setq g (gensym)) (rplaca (car penv) g) (cond ((and (null ival) (null sp)) ( 2670s!:comval (list (quote setq) g (list (quote spid!-to!-nil) g)) env 1)) (t ( 2671progn (s!:jumpif nil (list (quote is!-spid) g) env l1) (s!:comval (list ( 2672quote setq) g ival) env 1) (cond (sp (progn (cond ((fluidp sp) (progn ( 2673s!:outopcode1lit (quote FREEBIND) (s!:vecof (list sp)) env) (s!:outjump ( 2674quote JUMP) (setq l2 (gensym))) (s!:set_label l1) (s!:outopcode1lit (quote 2675FREEBIND) (s!:vecof (list sp)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr 2676env))))) (s!:comval (list (quote setq) sp t) env 1) (s!:set_label l2) (setq 2677atend (cons (quote FREERSTR) atend)))) (t (progn (s!:outopcode0 (quote 2678PUSHNIL) (quote (PUSHNIL))) (s!:outjump (quote JUMP) (setq l2 (gensym))) ( 2679s!:set_label l1) (s!:loadliteral t env) (s!:outopcode0 (quote PUSH) (quote ( 2680PUSH))) (s!:set_label l2) (rplacd env (cons sp (cdr env))) (setq atend (cons 2681(quote LOSE) atend))))))) (t (s!:set_label l1)))))) (setq w ( 2682s!:instate_local_decs v local_decs w)) (cond ((fluidp v) (progn ( 2683s!:outopcode1lit (quote FREEBIND) (s!:vecof (list v)) env) (rplacd env (cons 26843 (cons 0 (cons 0 (cdr env))))) (s!:comval (list (quote setq) v g) env 1) ( 2685setq atend (cons (quote FREERSTR) atend)))) (t (rplaca (car penv) v)))))) ( 2686setq args (cdr args)) (setq oargs (cdr oargs)) (setq penv (cdr penv))) (go 2687lab1180)) (setq w (s!:residual_local_decs local_decs w)) (s!:comval body env 26880) (prog nil lab1181 (cond ((null atend) (return nil))) (progn (s!:outopcode0 2689(car atend) (list (car atend))) (setq atend (cdr atend))) (go lab1181)) ( 2690s!:cancel_local_decs w) (setq nopts (plus nopts 256)) (cond (restarg (setq 2691nopts (plus nopts 512)))) (setq nargs (plus nargs (times 256 nopts))) (return 2692(cons (cons name (cons nargs (s!:endprocedure name env checksum))) 2693s!:other_defs)))) 2694 2695(de compile!-all nil (prog (var1183) (setq var1183 (reverse (oblist))) 2696lab1182 (cond ((null var1183) (return nil))) (prog (x) (setq x (car var1183)) 2697(prog (w) (setq w (getd x)) (cond ((and (or (eqcar w (quote expr)) (eqcar w 2698(quote macro))) (eqcar (cdr w) (quote lambda))) (progn (princ "Compile: ") ( 2699prin x) (terpri) (errorset (list (quote compile) (mkquote (list x))) t t))))) 2700) (setq var1183 (cdr var1183)) (go lab1182))) 2701 2702(flag (quote (rds deflist flag fluid global keyword remprop remflag unfluid 2703unkeyword unglobal dm defmacro carcheck faslend c_end)) (quote eval)) 2704 2705(flag (quote (rds)) (quote ignore)) 2706 2707(fluid (quote (!*backtrace))) 2708 2709(de s!:fasl_supervisor nil (prog (u w !*echo) top (setq u (errorset (quote ( 2710read)) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond 2711((equal u !$eof!$) (return nil))) (cond ((not (atom u)) (setq u (macroexpand 2712u)))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote faslend)) (return ( 2713apply (quote faslend) nil))) (t (cond ((eqcar u (quote rdf)) (progn (setq w ( 2714open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (terpri) (princ 2715"Reading file ") (prin u) (terpri) (setq w (rds w)) (s!:fasl_supervisor) ( 2716princ "End of file ") (prin u) (terpri) (close (rds w)))) (t (progn (princ 2717"Failed to open file ") (prin u) (terpri)))))) (t (s!:fslout0 u))))))) (go 2718top))) 2719 2720(fluid (quote (s!:fasl_code s!:fasl_savedef))) 2721 2722(de s!:fslout0 (u) (s!:fslout1 u nil)) 2723 2724(de s!:fslout1 (u loadonly) (prog (w) (cond ((not (atom u)) (setq u ( 2725macroexpand u)))) (cond ((atom u) (return nil)) (t (cond ((eqcar u (quote 2726progn)) (progn (prog (var1185) (setq var1185 (cdr u)) lab1184 (cond ((null 2727var1185) (return nil))) (prog (v) (setq v (car var1185)) (s!:fslout1 v 2728loadonly)) (setq var1185 (cdr var1185)) (go lab1184)) (return nil))) (t (cond 2729((eqcar u (quote eval!-when)) (return (prog nil (setq w (cadr u)) (setq u ( 2730cons (quote progn) (cddr u))) (cond ((and (memq (quote compile) w) (not 2731loadonly)) (eval u))) (cond ((memq (quote load) w) (s!:fslout1 u t))) (return 2732nil)))) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) ( 2733quote setq)) (not (atom (caddr u))) (flagp (caaddr u) (quote eval)))) (cond ( 2734(not loadonly) (errorset u t !*backtrace))))))))))) (cond ((eqcar u (quote 2735rdf)) (prog nil (setq w (open (setq u (eval (cadr u))) (quote input))) (cond 2736(w (progn (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) ( 2737s!:fasl_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w))) 2738) (t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (cond ( 2739!*nocompile (progn (cond ((and (not (eqcar u (quote faslend))) (not (eqcar u 2740(quote carcheck)))) (setq s!:fasl_code (cons u s!:fasl_code)))))) (t (cond (( 2741or (eqcar u (quote de)) (eqcar u (quote defun))) (progn (setq u (cdr u)) ( 2742cond ((and (setq w (get (car u) (quote c!-version))) (equal w (md60 (cons ( 2743car u) (cons (cadr u) (s!:fully_macroexpand_list (cddr u))))))) (progn (cond 2744((not (zerop (posn))) (terpri))) (princ "+++ ") (prin (car u)) (printc 2745" not compiled (C++ version available)") (setq s!:fasl_code (cons (list ( 2746quote restore!-c!-code) (mkquote (car u))) s!:fasl_code)))) (t (cond ((flagp 2747(car u) (quote lose)) (progn (princ "+++ ") (prin (car u)) (printc 2748" not compiled (LOSE flag)"))) (t (progn (cond ((setq w (get (car u) (quote 2749c!-version))) (progn (princ "+++ ") (prin (car u)) (princ 2750" reports C version with checksum ") (print w) (print 2751"+++ differing from this version:") (setq w (cons (car u) (cons (cadr u) ( 2752s!:fully_macroexpand_list (cddr u))))) (princ "::: ") (prettyprint w) (princ 2753"+++ which has checksum ") (print (md60 w))))) (prog (var1187) (setq var1187 2754(s!:compile1 (car u) (cadr u) (cddr u) nil)) lab1186 (cond ((null var1187) ( 2755return nil))) (prog (p) (setq p (car var1187)) (s!:fslout2 p u)) (setq 2756var1187 (cdr var1187)) (go lab1186))))))))) (t (cond ((or (eqcar u (quote dm) 2757) (eqcar u (quote defmacro))) (prog (g) (setq g (hashtagged!-name (cadr u) ( 2758cddr u))) (setq u (cdr u)) (cond ((flagp (car u) (quote lose)) (progn (princ 2759"+++ ") (prin (car u)) (printc " not compiled (LOSE flag)") (return nil)))) ( 2760setq w (cadr u)) (cond ((and w (null (cdr w))) (setq w (cons (car w) (cons ( 2761quote !&optional) (cons (gensym) nil)))))) (prog (var1189) (setq var1189 ( 2762s!:compile1 g w (cddr u) nil)) lab1188 (cond ((null var1189) (return nil))) ( 2763prog (p) (setq p (car var1189)) (s!:fslout2 p u)) (setq var1189 (cdr var1189) 2764) (go lab1188)) (setq s!:fasl_code (cons (list (quote dm) (car u) (quote (u 2765!&optional e)) (list g (quote u) (quote e))) s!:fasl_code)))) (t (cond (( 2766eqcar u (quote putd)) (prog (a1 a2 a3) (setq a1 (cadr u)) (setq a2 (caddr u)) 2767(setq a3 (cadddr u)) (cond ((and (eqcar a1 (quote quote)) (or (equal a2 ( 2768quote (quote expr))) (equal a2 (quote (quote macro)))) (or (eqcar a3 (quote 2769quote)) (eqcar a3 (quote function))) (eqcar (cadr a3) (quote lambda))) (progn 2770(setq a1 (cadr a1)) (setq a2 (cadr a2)) (setq a3 (cadr a3)) (setq u (cons ( 2771cond ((equal a2 (quote expr)) (quote de)) (t (quote dm))) (cons a1 (cdr a3))) 2772) (s!:fslout1 u loadonly))) (t (setq s!:fasl_code (cons u s!:fasl_code)))))) 2773(t (cond ((and (not (eqcar u (quote faslend))) (not (eqcar u (quote carcheck) 2774))) (progn (setq s!:fasl_code (cons u s!:fasl_code)) (cond ((and !*savedef ( 2775eqcar u (quote put)) (not (atom (setq w (cdr u)))) (eqcar (car w) (quote 2776quote)) (not (atom (setq w (cdr w)))) (eqcar (car w) (quote quote)) (memq ( 2777cadar w) (quote (procedure_type defined!-in!-file defined!-on!-line))) (or ( 2778numberp (setq w (cadr w))) (eqcar w (quote quote)))) (setq s!:fasl_savedef ( 2779cons (list nil (cadar (setq u (cdr u))) (cadar (setq u (cdr u))) (cond (( 2780numberp w) w) (t (cadr w)))) s!:fasl_savedef))))))))))))))))))) 2781 2782(de s!:fslout2 (p u) (prog (name nargs code env w) (setq name (car p)) (setq 2783nargs (cadr p)) (setq code (caddr p)) (setq env (cdddr p)) (cond ((and 2784!*savedef (equal name (car u))) (progn (setq s!:fasl_savedef (cons (list name 2785(cons (quote lambda) (cons (cadr u) (s!:fully_macroexpand_list (cddr u))))) 2786s!:fasl_savedef))))) (setq s!:fasl_code (cons (list (quote 2787symbol!-set!-definition) (mkquote name) (mkquote (cons nargs (cons code env)) 2788)) s!:fasl_code)))) 2789 2790(remprop (quote faslend) (quote stat)) 2791 2792(de faslend nil (prog nil (cond ((null s!:faslmod_name) (return nil))) (cond 2793((not (start!-module (car s!:faslmod_name))) (progn (cond ((neq (posn) 0) ( 2794terpri))) (princ "+++ Failed to open FASL output file for ") (printc 2795s!:faslmod_name) (return nil)))) (write!-module (cons (quote progn) (nreverse 2796s!:fasl_code)) (nreverse s!:fasl_savedef)) (start!-module nil) (princ 2797"Completed FASL files for ") (print (car s!:faslmod_name)) (setq dfprint!* 2798s!:dfprintsave) (setq !*defn nil) (setq !*comp (cdr s!:faslmod_name)) (setq 2799s!:faslmod_name nil) (setq s!:fasl_code (setq s!:fasl_savedef nil)) (return 2800nil))) 2801 2802(put (quote faslend) (quote stat) (quote endstat)) 2803 2804(de s!:file (s) (prog (r) (setq s (reverse (explodec s))) (prog nil lab1190 ( 2805cond ((null (and s (not (or (eqcar s (quote !/)) (eqcar s (quote !\)))))) ( 2806return nil))) (progn (setq r (cons (car s) r)) (setq s (cdr s))) (go lab1190) 2807) (return (list2string r)))) 2808 2809(de s!:trim!.c (s) (prog (r) (setq s (reverse (explodec s))) (cond ((eqcar s 2810(quote c)) (progn (setq s (cdr s)) (cond ((eqcar s (quote !.)) (setq s (cdr s 2811))))))) (return (list2string (reverse s))))) 2812 2813(de s!:dir (s) (prog nil (setq s (reverse (explodec s))) (prog nil lab1191 ( 2814cond ((null (and s (not (or (eqcar s (quote !/)) (eqcar s (quote !\)))))) ( 2815return nil))) (setq s (cdr s)) (go lab1191)) (cond (s (setq s (cdr s)))) ( 2816cond ((null s) (return ".")) (t (return (list2string (reverse s))))))) 2817 2818(de faslout (u) (prog nil (terpri) (princ "FASLOUT ") (prin u) (princ 2819": IN files; or type in expressions") (terpri) (princ 2820"When all done, execute FASLEND;") (terpri) (cond ((not (atom u)) (setq u ( 2821car u)))) (setq s!:faslmod_name (cons u !*comp)) (setq s!:fasl_code (setq 2822s!:fasl_savedef nil)) (setq s!:dfprintsave dfprint!*) (setq dfprint!* (quote 2823s!:fslout0)) (setq !*defn t) (setq !*comp nil) (cond ((getd (quote begin)) ( 2824return nil))) (s!:fasl_supervisor))) 2825 2826(put (quote faslout) (quote stat) (quote rlis)) 2827 2828(de s!:c_supervisor nil (prog (u w !*echo) top (setq u (errorset (quote (read 2829)) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond (( 2830equal u !$eof!$) (return nil))) (cond ((not (atom u)) (setq u (macroexpand u) 2831))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote c_end)) (return ( 2832apply (quote c_end) nil))) (t (cond ((eqcar u (quote rdf)) (progn (setq w ( 2833open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (terpri) (princ 2834"Reading file ") (prin u) (terpri) (setq w (rds w)) (s!:c_supervisor) (princ 2835"End of file ") (prin u) (terpri) (close (rds w)))) (t (progn (princ 2836"Failed to open file ") (prin u) (terpri)))))) (t (s!:cout0 u))))))) (go top) 2837)) 2838 2839(de s!:cout0 (u) (s!:cout1 u nil)) 2840 2841(de s!:cout1 (u loadonly) (prog (s!:into_c) (setq s!:into_c t) (cond ((not ( 2842atom u)) (setq u (macroexpand u)))) (cond ((atom u) (return nil)) (t (cond (( 2843eqcar u (quote progn)) (progn (prog (var1193) (setq var1193 (cdr u)) lab1192 2844(cond ((null var1193) (return nil))) (prog (v) (setq v (car var1193)) ( 2845s!:cout1 v loadonly)) (setq var1193 (cdr var1193)) (go lab1192)) (return nil) 2846)) (t (cond ((eqcar u (quote eval!-when)) (return (prog (w) (setq w (cadr u)) 2847(setq u (cons (quote progn) (cddr u))) (cond ((and (memq (quote compile) w) 2848(not loadonly)) (eval u))) (cond ((memq (quote load) w) (s!:cout1 u t))) ( 2849return nil)))) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) 2850(quote setq)) (not (atom (caddr u))) (flagp (caaddr u) (quote eval)))) (cond 2851((not loadonly) (errorset u t !*backtrace))))))))))) (cond ((eqcar u (quote 2852rdf)) (prog (w) (setq w (open (setq u (eval (cadr u))) (quote input))) (cond 2853(w (progn (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) ( 2854s!:c_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w)))) ( 2855t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (cond ((or 2856(eqcar u (quote de)) (eqcar u (quote defun))) (prog (w) (setq u (cdr u)) ( 2857setq w (s!:compile1 (car u) (cadr u) (cddr u) nil)) (prog (var1195) (setq 2858var1195 w) lab1194 (cond ((null var1195) (return nil))) (prog (p) (setq p ( 2859car var1195)) (s!:cgen (car p) (cadr p) (caddr p) (cdddr p))) (setq var1195 ( 2860cdr var1195)) (go lab1194)))) (t (cond ((or (eqcar u (quote dm)) (eqcar u ( 2861quote defmacro))) (prog (w g) (setq g (hashtagged!-name (cadr u) (cddr u))) ( 2862setq u (cdr u)) (setq w (cadr u)) (cond ((and w (null (cdr w))) (setq w (cons 2863(car w) (cons (quote !&optional) (cons (gensym) nil)))))) (setq w ( 2864s!:compile1 g w (cddr u) nil)) (prog (var1197) (setq var1197 w) lab1196 (cond 2865((null var1197) (return nil))) (prog (p) (setq p (car var1197)) (s!:cgen ( 2866car p) (cadr p) (caddr p) (cdddr p))) (setq var1197 (cdr var1197)) (go 2867lab1196)) (s!:cinit (list (quote dm) (car u) (quote (u !&optional e)) (list g 2868(quote u) (quote e)))))) (t (cond ((eqcar u (quote putd)) (prog (a1 a2 a3) ( 2869setq a1 (cadr u)) (setq a2 (caddr u)) (setq a3 (cadddr u)) (cond ((and (eqcar 2870a1 (quote quote)) (or (equal a2 (quote (quote expr))) (equal a2 (quote ( 2871quote macro)))) (or (eqcar a3 (quote quote)) (eqcar a3 (quote function))) ( 2872eqcar (cadr a3) (quote lambda))) (progn (setq a1 (cadr a1)) (setq a2 (cadr a2 2873)) (setq a3 (cadr a3)) (setq u (cons (cond ((equal a2 (quote expr)) (quote de 2874)) (t (quote dm))) (cons a1 (cdr a3)))) (s!:cout1 u loadonly))) (t (s!:cinit 2875u))))) (t (cond ((and (not (eqcar u (quote c_end))) (not (eqcar u (quote 2876carcheck)))) (s!:cinit u))))))))))))) 2877 2878(fluid (quote (s!:cmod_name))) 2879 2880(de c_end nil (prog nil (cond ((null s!:cmod_name) (return nil))) (s!:cend) ( 2881setq dfprint!* s!:dfprintsave) (setq !*defn nil) (setq !*comp (cdr 2882s!:cmod_name)) (setq s!:cmod_name nil) (return nil))) 2883 2884(put (quote c_end) (quote stat) (quote endstat)) 2885 2886(de c_out (u) (prog nil (terpri) (princ "C_OUT ") (prin u) (princ 2887": IN files; or type in expressions") (terpri) (princ 2888"When all done, execute C_END;") (terpri) (cond ((not (atom u)) (setq u (car 2889u)))) (cond ((null (s!:cstart u)) (progn (cond ((neq (posn) 0) (terpri))) ( 2890princ "+++ Failed to open C output file") (terpri) (return nil)))) (setq 2891s!:cmod_name (cons u !*comp)) (setq s!:dfprintsave dfprint!*) (setq dfprint!* 2892(quote s!:cout0)) (setq !*defn t) (setq !*comp nil) (cond ((getd (quote 2893begin)) (return nil))) (s!:c_supervisor))) 2894 2895(put (quote c_out) (quote stat) (quote rlis)) 2896 2897(de s!:compile!-file!* (fromfile !&optional tofile verbose !*pwrds) (prog ( 2898!*comp w save) (cond ((null tofile) (setq tofile fromfile))) (cond (verbose ( 2899progn (cond ((neq (posn) 0) (terpri))) (princ "+++ Compiling file ") (prin 2900fromfile) (terpri) (setq save (verbos nil)) (verbos (ilogand save 4))))) ( 2901cond ((not (start!-module tofile)) (progn (cond ((neq (posn) 0) (terpri))) ( 2902princ "+++ Failed to open FASL output file") (terpri) (cond (save (verbos 2903save))) (return nil)))) (setq w (open fromfile (quote input))) (cond (w ( 2904progn (setq w (rds w)) (s!:fasl_supervisor) (close (rds w)))) (t (progn ( 2905princ "Failed to open file ") (prin fromfile) (terpri)))) (cond (save (verbos 2906save))) (start!-module nil) (cond (verbose (progn (cond ((neq (posn) 0) ( 2907terpri))) (princ "+++ Compilation complete") (terpri)))) (return t))) 2908 2909(de compile!-file!* (fromfile !&optional tofile) (s!:compile!-file!* fromfile 2910tofile t t)) 2911 2912(de compd (name type defn) (prog (g !*comp) (setq !*comp t) (cond ((eqcar 2913defn (quote lambda)) (progn (setq g (dated!-name type)) ( 2914symbol!-set!-definition g defn) (compile (list g)) (setq defn g)))) (put name 2915type defn) (return name))) 2916 2917(de s!:compile0 (name) (prog (w args defn) (setq defn (getd name)) (cond (( 2918and (eqcar defn (quote macro)) (eqcar (cdr defn) (quote lambda))) (prog ( 2919!*comp lx vx bx) (setq lx (cdr defn)) (cond ((not (or (and (equal (length lx) 29203) (not (atom (setq bx (caddr lx)))) (equal (cadr lx) (cdr bx))) (and (equal 2921(length lx) 3) (not (atom (setq bx (caddr lx)))) (not (atom (cadr lx))) ( 2922eqcar (cdadr lx) (quote !&optional)) (not (atom (setq bx (cdr bx)))) (equal ( 2923caadr lx) (car bx)) (equal (cddadr lx) (cdr bx))))) (progn (setq w ( 2924hashtagged!-name name defn)) (symbol!-set!-definition w (cdr defn)) ( 2925s!:compile0 w) (cond ((equal 1 (length (cadr lx))) (symbol!-set!-env name ( 2926list (quote (u !&optional env)) (list w (quote u))))) (t (symbol!-set!-env 2927name (list (quote (u !&optional env)) (list w (quote u) (quote env))))))))))) 2928(t (cond ((or (not (eqcar defn (quote expr))) (not (eqcar (cdr defn) (quote 2929lambda)))) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( 2930princ "+++ ") (prin name) (princ " not compilable") (terpri)))))) (t (progn ( 2931setq args (cddr defn)) (setq defn (cdr args)) (setq args (car args)) (cond (( 2932stringp args) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( 2933princ "+++ ") (prin name) (princ " was already compiled") (terpri)))))) (t ( 2934progn (cond (!*savedef (put name (quote !*savedef) (cons (quote lambda) (cons 2935args (s!:fully_macroexpand_list defn)))))) (setq w (s!:compile1 name args 2936defn nil)) (prog (var1199) (setq var1199 w) lab1198 (cond ((null var1199) ( 2937return nil))) (prog (p) (setq p (car var1199)) (symbol!-set!-definition (car 2938p) (cdr p))) (setq var1199 (cdr var1199)) (go lab1198)))))))))))) 2939 2940(de s!:fully_macroexpand_list (l) (cond ((atom l) l) (t (prog (var1201 2941var1202) (setq var1201 l) lab1200 (cond ((null var1201) (return (reversip 2942var1202)))) (prog (u) (setq u (car var1201)) (setq var1202 (cons ( 2943s!:fully_macroexpand u) var1202))) (setq var1201 (cdr var1201)) (go lab1200)) 2944))) 2945 2946(de s!:fully_macroexpand (x) (prog (helper) (cond ((or (atom x) (eqcar x ( 2947quote quote))) (return x)) (t (cond ((eqcar (car x) (quote lambda)) (return ( 2948cons (cons (quote lambda) (cons (cadar x) (s!:fully_macroexpand_list (cddar x 2949)))) (s!:fully_macroexpand_list (cdr x))))) (t (cond ((setq helper (get (car 2950x) (quote s!:newname))) (return (s!:fully_macroexpand (cons helper (cdr x)))) 2951) (t (cond ((setq helper (get (car x) (quote s!:expandfn))) (return (funcall 2952helper x))) (t (cond ((setq helper (macro!-function (car x))) (return ( 2953s!:fully_macroexpand (funcall helper x)))) (t (return (cons (car x) ( 2954s!:fully_macroexpand_list (cdr x)))))))))))))))) 2955 2956(de s!:expandfunction (u) u) 2957 2958(de s!:expandflet (u) (cons (car u) (cons (prog (var1204 var1205) (setq 2959var1204 (cadr u)) lab1203 (cond ((null var1204) (return (reversip var1205)))) 2960(prog (b) (setq b (car var1204)) (setq var1205 (cons (s!:expandfletvars b) 2961var1205))) (setq var1204 (cdr var1204)) (go lab1203)) ( 2962s!:fully_macroexpand_list (cddr u))))) 2963 2964(de s!:expandfletvars (b) (cons (car b) (cons (cadr b) ( 2965s!:fully_macroexpand_list (cddr b))))) 2966 2967(de s!:expandlabels (u) (s!:expandflet u)) 2968 2969(de s!:expandmacrolet (u) (s!:expandflet u)) 2970 2971(de s!:expandprog (u) (cons (car u) (cons (cadr u) (s!:fully_macroexpand_list 2972(cddr u))))) 2973 2974(de s!:expandtagbody (u) (s!:fully_macroexpand_list u)) 2975 2976(de s!:expandprogv (u) (cons (car u) (cons (cadr u) (cons (caddr u) ( 2977s!:fully_macroexpand_list (cadddr u)))))) 2978 2979(de s!:expandblock (u) (cons (car u) (cons (cadr u) ( 2980s!:fully_macroexpand_list (cddr u))))) 2981 2982(de s!:expanddeclare (u) u) 2983 2984(de s!:expandlet (u) (cons (car u) (cons (prog (var1207 var1208) (setq 2985var1207 (cadr u)) lab1206 (cond ((null var1207) (return (reversip var1208)))) 2986(prog (x) (setq x (car var1207)) (setq var1208 (cons ( 2987s!:fully_macroexpand_list x) var1208))) (setq var1207 (cdr var1207)) (go 2988lab1206)) (s!:fully_macroexpand_list (cddr u))))) 2989 2990(de s!:expandlet!* (u) (s!:expandlet u)) 2991 2992(de s!:expandgo (u) u) 2993 2994(de s!:expandreturn!-from (u) (cons (car u) (cons (cadr u) ( 2995s!:fully_macroexpand_list (cddr u))))) 2996 2997(de s!:expandcond (u) (cons (car u) (prog (var1210 var1211) (setq var1210 ( 2998cdr u)) lab1209 (cond ((null var1210) (return (reversip var1211)))) (prog (x) 2999(setq x (car var1210)) (setq var1211 (cons (s!:fully_macroexpand_list x) 3000var1211))) (setq var1210 (cdr var1210)) (go lab1209)))) 3001 3002(de s!:expandcase (u) (cons (car u) (cons (s!:fully_macroexpand (cadr u)) ( 3003prog (var1213 var1214) (setq var1213 (cddr u)) lab1212 (cond ((null var1213) 3004(return (reversip var1214)))) (prog (x) (setq x (car var1213)) (setq var1214 3005(cons (cons (car x) (s!:fully_macroexpand_list (cdr x))) var1214))) (setq 3006var1213 (cdr var1213)) (go lab1212))))) 3007 3008(de s!:expandeval!-when (u) (cons (car u) (cons (cadr u) ( 3009s!:fully_macroexpand_list (cddr u))))) 3010 3011(de s!:expandthe (u) (cons (car u) (cons (cadr u) (s!:fully_macroexpand_list 3012(cddr u))))) 3013 3014(de s!:expandmv!-call (u) (cons (car u) (cons (cadr u) ( 3015s!:fully_macroexpand_list (cddr u))))) 3016 3017(put (quote function) (quote s!:expandfn) (function s!:expandfunction)) 3018 3019(put (quote flet) (quote s!:expandfn) (function s!:expandflet)) 3020 3021(put (quote labels) (quote s!:expandfn) (function s!:expandlabels)) 3022 3023(put (quote macrolet) (quote s!:expandfn) (function s!:expandmacrolet)) 3024 3025(put (quote prog) (quote s!:expandfn) (function s!:expandprog)) 3026 3027(put (quote tagbody) (quote s!:expandfn) (function s!:expandtagbody)) 3028 3029(put (quote progv) (quote s!:expandfn) (function s!:expandprogv)) 3030 3031(put (quote !~block) (quote s!:expandfn) (function s!:expandblock)) 3032 3033(put (quote declare) (quote s!:expandfn) (function s!:expanddeclare)) 3034 3035(put (quote !~let) (quote s!:expandfn) (function s!:expandlet)) 3036 3037(put (quote let!*) (quote s!:expandfn) (function s!:expandlet!*)) 3038 3039(put (quote go) (quote s!:expandfn) (function s!:expandgo)) 3040 3041(put (quote return!-from) (quote s!:expandfn) (function s!:expandreturn!-from 3042)) 3043 3044(put (quote cond) (quote s!:expandfn) (function s!:expandcond)) 3045 3046(put (quote case) (quote s!:expandfn) (function s!:expandcase)) 3047 3048(put (quote eval!-when) (quote s!:expandfn) (function s!:expandeval!-when)) 3049 3050(put (quote the) (quote s!:expandfn) (function s!:expandthe)) 3051 3052(put (quote multiple!-value!-call) (quote s!:expandfn) (function 3053s!:expandmv!-call)) 3054 3055(de compile (l) (prog nil (cond ((and (atom l) (not (null l))) (setq l (list 3056l)))) (prog (var1216) (setq var1216 l) lab1215 (cond ((null var1216) (return 3057nil))) (prog (name) (setq name (car var1216)) (errorset (list (quote 3058s!:compile0) (mkquote name)) t t)) (setq var1216 (cdr var1216)) (go lab1215)) 3059(return l))) 3060 3061 3062 3063(fluid (quote (!*fastvector !*unsafecar))) 3064 3065(flag (quote (fastvector unsafecar)) (quote switch)) 3066 3067(global (quote (!*noisy))) 3068 3069(setq !*noisy nil) 3070 3071(fluid (quote (C_file L_file O_file L_contents Setup_name File_name))) 3072 3073(dm c!:printf (u !&optional env) (list (quote c!:printf1) (cadr u) (cons ( 3074quote list) (cddr u)))) 3075 3076(flag (quote (c!:printf)) (quote variadic)) 3077 3078(de c!:printf1 (fmt args) (prog (a c) (setq fmt (explode2 fmt)) (prog nil 3079lab1217 (cond ((null fmt) (return nil))) (progn (setq c (car fmt)) (setq fmt 3080(cdr fmt)) (cond ((and (equal c (quote !\)) (or (equal (car fmt) (quote !n)) 3081(equal (car fmt) (quote !N)))) (progn (terpri) (setq fmt (cdr fmt)))) (t ( 3082cond ((and (equal c (quote !\)) (or (equal (car fmt) (quote !q)) (equal (car 3083fmt) (quote !Q)))) (progn (princ (quote !")) (setq fmt (cdr fmt)))) (t (cond 3084((equal c (quote !%)) (progn (setq c (car fmt)) (cond ((null args) (setq a ( 3085quote missing_arg))) (t (setq a (car args)))) (cond ((or (equal c (quote !v)) 3086(equal c (quote !V))) (cond ((flagp a (quote c!:live_across_call)) (progn ( 3087princ "stack[") (princ (minus (get a (quote c!:location)))) (princ "]"))) (t 3088(princ a)))) (t (cond ((or (equal c (quote !c)) (equal c (quote !C))) ( 3089c!:safeprin a)) (t (cond ((or (equal c (quote !a)) (equal c (quote !A))) ( 3090prin a)) (t (cond ((or (equal c (quote !t)) (equal c (quote !T))) (ttab a)) ( 3091t (cond ((equal c (quote !<)) (progn (setq args (cons nil args)) (cond (( 3092greaterp (posn) 70) (terpri))))) (t (princ a))))))))))) (cond (args (setq 3093args (cdr args)))) (setq fmt (cdr fmt)))) (t (princ c)))))))) (go lab1217)))) 3094 3095(de c!:safeprin (x) (prog (n lastc) (setq n 0) (prog (var1219) (setq var1219 3096(explode x)) lab1218 (cond ((null var1219) (return nil))) (prog (c) (setq c ( 3097car var1219)) (progn (cond ((and (greaterp n 120) (equal c (quote ! ))) ( 3098progn (terpri) (prin2 "//") (setq n 2))) (t (cond ((and (greaterp n 150) (neq 3099c !$eol!$)) (progn (terpri) (prin2 "// ") (setq n 3))) (t (setq n (plus n 1) 3100))))) (cond ((and (equal lastc (quote !\)) (equal c !$eol!$)) (princ 3101" (backslash)"))) (setq lastc c) (princ c) (cond ((equal c !$eol!$) (progn ( 3102princ "//") (setq n 2)))))) (setq var1219 (cdr var1219)) (go lab1218)) (cond 3103((equal lastc (quote !\)) (princ " (backslash)"))))) 3104 3105(de c!:valid_fndef (args body) (cond ((or (memq (quote !&optional) args) ( 3106memq (quote !&rest) args)) nil) (t (c!:valid_list body)))) 3107 3108(de c!:valid_list (x) (cond ((null x) t) (t (cond ((atom x) nil) (t (cond (( 3109not (c!:valid_expr (car x))) nil) (t (c!:valid_list (cdr x))))))))) 3110 3111(de c!:valid_expr (x) (cond ((atom x) t) (t (cond ((not (atom (car x))) ( 3112progn (cond ((not (c!:valid_list (cdr x))) nil) (t (cond ((not (eqcar (car x) 3113(quote lambda))) nil) (t (cond ((atom (cdar x)) nil) (t (c!:valid_fndef ( 3114cadar x) (cddar x)))))))))) (t (cond ((not (idp (car x))) nil) (t (cond (( 3115eqcar x (quote quote)) t) (t (prog (h) (setq h (get (car x) (quote c!:valid)) 3116) (cond ((null h) (return (c!:valid_list (cdr x))))) (return (funcall h (cdr 3117x))))))))))))) 3118 3119(de c!:cspecform (x env) (error 0 (list "special form" x))) 3120 3121(de c!:valid_specform (x) nil) 3122 3123(progn (put (quote and) (quote c!:code) (function c!:cspecform)) (put (quote 3124catch) (quote c!:code) (function c!:cspecform)) (put (quote compiler!-let) ( 3125quote c!:code) (function c!:cspecform)) (put (quote cond) (quote c!:code) ( 3126function c!:cspecform)) (put (quote declare) (quote c!:code) (function 3127c!:cspecform)) (put (quote de) (quote c!:code) (function c!:cspecform)) (put 3128(quote eval!-when) (quote c!:code) (function c!:cspecform)) (put (quote flet) 3129(quote c!:code) (function c!:cspecform)) (put (quote function) (quote 3130c!:code) (function c!:cspecform)) (put (quote go) (quote c!:code) (function 3131c!:cspecform)) (put (quote if) (quote c!:code) (function c!:cspecform)) (put 3132(quote labels) (quote c!:code) (function c!:cspecform)) (put (quote !~let) ( 3133quote c!:code) (function c!:cspecform)) (put (quote let!*) (quote c!:code) ( 3134function c!:cspecform)) (put (quote list) (quote c!:code) (function 3135c!:cspecform)) (put (quote list!*) (quote c!:code) (function c!:cspecform)) ( 3136put (quote macrolet) (quote c!:code) (function c!:cspecform)) (put (quote 3137multiple!-value!-call) (quote c!:code) (function c!:cspecform)) (put (quote 3138multiple!-value!-prog1) (quote c!:code) (function c!:cspecform)) (put (quote 3139or) (quote c!:code) (function c!:cspecform)) (put (quote prog) (quote c!:code 3140) (function c!:cspecform)) (put (quote !~prog) (quote c!:code) (function 3141c!:cspecform)) (put (quote prog!*) (quote c!:code) (function c!:cspecform)) ( 3142put (quote prog1) (quote c!:code) (function c!:cspecform)) (put (quote prog2) 3143(quote c!:code) (function c!:cspecform)) (put (quote progn) (quote c!:code) 3144(function c!:cspecform)) (put (quote progv) (quote c!:code) (function 3145c!:cspecform)) (put (quote quote) (quote c!:code) (function c!:cspecform)) ( 3146put (quote return) (quote c!:code) (function c!:cspecform)) (put (quote 3147return!-from) (quote c!:code) (function c!:cspecform)) (put (quote setq) ( 3148quote c!:code) (function c!:cspecform)) (put (quote tagbody) (quote c!:code) 3149(function c!:cspecform)) (put (quote the) (quote c!:code) (function 3150c!:cspecform)) (put (quote unless) (quote c!:code) (function c!:cspecform)) ( 3151put (quote unwind!-protect) (quote c!:code) (function c!:cspecform)) (put ( 3152quote when) (quote c!:code) (function c!:cspecform)) (put (quote catch) ( 3153quote c!:valid) (function c!:valid_specform)) (put (quote compiler!-let) ( 3154quote c!:valid) (function c!:valid_specform)) (put (quote cond) (quote 3155c!:valid) (function c!:valid_specform)) (put (quote declare) (quote c!:valid) 3156(function c!:valid_specform)) (put (quote de) (quote c!:valid) (function 3157c!:valid_specform)) (put (quote eval!-when) (quote c!:valid) (function 3158c!:valid_specform)) (put (quote flet) (quote c!:valid) (function 3159c!:valid_specform)) (put (quote function) (quote c!:valid) (function 3160c!:valid_specform)) (put (quote labels) (quote c!:valid) (function 3161c!:valid_specform)) (put (quote !~let) (quote c!:valid) (function 3162c!:valid_specform)) (put (quote let!*) (quote c!:valid) (function 3163c!:valid_specform)) (put (quote macrolet) (quote c!:valid) (function 3164c!:valid_specform)) (put (quote multiple!-value!-call) (quote c!:valid) ( 3165function c!:valid_specform)) (put (quote multiple!-value!-prog1) (quote 3166c!:valid) (function c!:valid_specform)) (put (quote prog) (quote c!:valid) ( 3167function c!:valid_specform)) (put (quote prog!*) (quote c!:valid) (function 3168c!:valid_specform)) (put (quote progv) (quote c!:valid) (function 3169c!:valid_specform)) (put (quote quote) (quote c!:valid) (function 3170c!:valid_specform)) (put (quote the) (quote c!:valid) (function 3171c!:valid_specform)) (put (quote unwind!-protect) (quote c!:valid) (function 3172c!:valid_specform))) 3173 3174(fluid (quote (c!:current_procedure c!:current_args c!:current_block 3175c!:current_contents c!:all_blocks c!:registers c!:stacklocs))) 3176 3177(fluid (quote (c!:used))) 3178 3179(setq c!:used nil) 3180 3181(de c!:alphanumeric (a b) (prog nil (setq a (compress (cddr (explodec a)))) ( 3182setq b (compress (cddr (explodec b)))) (return (lessp a b)))) 3183 3184(de c!:reset_gensyms nil (progn (remflag c!:used (quote c!:live_across_call)) 3185(remflag c!:used (quote c!:visited)) (prog nil lab1220 (cond ((null c!:used) 3186(return nil))) (progn (remprop (car c!:used) (quote c!:contents)) (remprop ( 3187car c!:used) (quote c!:why)) (remprop (car c!:used) (quote c!:where_to)) ( 3188remprop (car c!:used) (quote c!:count)) (remprop (car c!:used) (quote c!:live 3189)) (remprop (car c!:used) (quote c!:clash)) (remprop (car c!:used) (quote 3190c!:chosen)) (remprop (car c!:used) (quote c!:location)) (cond ((plist (car 3191c!:used)) (prog (o) (setq o (wrs nil)) (princ "+++++ ") (prin (car c!:used)) 3192(princ " ") (prin (plist (car c!:used))) (terpri) (wrs o)))) (setq c!:used ( 3193cdr c!:used))) (go lab1220)) (setq my_gensym_counter 0))) 3194 3195(de c!:my_gensym nil (prog (w) (setq w (compress1 (cons (quote !v) (cons ( 3196quote !_) (explodec (setq my_gensym_counter (plus my_gensym_counter 1))))))) 3197(setq c!:used (cons w c!:used)) (cond ((plist w) (progn (princ "????? ") ( 3198prin w) (princ " => ") (prin (plist w)) (terpri)))) (return w))) 3199 3200(de c!:newreg nil (prog (r) (setq r (c!:my_gensym)) (setq c!:registers (cons 3201r c!:registers)) (return r))) 3202 3203(de c!:startblock (s) (progn (setq c!:current_block s) (setq 3204c!:current_contents nil))) 3205 3206(de c!:outop (a b c d) (cond (c!:current_block (setq c!:current_contents ( 3207cons (list a b c d) c!:current_contents))))) 3208 3209(de c!:endblock (why where_to) (cond (c!:current_block (progn (put 3210c!:current_block (quote c!:contents) c!:current_contents) (put 3211c!:current_block (quote c!:why) why) (put c!:current_block (quote c!:where_to 3212) where_to) (setq c!:all_blocks (cons c!:current_block c!:all_blocks)) (setq 3213c!:current_contents nil) (setq c!:current_block nil))))) 3214 3215(de c!:cval_inner (x env) (prog (helper) (setq x (s!:improve x)) (cond ((atom 3216x) (return (c!:catom x env))) (t (cond ((eqcar (car x) (quote lambda)) ( 3217return (c!:clambda (cadar x) (cddar x) (cdr x) env))) (t (cond ((setq helper 3218(get (car x) (quote c!:code))) (return (funcall helper x env))) (t (cond (( 3219and (setq helper (get (car x) (quote c!:compile_macro))) (setq helper ( 3220funcall helper x))) (return (c!:cval helper env))) (t (cond ((and (idp (car x 3221)) (setq helper (macro!-function (car x)))) (return (c!:cval (funcall helper 3222x) env))) (t (return (c!:ccall (car x) (cdr x) env)))))))))))))) 3223 3224(de c!:cval (x env) (prog (r) (setq r (c!:cval_inner x env)) (cond ((and r ( 3225not (member!*!* r c!:registers))) (error 0 (list r "not a register" x)))) ( 3226return r))) 3227 3228(fluid (quote (c!:stack))) 3229 3230(de c!:start_nested_context nil (prog nil (setq c!:stack (cons (list 3231c!:current_block c!:current_contents c!:all_blocks) c!:stack)) (setq 3232c!:all_blocks nil) (c!:startblock (c!:my_gensym)))) 3233 3234(de c!:end_nested_context nil (prog (l b w) (setq l (c!:my_gensym)) ( 3235c!:endblock (quote goto) (list l)) (setq b (reverse c!:all_blocks)) (setq w ( 3236car c!:stack)) (setq c!:stack (cdr c!:stack)) (setq c!:current_block (car w)) 3237(setq c!:current_contents (cadr w)) (setq c!:all_blocks (caddr w)) ( 3238c!:endblock (quote inner_block) b) (c!:startblock l))) 3239 3240(de c!:clambda (bvl body args env) (prog (w w1 fluids env1 decs) (setq env1 ( 3241car env)) (setq w (prog (var1222 var1223) (setq var1222 args) lab1221 (cond ( 3242(null var1222) (return (reversip var1223)))) (prog (a) (setq a (car var1222)) 3243(setq var1223 (cons (c!:cval a env) var1223))) (setq var1222 (cdr var1222)) 3244(go lab1221))) (setq w1 (s!:find_local_decs body nil)) (setq localdecs (cons 3245(car w1) localdecs)) (setq w1 (cdr w1)) (cond ((null w1) (setq body nil)) (t 3246(cond ((null (cdr w1)) (setq body (car w1))) (t (setq body (cons (quote progn 3247) w1)))))) (prog (var1225) (setq var1225 bvl) lab1224 (cond ((null var1225) ( 3248return nil))) (prog (x) (setq x (car var1225)) (cond ((and (not (fluidp x)) ( 3249not (globalp x)) (c!:local_fluidp x localdecs)) (progn (make!-special x) ( 3250setq decs (cons x decs)))))) (setq var1225 (cdr var1225)) (go lab1224)) (prog 3251(var1227) (setq var1227 bvl) lab1226 (cond ((null var1227) (return nil))) ( 3252prog (v) (setq v (car var1227)) (progn (cond ((globalp v) (prog (oo) (setq oo 3253(wrs nil)) (princ "+++++ ") (prin v) (princ 3254" converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v)) ( 3255fluid (list v))))) (cond ((fluidp v) (progn (setq fluids (cons (cons v ( 3256c!:newreg)) fluids)) (flag (list (cdar fluids)) (quote c!:live_across_call)) 3257(setq env1 (cons (cons (quote c!:dummy!:name) (cdar fluids)) env1)) ( 3258c!:start_nested_context) (c!:outop (quote fluidbind) (cdar fluids) v ( 3259c!:find_literal v)) (c!:outop (quote strglob) (car w) v (c!:find_literal v))) 3260) (t (progn (setq env1 (cons (cons v (c!:newreg)) env1)) (c!:outop (quote 3261movr) (cdar env1) nil (car w))))) (setq w (cdr w)))) (setq var1227 (cdr 3262var1227)) (go lab1226)) (setq env (cons env1 (append fluids (cdr env)))) ( 3263setq w (c!:cval body env)) (prog (var1229) (setq var1229 fluids) lab1228 ( 3264cond ((null var1229) (return nil))) (prog (v) (setq v (car var1229)) (progn ( 3265c!:end_nested_context) (c!:outop (quote fluidunbind) (cdr v) (car v) ( 3266c!:find_literal (car v))))) (setq var1229 (cdr var1229)) (go lab1228)) ( 3267unfluid decs) (setq localdecs (cdr localdecs)) (return w))) 3268 3269(de c!:locally_bound (x env) (atsoc x (car env))) 3270 3271(flag (quote (nil t)) (quote c!:constant)) 3272 3273(fluid (quote (literal_vector))) 3274 3275(de c!:find_literal (x) (prog (n w) (setq w literal_vector) (setq n 0) (prog 3276nil lab1230 (cond ((null (and w (not (equal (car w) x)))) (return nil))) ( 3277progn (setq n (plus n 1)) (setq w (cdr w))) (go lab1230)) (cond ((null w) ( 3278setq literal_vector (append literal_vector (list x))))) (return n))) 3279 3280(de c!:catom (x env) (prog (v w) (setq v (c!:newreg)) (cond ((or (null x) ( 3281equal x (quote t)) (c!:small_number x)) (c!:outop (quote movk1) v nil x)) (t 3282(cond ((and (idp x) (or (fluidp x) (globalp x))) (c!:outop (quote ldrglob) v 3283x (c!:find_literal x))) (t (cond ((and (idp x) (setq w (c!:locally_bound x 3284env))) (c!:outop (quote movr) v nil (cdr w))) (t (cond ((or (not (idp x)) ( 3285flagp x (quote c!:constant))) (c!:outop (quote movk) v x (c!:find_literal x)) 3286) (t (c!:outop (quote ldrglob) v x (c!:find_literal x)))))))))) (return v))) 3287 3288(de c!:cjumpif (x env d1 d2) (prog (helper r) (setq x (s!:improve x)) (cond ( 3289(and (atom x) (or (not (idp x)) (and (flagp x (quote c!:constant)) (not ( 3290c!:locally_bound x env))))) (c!:endblock (quote goto) (list (cond (x d1) (t 3291d2))))) (t (cond ((and (not (atom x)) (setq helper (get (car x) (quote 3292c!:ctest)))) (return (funcall helper x env d1 d2))) (t (progn (setq r ( 3293c!:cval x env)) (c!:endblock (list (quote ifnull) r) (list d2 d1))))))))) 3294 3295(fluid (quote (c!:current))) 3296 3297(de c!:ccall (fn args env) (c!:ccall1 fn args env)) 3298 3299(fluid (quote (c!:visited))) 3300 3301(de c!:has_calls (a b) (prog (c!:visited) (return (c!:has_calls_1 a b)))) 3302 3303(de c!:has_calls_1 (a b) (cond ((or (equal a b) (not (atom a)) (memq a 3304c!:visited)) nil) (t (prog (has_call) (setq c!:visited (cons a c!:visited)) ( 3305prog (var1232) (setq var1232 (get a (quote c!:contents))) lab1231 (cond (( 3306null var1232) (return nil))) (prog (z) (setq z (car var1232)) (cond ((eqcar z 3307(quote call)) (setq has_call t)))) (setq var1232 (cdr var1232)) (go lab1231) 3308) (cond (has_call (return (prog (c!:visited) (return (c!:can_reach a b)))))) 3309(prog (var1234) (setq var1234 (get a (quote c!:where_to))) lab1233 (cond (( 3310null var1234) (return nil))) (prog (d) (setq d (car var1234)) (cond (( 3311c!:has_calls_1 d b) (setq has_call t)))) (setq var1234 (cdr var1234)) (go 3312lab1233)) (return has_call))))) 3313 3314(de c!:can_reach (a b) (cond ((equal a b) t) (t (cond ((or (not (atom a)) ( 3315memq a c!:visited)) nil) (t (progn (setq c!:visited (cons a c!:visited)) ( 3316c!:any_can_reach (get a (quote c!:where_to)) b))))))) 3317 3318(de c!:any_can_reach (l b) (cond ((null l) nil) (t (cond ((c!:can_reach (car 3319l) b) t) (t (c!:any_can_reach (cdr l) b)))))) 3320 3321(de c!:evalargs (args env) (prog (r) (prog (var1236) (setq var1236 args) 3322lab1235 (cond ((null var1236) (return nil))) (prog (a) (setq a (car var1236)) 3323(setq r (cons (c!:cval a env) r))) (setq var1236 (cdr var1236)) (go lab1235) 3324) (return (reversip r)))) 3325 3326(de c!:ccall1 (fn args env) (prog (tasks merge r val) (setq fn (list fn (cdr 3327env))) (setq val (c!:newreg)) (cond ((null args) (c!:outop (quote call) val 3328nil fn)) (t (cond ((null (cdr args)) (c!:outop (quote call) val (list ( 3329c!:cval (car args) env)) fn)) (t (progn (cond ((and (not (get (car fn) (quote 3330c!:direct_entrypoint))) (cddr args) (cdddr args)) (setq args (list (car args 3331) (cadr args) (caddr args) (cons (quote list) (cdddr args)))))) (setq r ( 3332c!:evalargs args env)) (c!:outop (quote call) val r fn)))))) (c!:outop (quote 3333reloadenv) (quote env) nil nil) (setq reloadenv t) (return val))) 3334 3335(fluid (quote (restart_label reloadenv does_call c!:current_c_name))) 3336 3337(de c!:local_fluidp1 (v decs) (and decs (or (and (eqcar (car decs) (quote 3338special)) (memq v (cdar decs))) (c!:local_fluidp1 v (cdr decs))))) 3339 3340(de c!:local_fluidp (v decs) (and decs (or (c!:local_fluidp1 v (car decs)) ( 3341c!:local_fluidp v (cdr decs))))) 3342 3343(fluid (quote (proglabs blockstack localdecs))) 3344 3345(de c!:cfndef (c!:current_procedure c!:current_c_name argsbody checksum) ( 3346prog (env n w c!:current_args c!:current_block restart_label 3347c!:current_contents c!:all_blocks entrypoint exitpoint args1 c!:registers 3348c!:stacklocs literal_vector reloadenv does_call blockstack proglabs args body 3349localdecs varargs c!:stack) (setq args (car argsbody)) (setq body (cdr 3350argsbody)) (setq w (s!:find_local_decs body nil)) (setq body (cdr w)) (cond ( 3351(atom body) (setq body nil)) (t (cond ((atom (cdr body)) (setq body (car body 3352))) (t (setq body (cons (quote progn) body)))))) (setq localdecs (list (car w 3353))) (c!:reset_gensyms) (wrs C_file) (linelength 200) (c!:printf 3354"\n\n// Code for %a\n\n" c!:current_procedure) (c!:find_literal 3355c!:current_procedure) (setq c!:current_args args) (setq varargs (geq (length 3356args) 4)) (prog (var1238) (setq var1238 args) lab1237 (cond ((null var1238) ( 3357return nil))) (prog (v) (setq v (car var1238)) (cond ((or (equal v (quote 3358!&optional)) (equal v (quote !&rest))) (error 0 3359"&optional and &rest not supported by this compiler (yet)")) (t (cond (( 3360globalp v) (prog (oo) (setq oo (wrs nil)) (princ "+++++ ") (prin v) (princ 3361" converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v)) ( 3362fluid (list v)) (setq n (cons (cons v (c!:my_gensym)) n)))) (t (cond ((or ( 3363fluidp v) (c!:local_fluidp v localdecs)) (setq n (cons (cons v (c!:my_gensym) 3364) n))))))))) (setq var1238 (cdr var1238)) (go lab1237)) (cond (!*r2i (setq 3365body (s!:r2i c!:current_procedure args body)))) (setq restart_label ( 3366c!:my_gensym)) (setq body (list (quote c!:private_tagbody) restart_label body 3367)) (cond (n (progn (setq body (list (list (quote return) body))) (setq args ( 3368subla n args)) (prog (var1240) (setq var1240 n) lab1239 (cond ((null var1240) 3369(return nil))) (prog (v) (setq v (car var1240)) (setq body (cons (list ( 3370quote setq) (car v) (cdr v)) body))) (setq var1240 (cdr var1240)) (go lab1239 3371)) (setq body (cons (quote !~prog) (cons (prog (var1242 var1243) (setq 3372var1242 (reverse n)) lab1241 (cond ((null var1242) (return (reversip var1243) 3373))) (prog (v) (setq v (car var1242)) (setq var1243 (cons (car v) var1243))) ( 3374setq var1242 (cdr var1242)) (go lab1241)) body)))))) (c!:printf 3375"static LispObject %s(LispObject env" c!:current_c_name) (setq env nil) (cond 3376(varargs (progn (prog (var1245) (setq var1245 (list (car args) (cadr args) ( 3377caddr args))) lab1244 (cond ((null var1245) (return nil))) (prog (x) (setq x 3378(car var1245)) (prog (aa) (c!:printf ",") (cond (n (progn (c!:printf 3379"\n ") (setq n nil))) (t (setq n t))) (setq aa ( 3380c!:my_gensym)) (setq env (cons (cons x aa) env)) (setq c!:registers (cons aa 3381c!:registers)) (setq args1 (cons aa args1)) (c!:printf " LispObject %s" aa))) 3382(setq var1245 (cdr var1245)) (go lab1244)) (c!:printf ", LispObject _a4up_") 3383)) (t (progn (setq n t) (prog (var1247) (setq var1247 args) lab1246 (cond (( 3384null var1247) (return nil))) (prog (x) (setq x (car var1247)) (prog (aa) ( 3385c!:printf ",") (cond (n (progn (c!:printf "\n ") (setq 3386n nil))) (t (setq n t))) (setq aa (c!:my_gensym)) (setq env (cons (cons x aa 3387) env)) (setq c!:registers (cons aa c!:registers)) (setq args1 (cons aa args1 3388)) (c!:printf " LispObject %s" aa))) (setq var1247 (cdr var1247)) (go lab1246 3389))))) (c!:printf ")\n{\n") (c!:printf " env = qenv(env);\n") (cond ( 3390varargs (prog (var1249) (setq var1249 (cdddr args)) lab1248 (cond ((null 3391var1249) (return nil))) (prog (x) (setq x (car var1249)) (prog (aa) (setq aa 3392(c!:my_gensym)) (setq env (cons (cons x aa) env)) (setq c!:registers (cons aa 3393c!:registers)) (setq args1 (cons aa args1)))) (setq var1249 (cdr var1249)) ( 3394go lab1248)))) (c!:startblock (setq entrypoint (c!:my_gensym))) (setq 3395exitpoint c!:current_block) (c!:endblock (quote goto) (list (list (c!:cval 3396body (cons env nil))))) (c!:optimise_flowgraph entrypoint c!:all_blocks env ( 3397cons (length args) c!:current_procedure) (reverse args1) varargs) (c!:printf 3398"}\n\n") (wrs O_file) (setq L_contents (cons (cons c!:current_procedure (cons 3399literal_vector checksum)) L_contents)) (return nil))) 3400 3401(flag (quote (rds deflist flag fluid global remprop remflag unfluid unglobal 3402dm carcheck C!-end)) (quote eval)) 3403 3404(flag (quote (rds)) (quote ignore)) 3405 3406(fluid (quote (!*backtrace))) 3407 3408(de c!:ccompilesupervisor nil (prog (u w) top (setq u (errorset (quote (read) 3409) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond (( 3410equal u !$eof!$) (return nil))) (cond ((atom u) (go top)) (t (cond ((eqcar u 3411(quote C!-end)) (return (apply (quote C!-end) nil))) (t (cond ((eqcar u ( 3412quote rdf)) (progn (setq w (open (setq u (eval (cadr u))) (quote input))) ( 3413cond (w (progn (terpri) (princ "Reading file ") (print u) (setq w (rds w)) ( 3414c!:ccompilesupervisor) (princ "End of file ") (print u) (close (rds w)))) (t 3415(progn (princ "Failed to open file ") (print u)))))) (t (c!:ccmpout1 u))))))) 3416(go top))) 3417 3418(global (quote (c!:char_mappings))) 3419 3420(setq c!:char_mappings (quote ((! . !A) (!! . !B) (!# . !C) (!$ . !D) (!% . 3421!E) (!^ . !F) (!& . !G) (!* . !H) (!( . !I) (!) . !J) (!- . !K) (!+ . !L) (!= 3422 . !M) (!\ . !N) (!| . !O) (!, . !P) (!. . !Q) (!< . !R) (!> . !S) (!: . !T) 3423(!; . !U) (!/ . !V) (!? . !W) (!~ . !X) (!` . !Y)))) 3424 3425(fluid (quote (c!:names_so_far))) 3426 3427(de c!:inv_name (n) (prog (r w) (cond ((setq w (assoc n c!:names_so_far)) ( 3428setq w (plus (cdr w) 1))) (t (setq w 0))) (setq c!:names_so_far (cons (cons n 3429w) c!:names_so_far)) (setq r (quote (!C !C !"))) (cond ((not (zerop w)) ( 3430setq r (append (reverse (explodec w)) r)))) (setq r (cons (quote !_) r)) ( 3431prog (var1251) (setq var1251 (explode2 n)) lab1250 (cond ((null var1251) ( 3432return nil))) (prog (c) (setq c (car var1251)) (progn (cond ((equal c (quote 3433_)) (setq r (cons (quote _) r))) (t (cond ((or (liter c) (digit c)) (setq r ( 3434cons c r))) (t (cond ((setq w (atsoc c c!:char_mappings)) (setq r (cons (cdr 3435w) r))) (t (setq r (cons (quote !Z) r)))))))))) (setq var1251 (cdr var1251)) 3436(go lab1250)) (setq r (cons (quote !") r)) (return (compress (reverse r))))) 3437 3438(fluid (quote (c!:defnames pending_functions))) 3439 3440(de c!:ccmpout1 (u) (prog (pending_functions) (setq pending_functions (list u 3441)) (prog nil lab1252 (cond ((null pending_functions) (return nil))) (progn ( 3442setq u (car pending_functions)) (setq pending_functions (cdr 3443pending_functions)) (c!:ccmpout1a u)) (go lab1252)))) 3444 3445(de c!:ccmpout1a (u) (prog (w checksum) (cond ((atom u) (return nil)) (t ( 3446cond ((eqcar u (quote progn)) (progn (prog (var1254) (setq var1254 (cdr u)) 3447lab1253 (cond ((null var1254) (return nil))) (prog (v) (setq v (car var1254)) 3448(c!:ccmpout1a v)) (setq var1254 (cdr var1254)) (go lab1253)) (return nil))) 3449(t (cond ((eqcar u (quote C!-end)) nil) (t (cond ((or (flagp (car u) (quote 3450eval)) (and (equal (car u) (quote setq)) (not (atom (caddr u))) (flagp ( 3451caaddr u) (quote eval)))) (errorset u t !*backtrace))))))))) (cond ((eqcar u 3452(quote rdf)) (prog nil (setq w (open (setq u (eval (cadr u))) (quote input))) 3453(cond (w (progn (princ "Reading file ") (print u) (setq w (rds w)) ( 3454c!:ccompilesupervisor) (princ "End of file ") (print u) (close (rds w)))) (t 3455(progn (princ "Failed to open file ") (print u)))))) (t (cond ((eqcar u ( 3456quote de)) (progn (setq u (cdr u)) (setq checksum (md60 u)) (setq c!:defnames 3457(cons (list (car u) (c!:inv_name (car u)) (length (cadr u)) checksum) 3458c!:defnames)) (princ "Compiling ") (prin (caar c!:defnames)) (princ " ... ") 3459(c!:cfndef (caar c!:defnames) (cadar c!:defnames) (cdr u) checksum) (terpri)) 3460)))))) 3461 3462(fluid (quote (!*defn dfprint!* dfprintsave))) 3463 3464(de c!:concat (a b) (compress (cons (quote !") (append (explode2 a) (append ( 3465explode2 b) (quote (!"))))))) 3466 3467(de c!:ccompilestart (name setupname dir) (prog (o d w) (setq c!:registers ( 3468setq c!:used nil)) (setq File_name (list2string (explodec name))) (setq 3469Setup_name (explodec setupname)) (setq Setup_name (subst (quote !_) (quote !- 3470) Setup_name)) (setq Setup_name (list2string Setup_name)) (cond (dir (progn ( 3471cond ((memq (quote win32) lispsystem!*) (setq name (c!:concat dir (c!:concat 3472"\" name)))) (t (setq name (c!:concat dir (c!:concat "/" name)))))))) (princ 3473"C file = ") (print name) (setq C_file (open (c!:concat name ".cpp") (quote 3474output))) (setq L_file (c!:concat name ".lsp")) (setq L_contents nil) (setq 3475c!:names_so_far nil) (setq o (reverse (explode (date!-and!-time)))) (prog (i) 3476(setq i 1) lab1255 (cond ((minusp (times 1 (difference 5 i))) (return nil))) 3477(progn (setq d (cons (car o) d)) (setq o (cdr o))) (setq i (plus i 1)) (go 3478lab1255)) (setq d (cons (quote !-) d)) (setq o (cdddr (cdddr (cddddr o)))) ( 3479setq w o) (setq o (cdddr o)) (setq d (cons (caddr o) (cons (cadr o) (cons ( 3480car o) d)))) (setq d (compress (cons (quote !") (cons (cadr w) (cons (car w) 3481(cons (quote !-) d)))))) (setq O_file (wrs C_file)) (setq c!:defnames nil) ( 3482c!:printf "\n// %s.c %tMachine generated C code\n\n" name 25) (c!:printf 3483"// $I") (c!:printf "d: $\n\n") (c!:printf "#include \qconfig.h\q\n") ( 3484c!:printf "#include \qheaders.h\q\n\n") (wrs O_file) (return nil))) 3485 3486(de C!-end nil (C!-end1 t)) 3487 3488(de C!-end1 (create_lfile) (prog (checksum c1 c2 c3 stubs) (wrs C_file) (cond 3489((equal (explodec Setup_name) (explodec (quote stubs))) (progn (setq stubs t 3490) (setq Setup_name "u01")))) (cond (create_lfile (c!:printf 3491"\n\nsetup_type const %s_setup[] =\n{\n" Setup_name)) (t (c!:printf 3492"\n\nsetup_type const_1 %s_setup[] =\n{\n" Setup_name))) (setq c!:defnames ( 3493reverse c!:defnames)) (prog nil lab1256 (cond ((null c!:defnames) (return nil 3494))) (prog (name nargs f0 f1 f2 f3 f4up) (setq name (caar c!:defnames)) (setq 3495checksum (cadddr (car c!:defnames))) (setq f0 (cadar c!:defnames)) (setq 3496nargs (caddar c!:defnames)) (cond ((equal nargs 0) (progn (setq f1 "G1W0") ( 3497setq f2 "G2W0") (setq f3 "G3W0") (setq f4up "G4W0"))) (t (cond ((equal nargs 34981) (progn (setq f1 f0) (setq f0 "G0W1") (setq f2 "G2W1") (setq f3 "G3W1") ( 3499setq f4up "G4W1"))) (t (cond ((equal nargs 2) (progn (setq f2 f0) (setq f0 3500"G0W2") (setq f1 "G1W2") (setq f3 "G3W2") (setq f4up "G4W2"))) (t (cond (( 3501equal nargs 3) (progn (setq f3 f0) (setq f0 "G0W3") (setq f1 "G1W3") (setq f2 3502"G2W3") (setq f4up "G4W3"))) (t (progn (setq f4up f0) (setq f0 "G0W4up") ( 3503setq f1 "G1W4up") (setq f2 "G2W4up") (setq f3 "G3W4up")))))))))) (cond ( 3504create_lfile (c!:printf " {\q%s\q,%t%s,%t%s,%t%s,%t%s,%t%s},\n" name 32 f0 350542 f1 52 f2 62 f3 72 f4up)) (t (prog (c1 c2) (setq c1 (divide checksum (expt 35062 31))) (setq c2 (cdr c1)) (setq c1 (car c1)) (c!:printf 3507" {\q%s\q, %t%s, %t%s, %t%s, %t%s, %t%s, %t%s, %t%s},\n" name 24 f0 40 f1 350852 f2 64 f3 76 f4up)))) (setq c!:defnames (cdr c!:defnames))) (go lab1256)) ( 3509setq c3 (setq checksum (md60 L_contents))) (setq c1 (remainder c3 10000000)) 3510(setq c3 (quotient c3 10000000)) (setq c2 (remainder c3 10000000)) (setq c3 ( 3511quotient c3 10000000)) (setq checksum (list2string (append (explodec c3) ( 3512cons (quote ! ) (append (explodec c2) (cons (quote ! ) (explodec c1))))))) ( 3513c!:printf " {nullptr, \n") (c!:printf 3514" reinterpret_cast<no_args *>(\n") (c!:printf 3515" reinterpret_cast<uintptr_t>(%a)),\n" Setup_name) (c!:printf 3516" reinterpret_cast<one_arg *>(\n") (c!:printf 3517" reinterpret_cast<uintptr_t>(%a)),\n" checksum) (c!:printf 3518" nullptr, nullptr, nullptr}\n};\n\n") (cond (stubs (progn (prog (i) ( 3519setq i 2) lab1257 (cond ((minusp (times 1 (difference 60 i))) (return nil))) 3520(progn (c!:printf "setup_type const u") (cond ((lessp i 10) (c!:printf "0"))) 3521(c!:printf "%s_setup[] = {\n" i) (c!:printf " {nullptr, \n") (c!:printf 3522" reinterpret_cast<no_args *>(\n") (c!:printf 3523" reinterpret_cast<uintptr_t>(%a)),\n" Setup_name) (c!:printf 3524" reinterpret_cast<one_arg *>(\n") (c!:printf 3525" reinterpret_cast<uintptr_t>(%a)),\n" checksum) (c!:printf 3526" nullptr, nullptr, nullptr}\n};\n\n")) (setq i (plus i 1)) (go 3527lab1257)) (c!:printf "\n\n")))) (c!:printf "%<// end of generated code\n") ( 3528close C_file) (cond (create_lfile (progn (setq L_file (open L_file (quote 3529output))) (wrs L_file) (linelength 72) (terpri) (princ "% ") (princ 3530Setup_name) (princ ".lsp") (ttab 20) (princ "Machine generated Lisp") (terpri 3531) (terpri) (princ "(c!:install ") (princ (quote !")) (princ Setup_name) ( 3532princ (quote !")) (princ " ") (princ checksum) (printc ")") (terpri) (prog ( 3533var1259) (setq var1259 (reverse L_contents)) lab1258 (cond ((null var1259) ( 3534return nil))) (prog (x) (setq x (car var1259)) (progn (princ "(c!:install '") 3535(prin (car x)) (princ " '") (prin (cadr x)) (princ " ") (prin (cddr x)) ( 3536princ ")") (terpri) (terpri))) (setq var1259 (cdr var1259)) (go lab1258)) ( 3537terpri) (princ "% End of generated Lisp code") (c!:reset_gensyms) (terpri) ( 3538terpri) (setq L_contents nil) (wrs O_file) (close L_file) (setq !*defn nil) ( 3539setq dfprint!* dfprintsave))) (t (progn (setq checksum (cons checksum ( 3540reverse L_contents))) (setq L_contents nil) (return checksum)))))) 3541 3542(put (quote C!-end) (quote stat) (quote endstat)) 3543 3544(de C!-compile (u) (prog nil (terpri) (princ "C!-COMPILE ") (prin u) (princ 3545": IN files; or type in expressions") (terpri) (princ 3546"When all done, execute C!-END;") (terpri) (verbos nil) (c!:ccompilestart ( 3547car u) (car u) nil) (setq dfprintsave dfprint!*) (setq dfprint!* (quote 3548c!:ccmpout1)) (setq !*defn t) (cond ((getd (quote begin)) (return nil))) ( 3549c!:ccompilesupervisor))) 3550 3551(put (quote C!-compile) (quote stat) (quote rlis)) 3552 3553(de c!:print_opcode (s) (prog (op r1 r2 r3 helper) (setq op (car s)) (setq r1 3554(cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (setq helper (get op ( 3555quote c!:opcode_printer))) (cond (helper (funcall helper op r1 r2 r3)) (t ( 3556progn (prin s) (terpri)))))) 3557 3558(de c!:print_exit_condition (why where_to next) (prog (helper) (cond ((equal 3559why (quote goto)) (progn (setq where_to (car where_to)) (cond ((equal 3560where_to next) nil) (t (cond ((atom where_to) (c!:printf " goto %s;\n" 3561where_to)) (t (progn (c!:printf " ") (c!:pgoto where_to)))))) (return nil) 3562)) (t (cond ((eqcar (car why) (quote call)) (return (prog (args locs g w) ( 3563cond ((setq w (get (cadar why) (quote c!:direct_entrypoint))) (progn (prog ( 3564var1261) (setq var1261 (cdr why)) lab1260 (cond ((null var1261) (return nil)) 3565) (prog (a) (setq a (car var1261)) (cond ((flagp a (quote c!:live_across_call 3566)) (progn (cond ((null g) (c!:printf " {\n"))) (setq g (c!:my_gensym)) ( 3567c!:printf " LispObject %s = %v;\n" g a) (setq args (cons g args)))) (t 3568(setq args (cons a args))))) (setq var1261 (cdr var1261)) (go lab1260)) ( 3569cond (g (c!:printf " "))) (c!:printf " return %s(" (cdr w)) (setq args 3570(reversip args)) (cond (args (progn (c!:printf "%v" (car args)) (prog ( 3571var1263) (setq var1263 (cdr args)) lab1262 (cond ((null var1263) (return nil) 3572)) (prog (a) (setq a (car var1263)) (c!:printf ", %v" a)) (setq var1263 (cdr 3573var1263)) (go lab1262))))) (c!:printf ");\n") (cond (g (c!:printf " }\n")) 3574))) (t (cond ((setq w (get (cadar why) (quote c!:c_entrypoint))) (progn (prog 3575(var1265) (setq var1265 (cdr why)) lab1264 (cond ((null var1265) (return nil 3576))) (prog (a) (setq a (car var1265)) (cond ((flagp a (quote 3577c!:live_across_call)) (progn (cond ((null g) (c!:printf " {\n"))) (setq g 3578(c!:my_gensym)) (c!:printf " LispObject %s = %v;\n" g a) (setq args ( 3579cons g args)))) (t (setq args (cons a args))))) (setq var1265 (cdr var1265)) 3580(go lab1264)) (c!:printf " return %s(nil" w) (prog (var1267) (setq 3581var1267 (reversip args)) lab1266 (cond ((null var1267) (return nil))) (prog ( 3582a) (setq a (car var1267)) (c!:printf ", %v" a)) (setq var1267 (cdr var1267)) 3583(go lab1266)) (c!:printf ");\n") (cond (g (c!:printf " }\n"))))) (t (prog 3584(nargs) (setq nargs (length (cdr why))) (c!:printf " {") (c!:printf 3585" LispObject fn = basic_elt(env, %s); %<// %c\n" (c!:find_literal (cadar 3586why)) (cadar why)) (cond ((equal nargs 0) (c!:printf 3587" return (*qfn0(fn))(fn")) (t (cond ((equal nargs 1) (c!:printf 3588" return (*qfn1(fn))(fn")) (t (cond ((equal nargs 2) (c!:printf 3589" return (*qfn2(fn))(fn")) (t (cond ((equal nargs 3) (c!:printf 3590" return (*qfn3(fn))(fn")) (t (c!:printf 3591" return (*qfn4up(fn))(fn"))))))))) (prog (var1269) (setq var1269 (cdr 3592why)) lab1268 (cond ((null var1269) (return nil))) (prog (a) (setq a (car 3593var1269)) (c!:printf ", %v" a)) (setq var1269 (cdr var1269)) (go lab1268)) ( 3594c!:printf ");\n }\n")))))) (return nil))))))) (setq helper (get (car why) 3595(quote c!:exit_helper))) (cond ((null helper) (error 0 (list 3596"Bad exit condition" why)))) (c!:printf " if (") (funcall helper (cdr why) 3597) (c!:printf ") ") (c!:pgoto (car where_to)) (cond ((neq (cadr where_to) next 3598) (progn (c!:printf " else ") (c!:pgoto (cadr where_to))))))) 3599 3600(de c!:pmovr (op r1 r2 r3) (c!:printf " %v = %v;\n" r1 r3)) 3601 3602(put (quote movr) (quote c!:opcode_printer) (function c!:pmovr)) 3603 3604(de c!:pmovk (op r1 r2 r3) (c!:printf 3605" %v = basic_elt(env, %s); %<// %c\n" r1 r3 r2)) 3606 3607(put (quote movk) (quote c!:opcode_printer) (function c!:pmovk)) 3608 3609(de c!:pmovk1 (op r1 r2 r3) (cond ((null r3) (c!:printf " %v = nil;\n" r1) 3610) (t (cond ((equal r3 (quote t)) (c!:printf " %v = lisp_true;\n" r1)) (t ( 3611c!:printf " %v = static_cast<LispObject>(%s)+TAG_FIXNUM; %<// %c\n" r1 ( 3612times 16 r3) r3)))))) 3613 3614(put (quote movk1) (quote c!:opcode_printer) (function c!:pmovk1)) 3615 3616(flag (quote (movk1)) (quote c!:uses_nil)) 3617 3618(de c!:preloadenv (op r1 r2 r3) (c!:printf " env = stack[%s];\n" (minus 3619reloadenv))) 3620 3621(put (quote reloadenv) (quote c!:opcode_printer) (function c!:preloadenv)) 3622 3623(de c!:pldrglob (op r1 r2 r3) (c!:printf 3624" %v = qvalue(basic_elt(env, %s)); %<// %c\n" r1 r3 r2)) 3625 3626(put (quote ldrglob) (quote c!:opcode_printer) (function c!:pldrglob)) 3627 3628(de c!:pstrglob (op r1 r2 r3) (c!:printf 3629" setvalue(basic_elt(env, %s), %v); %<// %c\n" r3 r1 r2)) 3630 3631(put (quote strglob) (quote c!:opcode_printer) (function c!:pstrglob)) 3632 3633(de c!:pnilglob (op r1 r2 r3) (c!:printf 3634" setvalue(basic_elt(env, %s), nil); %<// %c\n" r3 r2)) 3635 3636(put (quote nilglob) (quote c!:opcode_printer) (function c!:pnilglob)) 3637 3638(flag (quote (nilglob)) (quote c!:uses_nil)) 3639 3640(de c!:pnull (op r1 r2 r3) (c!:printf 3641" %v = (%v == nil ? lisp_true : nil);\n" r1 r3)) 3642 3643(put (quote null) (quote c!:opcode_printer) (function c!:pnull)) 3644 3645(put (quote not) (quote c!:opcode_printer) (function c!:pnull)) 3646 3647(flag (quote (null not)) (quote c!:uses_nil)) 3648 3649(de c!:pfastget (op r1 r2 r3) (progn (c!:printf 3650" if (!symbolp(%v)) %v = nil;\n" r2 r1) (c!:printf 3651" else { %v = qfastgets(%v);\n" r1 r2) (c!:printf 3652" if (%v != nil) { %v = elt(%v, %s); %<// %c\n" r1 r1 r1 (car r3) ( 3653cdr r3)) (c!:printf " if (%v == SPID_NOPROP) %v = nil; }}\n" r1 3654r1))) 3655 3656(put (quote fastget) (quote c!:opcode_printer) (function c!:pfastget)) 3657 3658(flag (quote (fastget)) (quote c!:uses_nil)) 3659 3660(de c!:pfastflag (op r1 r2 r3) (progn (c!:printf 3661" if (!symbolp(%v)) %v = nil;\n" r2 r1) (c!:printf 3662" else { %v = qfastgets(%v);\n" r1 r2) (c!:printf 3663" if (%v != nil) { %v = elt(%v, %s); %<// %c\n" r1 r1 r1 (car r3) ( 3664cdr r3)) (c!:printf 3665" if (%v == SPID_NOPROP) %v = nil; else %v = lisp_true; }}\n" r1 3666r1 r1))) 3667 3668(put (quote fastflag) (quote c!:opcode_printer) (function c!:pfastflag)) 3669 3670(flag (quote (fastflag)) (quote c!:uses_nil)) 3671 3672(de c!:pcar (op r1 r2 r3) (prog nil (cond ((not !*unsafecar) (progn ( 3673c!:printf " if (!car_legal(%v)) UNLIKELY return carerror(%v);\n" r3 r3) ( 3674c!:printf " %v = car(%v);\n" r1 r3))) (t (c!:printf " %v = car(%v);\n" 3675r1 r3))))) 3676 3677(put (quote car) (quote c!:opcode_printer) (function c!:pcar)) 3678 3679(de c!:pcdr (op r1 r2 r3) (prog nil (cond ((not !*unsafecar) (progn ( 3680c!:printf " if (!car_legal(%v)) UNLIKELY return cdrerror(%v);\n" r3 r3) ( 3681c!:printf " %v = cdr(%v);\n" r1 r3))) (t (c!:printf " %v = cdr(%v);\n" 3682r1 r3))))) 3683 3684(put (quote cdr) (quote c!:opcode_printer) (function c!:pcdr)) 3685 3686(de c!:pqcar (op r1 r2 r3) (c!:printf " %v = car(%v);\n" r1 r3)) 3687 3688(put (quote qcar) (quote c!:opcode_printer) (function c!:pqcar)) 3689 3690(de c!:pqcdr (op r1 r2 r3) (c!:printf " %v = cdr(%v);\n" r1 r3)) 3691 3692(put (quote qcdr) (quote c!:opcode_printer) (function c!:pqcdr)) 3693 3694(de c!:patom (op r1 r2 r3) (c!:printf 3695" %v = (consp(%v) ? nil : lisp_true);\n" r1 r3)) 3696 3697(put (quote atom) (quote c!:opcode_printer) (function c!:patom)) 3698 3699(flag (quote (atom)) (quote c!:uses_nil)) 3700 3701(de c!:pnumberp (op r1 r2 r3) (c!:printf 3702" %v = (is_number(%v) ? lisp_true : nil);\n" r1 r3)) 3703 3704(put (quote numberp) (quote c!:opcode_printer) (function c!:pnumberp)) 3705 3706(flag (quote (numberp)) (quote c!:uses_nil)) 3707 3708(de c!:pfixp (op r1 r2 r3) (c!:printf " %v = integerp(%v);\n" r1 r3)) 3709 3710(put (quote fixp) (quote c!:opcode_printer) (function c!:pfixp)) 3711 3712(flag (quote (fixp)) (quote c!:uses_nil)) 3713 3714(de c!:piminusp (op r1 r2 r3) (c!:printf 3715" %v = (static_cast<std::intptr_t>(%v) < 0 ? lisp_true : nil);\n" r1 r3)) 3716 3717(put (quote iminusp) (quote c!:opcode_printer) (function c!:piminusp)) 3718 3719(flag (quote (iminusp)) (quote c!:uses_nil)) 3720 3721(de c!:pilessp (op r1 r2 r3) (c!:printf 3722" %v = (static_cast<std::intptr_t>(%v) < static_cast<std::intptr_t>(%v)) ? lisp_true : nil;\n" 3723r1 r2 r3)) 3724 3725(put (quote ilessp) (quote c!:opcode_printer) (function c!:pilessp)) 3726 3727(flag (quote (ilessp)) (quote c!:uses_nil)) 3728 3729(de c!:pigreaterp (op r1 r2 r3) (c!:printf 3730" %v = (static_cast<std::intptr_t>(%v) > static_cast<std::intptr_t>(%v)) ? lisp_true : nil;\n" 3731r1 r2 r3)) 3732 3733(put (quote igreaterp) (quote c!:opcode_printer) (function c!:pigreaterp)) 3734 3735(flag (quote (igreaterp)) (quote c!:uses_nil)) 3736 3737(de c!:piminus (op r1 r2 r3) (c!:printf 3738" %v = static_cast<LispObject>(2*TAG_FIXNUM-(static_cast<std::intptr_t>(%v)));\n" 3739r1 r3)) 3740 3741(put (quote iminus) (quote c!:opcode_printer) (function c!:piminus)) 3742 3743(de c!:piadd1 (op r1 r2 r3) (c!:printf 3744" %v = static_cast<LispObject>(static_cast<std::intptr_t>(%v) + 0x10);\n" 3745r1 r3)) 3746 3747(put (quote iadd1) (quote c!:opcode_printer) (function c!:piadd1)) 3748 3749(de c!:pisub1 (op r1 r2 r3) (c!:printf 3750" %v = static_cast<LispObject>(static_cast<std::intptr_t>(%v) - 0x10);\n" 3751r1 r3)) 3752 3753(put (quote isub1) (quote c!:opcode_printer) (function c!:pisub1)) 3754 3755(de c!:piplus2 (op r1 r2 r3) (progn (c!:printf 3756" %v = static_cast<LispObject>(static_cast<std::uintptr_t>(%v) +" r1 r2) ( 3757c!:printf " static_cast<std::uintptr_t>(%v) - TAG_FIXNUM);\n" r3))) 3758 3759(put (quote iplus2) (quote c!:opcode_printer) (function c!:piplus2)) 3760 3761(de c!:pidifference (op r1 r2 r3) (progn (c!:printf 3762" %v = static_cast<LispObject>(static_cast<std::uintptr_t>(%v) - static_cast<std::uintptr_t>(%v)" 3763r1 r2 r3) (c!:printf " + TAG_FIXNUM);\n"))) 3764 3765(put (quote idifference) (quote c!:opcode_printer) (function c!:pidifference) 3766) 3767 3768(de c!:pitimes2 (op r1 r2 r3) (progn (c!:printf 3769" %v = fixnum_of_int(static_cast<std::intptr_t>(int_of_fixnum(%v) *" r1 r2 3770) (c!:printf " int_of_fixnum(%v)));\n" r3))) 3771 3772(put (quote itimes2) (quote c!:opcode_printer) (function c!:pitimes2)) 3773 3774(de c!:pmodular_plus (op r1 r2 r3) (progn (c!:printf 3775" { std::intptr_t w = int_of_fixnum(%v) + int_of_fixnum(%v);\n" r2 r3) ( 3776c!:printf " if (w >= current_modulus) w -= current_modulus;\n") ( 3777c!:printf " %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) 3778 3779(put (quote modular!-plus) (quote c!:opcode_printer) (function 3780c!:pmodular_plus)) 3781 3782(de c!:pmodular_difference (op r1 r2 r3) (progn (c!:printf 3783" { std::intptr_t w = int_of_fixnum(%v) - int_of_fixnum(%v);\n" r2 r3) ( 3784c!:printf " if (w < 0) w += current_modulus;\n") (c!:printf 3785" %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) 3786 3787(put (quote modular!-difference) (quote c!:opcode_printer) (function 3788c!:pmodular_difference)) 3789 3790(de c!:pmodular_minus (op r1 r2 r3) (progn (c!:printf 3791" { std::intptr_t w = int_of_fixnum(%v);\n" r3) (c!:printf 3792" if (w != 0) w = current_modulus - w;\n") (c!:printf 3793" %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) 3794 3795(put (quote modular!-minus) (quote c!:opcode_printer) (function 3796c!:pmodular_minus)) 3797 3798(de c!:passoc (op r1 r2 r3) (c!:printf " %v = Lassoc(nil, %v, %v);\n" r1 3799r2 r3)) 3800 3801(put (quote assoc) (quote c!:opcode_printer) (function c!:passoc)) 3802 3803(flag (quote (assoc)) (quote c!:uses_nil)) 3804 3805(de c!:patsoc (op r1 r2 r3) (c!:printf " %v = Latsoc(nil, %v, %v);\n" r1 3806r2 r3)) 3807 3808(put (quote atsoc) (quote c!:opcode_printer) (function c!:patsoc)) 3809 3810(flag (quote (atsoc)) (quote c!:uses_nil)) 3811 3812(de c!:pmember (op r1 r2 r3) (c!:printf " %v = Lmember(nil, %v, %v);\n" r1 3813r2 r3)) 3814 3815(put (quote member) (quote c!:opcode_printer) (function c!:pmember)) 3816 3817(flag (quote (member)) (quote c!:uses_nil)) 3818 3819(de c!:pmemq (op r1 r2 r3) (c!:printf " %v = Lmemq(nil, %v, %v);\n" r1 r2 3820r3)) 3821 3822(put (quote memq) (quote c!:opcode_printer) (function c!:pmemq)) 3823 3824(flag (quote (memq)) (quote c!:uses_nil)) 3825 3826(de c!:pget (op r1 r2 r3) (c!:printf " %v = get(%v, %v);\n" r1 r2 r3)) 3827 3828(put (quote get) (quote c!:opcode_printer) (function c!:pget)) 3829 3830(de c!:pqgetv (op r1 r2 r3) (progn (c!:printf 3831" %v = *reinterpret_cast<LispObject *>(reinterpret_cast<char *>(%v) + (CELL-TAG_VECTOR) +" 3832r1 r2) (c!:printf 3833" (((static_cast<std::intptr_t<(%v)-TAG_FIXNUM)/(16/CELL)));\n" r3))) 3834 3835(put (quote qgetv) (quote c!:opcode_printer) (function c!:pqgetv)) 3836 3837(de c!:pqputv (op r1 r2 r3) (progn (c!:printf 3838" *(LispObject *)((char *)%v + (CELL-TAG_VECTOR) +" r2) (c!:printf 3839" ((static_cast<std::intptr_t>(%v)-TAG_FIXNUM)/(16/CELL))) = %v;\n" r3 r1))) 3840 3841(put (quote qputv) (quote c!:opcode_printer) (function c!:pqputv)) 3842 3843(de c!:prplaca (op r1 r2 r3) (progn (c!:printf 3844" if (!car_legal(%v)) UNLIKELY return rplaca_fails(%v);\n" r2 r2) ( 3845c!:printf " setcar(%v, %v);\n" r2 r3))) 3846 3847(put (quote rplaca) (quote c!:opcode_printer) (function c!:prplaca)) 3848 3849(de c!:prplacd (op r1 r2 r3) (progn (c!:printf 3850" if (!car_legal(%v)) UNLIKELY return rplacd_fails(%v);\n" r2 r2) ( 3851c!:printf " setcdr(%v, %v);\n" r2 r3))) 3852 3853(put (quote rplacd) (quote c!:opcode_printer) (function c!:prplacd)) 3854 3855(de c!:peq (op r1 r2 r3) (c!:printf 3856" %v = (%v == %v ? lisp_true : nil);\n" r1 r2 r3)) 3857 3858(put (quote eq) (quote c!:opcode_printer) (function c!:peq)) 3859 3860(flag (quote (eq)) (quote c!:uses_nil)) 3861 3862(de c!:pequal (op r1 r2 r3) (c!:printf 3863" %v = (equal(%v, %v) ? lisp_true : nil);\n" r1 r2 r3 r2 r3)) 3864 3865(put (quote equal) (quote c!:opcode_printer) (function c!:pequal)) 3866 3867(flag (quote (equal)) (quote c!:uses_nil)) 3868 3869(de c!:pfluidbind (op r1 r2 r3) (prog nil (c!:printf "// Binding %a\n" r2) ( 3870c!:printf "// FLUIDBIND: reloadenv=%a litvec-offset=%a saveloc=%a\n" 3871reloadenv r3 (get r1 (quote c!:location))) (c!:printf 3872"{ bind_fluid_stack bind_fluid_var(%a, %a, %a);\n" (minus reloadenv) r3 ( 3873minus (get r1 (quote c!:location)))))) 3874 3875(put (quote fluidbind) (quote c!:opcode_printer) (function c!:pfluidbind)) 3876 3877(de c!:pfluidunbind (op r1 r2 r3) (prog nil (c!:printf 3878" ;} // end of a binding scope\n"))) 3879 3880(put (quote fluidunbind) (quote c!:opcode_printer) (function c!:pfluidunbind) 3881) 3882 3883(de c!:pcall (op r1 r2 r3) (prog (w boolfn) (cond ((setq w (get (car r3) ( 3884quote c!:direct_entrypoint))) (progn (cond ((flagp (intern (cdr w)) (quote 3885c!:noreturn)) (c!:printf " %s(" (cdr w))) (t (c!:printf " %v = %s(" r1 3886(cdr w)))) (cond (r2 (progn (c!:printf "%v" (car r2)) (prog (var1271) (setq 3887var1271 (cdr r2)) lab1270 (cond ((null var1271) (return nil))) (prog (a) ( 3888setq a (car var1271)) (c!:printf ", %v" a)) (setq var1271 (cdr var1271)) (go 3889lab1270))))) (c!:printf ");\n"))) (t (cond ((setq w (get (car r3) (quote 3890c!:direct_predicate))) (progn (setq boolfn t) (c!:printf 3891" %v = static_cast<LispObject>(%s(" r1 (cdr w)) (cond (r2 (progn ( 3892c!:printf "%v" (car r2)) (prog (var1273) (setq var1273 (cdr r2)) lab1272 ( 3893cond ((null var1273) (return nil))) (prog (a) (setq a (car var1273)) ( 3894c!:printf ", %v" a)) (setq var1273 (cdr var1273)) (go lab1272))))) (c!:printf 3895"));\n"))) (t (cond ((setq w (get (car r3) (quote c!:c_entrypoint))) (progn 3896(cond ((flagp (intern w) (quote c!:noreturn)) (c!:printf " %s(nil" w)) (t 3897(c!:printf " %v = %s(nil" r1 w))) (prog (var1275) (setq var1275 r2) 3898lab1274 (cond ((null var1275) (return nil))) (prog (a) (setq a (car var1275)) 3899(c!:printf ", %v" a)) (setq var1275 (cdr var1275)) (go lab1274)) (c!:printf 3900");\n"))) (t (prog (nargs) (setq nargs (length r2)) (c!:printf 3901" { LispObject fn = basic_elt(env, %s); %<// %c\n" (c!:find_literal (car 3902r3)) (car r3)) (cond ((equal nargs 0) (c!:printf 3903" %v = (*qfn0(fn))(fn" r1)) (t (cond ((equal nargs 1) (c!:printf 3904" %v = (*qfn1(fn))(fn" r1)) (t (cond ((equal nargs 2) (c!:printf 3905" %v = (*qfn2(fn))(fn" r1)) (t (cond ((equal nargs 3) (c!:printf 3906" %v = (*qfn3(fn))(fn" r1)) (t (c!:printf 3907" %v = (*qfn4up(fn))(fn" r1))))))))) (prog (var1277) (setq var1277 r2) 3908lab1276 (cond ((null var1277) (return nil))) (prog (a) (setq a (car var1277) 3909) (c!:printf ", %v" a)) (setq var1277 (cdr var1277)) (go lab1276)) (c!:printf 3910");\n }\n")))))))) (cond ((not (flagp (car r3) (quote c!:no_errors))) ( 3911c!:printf " errexit();\n"))) (cond (boolfn (c!:printf 3912" %v = %v ? lisp_true : nil;\n" r1 r1))))) 3913 3914(put (quote call) (quote c!:opcode_printer) (function c!:pcall)) 3915 3916(de c!:pgoto (lab) (prog nil (cond ((atom lab) (return (c!:printf 3917"goto %s;\n" lab)))) (setq lab (get (car lab) (quote c!:chosen))) (c!:printf 3918"return onevalue(%v);\n" lab))) 3919 3920(de c!:pifnull (s) (c!:printf "%v == nil" (car s))) 3921 3922(put (quote ifnull) (quote c!:exit_helper) (function c!:pifnull)) 3923 3924(de c!:pifatom (s) (c!:printf "!consp(%v)" (car s))) 3925 3926(put (quote ifatom) (quote c!:exit_helper) (function c!:pifatom)) 3927 3928(de c!:pifsymbol (s) (c!:printf "symbolp(%v)" (car s))) 3929 3930(put (quote ifsymbol) (quote c!:exit_helper) (function c!:pifsymbol)) 3931 3932(de c!:pifnumber (s) (c!:printf "is_number(%v)" (car s))) 3933 3934(put (quote ifnumber) (quote c!:exit_helper) (function c!:pifnumber)) 3935 3936(de c!:pifizerop (s) (c!:printf "(%v) == 1" (car s))) 3937 3938(put (quote ifizerop) (quote c!:exit_helper) (function c!:pifizerop)) 3939 3940(de c!:pifeq (s) (c!:printf "%v == %v" (car s) (cadr s))) 3941 3942(put (quote ifeq) (quote c!:exit_helper) (function c!:pifeq)) 3943 3944(de c!:pifequal (s) (c!:printf "equal(%v, %v)" (car s) (cadr s) (car s) (cadr 3945s))) 3946 3947(put (quote ifequal) (quote c!:exit_helper) (function c!:pifequal)) 3948 3949(de c!:pifilessp (s) (c!:printf 3950"(static_cast<std::intptr_t>(%v) < static_cast<std::intptr_t>(%v))" (car s) ( 3951cadr s))) 3952 3953(put (quote ifilessp) (quote c!:exit_helper) (function c!:pifilessp)) 3954 3955(de c!:pifigreaterp (s) (c!:printf 3956"(static_cast<std::intptr_t>(%v) > static_cast<std::intptr_t>(%v))" (car s) ( 3957cadr s))) 3958 3959(put (quote ifigreaterp) (quote c!:exit_helper) (function c!:pifigreaterp)) 3960 3961(de c!:flag_exit_label (why where_to next) (prog (helper) (cond ((equal why ( 3962quote goto)) (progn (setq where_to (car where_to)) (cond ((equal where_to 3963next) nil) (t (cond ((atom where_to) (flag (list where_to) (quote c!:visited) 3964))))) (return nil)))) (cond ((atom where_to) (return nil))) (cond ((atom (car 3965where_to)) (flag (list (car where_to)) (quote c!:visited)))) (cond ((null ( 3966cdr where_to)) (return nil))) (cond ((and (neq (cadr where_to) next) (atom ( 3967cadr where_to))) (flag (list (cadr where_to)) (quote c!:visited)))))) 3968 3969(de c!:display_flowgraph (s) (prog (why where_to s s1) (prog (b) (setq b ( 3970reverse c!:all_blocks)) lab1278 (cond ((null b) (return nil))) (progn (setq s 3971(car b)) (cond ((cdr b) (setq s1 (cadr b))) (t (setq s1 nil))) (setq why ( 3972get s (quote c!:why))) (setq where_to (get s (quote c!:where_to))) ( 3973c!:flag_exit_label why where_to s1)) (setq b (cdr b)) (go lab1278)) (prog (b) 3974(setq b (reverse c!:all_blocks)) lab1281 (cond ((null b) (return nil))) ( 3975progn (setq s (car b)) (cond ((cdr b) (setq s1 (cadr b))) (t (setq s1 nil))) 3976(cond ((flagp s (quote c!:visited)) (c!:printf "%s:\n" s))) (prog (var1280) ( 3977setq var1280 (reverse (get s (quote c!:contents)))) lab1279 (cond ((null 3978var1280) (return nil))) (prog (k) (setq k (car var1280)) (c!:print_opcode k)) 3979(setq var1280 (cdr var1280)) (go lab1279)) (setq why (get s (quote c!:why))) 3980(setq where_to (get s (quote c!:where_to))) (c!:print_exit_condition why 3981where_to s1)) (setq b (cdr b)) (go lab1281)))) 3982 3983(fluid (quote (c!:startpoint))) 3984 3985(de c!:branch_chain (s count) (prog (contents why where_to n) (cond ((not ( 3986atom s)) (return s)) (t (cond ((flagp s (quote c!:visited)) (progn (setq n ( 3987get s (quote c!:count))) (cond ((null n) (setq n 1)) (t (setq n (plus n 1)))) 3988(put s (quote c!:count) n) (return s)))))) (flag (list s) (quote c!:visited) 3989) (setq contents (get s (quote c!:contents))) (setq why (get s (quote c!:why) 3990)) (setq where_to (prog (var1283 var1284) (setq var1283 (get s (quote 3991c!:where_to))) lab1282 (cond ((null var1283) (return (reversip var1284)))) ( 3992prog (z) (setq z (car var1283)) (setq var1284 (cons (c!:branch_chain z count) 3993var1284))) (setq var1283 (cdr var1283)) (go lab1282))) (prog nil lab1285 ( 3994cond ((null (and contents (eqcar (car contents) (quote movr)) (equal why ( 3995quote goto)) (not (atom (car where_to))) (equal (caar where_to) (cadr (car 3996contents))))) (return nil))) (progn (setq where_to (list (list (cadddr (car 3997contents))))) (setq contents (cdr contents))) (go lab1285)) (put s (quote 3998c!:contents) contents) (put s (quote c!:where_to) where_to) (cond ((and (null 3999contents) (equal why (quote goto))) (progn (remflag (list s) (quote 4000c!:visited)) (return (car where_to))))) (cond (count (progn (setq n (get s ( 4001quote c!:count))) (cond ((null n) (setq n 1)) (t (setq n (plus n 1)))) (put s 4002(quote c!:count) n)))) (return s))) 4003 4004(de c!:one_operand (op) (progn (flag (list op) (quote c!:set_r1)) (flag (list 4005op) (quote c!:read_r3)) (put op (quote c!:code) (function c!:builtin_one)))) 4006 4007(de c!:two_operands (op) (progn (flag (list op) (quote c!:set_r1)) (flag ( 4008list op) (quote c!:read_r2)) (flag (list op) (quote c!:read_r3)) (put op ( 4009quote c!:code) (function c!:builtin_two)))) 4010 4011(prog (var1287) (setq var1287 (quote (car cdr qcar qcdr null not atom numberp 4012fixp iminusp iminus iadd1 isub1 modular!-minus))) lab1286 (cond ((null 4013var1287) (return nil))) (prog (n) (setq n (car var1287)) (c!:one_operand n)) 4014(setq var1287 (cdr var1287)) (go lab1286)) 4015 4016(prog (var1289) (setq var1289 (quote (eq equal atsoc memq iplus2 idifference 4017assoc member itimes2 ilessp igreaterp qgetv get modular!-plus 4018modular!-difference))) lab1288 (cond ((null var1289) (return nil))) (prog (n) 4019(setq n (car var1289)) (c!:two_operands n)) (setq var1289 (cdr var1289)) (go 4020lab1288)) 4021 4022(flag (quote (movr movk movk1 ldrglob call reloadenv fluidbind fastget 4023fastflag)) (quote c!:set_r1)) 4024 4025(flag (quote (strglob qputv fluidunbind)) (quote c!:read_r1)) 4026 4027(flag (quote (qputv fastget fastflag rplaca rplacd)) (quote c!:read_r2)) 4028 4029(flag (quote (movr qputv rplaca rplacd)) (quote c!:read_r3)) 4030 4031(flag (quote (ldrglob strglob nilglob movk call)) (quote c!:read_env)) 4032 4033(flag (quote (call qputv rplaca rplacd fluidbind fluidunbind)) (quote 4034c!:side_effect)) 4035 4036(de c!:live_variable_analysis (c!:all_blocks) (prog (changed z) (prog nil 4037lab1296 (progn (setq changed nil) (prog (var1295) (setq var1295 c!:all_blocks 4038) lab1294 (cond ((null var1295) (return nil))) (prog (b) (setq b (car var1295 4039)) (prog (w live) (prog (var1291) (setq var1291 (get b (quote c!:where_to))) 4040lab1290 (cond ((null var1291) (return nil))) (prog (x) (setq x (car var1291)) 4041(cond ((atom x) (setq live (union live (get x (quote c!:live))))) (t (setq 4042live (union live x))))) (setq var1291 (cdr var1291)) (go lab1290)) (setq w ( 4043get b (quote c!:why))) (cond ((not (atom w)) (progn (setq live (union live ( 4044cdr w))) (cond ((and (eqcar (car w) (quote call)) (not (get (cadar w) (quote 4045c!:direct_entrypoint))) (not (get (cadar w) (quote c!:c_entrypoint)))) (progn 4046(setq live (union (quote (env)) live)))))))) (prog (var1293) (setq var1293 ( 4047get b (quote c!:contents))) lab1292 (cond ((null var1293) (return nil))) ( 4048prog (s) (setq s (car var1293)) (prog (op r1 r2 r3) (setq op (car s)) (setq 4049r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond ((flagp op (quote 4050c!:set_r1)) (cond ((memq r1 live) (setq live (delete r1 live))) (t (cond (( 4051flagp op (quote c!:side_effect)) nil) (t (setq op (quote nop)))))))) (cond (( 4052flagp op (quote c!:read_r1)) (setq live (union live (list r1))))) (cond (( 4053flagp op (quote c!:read_r2)) (setq live (union live (list r2))))) (cond (( 4054flagp op (quote c!:read_r3)) (setq live (union live (list r3))))) (cond (( 4055equal op (quote call)) (progn (setq does_call t) (cond ((not (flagp (car r3) 4056(quote c!:no_errors))) (flag live (quote c!:live_across_call)))) (setq live ( 4057union live r2))))) (cond ((flagp op (quote c!:read_env)) (setq live (union 4058live (quote (env)))))))) (setq var1293 (cdr var1293)) (go lab1292)) (setq 4059live (sort live (function orderp))) (cond ((not (equal live (get b (quote 4060c!:live)))) (progn (put b (quote c!:live) live) (setq changed t)))))) (setq 4061var1295 (cdr var1295)) (go lab1294))) (cond ((null (not changed)) (go lab1296 4062)))) (setq z c!:registers) (setq c!:registers (setq c!:stacklocs nil)) (prog 4063(var1298) (setq var1298 z) lab1297 (cond ((null var1298) (return nil))) (prog 4064(r) (setq r (car var1298)) (cond ((flagp r (quote c!:live_across_call)) ( 4065setq c!:stacklocs (cons r c!:stacklocs))) (t (setq c!:registers (cons r 4066c!:registers))))) (setq var1298 (cdr var1298)) (go lab1297)))) 4067 4068(de c!:insert1 (a b) (cond ((memq a b) b) (t (cons a b)))) 4069 4070(de c!:clash (a b) (cond ((equal (flagp a (quote c!:live_across_call)) (flagp 4071b (quote c!:live_across_call))) (progn (put a (quote c!:clash) (c!:insert1 b 4072(get a (quote c!:clash)))) (put b (quote c!:clash) (c!:insert1 a (get b ( 4073quote c!:clash)))))))) 4074 4075(de c!:build_clash_matrix (c!:all_blocks) (prog nil (prog (var1306) (setq 4076var1306 c!:all_blocks) lab1305 (cond ((null var1306) (return nil))) (prog (b) 4077(setq b (car var1306)) (prog (live w) (prog (var1300) (setq var1300 (get b ( 4078quote c!:where_to))) lab1299 (cond ((null var1300) (return nil))) (prog (x) ( 4079setq x (car var1300)) (cond ((atom x) (setq live (union live (get x (quote 4080c!:live))))) (t (setq live (union live x))))) (setq var1300 (cdr var1300)) ( 4081go lab1299)) (setq w (get b (quote c!:why))) (cond ((not (atom w)) (progn ( 4082setq live (union live (cdr w))) (cond ((and (eqcar (car w) (quote call)) (not 4083(get (cadar w) (quote c!:direct_entrypoint))) (not (get (cadar w) (quote 4084c!:c_entrypoint)))) (setq live (union (quote (env)) live))))))) (prog ( 4085var1304) (setq var1304 (get b (quote c!:contents))) lab1303 (cond ((null 4086var1304) (return nil))) (prog (s) (setq s (car var1304)) (prog (op r1 r2 r3) 4087(setq op (car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) 4088(cond ((or (equal op (quote reloadenv)) (equal op (quote fluidbind))) (setq 4089reloadenv t))) (cond ((flagp op (quote c!:set_r1)) (cond ((memq r1 live) ( 4090progn (setq live (delete r1 live)) (prog (var1302) (setq var1302 live) 4091lab1301 (cond ((null var1302) (return nil))) (prog (v) (setq v (car var1302)) 4092(c!:clash r1 v)) (setq var1302 (cdr var1302)) (go lab1301)))) (t (cond (( 4093flagp op (quote c!:side_effect)) nil) (t (progn (setq op (quote nop)) (rplacd 4094s (cons (car s) (cdr s))) (rplaca s op)))))))) (cond ((flagp op (quote 4095c!:read_r1)) (setq live (union live (list r1))))) (cond ((flagp op (quote 4096c!:read_r2)) (setq live (union live (list r2))))) (cond ((flagp op (quote 4097c!:read_r3)) (setq live (union live (list r3))))) (cond ((equal op (quote 4098call)) (setq live (union live r2)))) (cond ((flagp op (quote c!:read_env)) ( 4099setq live (union live (quote (env)))))))) (setq var1304 (cdr var1304)) (go 4100lab1303)))) (setq var1306 (cdr var1306)) (go lab1305)) (return nil))) 4101 4102(de c!:allocate_registers (rl) (prog (schedule neighbours allocation) (setq 4103neighbours 0) (prog nil lab1310 (cond ((null rl) (return nil))) (prog (w x) ( 4104setq w rl) (prog nil lab1307 (cond ((null (and w (greaterp (length (setq x ( 4105get (car w) (quote c!:clash)))) neighbours))) (return nil))) (setq w (cdr w)) 4106(go lab1307)) (cond (w (progn (setq schedule (cons (car w) schedule)) (setq 4107rl (deleq (car w) rl)) (prog (var1309) (setq var1309 x) lab1308 (cond ((null 4108var1309) (return nil))) (prog (r) (setq r (car var1309)) (put r (quote 4109c!:clash) (deleq (car w) (get r (quote c!:clash))))) (setq var1309 (cdr 4110var1309)) (go lab1308)))) (t (setq neighbours (plus neighbours 1))))) (go 4111lab1310)) (prog (var1314) (setq var1314 schedule) lab1313 (cond ((null 4112var1314) (return nil))) (prog (r) (setq r (car var1314)) (prog (poss) (setq 4113poss allocation) (prog (var1312) (setq var1312 (get r (quote c!:clash))) 4114lab1311 (cond ((null var1312) (return nil))) (prog (x) (setq x (car var1312)) 4115(setq poss (deleq (get x (quote c!:chosen)) poss))) (setq var1312 (cdr 4116var1312)) (go lab1311)) (cond ((null poss) (progn (setq poss (c!:my_gensym)) 4117(setq allocation (append allocation (list poss))))) (t (setq poss (car poss)) 4118)) (put r (quote c!:chosen) poss))) (setq var1314 (cdr var1314)) (go lab1313) 4119) (return allocation))) 4120 4121(de c!:remove_nops (c!:all_blocks) (prog (var1324) (setq var1324 4122c!:all_blocks) lab1323 (cond ((null var1324) (return nil))) (prog (b) (setq b 4123(car var1324)) (prog (r) (prog (var1319) (setq var1319 (get b (quote 4124c!:contents))) lab1318 (cond ((null var1319) (return nil))) (prog (s) (setq s 4125(car var1319)) (cond ((not (eqcar s (quote nop))) (prog (op r1 r2 r3) (setq 4126op (car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond 4127((or (flagp op (quote c!:set_r1)) (flagp op (quote c!:read_r1))) (setq r1 ( 4128get r1 (quote c!:chosen))))) (cond ((flagp op (quote c!:read_r2)) (setq r2 ( 4129get r2 (quote c!:chosen))))) (cond ((flagp op (quote c!:read_r3)) (setq r3 ( 4130get r3 (quote c!:chosen))))) (cond ((equal op (quote call)) (setq r2 (prog ( 4131var1316 var1317) (setq var1316 r2) lab1315 (cond ((null var1316) (return ( 4132reversip var1317)))) (prog (v) (setq v (car var1316)) (setq var1317 (cons ( 4133get v (quote c!:chosen)) var1317))) (setq var1316 (cdr var1316)) (go lab1315) 4134)))) (cond ((not (and (equal op (quote movr)) (equal r1 r3))) (setq r (cons ( 4135list op r1 r2 r3) r)))))))) (setq var1319 (cdr var1319)) (go lab1318)) (put b 4136(quote c!:contents) (reverse r)) (setq r (get b (quote c!:why))) (cond ((not 4137(atom r)) (put b (quote c!:why) (cons (car r) (prog (var1321 var1322) (setq 4138var1321 (cdr r)) lab1320 (cond ((null var1321) (return (reversip var1322)))) 4139(prog (v) (setq v (car var1321)) (setq var1322 (cons (get v (quote c!:chosen) 4140) var1322))) (setq var1321 (cdr var1321)) (go lab1320)))))))) (setq var1324 ( 4141cdr var1324)) (go lab1323))) 4142 4143(de c!:assign (u v c) (cond ((flagp u (quote fluid)) (cons (list (quote 4144strglob) v u (c!:find_literal u)) c)) (t (cons (list (quote movr) u nil v) c) 4145))) 4146 4147(de c!:insert_tailcall (b) (prog (why dest contents fcall res w) (setq why ( 4148get b (quote c!:why))) (setq dest (get b (quote c!:where_to))) (setq contents 4149(get b (quote c!:contents))) (prog nil lab1325 (cond ((null (and contents ( 4150not (eqcar (car contents) (quote call))))) (return nil))) (progn (setq w ( 4151cons (car contents) w)) (setq contents (cdr contents))) (go lab1325)) (cond ( 4152(null contents) (return nil))) (setq fcall (car contents)) (setq contents ( 4153cdr contents)) (setq res (cadr fcall)) (prog nil lab1326 (cond ((null w) ( 4154return nil))) (progn (cond ((eqcar (car w) (quote reloadenv)) (setq w (cdr w) 4155)) (t (cond ((and (eqcar (car w) (quote movr)) (equal (cadddr (car w)) res)) 4156(progn (setq res (cadr (car w))) (setq w (cdr w)))) (t (setq res (setq w nil) 4157)))))) (go lab1326)) (cond ((null res) (return nil))) (cond ((c!:does_return 4158res why dest) (cond ((and (equal (car (cadddr fcall)) c!:current_procedure) ( 4159lessp (length c!:current_args) 4)) (progn (prog (var1328) (setq var1328 (pair 4160c!:current_args (caddr fcall))) lab1327 (cond ((null var1328) (return nil))) 4161(prog (p) (setq p (car var1328)) (setq contents (c!:assign (car p) (cdr p) 4162contents))) (setq var1328 (cdr var1328)) (go lab1327)) (put b (quote 4163c!:contents) contents) (put b (quote c!:why) (quote goto)) (put b (quote 4164c!:where_to) (list restart_label)))) (t (progn (put b (quote c!:contents) 4165contents) (put b (quote c!:why) (cons (list (quote call) (car (cadddr fcall)) 4166) (caddr fcall))) (put b (quote c!:where_to) nil)))))))) 4167 4168(de c!:does_return (res why where_to) (cond ((not (equal why (quote goto))) 4169nil) (t (cond ((not (atom (car where_to))) (equal res (caar where_to))) (t ( 4170prog (contents) (setq where_to (car where_to)) (setq contents (reverse (get 4171where_to (quote c!:contents)))) (setq why (get where_to (quote c!:why))) ( 4172setq where_to (get where_to (quote c!:where_to))) (prog nil lab1329 (cond (( 4173null contents) (return nil))) (cond ((eqcar (car contents) (quote reloadenv)) 4174(setq contents (cdr contents))) (t (cond ((and (eqcar (car contents) (quote 4175movr)) (equal (cadddr (car contents)) res)) (progn (setq res (cadr (car 4176contents))) (setq contents (cdr contents)))) (t (setq res (setq contents nil) 4177))))) (go lab1329)) (cond ((null res) (return nil)) (t (return ( 4178c!:does_return res why where_to)))))))))) 4179 4180(de showblock (l) (prog nil (cond (!*noisy (progn (prin l) (printc ":") (prog 4181(var1331) (setq var1331 (get l (quote c!:contents))) lab1330 (cond ((null 4182var1331) (return nil))) (prog (i) (setq i (car var1331)) (progn (princ " ") 4183(print i))) (setq var1331 (cdr var1331)) (go lab1330)) (princ " ") (prin ( 4184get l (quote c!:why))) (princ " ") (print (get l (quote c!:where_to)))))))) 4185 4186(de showblocklist (l) (prog (var1333) (setq var1333 l) lab1332 (cond ((null 4187var1333) (return nil))) (prog (q) (setq q (car var1333)) (showblock q)) (setq 4188var1333 (cdr var1333)) (go lab1332))) 4189 4190(de c!:flatten (b) (prog (w r inner) (showblocklist b) (prog nil lab1336 ( 4191cond ((null b) (return nil))) (progn (cond ((equal (get (car b) (quote c!:why 4192)) (quote inner_block)) (progn (setq inner (get (car b) (quote c!:where_to))) 4193(cond (!*noisy (progn (printc "This is an inner block") (showblocklist inner 4194)))) (setq w (c!:flatten inner)) (cond (!*noisy (progn (printc 4195"Inner block flattened") (showblocklist w)))) (put (car b) (quote c!:why) ( 4196quote goto)) (put (car b) (quote c!:where_to) (list (car inner))) (setq r ( 4197cons (car b) r)) (prog (var1335) (setq var1335 (reverse w)) lab1334 (cond (( 4198null var1335) (return nil))) (prog (x) (setq x (car var1335)) (setq r (cons x 4199r))) (setq var1335 (cdr var1335)) (go lab1334)))) (t (setq r (cons (car b) r 4200)))) (setq b (cdr b))) (go lab1336)) (cond (!*noisy (progn (printc 4201"Whole block flattened") (showblocklist (reverse r))))) (return r))) 4202 4203(de c!:optimise_flowgraph (c!:startpoint c!:all_blocks env argch args varargs 4204) (prog (w n locs stacks) (printc "#if 0 // Start of trace output") (setq 4205c!:all_blocks (c!:flatten (reverse c!:all_blocks))) (prog (var1338) (setq 4206var1338 c!:all_blocks) lab1337 (cond ((null var1338) (return nil))) (prog (b) 4207(setq b (car var1338)) (c!:insert_tailcall b)) (setq var1338 (cdr var1338)) 4208(go lab1337)) (cond (!*noisy (progn (printc "now do live variable stuff") ( 4209showblocklist c!:all_blocks)))) (c!:live_variable_analysis c!:all_blocks) ( 4210cond (!*noisy (progn (printc "now build clash list") (princ "reloadenv = ") ( 4211print reloadenv) (showblocklist c!:all_blocks)))) (c!:build_clash_matrix 4212c!:all_blocks) (cond (!*noisy (progn (princ "reloadenv = ") (print reloadenv) 4213))) (prog (var1342) (setq var1342 env) lab1341 (cond ((null var1342) (return 4214nil))) (prog (u) (setq u (car var1342)) (prog (var1340) (setq var1340 env) 4215lab1339 (cond ((null var1340) (return nil))) (prog (v) (setq v (car var1340)) 4216(c!:clash (cdr u) (cdr v))) (setq var1340 (cdr var1340)) (go lab1339))) ( 4217setq var1342 (cdr var1342)) (go lab1341)) (setq locs (c!:allocate_registers 4218c!:registers)) (setq stacks (c!:allocate_registers c!:stacklocs)) (flag 4219stacks (quote c!:live_across_call)) (cond (!*noisy (progn (printc 4220"before remove nops") (showblocklist c!:all_blocks)))) (c!:remove_nops 4221c!:all_blocks) (cond (!*noisy (progn (printc "after remove nops") ( 4222showblocklist c!:all_blocks)))) (printc "#endif // End of trace output") ( 4223cond (locs (progn (c!:printf " UNUSED_NAME LispObject %s" (car locs)) ( 4224prog (var1344) (setq var1344 (cdr locs)) lab1343 (cond ((null var1344) ( 4225return nil))) (prog (v) (setq v (car var1344)) (c!:printf ", %s" v)) (setq 4226var1344 (cdr var1344)) (go lab1343)) (c!:printf ";\n")))) (cond ((or stacks 4227reloadenv) (c!:printf " stack_restorer stack_restorer_var;\n"))) (cond (( 4228and varargs args) (progn (setq w " ") (c!:printf " LispObject") (prog ( 4229var1346) (setq var1346 (cdddr args)) lab1345 (cond ((null var1346) (return 4230nil))) (prog (v) (setq v (car var1346)) (progn (c!:printf "%s%s" w v) (setq w 4231", "))) (setq var1346 (cdr var1346)) (go lab1345)) (c!:printf ";\n") (prog ( 4232var1348) (setq var1348 (cdddr args)) lab1347 (cond ((null var1348) (return 4233nil))) (prog (v) (setq v (car var1348)) (progn (c!:printf 4234" if (_a4up_ == nil)\n aerror1(\qnot enough arguments provided\q, basic_elt(env, 0));\n" 4235) (c!:printf " %s = car(_a4up_); _a4up_ = cdr(_a4up_);\n" v))) (setq 4236var1348 (cdr var1348)) (go lab1347)) (c!:printf 4237" if (_a4up_ != nil)\n aerror1(\qtoo many arguments provided\q, basic_elt(env, 0));\n" 4238)))) (c!:printf "#ifdef CHECK_STACK\n") (c!:printf " if_check_stack;\n") ( 4239c!:printf "#endif\n") (cond (does_call (progn (c!:printf 4240"#ifdef CONSERVATIVE\n") (c!:printf " poll();\n") (c!:printf 4241"#else // CONSERVATIVE\n") (c!:printf 4242" if (++reclaim_trigger_count == reclaim_trigger_target ||\n") (c!:printf 4243" stack >= stackLimit)\n") (c!:printf " { Save saveArgs(env") ( 4244cond ((not (null args)) (progn (c!:printf ", %s" (car args)) (setq w (cdr 4245args)) (cond ((not (null w)) (progn (c!:printf ", %s" (car w)) (setq w (cdr w 4246)) (cond ((not (null w)) (progn (c!:printf ", %s" (car w)) (setq w (cdr w)) ( 4247cond ((not (null w)) (c!:printf ", _a4up_")))))))))))) (c!:printf ");\n") ( 4248c!:printf " env = reclaim(env, \qstack\q, GC_STACK, 0);\n") (c!:printf 4249" errexit();\n") (c!:printf " saveArgs.restore(env") (cond (( 4250not (null args)) (progn (c!:printf ", %s" (car args)) (setq w (cdr args)) ( 4251cond ((not (null w)) (progn (c!:printf ", %s" (car w)) (setq w (cdr w)) (cond 4252((not (null w)) (progn (c!:printf ", %s" (car w)) (setq w (cdr w)) (cond (( 4253not (null w)) (c!:printf ", _a4up_")))))))))))) (c!:printf ");\n }\n") ( 4254c!:printf "#endif // CONSERVATIVE\n")))) (setq n 0) (cond (stacks (progn ( 4255c!:printf "%<// space for vars preserved across procedure calls\n") (prog ( 4256var1350) (setq var1350 stacks) lab1349 (cond ((null var1350) (return nil))) ( 4257prog (v) (setq v (car var1350)) (progn (put v (quote c!:location) n) (setq n 4258(plus n 1)))) (setq var1350 (cdr var1350)) (go lab1349))))) (cond (reloadenv 4259(progn (setq reloadenv n) (cond ((equal n 0) (c!:printf 4260" RealSave saveEnv(env);\n")) (t (c!:printf 4261" RealSave saveEnv(env, PushCount(%a));\n" n))))) (t (cond ((neq n 0) ( 4262c!:printf " RealSave Workspace(PushCount(%a));\n" n))))) (cond (env ( 4263c!:printf "%<// copy arguments values to proper place\n"))) (prog (var1352) ( 4264setq var1352 env) lab1351 (cond ((null var1352) (return nil))) (prog (v) ( 4265setq v (car var1352)) (cond ((flagp (cdr v) (quote c!:live_across_call)) ( 4266c!:printf " stack[%s] = %s;\n" (minus (get (get (cdr v) (quote c!:chosen)) 4267(quote c!:location))) (cdr v))) (t (c!:printf " %s = %s;\n" (get (cdr v) 4268(quote c!:chosen)) (cdr v))))) (setq var1352 (cdr var1352)) (go lab1351)) ( 4269c!:printf "%<// end of prologue\n") (c!:display_flowgraph c!:startpoint) ( 4270remflag c!:all_blocks (quote c!:visited)))) 4271 4272(de c!:cand (u env) (prog (w r) (setq w (reverse (cdr u))) (cond ((null w) ( 4273return (c!:cval nil env)))) (setq r (list (list (quote t) (car w)))) (setq w 4274(cdr w)) (prog (var1354) (setq var1354 w) lab1353 (cond ((null var1354) ( 4275return nil))) (prog (z) (setq z (car var1354)) (setq r (cons (list (list ( 4276quote null) z) nil) r))) (setq var1354 (cdr var1354)) (go lab1353)) (setq r ( 4277cons (quote cond) r)) (return (c!:cval r env)))) 4278 4279(put (quote and) (quote c!:code) (function c!:cand)) 4280 4281(de c!:ccatch (u env) (error 0 "catch")) 4282 4283(put (quote catch) (quote c!:code) (function c!:ccatch)) 4284 4285(de c!:ccompile_let (u env) (error 0 "compiler-let")) 4286 4287(put (quote compiler!-let) (quote c!:code) (function c!:ccompiler_let)) 4288 4289(de c!:ccond (u env) (prog (v join) (setq v (c!:newreg)) (setq join ( 4290c!:my_gensym)) (prog (var1356) (setq var1356 (cdr u)) lab1355 (cond ((null 4291var1356) (return nil))) (prog (c) (setq c (car var1356)) (prog (l1 l2) (setq 4292l1 (c!:my_gensym)) (setq l2 (c!:my_gensym)) (cond ((atom (cdr c)) (progn ( 4293c!:outop (quote movr) v nil (c!:cval (car c) env)) (c!:endblock (list (quote 4294ifnull) v) (list l2 join)))) (t (progn (c!:cjumpif (car c) env l1 l2) ( 4295c!:startblock l1) (c!:outop (quote movr) v nil (c!:cval (cons (quote progn) ( 4296cdr c)) env)) (c!:endblock (quote goto) (list join))))) (c!:startblock l2))) 4297(setq var1356 (cdr var1356)) (go lab1355)) (c!:outop (quote movk1) v nil nil) 4298(c!:endblock (quote goto) (list join)) (c!:startblock join) (return v))) 4299 4300(put (quote cond) (quote c!:code) (function c!:ccond)) 4301 4302(de c!:valid_cond (x) (cond ((null x) t) (t (cond ((not (c!:valid_list (car x 4303))) nil) (t (c!:valid_cond (cdr x))))))) 4304 4305(put (quote cond) (quote c!:valid) (function c!:valid_cond)) 4306 4307(de c!:cdeclare (u env) (error 0 "declare")) 4308 4309(put (quote declare) (quote c!:code) (function c!:cdeclare)) 4310 4311(de c!:cde (u env) (error 0 "de")) 4312 4313(put (quote de) (quote c!:code) (function c!:cde)) 4314 4315(de c!:cdefun (u env) (error 0 "defun")) 4316 4317(put (quote !~defun) (quote c!:code) (function c!:cdefun)) 4318 4319(de c!:ceval_when (u env) (error 0 "eval-when")) 4320 4321(put (quote eval!-when) (quote c!:code) (function c!:ceval_when)) 4322 4323(de c!:cflet (u env) (error 0 "flet")) 4324 4325(put (quote flet) (quote c!:code) (function c!:cflet)) 4326 4327(de c!:cfunction (u env) (prog (v) (setq u (cadr u)) (cond ((not (atom u)) ( 4328progn (cond ((not (eqcar u (quote lambda))) (error 0 (list 4329"lambda expression needed" u)))) (setq v (hashtagged!-name (quote lambda) u)) 4330(setq pending_functions (cons (cons (quote de) (cons v (cdr u))) 4331pending_functions)) (setq u v)))) (setq v (c!:newreg)) (c!:outop (quote movk) 4332v u (c!:find_literal u)) (return v))) 4333 4334(de c!:valid_function (x) (cond ((atom x) nil) (t (cond ((not (null (cdr x))) 4335nil) (t (cond ((idp (car x)) t) (t (cond ((atom (car x)) nil) (t (cond ((not 4336(eqcar (car x) (quote lambda))) nil) (t (cond ((atom (cdar x)) nil) (t ( 4337c!:valid_fndef (cadar x) (cddar x))))))))))))))) 4338 4339(put (quote function) (quote c!:code) (function c!:cfunction)) 4340 4341(put (quote function) (quote c!:valid) (function c!:valid_function)) 4342 4343(de c!:cgo (u env) (prog (w w1) (setq w1 proglabs) (prog nil lab1357 (cond (( 4344null (and (null w) w1)) (return nil))) (progn (setq w (assoc!*!* (cadr u) ( 4345car w1))) (setq w1 (cdr w1))) (go lab1357)) (cond ((null w) (error 0 (list u 4346"label not set")))) (c!:endblock (quote goto) (list (cadr w))) (return nil))) 4347 4348(put (quote go) (quote c!:code) (function c!:cgo)) 4349 4350(put (quote go) (quote c!:valid) (function c!:valid_quote)) 4351 4352(de c!:cif (u env) (prog (v join l1 l2 w) (setq v (c!:newreg)) (setq join ( 4353c!:my_gensym)) (setq l1 (c!:my_gensym)) (setq l2 (c!:my_gensym)) (c!:cjumpif 4354(car (setq u (cdr u))) env l1 l2) (c!:startblock l1) (c!:outop (quote movr) v 4355nil (c!:cval (car (setq u (cdr u))) env)) (c!:endblock (quote goto) (list 4356join)) (c!:startblock l2) (setq u (cdr u)) (cond (u (setq u (car u)))) ( 4357c!:outop (quote movr) v nil (c!:cval u env)) (c!:endblock (quote goto) (list 4358join)) (c!:startblock join) (return v))) 4359 4360(put (quote if) (quote c!:code) (function c!:cif)) 4361 4362(de c!:clabels (u env) (error 0 "labels")) 4363 4364(put (quote labels) (quote c!:code) (function c!:clabels)) 4365 4366(de c!:expand!-let (vl b) (cond ((null vl) (cons (quote progn) b)) (t (cond ( 4367(null (cdr vl)) (c!:expand!-let!* vl b)) (t (prog (vars vals) (prog (var1359) 4368(setq var1359 vl) lab1358 (cond ((null var1359) (return nil))) (prog (v) ( 4369setq v (car var1359)) (cond ((atom v) (progn (setq vars (cons v vars)) (setq 4370vals (cons nil vals)))) (t (cond ((atom (cdr v)) (progn (setq vars (cons (car 4371v) vars)) (setq vals (cons nil vals)))) (t (progn (setq vars (cons (car v) 4372vars)) (setq vals (cons (cadr v) vals)))))))) (setq var1359 (cdr var1359)) ( 4373go lab1358)) (return (cons (cons (quote lambda) (cons vars b)) vals)))))))) 4374 4375(de c!:clet (x env) (c!:cval (c!:expand!-let (cadr x) (cddr x)) env)) 4376 4377(de c!:valid_let (x) (cond ((null x) t) (t (cond ((not (c!:valid_cond (car x) 4378)) nil) (t (c!:valid_list (cdr x))))))) 4379 4380(put (quote !~let) (quote c!:code) (function c!:clet)) 4381 4382(put (quote !~let) (quote c!:valid) (function c!:valid_let)) 4383 4384(de c!:expand!-let!* (vl b) (cond ((null vl) (cons (quote progn) b)) (t (prog 4385(var val) (setq var (car vl)) (cond ((not (atom var)) (progn (setq val (cdr 4386var)) (setq var (car var)) (cond ((not (atom val)) (setq val (car val))))))) 4387(setq b (list (list (quote return) (c!:expand!-let!* (cdr vl) b)))) (cond ( 4388val (setq b (cons (list (quote setq) var val) b)))) (return (cons (quote prog 4389) (cons (list var) b))))))) 4390 4391(de c!:clet!* (x env) (c!:cval (c!:expand!-let!* (cadr x) (cddr x)) env)) 4392 4393(put (quote let!*) (quote c!:code) (function c!:clet!*)) 4394 4395(put (quote let!*) (quote c!:valid) (function c!:valid_let)) 4396 4397(de c!:clist (u env) (cond ((null (cdr u)) (c!:cval nil env)) (t (cond ((null 4398(cddr u)) (c!:cval (cons (quote ncons) (cdr u)) env)) (t (cond ((eqcar (cadr 4399u) (quote cons)) (c!:cval (list (quote acons) (cadr (cadr u)) (caddr (cadr u 4400)) (cons (quote list) (cddr u))) env)) (t (cond ((null (cdddr u)) (c!:cval ( 4401cons (quote list2) (cdr u)) env)) (t (cond ((null (cddddr u)) (c!:cval (cons 4402(quote list3) (cdr u)) env)) (t (cond ((null (cdr (cddddr u))) (c!:cval (cons 4403(quote list4) (cdr u)) env)) (t (c!:cval (list (quote list3!*) (cadr u) ( 4404caddr u) (cadddr u) (cons (quote list) (cddddr u))) env)))))))))))))) 4405 4406(put (quote list) (quote c!:code) (function c!:clist)) 4407 4408(de c!:clist!* (u env) (prog (v) (setq u (reverse (cdr u))) (setq v (car u)) 4409(prog (var1361) (setq var1361 (cdr u)) lab1360 (cond ((null var1361) (return 4410nil))) (prog (a) (setq a (car var1361)) (setq v (list (quote cons) a v))) ( 4411setq var1361 (cdr var1361)) (go lab1360)) (return (c!:cval v env)))) 4412 4413(put (quote list!*) (quote c!:code) (function c!:clist!*)) 4414 4415(de c!:ccons (u env) (prog (a1 a2) (setq a1 (s!:improve (cadr u))) (setq a2 ( 4416s!:improve (caddr u))) (cond ((or (equal a2 nil) (equal a2 (quote (quote nil) 4417)) (equal a2 (quote (list)))) (return (c!:cval (list (quote ncons) a1) env))) 4418) (cond ((eqcar a1 (quote cons)) (return (c!:cval (list (quote acons) (cadr 4419a1) (caddr a1) a2) env)))) (cond ((eqcar a2 (quote cons)) (return (c!:cval ( 4420list (quote list2!*) a1 (cadr a2) (caddr a2)) env)))) (cond ((eqcar a2 (quote 4421list)) (return (c!:cval (list (quote cons) a1 (list (quote cons) (cadr a2) ( 4422cons (quote list) (cddr a2)))) env)))) (return (c!:ccall (car u) (cdr u) env) 4423))) 4424 4425(put (quote cons) (quote c!:code) (function c!:ccons)) 4426 4427(de c!:cget (u env) (prog (a1 a2 w r r1) (setq a1 (s!:improve (cadr u))) ( 4428setq a2 (s!:improve (caddr u))) (cond ((and (eqcar a2 (quote quote)) (idp ( 4429setq w (cadr a2))) (setq w (symbol!-make!-fastget w nil))) (progn (setq r ( 4430c!:newreg)) (c!:outop (quote fastget) r (c!:cval a1 env) (cons w (cadr a2))) 4431(return r))) (t (return (c!:ccall (car u) (cdr u) env)))))) 4432 4433(put (quote get) (quote c!:code) (function c!:cget)) 4434 4435(de c!:cflag (u env) (prog (a1 a2 w r r1) (setq a1 (s!:improve (cadr u))) ( 4436setq a2 (s!:improve (caddr u))) (cond ((and (eqcar a2 (quote quote)) (idp ( 4437setq w (cadr a2))) (setq w (symbol!-make!-fastget w nil))) (progn (setq r ( 4438c!:newreg)) (c!:outop (quote fastflag) r (c!:cval a1 env) (cons w (cadr a2))) 4439(return r))) (t (return (c!:ccall (car u) (cdr u) env)))))) 4440 4441(put (quote flagp) (quote c!:code) (function c!:cflag)) 4442 4443(de c!:cgetv (u env) (cond ((not !*fastvector) (c!:ccall (car u) (cdr u) env) 4444) (t (c!:cval (cons (quote qgetv) (cdr u)) env)))) 4445 4446(put (quote getv) (quote c!:code) (function c!:cgetv)) 4447 4448(de c!:cputv (u env) (cond ((not !*fastvector) (c!:ccall (car u) (cdr u) env) 4449) (t (c!:cval (cons (quote qputv) (cdr u)) env)))) 4450 4451(put (quote putv) (quote c!:code) (function c!:cputv)) 4452 4453(de c!:cqputv (x env) (prog (rr) (setq rr (c!:evalargs (cdr x) env)) ( 4454c!:outop (quote qputv) (caddr rr) (car rr) (cadr rr)) (return (caddr rr)))) 4455 4456(put (quote qputv) (quote c!:code) (function c!:cqputv)) 4457 4458(de c!:cmacrolet (u env) (error 0 "macrolet")) 4459 4460(put (quote macrolet) (quote c!:code) (function c!:cmacrolet)) 4461 4462(de c!:cmultiple_value_call (u env) (error 0 "multiple_value_call")) 4463 4464(put (quote multiple!-value!-call) (quote c!:code) (function 4465c!:cmultiple_value_call)) 4466 4467(de c!:cmultiple_value_prog1 (u env) (error 0 "multiple_value_prog1")) 4468 4469(put (quote multiple!-value!-prog1) (quote c!:code) (function 4470c!:cmultiple_value_prog1)) 4471 4472(de c!:cor (u env) (prog (next done v r) (setq v (c!:newreg)) (setq done ( 4473c!:my_gensym)) (setq u (cdr u)) (prog nil lab1362 (cond ((null (cdr u)) ( 4474return nil))) (progn (setq next (c!:my_gensym)) (c!:outop (quote movr) v nil 4475(c!:cval (car u) env)) (setq u (cdr u)) (c!:endblock (list (quote ifnull) v) 4476(list next done)) (c!:startblock next)) (go lab1362)) (c!:outop (quote movr) 4477v nil (c!:cval (car u) env)) (c!:endblock (quote goto) (list done)) ( 4478c!:startblock done) (return v))) 4479 4480(put (quote or) (quote c!:code) (function c!:cor)) 4481 4482(de c!:cprog (u env) (prog (w w1 bvl local_proglabs progret progexit fluids 4483env1 body decs) (setq env1 (car env)) (setq bvl (cadr u)) (setq w ( 4484s!:find_local_decs (cddr u) t)) (setq body (cdr w)) (setq localdecs (cons ( 4485car w) localdecs)) (prog (var1364) (setq var1364 bvl) lab1363 (cond ((null 4486var1364) (return nil))) (prog (v) (setq v (car var1364)) (progn (cond ((and ( 4487not (globalp v)) (not (fluidp v)) (c!:local_fluidp v localdecs)) (progn ( 4488make!-special v) (setq decs (cons v decs))))))) (setq var1364 (cdr var1364)) 4489(go lab1363)) (prog (var1366) (setq var1366 bvl) lab1365 (cond ((null var1366 4490) (return nil))) (prog (v) (setq v (car var1366)) (progn (cond ((globalp v) ( 4491prog (oo) (setq oo (wrs nil)) (princ "+++++ ") (prin v) (princ 4492" converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v)) ( 4493fluid (list v))))) (cond ((fluidp v) (progn (setq fluids (cons (cons v ( 4494c!:newreg)) fluids)) (flag (list (cdar fluids)) (quote c!:live_across_call)) 4495(setq env1 (cons (cons (quote c!:dummy!:name) (cdar fluids)) env1)) ( 4496c!:start_nested_context) (c!:outop (quote fluidbind) (cdar fluids) v ( 4497c!:find_literal v)) (cond ((eqcar u (quote prog)) (c!:outop (quote nilglob) 4498nil v (c!:find_literal v)))))) (t (progn (setq env1 (cons (cons v (c!:newreg) 4499) env1)) (c!:outop (quote movk1) (cdar env1) nil nil)))))) (setq var1366 (cdr 4500var1366)) (go lab1365)) (setq env (cons env1 (append fluids (cdr env)))) ( 4501setq u body) (setq progret (c!:newreg)) (setq progexit (c!:my_gensym)) (setq 4502blockstack (cons (cons nil (cons progret progexit)) blockstack)) (prog ( 4503var1368) (setq var1368 u) lab1367 (cond ((null var1368) (return nil))) (prog 4504(a) (setq a (car var1368)) (cond ((atom a) (cond ((atsoc a local_proglabs) ( 4505progn (cond ((not (null a)) (progn (setq w (wrs nil)) (princ 4506"+++++ multiply defined label: ") (prin a) (terpri) (wrs w)))))) (t (setq 4507local_proglabs (cons (list a (c!:my_gensym)) local_proglabs))))))) (setq 4508var1368 (cdr var1368)) (go lab1367)) (setq proglabs (cons local_proglabs 4509proglabs)) (prog (var1370) (setq var1370 u) lab1369 (cond ((null var1370) ( 4510return nil))) (prog (a) (setq a (car var1370)) (cond ((atom a) (progn (setq w 4511(cdr (assoc!*!* a local_proglabs))) (cond ((null (cdr w)) (progn (rplacd w t 4512) (c!:endblock (quote goto) (list (car w))) (c!:startblock (car w))))))) (t ( 4513c!:cval a env)))) (setq var1370 (cdr var1370)) (go lab1369)) (c!:outop (quote 4514movk1) progret nil nil) (c!:endblock (quote goto) (list progexit)) ( 4515c!:startblock progexit) (prog (var1372) (setq var1372 fluids) lab1371 (cond ( 4516(null var1372) (return nil))) (prog (v) (setq v (car var1372)) (progn ( 4517c!:end_nested_context) (c!:outop (quote fluidunbind) (cdr v) (car v) ( 4518c!:find_literal (car v))))) (setq var1372 (cdr var1372)) (go lab1371)) (setq 4519blockstack (cdr blockstack)) (setq proglabs (cdr proglabs)) (unfluid decs) ( 4520setq localdecs (cdr localdecs)) (return progret))) 4521 4522(put (quote prog) (quote c!:code) (function c!:cprog)) 4523 4524(put (quote !~prog) (quote c!:code) (function c!:cprog)) 4525 4526(de c!:valid_prog (x) (c!:valid_list (cdr x))) 4527 4528(put (quote prog) (quote c!:valid) (function c!:valid_prog)) 4529 4530(put (quote !~prog) (quote c!:valid) (function c!:valid_prog)) 4531 4532(de c!:cprog!* (u env) (error 0 "prog*")) 4533 4534(put (quote prog!*) (quote c!:code) (function c!:cprog!*)) 4535 4536(de c!:cprog1 (u env) (prog (g) (setq g (c!:my_gensym)) (setq g (list (quote 4537prog) (list g) (list (quote setq) g (cadr u)) (cons (quote progn) (cddr u)) ( 4538list (quote return) g))) (return (c!:cval g env)))) 4539 4540(put (quote prog1) (quote c!:code) (function c!:cprog1)) 4541 4542(de c!:cprog2 (u env) (prog (g) (setq u (cdr u)) (setq g (c!:my_gensym)) ( 4543setq g (list (quote prog) (list g) (list (quote setq) g (cadr u)) (cons ( 4544quote progn) (cddr u)) (list (quote return) g))) (setq g (list (quote progn) 4545(car u) g)) (return (c!:cval g env)))) 4546 4547(put (quote prog2) (quote c!:code) (function c!:cprog2)) 4548 4549(de c!:cprogn (u env) (prog (r) (setq u (cdr u)) (cond ((equal u nil) (setq u 4550(quote (nil))))) (prog (var1374) (setq var1374 u) lab1373 (cond ((null 4551var1374) (return nil))) (prog (s) (setq s (car var1374)) (setq r (c!:cval s 4552env))) (setq var1374 (cdr var1374)) (go lab1373)) (return r))) 4553 4554(put (quote progn) (quote c!:code) (function c!:cprogn)) 4555 4556(de c!:cprogv (u env) (error 0 "progv")) 4557 4558(put (quote progv) (quote c!:code) (function c!:cprogv)) 4559 4560(de c!:cquote (u env) (prog (v) (setq u (cadr u)) (setq v (c!:newreg)) (cond 4561((or (null u) (equal u (quote t)) (c!:small_number u)) (c!:outop (quote movk1 4562) v nil u)) (t (c!:outop (quote movk) v u (c!:find_literal u)))) (return v))) 4563 4564(de c!:valid_quote (x) t) 4565 4566(put (quote quote) (quote c!:code) (function c!:cquote)) 4567 4568(put (quote quote) (quote c!:valid) (function c!:valid_quote)) 4569 4570(de c!:creturn (u env) (prog (w) (setq w (assoc!*!* nil blockstack)) (cond (( 4571null w) (error 0 "RETURN out of context"))) (c!:outop (quote movr) (cadr w) 4572nil (c!:cval (cadr u) env)) (c!:endblock (quote goto) (list (cddr w))) ( 4573return nil))) 4574 4575(put (quote return) (quote c!:code) (function c!:creturn)) 4576 4577(put (quote return!-from) (quote c!:code) (function c!:creturn_from)) 4578 4579(de c!:csetq (u env) (prog (v w) (setq v (c!:cval (caddr u) env)) (setq u ( 4580cadr u)) (cond ((not (idp u)) (error 0 (list u "bad variable in setq"))) (t ( 4581cond ((setq w (c!:locally_bound u env)) (c!:outop (quote movr) (cdr w) nil v) 4582) (t (cond ((flagp u (quote c!:constant)) (error 0 (list u 4583"attempt to use setq on a constant"))) (t (c!:outop (quote strglob) v u ( 4584c!:find_literal u)))))))) (return v))) 4585 4586(put (quote setq) (quote c!:code) (function c!:csetq)) 4587 4588(put (quote noisy!-setq) (quote c!:code) (function c!:csetq)) 4589 4590(de c!:cprivate_tagbody (u env) (prog nil (setq u (cdr u)) (c!:endblock ( 4591quote goto) (list (car u))) (c!:startblock (car u)) (setq c!:current_args ( 4592prog (var1376 var1377) (setq var1376 c!:current_args) lab1375 (cond ((null 4593var1376) (return (reversip var1377)))) (prog (v) (setq v (car var1376)) (setq 4594var1377 (cons (prog (z) (setq z (assoc!*!* v (car env))) (return (cond (z ( 4595cdr z)) (t v)))) var1377))) (setq var1376 (cdr var1376)) (go lab1375))) ( 4596return (c!:cval (cadr u) env)))) 4597 4598(put (quote c!:private_tagbody) (quote c!:code) (function c!:cprivate_tagbody 4599)) 4600 4601(de c!:cthe (u env) (c!:cval (caddr u) env)) 4602 4603(put (quote the) (quote c!:code) (function c!:cthe)) 4604 4605(de c!:cunless (u env) (prog (v join l1 l2) (setq v (c!:newreg)) (setq join ( 4606c!:my_gensym)) (setq l1 (c!:my_gensym)) (setq l2 (c!:my_gensym)) (c!:cjumpif 4607(cadr u) env l2 l1) (c!:startblock l1) (c!:outop (quote movr) v nil (c!:cval 4608(cons (quote progn) (cddr u)) env)) (c!:endblock (quote goto) (list join)) ( 4609c!:startblock l2) (c!:outop (quote movk1) v nil nil) (c!:endblock (quote goto 4610) (list join)) (c!:startblock join) (return v))) 4611 4612(put (quote unless) (quote c!:code) (function c!:cunless)) 4613 4614(de c!:cunwind_protect (u env) (error 0 "unwind_protect")) 4615 4616(put (quote unwind!-protect) (quote c!:code) (function c!:cunwind_protect)) 4617 4618(de c!:cwhen (u env) (prog (v join l1 l2) (setq v (c!:newreg)) (setq join ( 4619c!:my_gensym)) (setq l1 (c!:my_gensym)) (setq l2 (c!:my_gensym)) (c!:cjumpif 4620(cadr u) env l1 l2) (c!:startblock l1) (c!:outop (quote movr) v nil (c!:cval 4621(cons (quote progn) (cddr u)) env)) (c!:endblock (quote goto) (list join)) ( 4622c!:startblock l2) (c!:outop (quote movk1) v nil nil) (c!:endblock (quote goto 4623) (list join)) (c!:startblock join) (return v))) 4624 4625(put (quote when) (quote c!:code) (function c!:cwhen)) 4626 4627(de c!:expand_map (fnargs) (prog (carp fn fn1 args var avar moveon l1 r s 4628closed) (setq fn (car fnargs)) (cond ((or (equal fn (quote mapc)) (equal fn ( 4629quote mapcar)) (equal fn (quote mapcan))) (setq carp t))) (setq fnargs (cdr 4630fnargs)) (cond ((atom fnargs) (error 0 "bad arguments to map function"))) ( 4631setq fn1 (cadr fnargs)) (prog nil lab1378 (cond ((null (or (eqcar fn1 (quote 4632function)) (and (eqcar fn1 (quote quote)) (eqcar (cadr fn1) (quote lambda)))) 4633) (return nil))) (progn (setq fn1 (cadr fn1)) (setq closed t)) (go lab1378)) 4634(setq args (car fnargs)) (setq l1 (c!:my_gensym)) (setq r (c!:my_gensym)) ( 4635setq s (c!:my_gensym)) (setq var (c!:my_gensym)) (setq avar var) (cond (carp 4636(setq avar (list (quote car) avar)))) (cond (closed (setq fn1 (list fn1 avar) 4637)) (t (setq fn1 (list (quote apply1) fn1 avar)))) (setq moveon (list (quote 4638setq) var (list (quote cdr) var))) (cond ((or (equal fn (quote map)) (equal 4639fn (quote mapc))) (setq fn (sublis (list (cons (quote l1) l1) (cons (quote 4640var) var) (cons (quote fn) fn1) (cons (quote args) args) (cons (quote moveon) 4641moveon)) (quote (prog (var) (setq var args) l1 (cond ((not var) (return nil) 4642)) fn moveon (go l1)))))) (t (cond ((or (equal fn (quote maplist)) (equal fn 4643(quote mapcar))) (setq fn (sublis (list (cons (quote l1) l1) (cons (quote var 4644) var) (cons (quote fn) fn1) (cons (quote args) args) (cons (quote moveon) 4645moveon) (cons (quote r) r)) (quote (prog (var r) (setq var args) l1 (cond (( 4646not var) (return (reversip r)))) (setq r (cons fn r)) moveon (go l1)))))) (t 4647(setq fn (sublis (list (cons (quote l1) l1) (cons (quote l2) (c!:my_gensym)) 4648(cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) (cons ( 4649quote moveon) moveon) (cons (quote r) (c!:my_gensym)) (cons (quote s) ( 4650c!:my_gensym))) (quote (prog (var r s) (setq var args) (setq r (setq s (list 4651nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond ((not ( 4652atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))))))))) (return fn)) 4653) 4654 4655(put (quote map) (quote c!:compile_macro) (function c!:expand_map)) 4656 4657(put (quote maplist) (quote c!:compile_macro) (function c!:expand_map)) 4658 4659(put (quote mapc) (quote c!:compile_macro) (function c!:expand_map)) 4660 4661(put (quote mapcar) (quote c!:compile_macro) (function c!:expand_map)) 4662 4663(put (quote mapcon) (quote c!:compile_macro) (function c!:expand_map)) 4664 4665(put (quote mapcan) (quote c!:compile_macro) (function c!:expand_map)) 4666 4667(de c!:expand_carcdr (x) (prog (name) (setq name (cdr (reverse (cdr (explode2 4668(car x)))))) (setq x (cadr x)) (prog (var1380) (setq var1380 name) lab1379 ( 4669cond ((null var1380) (return nil))) (prog (v) (setq v (car var1380)) (setq x 4670(list (cond ((equal v (quote a)) (quote car)) (t (quote cdr))) x))) (setq 4671var1380 (cdr var1380)) (go lab1379)) (return x))) 4672 4673(progn (put (quote caar) (quote c!:compile_macro) (function c!:expand_carcdr) 4674) (put (quote cadr) (quote c!:compile_macro) (function c!:expand_carcdr)) ( 4675put (quote cdar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put ( 4676quote cddr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4677caaar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4678caadr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4679cadar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4680caddr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4681cdaar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4682cdadr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4683cddar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4684cdddr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4685caaaar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4686caaadr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4687caadar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4688caaddr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4689cadaar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4690cadadr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4691caddar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4692cadddr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4693cdaaar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4694cdaadr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4695cdadar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4696cdaddr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4697cddaar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4698cddadr) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4699cdddar) (quote c!:compile_macro) (function c!:expand_carcdr)) (put (quote 4700cddddr) (quote c!:compile_macro) (function c!:expand_carcdr))) 4701 4702(de c!:builtin_one (x env) (prog (r1 r2) (setq r1 (c!:cval (cadr x) env)) ( 4703c!:outop (car x) (setq r2 (c!:newreg)) (cdr env) r1) (return r2))) 4704 4705(de c!:builtin_two (x env) (prog (a1 a2 r rr) (setq a1 (cadr x)) (setq a2 ( 4706caddr x)) (setq rr (c!:evalargs (list a1 a2) env)) (c!:outop (car x) (setq r 4707(c!:newreg)) (car rr) (cadr rr)) (return r))) 4708 4709(de c!:rplac (x env) (prog (a1 a2 r rr) (setq a1 (cadr x)) (setq a2 (caddr x) 4710) (setq rr (c!:evalargs (list a1 a2) env)) (c!:outop (car x) nil (car rr) ( 4711cadr rr)) (c!:outop (quote movr) (setq r (c!:newreg)) nil (car rr)) (return r 4712))) 4713 4714(put (quote rplaca) (quote c!:code) (function c!:rplac)) 4715 4716(put (quote rplacd) (quote c!:code) (function c!:rplac)) 4717 4718(de c!:narg (x env) (c!:cval (expand (cdr x) (get (car x) (quote 4719c!:binary_version))) env)) 4720 4721(prog (var1382) (setq var1382 (quote ((plus plus2) (times times2) (iplus 4722iplus2) (itimes itimes2)))) lab1381 (cond ((null var1382) (return nil))) ( 4723prog (n) (setq n (car var1382)) (progn (put (car n) (quote c!:binary_version) 4724(cadr n)) (put (car n) (quote c!:code) (function c!:narg)))) (setq var1382 ( 4725cdr var1382)) (go lab1381)) 4726 4727(de c!:cplus2 (u env) (prog (a b) (setq a (s!:improve (cadr u))) (setq b ( 4728s!:improve (caddr u))) (return (cond ((and (numberp a) (numberp b)) (c!:cval 4729(plus a b) env)) (t (cond ((equal a 0) (c!:cval b env)) (t (cond ((equal a 1) 4730(c!:cval (list (quote add1) b) env)) (t (cond ((equal b 0) (c!:cval a env)) 4731(t (cond ((equal b 1) (c!:cval (list (quote add1) a) env)) (t (cond ((equal b 4732(minus 1)) (c!:cval (list (quote sub1) a) env)) (t (c!:ccall (car u) (cdr u) 4733env)))))))))))))))) 4734 4735(put (quote plus2) (quote c!:code) (function c!:cplus2)) 4736 4737(de c!:ciplus2 (u env) (prog (a b) (setq a (s!:improve (cadr u))) (setq b ( 4738s!:improve (caddr u))) (return (cond ((and (numberp a) (numberp b)) (c!:cval 4739(plus a b) env)) (t (cond ((equal a 0) (c!:cval b env)) (t (cond ((equal a 1) 4740(c!:cval (list (quote iadd1) b) env)) (t (cond ((equal b 0) (c!:cval a env)) 4741(t (cond ((equal b 1) (c!:cval (list (quote iadd1) a) env)) (t (cond ((equal 4742b (minus 1)) (c!:cval (list (quote isub1) a) env)) (t (c!:builtin_two u env) 4743))))))))))))))) 4744 4745(put (quote iplus2) (quote c!:code) (function c!:ciplus2)) 4746 4747(de c!:cdifference (u env) (prog (a b) (setq a (s!:improve (cadr u))) (setq b 4748(s!:improve (caddr u))) (return (cond ((and (numberp a) (numberp b)) ( 4749c!:cval (difference a b) env)) (t (cond ((equal a 0) (c!:cval (list (quote 4750minus) b) env)) (t (cond ((equal b 0) (c!:cval a env)) (t (cond ((equal b 1) 4751(c!:cval (list (quote sub1) a) env)) (t (cond ((equal b (minus 1)) (c!:cval ( 4752list (quote add1) a) env)) (t (c!:ccall (car u) (cdr u) env)))))))))))))) 4753 4754(put (quote difference) (quote c!:code) (function c!:cdifference)) 4755 4756(de c!:cidifference (u env) (prog (a b) (setq a (s!:improve (cadr u))) (setq 4757b (s!:improve (caddr u))) (return (cond ((and (numberp a) (numberp b)) ( 4758c!:cval (difference a b) env)) (t (cond ((equal a 0) (c!:cval (list (quote 4759iminus) b) env)) (t (cond ((equal b 0) (c!:cval a env)) (t (cond ((equal b 1) 4760(c!:cval (list (quote isub1) a) env)) (t (cond ((equal b (minus 1)) (c!:cval 4761(list (quote iadd1) a) env)) (t (c!:builtin_two u env)))))))))))))) 4762 4763(put (quote idifference) (quote c!:code) (function c!:cidifference)) 4764 4765(de c!:ctimes2 (u env) (prog (a b) (setq a (s!:improve (cadr u))) (setq b ( 4766s!:improve (caddr u))) (return (cond ((and (numberp a) (numberp b)) (c!:cval 4767(times a b) env)) (t (cond ((or (equal a 0) (equal b 0)) (c!:cval 0 env)) (t 4768(cond ((equal a 1) (c!:cval b env)) (t (cond ((equal b 1) (c!:cval a env)) (t 4769(cond ((equal a (minus 1)) (c!:cval (list (quote minus) b) env)) (t (cond (( 4770equal b (minus 1)) (c!:cval (list (quote minus) a) env)) (t (c!:ccall (car u) 4771(cdr u) env)))))))))))))))) 4772 4773(put (quote times2) (quote c!:code) (function c!:ctimes2)) 4774 4775(de c!:citimes2 (u env) (prog (a b) (setq a (s!:improve (cadr u))) (setq b ( 4776s!:improve (caddr u))) (return (cond ((and (numberp a) (numberp b)) (c!:cval 4777(times a b) env)) (t (cond ((or (equal a 0) (equal b 0)) (c!:cval 0 env)) (t 4778(cond ((equal a 1) (c!:cval b env)) (t (cond ((equal b 1) (c!:cval a env)) (t 4779(cond ((equal a (minus 1)) (c!:cval (list (quote iminus) b) env)) (t (cond ( 4780(equal b (minus 1)) (c!:cval (list (quote iminus) a) env)) (t (c!:builtin_two 4781u env)))))))))))))))) 4782 4783(put (quote itimes2) (quote c!:code) (function c!:citimes2)) 4784 4785(de c!:cminus (u env) (prog (a b) (setq a (s!:improve (cadr u))) (return ( 4786cond ((numberp a) (c!:cval (minus a) env)) (t (cond ((eqcar a (quote minus)) 4787(c!:cval (cadr a) env)) (t (c!:ccall (car u) (cdr u) env)))))))) 4788 4789(put (quote minus) (quote c!:code) (function c!:cminus)) 4790 4791(de c!:ceq (x env) (prog (a1 a2 r rr) (setq a1 (s!:improve (cadr x))) (setq 4792a2 (s!:improve (caddr x))) (cond ((equal a1 nil) (return (c!:cval (list ( 4793quote null) a2) env))) (t (cond ((equal a2 nil) (return (c!:cval (list (quote 4794null) a1) env)))))) (setq rr (c!:evalargs (list a1 a2) env)) (c!:outop ( 4795quote eq) (setq r (c!:newreg)) (car rr) (cadr rr)) (return r))) 4796 4797(put (quote eq) (quote c!:code) (function c!:ceq)) 4798 4799(de c!:cequal (x env) (prog (a1 a2 r rr) (setq a1 (s!:improve (cadr x))) ( 4800setq a2 (s!:improve (caddr x))) (cond ((equal a1 nil) (return (c!:cval (list 4801(quote null) a2) env))) (t (cond ((equal a2 nil) (return (c!:cval (list ( 4802quote null) a1) env)))))) (setq rr (c!:evalargs (list a1 a2) env)) (c!:outop 4803(cond ((or (c!:eqvalid a1) (c!:eqvalid a2)) (quote eq)) (t (quote equal))) ( 4804setq r (c!:newreg)) (car rr) (cadr rr)) (return r))) 4805 4806(put (quote equal) (quote c!:code) (function c!:cequal)) 4807 4808(de c!:is_fixnum (x) (and (fixp x) (geq x (minus 134217728)) (leq x 134217727 4809))) 4810 4811(de c!:certainlyatom (x) (or (null x) (equal x t) (c!:is_fixnum x) (and ( 4812eqcar x (quote quote)) (or (symbolp (cadr x)) (c!:is_fixnum (cadr x)))))) 4813 4814(de c!:atomlist1 (u) (or (atom u) (and (or (symbolp (car u)) (c!:is_fixnum ( 4815car u))) (c!:atomlist1 (cdr u))))) 4816 4817(de c!:atomlist (x) (or (null x) (and (eqcar x (quote quote)) (c!:atomlist1 ( 4818cadr x))) (and (eqcar x (quote list)) (or (null (cdr x)) (and ( 4819c!:certainlyatom (cadr x)) (c!:atomlist (cons (quote list) (cddr x)))))) (and 4820(eqcar x (quote cons)) (c!:certainlyatom (cadr x)) (c!:atomlist (caddr x)))) 4821) 4822 4823(de c!:atomcar (x) (and (or (eqcar x (quote cons)) (eqcar x (quote list))) ( 4824not (null (cdr x))) (c!:certainlyatom (cadr x)))) 4825 4826(de c!:atomkeys1 (u) (or (atom u) (and (not (atom (car u))) (or (symbolp ( 4827caar u)) (c!:is_fixnum (caar u))) (c!:atomlist1 (cdr u))))) 4828 4829(de c!:atomkeys (x) (or (null x) (and (eqcar x (quote quote)) (c!:atomkeys1 ( 4830cadr x))) (and (eqcar x (quote list)) (or (null (cdr x)) (and (c!:atomcar ( 4831cadr x)) (c!:atomkeys (cons (quote list) (cddr x)))))) (and (eqcar x (quote 4832cons)) (c!:atomcar (cadr x)) (c!:atomkeys (caddr x))))) 4833 4834(de c!:comsublis (x) (cond ((c!:atomkeys (cadr x)) (cons (quote subla) (cdr x 4835))) (t nil))) 4836 4837(put (quote sublis) (quote c!:compile_macro) (function c!:comsublis)) 4838 4839(de c!:comassoc (x) (cond ((or (c!:certainlyatom (cadr x)) (c!:atomkeys ( 4840caddr x))) (cons (quote atsoc) (cdr x))) (t nil))) 4841 4842(put (quote assoc) (quote c!:compile_macro) (function c!:comassoc)) 4843 4844(put (quote assoc!*!*) (quote c!:compile_macro) (function c!:comassoc)) 4845 4846(de c!:commember (x) (cond ((or (c!:certainlyatom (cadr x)) (c!:atomlist ( 4847caddr x))) (cons (quote memq) (cdr x))) (t nil))) 4848 4849(put (quote member) (quote c!:compile_macro) (function c!:commember)) 4850 4851(de c!:comdelete (x) (cond ((or (c!:certainlyatom (cadr x)) (c!:atomlist ( 4852caddr x))) (cons (quote deleq) (cdr x))) (t nil))) 4853 4854(put (quote delete) (quote c!:compile_macro) (function c!:comdelete)) 4855 4856(de c!:ctestif (x env d1 d2) (prog (l1 l2) (setq l1 (c!:my_gensym)) (setq l2 4857(c!:my_gensym)) (c!:jumpif (cadr x) l1 l2) (setq x (cddr x)) (c!:startblock 4858l1) (c!:jumpif (car x) d1 d2) (c!:startblock l2) (c!:jumpif (cadr x) d1 d2))) 4859 4860(put (quote if) (quote c!:ctest) (function c!:ctestif)) 4861 4862(de c!:ctestnull (x env d1 d2) (c!:cjumpif (cadr x) env d2 d1)) 4863 4864(put (quote null) (quote c!:ctest) (function c!:ctestnull)) 4865 4866(put (quote not) (quote c!:ctest) (function c!:ctestnull)) 4867 4868(de c!:ctestatom (x env d1 d2) (prog nil (setq x (c!:cval (cadr x) env)) ( 4869c!:endblock (list (quote ifatom) x) (list d1 d2)))) 4870 4871(put (quote atom) (quote c!:ctest) (function c!:ctestatom)) 4872 4873(de c!:ctestconsp (x env d1 d2) (prog nil (setq x (c!:cval (cadr x) env)) ( 4874c!:endblock (list (quote ifatom) x) (list d2 d1)))) 4875 4876(put (quote consp) (quote c!:ctest) (function c!:ctestconsp)) 4877 4878(de c!:ctestsymbol (x env d1 d2) (prog nil (setq x (c!:cval (cadr x) env)) ( 4879c!:endblock (list (quote ifsymbol) x) (list d1 d2)))) 4880 4881(put (quote idp) (quote c!:ctest) (function c!:ctestsymbol)) 4882 4883(de c!:ctestnumberp (x env d1 d2) (prog nil (setq x (c!:cval (cadr x) env)) ( 4884c!:endblock (list (quote ifnumber) x) (list d1 d2)))) 4885 4886(put (quote numberp) (quote c!:ctest) (function c!:ctestnumberp)) 4887 4888(de c!:ctestizerop (x env d1 d2) (prog nil (setq x (c!:cval (cadr x) env)) ( 4889c!:endblock (list (quote ifizerop) x) (list d1 d2)))) 4890 4891(put (quote izerop) (quote c!:ctest) (function c!:ctestizerop)) 4892 4893(de c!:ctesteq (x env d1 d2) (prog (a1 a2 r) (setq a1 (cadr x)) (setq a2 ( 4894caddr x)) (cond ((equal a1 nil) (return (c!:cjumpif a2 env d2 d1))) (t (cond 4895((equal a2 nil) (return (c!:cjumpif a1 env d2 d1)))))) (setq r (c!:evalargs ( 4896list a1 a2) env)) (c!:endblock (cons (quote ifeq) r) (list d1 d2)))) 4897 4898(put (quote eq) (quote c!:ctest) (function c!:ctesteq)) 4899 4900(de c!:ctesteqcar (x env d1 d2) (prog (a1 a2 r d3) (setq a1 (cadr x)) (setq 4901a2 (caddr x)) (setq d3 (c!:my_gensym)) (setq r (c!:evalargs (list a1 a2) env) 4902) (c!:endblock (list (quote ifatom) (car r)) (list d2 d3)) (c!:startblock d3) 4903(c!:outop (quote qcar) (car r) nil (car r)) (c!:endblock (cons (quote ifeq) 4904r) (list d1 d2)))) 4905 4906(put (quote eqcar) (quote c!:ctest) (function c!:ctesteqcar)) 4907 4908(global (quote (least_fixnum greatest_fixnum))) 4909 4910(setq least_fixnum (minus (expt 2 27))) 4911 4912(setq greatest_fixnum (difference (expt 2 27) 1)) 4913 4914(de c!:small_number (x) (and (fixp x) (geq x least_fixnum) (leq x 4915greatest_fixnum))) 4916 4917(de c!:eqvalid (x) (cond ((atom x) (c!:small_number x)) (t (cond ((flagp (car 4918x) (quote c!:fixnum_fn)) t) (t (and (equal (car x) (quote quote)) (or (idp ( 4919cadr x)) (c!:small_number (cadr x))))))))) 4920 4921(flag (quote (iplus iplus2 idifference iminus itimes itimes2)) (quote 4922c!:fixnum_fn)) 4923 4924(de c!:ctestequal (x env d1 d2) (prog (a1 a2 r) (setq a1 (s!:improve (cadr x) 4925)) (setq a2 (s!:improve (caddr x))) (cond ((equal a1 nil) (return (c!:cjumpif 4926a2 env d2 d1))) (t (cond ((equal a2 nil) (return (c!:cjumpif a1 env d2 d1))) 4927))) (setq r (c!:evalargs (list a1 a2) env)) (c!:endblock (cons (cond ((or ( 4928c!:eqvalid a1) (c!:eqvalid a2)) (quote ifeq)) (t (quote ifequal))) r) (list 4929d1 d2)))) 4930 4931(put (quote equal) (quote c!:ctest) (function c!:ctestequal)) 4932 4933(de c!:ctestneq (x env d1 d2) (prog (a1 a2 r) (setq a1 (s!:improve (cadr x))) 4934(setq a2 (s!:improve (caddr x))) (cond ((equal a1 nil) (return (c!:cjumpif 4935a2 env d1 d2))) (t (cond ((equal a2 nil) (return (c!:cjumpif a1 env d1 d2)))) 4936)) (setq r (c!:evalargs (list a1 a2) env)) (c!:endblock (cons (cond ((or ( 4937c!:eqvalid a1) (c!:eqvalid a2)) (quote ifeq)) (t (quote ifequal))) r) (list 4938d2 d1)))) 4939 4940(put (quote neq) (quote c!:ctest) (function c!:ctestneq)) 4941 4942(de c!:ctestilessp (x env d1 d2) (prog (r) (setq r (c!:evalargs (list (cadr x 4943) (caddr x)) env)) (c!:endblock (cons (quote ifilessp) r) (list d1 d2)))) 4944 4945(put (quote ilessp) (quote c!:ctest) (function c!:ctestilessp)) 4946 4947(de c!:ctestigreaterp (x env d1 d2) (prog (r) (setq r (c!:evalargs (list ( 4948cadr x) (caddr x)) env)) (c!:endblock (cons (quote ifigreaterp) r) (list d1 4949d2)))) 4950 4951(put (quote igreaterp) (quote c!:ctest) (function c!:ctestigreaterp)) 4952 4953(de c!:ctestand (x env d1 d2) (prog (next) (prog (var1384) (setq var1384 (cdr 4954x)) lab1383 (cond ((null var1384) (return nil))) (prog (a) (setq a (car 4955var1384)) (progn (setq next (c!:my_gensym)) (c!:cjumpif a env next d2) ( 4956c!:startblock next))) (setq var1384 (cdr var1384)) (go lab1383)) (c!:endblock 4957(quote goto) (list d1)))) 4958 4959(put (quote and) (quote c!:ctest) (function c!:ctestand)) 4960 4961(de c!:ctestor (x env d1 d2) (prog (next) (prog (var1386) (setq var1386 (cdr 4962x)) lab1385 (cond ((null var1386) (return nil))) (prog (a) (setq a (car 4963var1386)) (progn (setq next (c!:my_gensym)) (c!:cjumpif a env d1 next) ( 4964c!:startblock next))) (setq var1386 (cdr var1386)) (go lab1385)) (c!:endblock 4965(quote goto) (list d2)))) 4966 4967(put (quote or) (quote c!:ctest) (function c!:ctestor)) 4968 4969(fluid (quote (c!:c_entrypoint_list))) 4970 4971(null (setq c!:c_entrypoint_list (quote ((abs c!:c_entrypoint "Labsval") ( 4972apply0 c!:c_entrypoint "Lapply0") (apply1 c!:c_entrypoint "Lapply1") (apply2 4973c!:c_entrypoint "Lapply2") (apply3 c!:c_entrypoint "Lapply3") (ash1 4974c!:c_entrypoint "Lash1") (atan c!:c_entrypoint "Latan") (atom c!:c_entrypoint 4975"Latom") (atsoc c!:c_entrypoint "Latsoc") (batchp c!:c_entrypoint "Lbatchp") 4976(boundp c!:c_entrypoint "Lboundp") (bps!-putv c!:c_entrypoint "Lbpsputv") ( 4977caaaar c!:c_entrypoint "Lcaaaar") (caaadr c!:c_entrypoint "Lcaaadr") (caaar 4978c!:c_entrypoint "Lcaaar") (caadar c!:c_entrypoint "Lcaadar") (caaddr 4979c!:c_entrypoint "Lcaaddr") (caadr c!:c_entrypoint "Lcaadr") (caar 4980c!:c_entrypoint "Lcaar") (cadaar c!:c_entrypoint "Lcadaar") (cadadr 4981c!:c_entrypoint "Lcadadr") (cadar c!:c_entrypoint "Lcadar") (caddar 4982c!:c_entrypoint "Lcaddar") (cadddr c!:c_entrypoint "Lcadddr") (caddr 4983c!:c_entrypoint "Lcaddr") (cadr c!:c_entrypoint "Lcadr") (car c!:c_entrypoint 4984"Lcar") (cdaaar c!:c_entrypoint "Lcdaaar") (cdaadr c!:c_entrypoint "Lcdaadr" 4985) (cdaar c!:c_entrypoint "Lcdaar") (cdadar c!:c_entrypoint "Lcdadar") (cdaddr 4986c!:c_entrypoint "Lcdaddr") (cdadr c!:c_entrypoint "Lcdadr") (cdar 4987c!:c_entrypoint "Lcdar") (cddaar c!:c_entrypoint "Lcddaar") (cddadr 4988c!:c_entrypoint "Lcddadr") (cddar c!:c_entrypoint "Lcddar") (cdddar 4989c!:c_entrypoint "Lcdddar") (cddddr c!:c_entrypoint "Lcddddr") (cdddr 4990c!:c_entrypoint "Lcdddr") (cddr c!:c_entrypoint "Lcddr") (cdr c!:c_entrypoint 4991"Lcdr") (char!-code c!:c_entrypoint "Lchar_code") (close c!:c_entrypoint 4992"Lclose") (codep c!:c_entrypoint "Lcodep") (constantp c!:c_entrypoint 4993"Lconstantp") (date c!:c_entrypoint "Ldate") (deleq c!:c_entrypoint "Ldeleq") 4994(digit c!:c_entrypoint "Ldigitp") (eject c!:c_entrypoint "Leject") (endp 4995c!:c_entrypoint "Lendp") (eq c!:c_entrypoint "Leq") (eqcar c!:c_entrypoint 4996"Leqcar") (eql c!:c_entrypoint "Leql") (eqn c!:c_entrypoint "Leqn_2") (error1 4997c!:c_entrypoint "Lerror_0") (evenp c!:c_entrypoint "Levenp") (evlis 4998c!:c_entrypoint "Levlis") (explode c!:c_entrypoint "Lexplode") (explode2 4999c!:c_entrypoint "Lexplodec") (explodec c!:c_entrypoint "Lexplodec") (expt 5000c!:c_entrypoint "Lexpt") (fix c!:c_entrypoint "Ltruncate") (fixp 5001c!:c_entrypoint "Lfixp") (flag c!:c_entrypoint "Lflag") (flagp!*!* 5002c!:c_entrypoint "Lflagp") (flagp c!:c_entrypoint "Lflagp") (flagpcar 5003c!:c_entrypoint "Lflagpcar") (float c!:c_entrypoint "Lfloat") (floatp 5004c!:c_entrypoint "Lfloatp") (fluidp c!:c_entrypoint "Lsymbol_specialp") (gcdn 5005c!:c_entrypoint "Lgcd_2") (gctime c!:c_entrypoint "Lgctime") (gensym 5006c!:c_entrypoint "Lgensym") (gensym1 c!:c_entrypoint "Lgensym1") (geq 5007c!:c_entrypoint "Lgeq_2") (get!* c!:c_entrypoint "Lget") (getenv 5008c!:c_entrypoint "Lgetenv") (getv c!:c_entrypoint "Lgetv") (svref 5009c!:c_entrypoint "Lgetv") (globalp c!:c_entrypoint "Lsymbol_globalp") ( 5010greaterp c!:c_entrypoint "Lgreaterp_2") (iadd1 c!:c_entrypoint "Liadd1") ( 5011idifference c!:c_entrypoint "Lidifference_2") (idp c!:c_entrypoint "Lsymbolp" 5012) (igreaterp c!:c_entrypoint "Ligreaterp_2") (ilessp c!:c_entrypoint 5013"Lilessp") (iminus c!:c_entrypoint "Liminus") (iminusp c!:c_entrypoint 5014"Liminusp") (indirect c!:c_entrypoint "Lindirect") (integerp c!:c_entrypoint 5015"Lintegerp") (iplus2 c!:c_entrypoint "Liplus_2") (iquotient c!:c_entrypoint 5016"Liquotient_2") (iremainder c!:c_entrypoint "Liremainder_2") (irightshift 5017c!:c_entrypoint "Lirightshift") (isub1 c!:c_entrypoint "Lisub1") (itimes2 5018c!:c_entrypoint "Litimes_2") (length c!:c_entrypoint "Llength") (lengthc 5019c!:c_entrypoint "Llengthc") (leq c!:c_entrypoint "Lleq_2") (lessp 5020c!:c_entrypoint "Llessp_2") (linelength c!:c_entrypoint "Llinelength") ( 5021load!-module c!:c_entrypoint "Lload_module") (lposn c!:c_entrypoint "Llposn") 5022(macro!-function c!:c_entrypoint "Lmacro_function") (macroexpand!-1 5023c!:c_entrypoint "Lmacroexpand_1") (macroexpand c!:c_entrypoint "Lmacroexpand" 5024) (make!-bps c!:c_entrypoint "Lget_bps") (make!-global c!:c_entrypoint 5025"Lmake_global") (make!-simple!-string c!:c_entrypoint "Lsmkvect") ( 5026make!-special c!:c_entrypoint "Lmake_special") (mapstore c!:c_entrypoint 5027"Lmapstore") (max2 c!:c_entrypoint "Lmax_2") (memq c!:c_entrypoint "Lmemq") ( 5028min2 c!:c_entrypoint "Lmin_2") (minus c!:c_entrypoint "Lminus") (minusp 5029c!:c_entrypoint "Lminusp") (mkquote c!:c_entrypoint "Lmkquote") (mkvect 5030c!:c_entrypoint "Lmkvect") (mod c!:c_entrypoint "Lmod_2") ( 5031modular!-difference c!:c_entrypoint "Lmodular_difference") (modular!-expt 5032c!:c_entrypoint "Lmodular_expt") (modular!-minus c!:c_entrypoint 5033"Lmodular_minus") (modular!-number c!:c_entrypoint "Lmodular_number") ( 5034modular!-plus c!:c_entrypoint "Lmodular_plus") (modular!-quotient 5035c!:c_entrypoint "Lmodular_quotient") (modular!-reciprocal c!:c_entrypoint 5036"Lmodular_reciprocal") (modular!-times c!:c_entrypoint "Lmodular_times") ( 5037nconc c!:c_entrypoint "Lnconc") (neq c!:c_entrypoint "Lneq_2") (not 5038c!:c_entrypoint "Lnull") (null c!:c_entrypoint "Lnull") (numberp 5039c!:c_entrypoint "Lnumberp") (oddp c!:c_entrypoint "Loddp") (onep 5040c!:c_entrypoint "Lonep") (orderp c!:c_entrypoint "Lorderp") (pagelength 5041c!:c_entrypoint "Lpagelength") (pairp c!:c_entrypoint "Lconsp") (plist 5042c!:c_entrypoint "Lplist") (plusp c!:c_entrypoint "Lplusp") (posn 5043c!:c_entrypoint "Lposn") (put c!:c_entrypoint "Lputprop") (putv!-char 5044c!:c_entrypoint "Lsputv") (putv c!:c_entrypoint "Lputv") (qcaar 5045c!:c_entrypoint "Lcaar") (qcadr c!:c_entrypoint "Lcadr") (qcar 5046c!:c_entrypoint "Lcar") (qcdar c!:c_entrypoint "Lcdar") (qcddr 5047c!:c_entrypoint "Lcddr") (qcdr c!:c_entrypoint "Lcdr") (qgetv c!:c_entrypoint 5048"Lgetv") (rds c!:c_entrypoint "Lrds") (reclaim c!:c_entrypoint "Lgc") (remd 5049c!:c_entrypoint "Lremd") (remflag c!:c_entrypoint "Lremflag") (remob 5050c!:c_entrypoint "Lunintern") (remprop c!:c_entrypoint "Lremprop") (reverse 5051c!:c_entrypoint "Lreverse") (reversip c!:c_entrypoint "Lnreverse") (rplaca 5052c!:c_entrypoint "Lrplaca") (rplacd c!:c_entrypoint "Lrplacd") (schar 5053c!:c_entrypoint "Lsgetv") (seprp c!:c_entrypoint "Lwhitespace_char_p") ( 5054set!-small!-modulus c!:c_entrypoint "Lset_small_modulus") (set 5055c!:c_entrypoint "Lset") (smemq c!:c_entrypoint "Lsmemq") (spaces 5056c!:c_entrypoint "Lxtab") (special!-char c!:c_entrypoint "Lspecial_char") ( 5057special!-form!-p c!:c_entrypoint "Lspecial_form_p") (spool c!:c_entrypoint 5058"Lspool") (stop c!:c_entrypoint "Lstop") (stringp c!:c_entrypoint "Lstringp") 5059(subla c!:c_entrypoint "Lsubla") (subst c!:c_entrypoint "Lsubst") ( 5060symbol!-env c!:c_entrypoint "Lsymbol_env") (symbol!-function c!:c_entrypoint 5061"Lsymbol_function") (symbol!-name c!:c_entrypoint "Lsymbol_name") ( 5062symbol!-set!-definition c!:c_entrypoint "Lsymbol_set_definition") ( 5063symbol!-set!-env c!:c_entrypoint "Lsymbol_set_env") (symbol!-value 5064c!:c_entrypoint "Lsymbol_value") (system c!:c_entrypoint "Lsystem") (terpri 5065c!:c_entrypoint "Lterpri") (threevectorp c!:c_entrypoint "Lthreevectorp") ( 5066time c!:c_entrypoint "Ltime") (ttab c!:c_entrypoint "Lttab") (tyo 5067c!:c_entrypoint "Ltyo") (unmake!-global c!:c_entrypoint "Lunmake_global") ( 5068unmake!-special c!:c_entrypoint "Lunmake_special") (upbv c!:c_entrypoint 5069"Lupbv") (verbos c!:c_entrypoint "Lverbos") (wrs c!:c_entrypoint "Lwrs") ( 5070xcons c!:c_entrypoint "Lxcons") (xtab c!:c_entrypoint "Lxtab") (zerop 5071c!:c_entrypoint "Lzerop") (cons c!:direct_entrypoint (2 . "cons")) (ncons 5072c!:direct_entrypoint (1 . "ncons")) (list2 c!:direct_entrypoint (2 . "list2") 5073) (list2!* c!:direct_entrypoint (3 . "list2star")) (acons 5074c!:direct_entrypoint (3 . "acons")) (list3 c!:direct_entrypoint (3 . "list3") 5075) (list3!* c!:direct_entrypoint (4 . "list3star")) (list4 5076c!:direct_entrypoint (4 . "list4")) (plus2 c!:direct_entrypoint (2 . "plus2") 5077) (difference c!:direct_entrypoint (2 . "difference2")) (add1 5078c!:direct_entrypoint (1 . "add1")) (sub1 c!:direct_entrypoint (1 . "sub1")) ( 5079lognot c!:direct_entrypoint (1 . "lognot")) (ash c!:direct_entrypoint (2 . 5080"ash")) (quotient c!:direct_entrypoint (2 . "quot2")) (remainder 5081c!:direct_entrypoint (2 . "Cremainder")) (times2 c!:direct_entrypoint (2 . 5082"times2")) (minus c!:direct_entrypoint (1 . "negate")) (lessp 5083c!:direct_predicate (2 . "lessp2")) (leq c!:direct_predicate (2 . "lesseq2")) 5084(greaterp c!:direct_predicate (2 . "greaterp2")) (geq c!:direct_predicate (2 5085 . "geq2")) (zerop c!:direct_predicate (1 . "zerop")))))) 5086 5087(null (setq c!:c_entrypoint_list (append c!:c_entrypoint_list (quote ((append 5088c!:c_entrypoint "Lappend_2") (assoc c!:c_entrypoint "Lassoc") (compress 5089c!:c_entrypoint "Lcompress") (delete c!:c_entrypoint "Ldelete") (divide 5090c!:c_entrypoint "Ldivide_2") (equal c!:c_entrypoint "Lequal") (intern 5091c!:c_entrypoint "Lintern") (liter c!:c_entrypoint "Lalpha_char_p") (member 5092c!:c_entrypoint "Lmember") (prin c!:c_entrypoint "Lprin") (prin1 5093c!:c_entrypoint "Lprin") (prin2 c!:c_entrypoint "Lprinc") (princ 5094c!:c_entrypoint "Lprinc") (print c!:c_entrypoint "Lprint") (printc 5095c!:c_entrypoint "Lprintc") (read c!:c_entrypoint "Lread") (readch 5096c!:c_entrypoint "Lreadch") (sublis c!:c_entrypoint "Lsublis") (vectorp 5097c!:c_entrypoint "Lsimple_vectorp") (get c!:direct_entrypoint (2 . "get")))))) 5098) 5099 5100(prog (var1388) (setq var1388 c!:c_entrypoint_list) lab1387 (cond ((null 5101var1388) (return nil))) (prog (x) (setq x (car var1388)) (put (car x) (cadr x 5102) (caddr x))) (setq var1388 (cdr var1388)) (go lab1387)) 5103 5104(flag (quote (atom atsoc codep constantp deleq digit endp eq eqcar evenp eql 5105fixp flagp flagpcar floatp get globalp iadd1 idifference idp igreaterp ilessp 5106iminus iminusp indirect integerp iplus2 irightshift isub1 itimes2 liter memq 5107minusp not null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr qcdr 5108remflag remprop reversip seprp special!-form!-p stringp symbol!-env 5109symbol!-name symbol!-value threevectorp vectorp zerop)) (quote c!:no_errors)) 5110 5111 5112% end of file 5113