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