2 <DEFINE PUTR-GEN (VAR NUM VAL
3 "OPTIONAL" (HINT <>) (PHINT <>)
4 "AUX" RD ETYP VAC ACN TCOFF VADDR VVAC ANYCOFF VOFF STACK? A1
6 #DECL ((VAR) ANY (NUM) <OR FIX VARTBL> (VAL) ANY)
7 <COND (<NOT <TYPE? .VAR VARTBL>> <SET HINT <TYPE .VAR>>)>
8 <COND (.PHINT <SET PHINT <PARSE-HINT .PHINT TYPE>>)>
10 (<OR <TYPE? .NUM VARTBL> <NOT .HINT>>
11 <CALL-RTE ,IPUTR!-MIMOP CALL <> <> .VAR .NUM .VAL>
14 <OR <SET RD <GET-RELE-DESCRIPTOR .NUM .HINT>>
15 <ERROR "RECORD TYPE NOT FOUND" .NUM .HINT PUTR-GEN>>
16 ; "This crock causes the actual contents of FR to be saved when
17 bindind UNWIND, so it can be restored by the kernel. CFRAME
18 saves a pointer to the real frame, which is by no means the
19 same thing when MAKTUP-FLAG is set."
20 <COND (<AND ,MAKTUP-FLAG
25 <SET RHINT <PARSE-HINT .HINT RECORD-TYPE>>
26 <OR <==? .RHINT LBIND>
27 <==? .RHINT T$LBIND>>>>
28 <EMIT-PUSH <TYPE-WORD T$FRAME> LONG>
29 <EMIT-PUSH <MA-REG ,AC-F> LONG>)>
30 <SET STACK? <GET-RSTACK? .HINT>>
32 <COND (<TYPE? .VAR VARTBL> <SET VAC <LOAD-VAR .VAR VALUE <> PREF-VAL>>)
33 (ELSE <SET VAC <GET-AC PREF-VAL T>> <MOVE-VALUE .VAR .VAC>)>
35 <SET TCOFF <MA-DISP .VAC <RED-OFFSET-TYPCNT .RD>>>
36 <SET ANYCOFF <MA-DISP .VAC <+ <RED-OFFSET-TYPCNT .RD> 2>>>
37 <SET VOFF <MA-DISP .VAC <RED-OFFSET-VALUE .RD>>>
39 (<==? <SET ETYP <RED-KIND .RD>> ANY>
40 <COND (<OR <FIX-CONSTANT? .VAL>
41 <AND <TYPE? .VAL VARTBL>
42 <SET LV <FIND-CACHE-VAR .VAL>>
43 <NOT <AND <LINKVAR-VALUE-STORED .LV>
44 <LINKVAR-TYPE-STORED .LV>
45 <LINKVAR-COUNT-STORED .LV>>>
46 <NOT <AND <SET A1 <LINKVAR-TYPE-WORD-AC .LV>>
47 <==? <LINKVAR-VALUE-AC .LV> <NEXT-AC .A1>>>>>>
48 <MOVE-VALUE .VAL .VOFF>
49 <MOVE-TYPE .VAL .TCOFF .ANYCOFF>)
51 <EMIT ,INST-MOVQ <VAR-TYPE-ADDRESS .VAL TYPE-WORD> .TCOFF>)
52 (ELSE <EMIT ,INST-MOVQ <ADDR-TYPE-MQUOTE .VAL> .TCOFF>)>)
53 (<OR <==? .ETYP SMALL-INT> <==? .ETYP SMALL-POS-INT>>
54 <COND (<TYPE? .VAL FIX> <EMIT-MOVE <MA-IMM .VAL> .VOFF WORD>)
56 <COND (<SET VVAC <VAR-VALUE-IN-AC? .VAL>>
57 <EMIT-MOVE <MA-REG .VVAC> .VOFF WORD>)
59 <SET VADDR <MA-DISP ,AC-F <+ <VARTBL-LOC .VAL> 2>>>
60 <EMIT-MOVE .VADDR .VOFF WORD>)>)
61 (<ERROR "BAD ARGUMENT" PUT-RECORD>)>)
62 (<OR <==? .ETYP TYPE-C> <==? .ETYP VWORD1>>
65 <COND (<OR <==? .VAL <>>
66 <AND <TYPE? .VAL VARTBL> <==? <VARTBL-DECL .VAL> FALSE>>
68 <COND (<==? .ETYP TYPE-C> <EMIT ,INST-MCOMW <MA-IMM 0> .VOFF>)
69 (ELSE <EMIT ,INST-CLRL .VOFF>)>)
70 (<OR <NOT <TYPE? .VAL VARTBL>> <VARTBL-DECL .VAL> .PHINT>
71 <COND (<==? .ETYP TYPE-C>
73 <COND (<TYPE? .VAL VARTBL>
74 <VAR-VALUE-ADDRESS .VAL>)
77 (ELSE <MOVE-VALUE .VAL .VOFF>)>)
79 <TESTSET .VAL .VOFF <> <==? .ETYP TYPE-C>>)>)
80 (ELSE <MOVE-VALUE .VAL .VOFF>)>)
81 (<==? .ETYP COUNTVWORD>
82 <COND (<AND <RED-SBOOL .RD>
84 <==? <VARTBL-DECL .VAR> FALSE>
86 <EMIT ,INST-CLRL .VOFF>
87 <EMIT ,INST-CLRW .TCOFF>)
89 <COND (<OR <NOT <RED-SBOOL .RD>> .PHINT <VARTBL-DECL .VAL>>
90 <MOVE-VALUE .VAL .VOFF>
91 <COUNT-STORE-REC .VAL .TCOFF>)
92 (ELSE <TESTSET .VAL .VOFF .TCOFF>)>)
94 <MOVE-VALUE .VAL .VOFF>
95 <EMIT-MOVE <MA-IMM <LENGTH .VAL>> .TCOFF WORD>)>)
97 <COND (<TYPE? .VAL FIX> <EMIT-MOVE <MA-IMM .VAL> .VOFF BYTE>)
98 (ELSE <EMIT-MOVE <VAR-VALUE-ADDRESS .VAL> .VOFF BYTE>)>)
99 (<==? .ETYP BOOLEAN> <TEST-BOOL .VOFF <RED-BIT-NUMBER .RD> .VAL>)>
103 <DEFINE TESTSET (VAR VADDR TCADDR "OPT" (HW <>) "AUX" ELAB FLAB)
104 #DECL ((VAR) VARTBL (VADDR) EFF-ADDR (TCADDR) <OR FIX FALSE EFF-ADDR>)
105 <SET FLAB <MAKE-LABEL>>
106 <TYPE-TST-GEN .VAR FALSE - .FLAB>
107 <EMIT <COND (.HW ,INST-CLRW) (ELSE ,INST-CLRL)> .VADDR>
108 <AND <TYPE? .TCADDR EFF-ADDR> <EMIT ,INST-CLRW .TCADDR>>
109 <SET ELAB <MAKE-LABEL>>
110 <GEN-BRANCH ,INST-BRB .ELAB <>>
111 <EMIT-LABEL .FLAB <>>
112 <EMIT-MOVE <VAR-VALUE-ADDRESS .VAR> .VADDR
113 <COND (.HW WORD) (ELSE LONG)>>
114 <COND (<TYPE? .TCADDR EFF-ADDR>
115 <COUNT-STORE-REC .VAR .TCADDR>)>
116 <EMIT-LABEL .ELAB <>>>
118 <DEFINE TEST-BOOL (VCADDR BITNO VAL "AUX" FLAB ELAB)
119 #DECL ((VCADDR) EFF-ADDR (BITNO) FIX (VAL) VARTBL)
120 <SET FLAB <MAKE-LABEL>>
121 <TYPE-TST-GEN .VAL FALSE - .FLAB>
122 <EMIT ,INST-BICL2 .VCADDR <MA-IMM <CHTYPE <LSH 1 .BITNO> FIX>>>
123 <SET ELAB <MAKE-LABEL>>
124 <GEN-BRANCH ,INST-BRB .ELAB <>>
125 <EMIT ,INST-BISL .VCADDR <MA-IMM <CHTYPE <LSH 1 .BITNO> FIX>>>
126 <EMIT-LABEL .ELAB <>>>
128 <DEFINE NTH-RECORD-GEN (VAR OFF RES
129 "OPTIONAL" (HINT1 <>) (HINT2 <>)
130 "AUX" RD (BRANCH? <>) VAC ACN TCOFF ANYCOFF VOFF TYP
131 NTYP DAC ETYP STACK? AC-LOADED)
132 #DECL ((VAR) ANY (OFF) <OR VARTBL FIX> (HINT2) <OR FALSE HINT>
133 (RES) <OR ATOM VARTBL>)
134 <COND (<NOT <TYPE? .VAR VARTBL>> <SET HINT1 <TYPE .VAR>>)>
135 <COND (<OR <NOT .HINT1> <TYPE? .OFF VARTBL>>
136 <CALL-RTE ,INTHR!-MIMOP CALL .RES <> .VAR .OFF>)
138 <OR <SET RD <GET-RELE-DESCRIPTOR .OFF .HINT1>>
139 <ERROR "RECORD TYPE NOT FOUND" .HINT1 .OFF NTH-RECORD-GEN>>
140 <SET STACK? <GET-RSTACK? .HINT1>>
141 <SET TYP <RED-OBJTYP .RD>>
142 <SET NTYP <AND .HINT2 <PARSE-HINT .HINT2 TYPE>>>
143 <COND (<N==? .RES STACK> <SET BRANCH? <GET-RELE-BRANCH? .HINT2>>)>
144 <COND (<TYPE? .VAR VARTBL>
145 <SET VAC <LOAD-VAR .VAR VALUE <> PREF-VAL>>)
146 (ELSE <SET VAC <GET-AC VALUE T>> <MOVE-VALUE .VAR .VAC>)>
148 <SET TCOFF <MA-DISP .VAC <RED-OFFSET-TYPCNT .RD>>>
149 <SET ANYCOFF <MA-DISP .VAC <+ <RED-OFFSET-TYPCNT .RD> 2>>>
150 <SET VOFF <MA-DISP .VAC <RED-OFFSET-VALUE .RD>>>
151 <COND (<==? .VAR .RES>
153 <COND (<==? <SET ETYP <RED-KIND .RD>> ANY>
154 <RANY-OFF .RES .TCOFF .VOFF .VAC>)
155 (<AND <OR <==? .ETYP VWORD1> <==? .ETYP COUNTVWORD>> .BRANCH?>
156 <SET AC-LOADED <BRANCH-VALUE .VOFF .BRANCH? <RED-LENGTH .RD>>>
163 <COND (<RED-LENGTH .RD> .AC-LOADED)>
164 <COND (<RED-LENGTH .RD> <NEXT-AC .AC-LOADED>)
166 (<AND <==? .ETYP TYPE-C> .BRANCH?>
167 <SET AC-LOADED <BRANCH-HW .VOFF .BRANCH?>>
176 (<OR <==? .ETYP VWORD1> <==? .ETYP TYPE-C>>
177 <COND (<RED-SBOOL .RD>
190 <==? .ETYP TYPE-C>>)>)
191 (<==? .ETYP COUNTVWORD>
192 <COND (<RED-SBOOL .RD>
193 <TEST-NTH .VOFF .TYP .VAC .RES .TCOFF .NTYP>)
194 (<GEN-NTH .VOFF .TYP .VAC .RES .TCOFF>)>)
195 (<==? .ETYP SMALL-FR-OFFSET>
196 <PROTECT <SET DAC <GET-AC PREF-VAL T>>>
197 <EMIT ,INST-CVTWL .VOFF <MA-REG .DAC>>
198 <EMIT ,INST-ADDL2 <MA-REG .VAC> <MA-REG .DAC>>
199 <DEST-DECL .DAC .RES T$LBIND>)
200 (<OR <==? .ETYP SMALL-INT> <==? .ETYP SMALL-POS-INT>>
201 <PROTECT <SET DAC <GET-AC PREF-VAL T>>>
202 <COND (<==? .ETYP SMALL-INT>
203 <EMIT ,INST-CVTWL .VOFF <MA-REG .DAC>>)
204 (ELSE <EMIT ,INST-MOVZWL .VOFF <MA-REG .DAC>>)>
205 <DEST-DECL .DAC .RES FIX>)
207 <PROTECT <SET DAC <GET-AC PREF-VAL T>>>
208 <EMIT ,INST-MOVZBL .VOFF <MA-REG .DAC>>
209 <DEST-DECL .DAC .RES FIX>)
212 <BOOL-NTH-BRANCH .VOFF <RED-BIT-NUMBER .RD> .BRANCH?>)
213 (<BOOL-NTH .VOFF <RED-BIT-NUMBER .RD> .RES>)>)>)>
216 <DEFINE BRANCH-VALUE (VADDR BRANCH? TWO? "AUX" AC)
217 #DECL ((VADDR) EFF-ADDR (BRANCH?) <LIST ATOM ATOM>)
218 <SET AC <GET-AC <COND (.TWO? DOUBLE)(ELSE PREF-VAL)> T>>
219 <EMIT ,INST-MOVL .VADDR
220 <MA-REG <COND (.TWO? <NEXT-AC .AC>)(ELSE .AC)>>>
221 <COND (<==? <1 .BRANCH?> ->
222 <GEN-BRANCH ,INST-BNEQ <2 .BRANCH?> <>>)
224 <GEN-BRANCH ,INST-BEQL <2 .BRANCH?> <>>)>
227 <DEFINE BRANCH-HW (VADDR BRANCH? "AUX" (AC <GET-AC PREF-VAL T>))
228 #DECL ((VADDR) EFF-ADDR (BRANCH?) <LIST ATOM ATOM>)
229 <EMIT ,INST-CVTWL .VADDR <MA-REG .AC>>
230 <COND (<==? <1 .BRANCH?> ->
231 <GEN-BRANCH ,INST-BGEQ <2 .BRANCH?> <>>)
233 <GEN-BRANCH ,INST-BLSS <2 .BRANCH?> <>>)>
236 <DEFINE RANY-OFF (RES TCOFF VOFF VAC "AUX" TAC)
237 #DECL ((RES) <OR ATOM VARTBL> (TCADDR VADDR) EFF-ADDR (VAC) AC)
238 <COND (<==? .RES STACK> <EMIT-PUSH .TCOFF DOUBLE>)
240 <COND (<AND <N==? .VAC ,AC-0>
241 <NOT <AC-PROT <SET TAC <PREV-AC .VAC>>>>
242 <OR <ALL-DEAD? .TAC> <ALL-STORED? .TAC>>>
245 <EMIT ,INST-MOVQ .TCOFF <MA-REG .TAC>>)
247 <PROTECT <SET TAC <GET-AC DOUBLE T>>>
248 <EMIT ,INST-MOVQ .TCOFF <MA-REG .TAC>>
249 <SET VAC <NEXT-AC .TAC>>)>
250 <DEST-PAIR .VAC .TAC .RES>)>>
252 <DEFINE TEST-NTH (VADDR TYP VAC RES CADDR HTYP
254 "AUX" FLAB ELAB RVAC RTAC VPUSH (TYPV <>))
255 #DECL ((VADDR) EFF-ADDR (TYP) ATOM (VAC) AC (RES) <OR ATOM VARTBL>
256 (CADDR) <OR EFF-ADDR FALSE FIX> (HTYP) <OR FALSE ATOM>)
257 <COND (<AND .TYP <SET TYPV <MEMQ .TYP ,TYPE-WORDS>>> <SET TYPV <2 .TYPV>>)>
258 <COND (<TYPE? .RES VARTBL>
259 <COND (<OR <NOT .HTYP> .CADDR>
260 <SET RTAC <GET-AC DOUBLE T>>
261 <SET RVAC <NEXT-AC .RTAC>>
263 (ELSE <SET RVAC <FIND-APP-AC .VAC .TYP>>)>
265 <SET ELAB <MAKE-LABEL>>
266 <SET FLAB <MAKE-LABEL>>
268 <EMIT <COND (.HW ,INST-TSTW) (ELSE ,INST-TSTL)> .VADDR>
269 <GEN-BRANCH <COND (.HW ,INST-BGEQ) (ELSE ,INST-BNEQ)> .FLAB <>>
270 <COND (<==? .RES STACK>
271 <EMIT-PUSH <TYPE-WORD FALSE> LONG>
273 (ELSE <MOVE-TYPE <> .RTAC> <MOVE-VALUE <> .RVAC>)>
274 <GEN-BRANCH ,INST-BRB .ELAB <>>
275 <EMIT-LABEL .FLAB <>>)>
279 <COND (<TYPE? .CADDR FIX>
281 <SET VPUSH <CHTYPE <ORB .TYPV <LSH .CADDR 16>> FIX>>
282 <EMIT-PUSH <MA-IMM .VPUSH> LONG>)
284 <EMIT-PUSH <TYPE-CODE .TYP> WORD>
285 <EMIT-PUSH <MA-IMM .CADDR> WORD>)>)
287 <EMIT-PUSH <TYPE-CODE .TYP> WORD>
288 <EMIT-PUSH .CADDR WORD>)>)
289 (<EMIT-PUSH <TYPE-WORD .TYP> LONG>)>
290 <COND (.HW <EMIT ,INST-MOVZWL .VADDR <MA-AINC ,AC-TP>>)
291 (ELSE <EMIT-PUSH .VADDR LONG>)>)
296 (<AND <TYPE? .CADDR FIX> <TYPE? .TYPV FIX>>
297 <SET VPUSH <CHTYPE <ORB .TYPV <LSH .CADDR 16>> FIX>>
298 <LOAD-CONSTANT .RTAC .VPUSH>)
302 <COND (<TYPE? .CADDR FIX>
303 <LOAD-CONSTANT .RTAC <MA-IMM <CHTYPE <LSH .CADDR 16> FIX>>>
304 <EMIT ,INST-MOVW <TYPE-CODE .TYP> <MA-REG .RTAC>>)
305 (ELSE <EMIT ,INST-MOVL .CADDR <MA-REG .RTAC>>)>)
306 (ELSE <EMIT ,INST-MOVL <TYPE-WORD .TYP> <MA-REG .RTAC>>)>
309 <COND (<TYPE? .CADDR FIX> <LOAD-CONSTANT .RTAC .CADDR>)
310 (.CADDR <MOVE-TO-AC .RTAC .CADDR WORD>)>)>
311 <COND (.HW <EMIT ,INST-MOVZWL .VADDR <MA-REG .RVAC>>)
312 (ELSE <EMIT-MOVE .VADDR <MA-REG .RVAC> LONG>)>)>
314 <EMIT-LABEL .ELAB <>>
315 <AND <TYPE? .RES VARTBL> <DEST-PAIR .RVAC .RTAC .RES>>)
317 <COND (.CADDR <DEST-COUNT-DECL .RVAC .RTAC .RES .TYP>)
318 (ELSE <DEST-DECL .RVAC .RES .TYP>)>)>>
320 <DEFINE FIND-APP-AC (VAC TYP "OPTIONAL" (RES <>))
321 #DECL ((VAC) AC (TYP) <OR FALSE ATOM>)
322 <COND (<OR <NOT .TYP> <STRUCTURED-TYPE? .TYP>>
323 <COND (<FREE-VALUE-AC? STORED> <GET-AC PREF-VAL T>)
324 (ELSE <MUNG-AC .VAC> .VAC)>)
325 (<GET-AC PREF-VAL T>)>>
327 <DEFINE GEN-NTH (VADDR TYP VAC RES CADDR
328 "OPT" (HW <>) (RTAC <>) (RVAC <>)
329 "AUX" VPUSH (NO-LOAD <>))
330 #DECL ((VADDR) EFF-ADDR (TYP) ATOM (VAC) AC (RES) <OR ATOM VARTBL>
331 (CADDR) <OR EFF-ADDR FALSE FIX>)
332 <COND (<==? .RES STACK>
333 <COND (<AND <TYPE? .CADDR FIX> <MEMQ .TYP ,TYPE-WORDS>>
335 <CHTYPE <ORB <TYPE-CODE .TYP VALUE> <LSH .CADDR 16>>
337 <EMIT-PUSH <MA-IMM .VPUSH> LONG>)
339 <EMIT-PUSH <TYPE-CODE .TYP> WORD>
340 <EMIT-PUSH .CADDR WORD>)
341 (<EMIT-PUSH <TYPE-WORD .TYP> LONG>)>
342 <COND (.HW <EMIT ,INST-MOVZWL .VADDR <MA-AINC ,AC-TP>>)
343 (ELSE <EMIT-PUSH .VADDR LONG>)>)
345 <COND (<AND <NOT .RTAC> .CADDR>
346 <SET RTAC <GET-AC DOUBLE T>>
347 <PROTECT <SET RVAC <NEXT-AC .RTAC>>>)
348 (<NOT .RVAC> <PROTECT <SET RVAC <FIND-APP-AC .VAC .TYP>>>)
349 (ELSE <SET NO-LOAD T>)>
351 <COND (<TYPE? .CADDR FIX> <LOAD-CONSTANT .RTAC .CADDR>)
352 (ELSE <EMIT ,INST-MOVZWL .CADDR <MA-REG .RTAC>>)>
353 <COND (<NOT .NO-LOAD>
354 <EMIT-MOVE .VADDR <MA-REG .RVAC> LONG>)>
355 <DEST-COUNT-DECL .RVAC .RTAC .RES .TYP>)
357 <COND (.HW <EMIT ,INST-MOVZWL .VADDR <MA-REG .RVAC>>)
359 <EMIT-MOVE .VADDR <MA-REG .RVAC> LONG>)>
360 <DEST-DECL .RVAC .RES .TYP>)
362 <DEST-DECL .RVAC .RES .TYP>)>
363 <LOAD-AC .RVAC .VADDR>)>>
365 <DEFINE BOOL-NTH (VADDR BNO RES "AUX" ELAB FLAB RVAC RTAC)
366 #DECL ((VADDR) EFF-ADDR (BNO) FIX (RES) <OR ATOM VARTBL>
367 (BRANCH?) <OR LIST FALSE>)
368 <SET ELAB <MAKE-LABEL>>
369 <SET FLAB <MAKE-LABEL>>
370 <COND (<TYPE? .RES VARTBL>
371 <SET RTAC <GET-AC PREF-TYPE>>
372 <SET RVAC <GET-AC PREF-VAL>>
373 <DEST-PAIR .RVAC .RTAC .RES>)>
374 <GEN-BRANCH ,INST-BBC <MA-IMM .BNO> .VADDR .FLAB <>>
375 <COND (<==? .RES STACK>
376 <EMIT-PUSH <ADDR-TYPE-MQUOTE T> LONG>
377 <EMIT-PUSH <ADDR-VALUE-MQUOTE T> LONG>)
378 (ELSE <MOVE-TYPE T .RTAC> <MOVE-VALUE T .RVAC>)>
379 <GEN-BRANCH ,INST-BRB .ELAB <>>
380 <EMIT-LABEL .FLAB <>>
381 <COND (<==? .RES STACK>
382 <EMIT-PUSH <TYPE-WORD FALSE> LONG>
384 (ELSE <MOVE-TYPE <> .RTAC> <MOVE-VALUE <> .RVAC>)>
385 <EMIT-LABEL .ELAB <>>>
387 <DEFINE BOOL-NTH-BRANCH (VADDR BNO BRANCH)
388 #DECL ((VADDR) EFF-ADDR (BNO) FIX (BRANCH) <LIST ATOM ATOM>)
389 <EMIT ,INST-BTST NO-SIZE-WORD .VADDR <EXTWORD-DATA .BNO>>
390 <COND (<==? <1 .BRANCH> ->
391 <GEN-BRANCH ,INST-BBC <MA-IMM .BNO> .VADDR <2 .BRANCH> <>>)
393 <GEN-BRANCH ,INST-BBS <MA-IMM .BNO> .VADDR <2 .BRANCH> <>>)>>
395 <DEFINE COUNT-STORE-REC (VAL TCADDR "AUX" (LV <FIND-CACHE-VAR .VAL>) AC)
398 <LINKVAR-COUNT-STORED .LV>
399 <LINKVAR-COUNT-AC .LV>>
400 <EMIT-MOVE <VAR-COUNT-ADDRESS .VAL> .TCADDR WORD>)
401 (<SET AC <LINKVAR-TYPE-WORD-AC .LV>>
402 <EMIT ,INST-ROTL <MA-BYTE-IMM 16> <MA-REG .AC>
403 <MA-REG <SET AC <GET-AC ANY-AC T>>>>
404 <EMIT-MOVE <MA-REG .AC> .TCADDR WORD>)>>