2 "MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
4 <DEFINE BIT-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (POSN 0) POS WIDTH)
5 #DECL ((WIDTH POS NOD) NODE (K) <LIST [REST NODE]>)
6 <COND (<SEGFLUSH .NOD .RTYP>)
8 <ARGCHK <LENGTH .K> '(1 2) BITS>
9 <EANA <SET WIDTH <1 .K>> FIX BITS>
10 <COND (<NOT <EMPTY? <REST .K>>>
11 <EANA <SET POS <2 .K>> FIX BITS>
12 <SET POSN <NODE-NAME .POS>> ;"May be position field.")>
13 <COND (<AND <==? <NODE-TYPE .WIDTH> ,QUOTE-CODE>
14 <OR <NOT <ASSIGNED? POS>> ;"Only one arg."
15 <==? <NODE-TYPE .POS> ,QUOTE-CODE>>>
16 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
17 <PUT .NOD ,NODE-NAME <BITS <NODE-NAME .WIDTH> .POSN>>
19 (ELSE <PUT .NOD ,NODE-TYPE ,BITS-CODE>)>)>
20 <TYPE-OK? BITS .RTYP>>
22 <PUT ,BITS ANALYSIS ,BIT-ANA>
24 <DEFINE GETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 2 ,GETBITS-CODE>>
26 <PUT ,GETBITS ANALYSIS ,GETBITS-ANA>
28 <DEFINE PUTBITS-ANA (N R) <PGBITS .N .R '(2 3) ,PUTBITS-CODE>>
30 <PUT ,PUTBITS ANALYSIS ,PUTBITS-ANA>
32 <DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>) (NAM <NODE-NAME .NOD>))
33 #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
34 <COND (<SEGFLUSH .NOD .RTYP>)
36 <ARGCHK <LENGTH .K> .NARG .NAM>
37 <PUT .NOD ,NODE-TYPE .COD>
39 <COND (<==? .COD ,GETBITS-CODE>
42 (ELSE '<PRIMTYPE WORD>)>
44 <EANA <2 .K> BITS .NAM>
45 <IF <==? <LENGTH .K> 3>
46 <EANA <3 .K> '<PRIMTYPE WORD> .NAM>>)>
47 <TYPE-OK? <COND (<==? .COD ,GETBITS-CODE> WORD)
48 (<ISTYPE? <RESULT-TYPE <1 .K>>>)
49 (ELSE '<PRIMTYPE WORD>)>
52 <DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>))
53 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
54 <COND (<SEGFLUSH .NOD .RTYP>)
56 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
58 <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
59 (<1? .LN> <PUT .NOD ,NODE-TYPE ,ID-CODE>)
61 <PUT .NOD ,NODE-TYPE ,BITL-CODE>
65 <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>>
67 <TYPE-OK? WORD .RTYP>>
69 <PUT ,ANDB ANALYSIS ,BITLOG>
71 <PUT ,ORB ANALYSIS ,BITLOG>
73 <PUT ,XORB ANALYSIS ,BITLOG>
75 <PUT ,EQVB ANALYSIS ,BITLOG>
77 <DEFINE BITLOG-GEN (N W
78 "AUX" (K <KIDS .N>) (REG <UPDATE-WHERE .N .W>) (FST <1 .K>)
79 (INS <LGINS <NODE-SUBR .N>>))
80 #DECL ((FST N) NODE (K) <LIST [REST NODE]> (REG) DATUM)
81 <COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
84 <SET REG <GEN <1 .K> .REG>>
85 <RET-TMP-AC <DATTYP .REG> .REG>
88 <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE WORD)>>
90 <FUNCTION (NN "AUX" (NXT <GEN .NN DONT-CARE>) TT)
91 #DECL ((NN) NODE (NXT) DATUM)
92 <COND (<TYPE? <DATVAL .REG> AC>)
93 (<TYPE? <SET TT <DATVAL .NXT>> AC>
94 <PUT .NXT ,DATVAL <DATVAL .REG>>
95 <PUT .REG ,DATVAL .TT>
96 <FIX-ACLINK .TT .REG .NXT>)
98 <PUT <SET TT <DATVAL .REG>> ,ACPROT T>
100 <IMCHK .INS <ACSYM .TT> <DATVAL .NXT> T>
107 <NTH '![(`AND `ANDI `ANDCMI )
111 <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
113 <SETG LSUBRS ![,EQVB ,XORB ,ORB ,ANDB!]>
115 <DEFINE GETBITS-GEN (N W
116 "AUX" (WRDN <1 <KIDS .N>>) (BP <2 <KIDS .N>>) REG POS WDTH
117 BAC AC BPW WRD BPD TEM)
118 #DECL ((WRDN N BP) NODE (POS WDTH) FIX (WRD REG BPD) DATUM (AC BAC) AC
119 (BPW) <PRIMTYPE WORD>)
121 (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
122 <SET WRD <GEN .WRDN DONT-CARE>>
123 <SET BPW <NODE-NAME .BP>>
124 <SET POS <CHTYPE <GETBITS .BPW #BITS *360600000000*> FIX>>
125 <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
127 (<AND <==? <+ .POS .WDTH> 36>
129 <TYPE? <DATVAL .WRD> AC>
130 <NOT <ACRESIDUE <SET AC <DATVAL .WRD>>>>
131 <OR <==? .W DONT-CARE>
132 <AND <TYPE? .W DATUM> <==? .AC <DATVAL .WRD>>>>>
133 <MUNG-AC .AC <SET REG .WRD>>
134 <EMIT <INSTRUCTION `LSH <ACSYM .AC> <- .POS>>>)
136 <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
139 <COND (<AND <==? .WDTH 18> ;"Could be half word hack."
141 <EMIT <INSTRUCTION `HRRZ
146 <EMIT <INSTRUCTION `HLRZ
151 <EMIT <INSTRUCTION `LDB
153 [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
154 !<ADDR:VALUE .WRD>>]>>)>
157 (<==? <NODE-TYPE .BP> ,BITS-CODE>
160 <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
163 <1 <SET TEM <RBITS-GEN .BP <DATUM BITS ANY-AC> .WRD>>>>
164 <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
168 <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
170 <PUT .TEM 1 <1 <ADDR:VALUE .WRD>>>
171 <PUTREST .TEM <REST <ADDR:VALUE .WRD>>>
172 <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
173 <PUT .BAC ,ACPROT <>>
177 (ELSE ;"Non constant byte pointer."
180 <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
182 <SET BPD <GEN .BP DONT-CARE>>
183 <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
186 <SET BPD <MOVE:ARG .BPD <DATUM BITS ANY-AC>>>
187 <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
189 <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> !<ADDR:VALUE .WRD>>>
190 <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
191 <PUT .BAC ,ACPROT <>>
197 <DEFINE PUTBITS-GEN (N W
198 "AUX" (K <KIDS .N>) (SWRD <1 .K>) (BP <2 .K>) BAC POS WDTH
199 FLD BPW BPD SWRDD (FLG T) TEM NUM)
200 #DECL ((N SWRD BP) NODE (FLD BPD REG SWRDD) DATUM (AC BAC PAC) AC
201 (POS WDTH) FIX (BPW) <PRIMTYPE WORD> (NUM) <OR FALSE FIX>)
203 (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
205 <CHTYPE <GETBITS <SET BPW <NODE-NAME .BP>> #BITS *360600000000*> FIX>>
206 <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
208 (<AND <==? <NODE-TYPE .SWRD> ,QUOTE-CODE>
209 <0? <CHTYPE <NODE-NAME .SWRD> FIX>>>
210 <SET SWRDD <GEN <3 .K> <REG? <RESULT-TYPE .SWRD> .W>>>
211 <MUNG-AC <DATVAL .SWRDD> .SWRDD>
212 <COND (<L? <+ .POS .WDTH> 36>
213 <IMCHK '(`AND `ANDI )
214 <ACSYM <DATVAL .SWRDD>>
215 <REFERENCE:ADR <GETBITS -1 <BITS .WDTH>>>>)>
216 <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .SWRDD>> .POS>>)
220 <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)> .W>>>
221 <MUNG-AC <DATVAL .SWRDD> .SWRDD>
227 <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
228 <EMIT <INSTRUCTION <COND (<0? .NUM> `HLLZS ) (ELSE `HLLOS )>
229 <ADDRSYM <DATVAL .SWRDD>>>>)
230 (ELSE <PCLOB .SWRDD '(`HRR `HRRI ) <3 .K>>)>)
232 <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
233 <EMIT <INSTRUCTION <COND (<0? .NUM> `HRRZS ) (ELSE `HRROS )>
234 <ADDRSYM <DATVAL .SWRDD>>>>)
235 (ELSE <PCLOB .SWRDD '(`HRL `HRLI ) <3 .K>>)>
237 (<AND <OR <AND <L? .POS 18> <L=? <+ .POS .WDTH> 18>> <G? .POS 18>>
239 <OR <0? .NUM> <L? .WDTH <POPWR2 <+ .NUM 1>>>>>
240 <EMIT <INSTRUCTION <COND (<0? .NUM>
241 <COND (<L? .POS 18> `ANDCMI ) (ELSE `TLZ )>)
243 <COND (<L? .POS 18> `IORI ) (ELSE `TLO )>)>
244 <ACSYM <DATVAL .SWRDD>>
245 <LSH <LSH -1 <- .WDTH 36>>
246 <COND (<L? .POS 18> .POS)
247 (ELSE <- .POS 18>)>>>>)
249 <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>
250 <PUT <DATVAL .FLD> ,ACPROT T>
252 <PUT <DATVAL .SWRDD> ,ACPROT T>
253 <EMIT <INSTRUCTION `DPB
254 <ACSYM <DATVAL .FLD>>
255 [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
256 <ADDRSYM <DATVAL .SWRDD>>>]>>
257 <PUT <DATVAL .FLD> ,ACPROT <>>
258 <PUT <DATVAL .SWRDD> ,ACPROT <>>
259 <RET-TMP-AC .FLD>)>)>)
261 <COND (<NOT <AND <NOT <SIDE-EFFECTS .N>> <MEMQ <NODE-TYPE .SWRD> ,SNODES>>>
264 <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
268 <COND (<==? <NODE-TYPE .BP> ,BITS-CODE>
273 <COND (<ASSIGNED? SWRDD> .SWRDD)
274 (ELSE ,NO-DATUM)>>>>)
275 (ELSE <GEN .BP DONT-CARE>)>>
277 <COND (<SET NUM <ZERQ .K>>
278 <SET FLD <MOVE:ARG <REFERENCE .NUM> <DATUM WORD ANY-AC>>>)
279 (ELSE <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>)>
281 <PUT .FLD ,DATTYP WORD>
282 <COND (<NOT <ASSIGNED? SWRDD>>
285 <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
287 <COND (<NOT <TYPE? <DATVAL .SWRDD> AC>>
291 <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
293 <PUT <DATVAL .SWRDD> ,ACPROT T>
295 <PUT <DATVAL .FLD> ,ACPROT T>
297 <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
299 <PUT <2 .TEM> 1 <ADDRSYM <DATVAL .SWRDD>>>
300 <PUTREST <2 .TEM> ()>)>
301 <MUNG-AC <DATVAL .SWRDD> .SWRDD>
304 <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> <ADDRSYM <DATVAL .SWRDD>>>>)>
305 <EMIT <INSTRUCTION `DPB <ACSYM <DATVAL .FLD>> <ADDRSYM .BAC>>>
306 <PUT .BAC ,ACPROT <>>
307 <PUT <DATVAL .SWRDD> ,ACPROT <>>
308 <PUT <DATVAL .FLD> ,ACPROT <>>
311 <MOVE:ARG .SWRDD .W>>
313 <DEFINE ZERQ (L "AUX" NUM)
314 #DECL ((L) <LIST [REST NODE]>)
315 <COND (<==? <LENGTH .L> 2> 0)
316 (<AND <==? <NODE-TYPE <SET NUM <3 .L>>> ,QUOTE-CODE>
317 <==? <PRIMTYPE <SET NUM <NODE-NAME .NUM>>> WORD>
318 <OR <AND <0? <SET NUM <CHTYPE .NUM FIX>>> 0>
319 <AND <POPWR2 <+ .NUM 1>> .NUM>>>)>>
321 <DEFINE PCLOB (DEST INS SRC "AUX" SRCD)
322 #DECL ((DEST SRCD) DATUM (SRC) NODE)
323 <SET SRCD <GEN .SRC DONT-CARE>>
325 <PUT <DATVAL .DEST> ,ACPROT T>
326 <IMCHK .INS <ACSYM <DATVAL .DEST>> <DATVAL .SRCD>>
327 <PUT <DATVAL .DEST> ,ACPROT <>>
330 <DEFINE BITS-GEN (N W) <1 <RBITS-GEN .N .W DONT-CARE>>>
332 <DEFINE RBITS-GEN (N W ADDR
333 "AUX" (K <KIDS .N>) (WDTHN <1 .K>) WDTH POS TEM
334 (REG <REG? WORD .W>) POSD (FLG T))
335 #DECL ((POS N WDTHN) NODE (REG WDTH POSD) DATUM (K) <LIST [REST NODE]>)
336 <COND (<==? <LENGTH .K> 2> <SET POS <2 .K>>)>
338 (<==? <NODE-TYPE .WDTHN> ,QUOTE-CODE>
339 <SET TEM <MAKE-PTR .ADDR T <NODE-NAME .WDTHN>>>)
340 (<OR <NOT <ASSIGNED? POS>>
341 <==? <NODE-TYPE .POS> ,QUOTE-CODE>>
345 <COND (<ASSIGNED? POS> <NODE-NAME .POS>) (ELSE 0)>>>
349 <SET WDTH <GEN .WDTHN .REG>>
350 <MUNG-AC <DATVAL .REG> .REG>
351 <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .REG>> 24>>
352 <COND (<TYPE? .ADDR DATUM>
353 <EMIT <SET TEM <INSTRUCTION `HRRI <ACSYM <DATVAL .REG>> 0>>>
354 <SET TEM <REST .TEM 2>>)
355 (ELSE <SET TEM '(0)>)>)>
356 <SET POSD <GEN .POS <DATUM WORD ANY-AC>>>
357 <PUT <DATVAL .POSD> ,ACPROT T>
358 <COND (<NOT <ASSIGNED? WDTH>>
359 <SET WDTH <DATUM WORD ANY-AC>>
360 <PUT .WDTH ,DATVAL <GETREG .WDTH>>
361 <EMIT <INSTRUCTION `MOVE <ACSYM <DATVAL .WDTH>> .TEM>>
362 <SET TEM <REST <1 .TEM>>>)
363 (ELSE <TOACV .WDTH>)>
364 <PUT <DATVAL .WDTH> ,ACPROT T>
365 <EMIT <INSTRUCTION `DPB
366 <ACSYM <DATVAL .POSD>>
367 [<FORM (<COND (.FLG 123264) (ELSE 98688)>)
368 <ADDRSYM <DATVAL .WDTH>>>]>>
369 <PUT <DATVAL .WDTH> ,ACPROT <>>
370 <PUT <DATVAL .POSD> ,ACPROT <>>
372 <COND (<TYPE? <DATTYP .WDTH> AC>
373 <RET-TMP-AC <DATTYP .WDTH> .WDTH>)>
374 <PUT .WDTH ,DATTYP BITS>
375 [<MOVE:ARG .WDTH .W> .TEM]>
377 <DEFINE MAKE-PTR (AD W-P CNST "AUX" (BP <BITS 6 <COND (.W-P 24) (ELSE 30)>>))
379 <COND (<TYPE? .AD DATUM>
380 [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) HERE>])
382 [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) 0>])>>