3 <DEFINE MIMOC (CODLIST "OPTIONAL" (NEW-MSUBR T) "AUX" STATUS ARGS
5 #DECL ((CODLIST) <LIST [REST <OR FORM ATOM>]> (RESET-ALL) BOOLEAN
6 (CODPTR) <SPECIAL LIST>)
7 <INIT-ALL-STUFF .NEW-MSUBR>
9 <REPEAT (NUM APL CODITEM PPTR OSTATUS (LABEL? <>)
10 (FROB? <>) (FIRST? T) (PROTECT? <>) TF)
11 <SET CODITEM <1 .CODPTR>>
13 <SET CODPTR <REST .CODPTR>>
14 <AND <GASSIGNED? MAX-SPACE> ,MAX-SPACE <PUTREST .PPTR ()>>
15 <COND (<G? ,FLUSH-NEXT 0>
16 <SETG FLUSH-NEXT <- ,FLUSH-NEXT 1>>
17 <COND (<EMPTY? .CODPTR> <RETURN>) (<AGAIN>)>)>
20 <COND (<GETPROP .CODITEM DONE>)
21 (<TYPE? .CODITEM FORM>
22 <COND (<OR <NOT <GASSIGNED? <1 .CODITEM>>>
23 <NOT <TYPE? <SET NUM ,<1 .CODITEM>> FIX>>>
24 <ERROR "UNKNOWN" .CODITEM>)>
30 <SET APL <NTH ,OP-APPLY-VECTOR .NUM>>
32 <SET TF <OR <MEMQ + .CODITEM>
34 <PROG ((OUTST ,OUTST-LABEL-TABLE)
36 #DECL ((OUTST) VECTOR)
38 <FUNCTION (LREF) #DECL ((LREF) LABEL-REF)
39 <COND (<==? <LABEL-REF-NAME .LREF> .LAB>
40 <COND (<LABEL-REF-LOOP-LABEL .LREF>
44 (<SET-DEATH .CODPTR>)>
45 <COND (<==? .NUM ,BAD-OPERATION>
46 <ERROR "BAD OPERATION" MIMOC .CODITEM>)>
47 <COND (<AND <==? .NUM ,DEAD!-MIMOP> <NOT .LABEL?>>
48 <SET OSTATUS .STATUS>)
54 <COND (<N==? <SET FROB? <FIRST-PROCESS .CODPTR>>
56 <ILDB-LOOKAHEAD .CODPTR>)>)>
57 <COND (<MEMQ .NUM ,PASS-OPS>
58 <SET STATUS <APPLY .APL !<REST .CODITEM>>>)
60 <SET ARGS <PROCESS-ARGS <REST .CODITEM> .NUM
62 <SET STATUS <APPLY .APL !.ARGS>>)>
63 <COND (<OR <NOT .FROB?>
64 <==? <1 .CODITEM> MAKTUP!-MIMOP>
65 <==? <1 .CODITEM> OPT-DISPATCH!-MIMOP>>
66 <COND (<N==? <SET FROB? <FIRST-PROCESS .CODPTR>>
68 <ILDB-LOOKAHEAD .CODPTR>)>)>
69 <COND (.OSTATUS <SET STATUS .OSTATUS> <SET OSTATUS <>>)
73 (<TYPE? .CODITEM ATOM>
75 <GEN-LABEL .CODITEM .STATUS>)
76 (<ERROR "BAD CODE ITEM" MIMOC>)>
77 <COND (<EMPTY? .CODPTR> <RETURN>)>>
81 <DEFINE SET--DEATH (CODPTR "OPT" (REALLY-DEAD <>) "AUX" (N ,FLUSH-NEXT))
82 #DECL ((CODPTR) LIST (N) FIX)
87 (<TYPE? .CODITEM FORM>
88 <COND (<AND <L? <SET N <- .N 1>> 0> <NOT <GETPROP .CODITEM DONE>>>
89 <COND (<==? <1 .CODITEM> DEAD!-MIMOP>
92 <COND (<TYPE? .ATM VARTBL>
94 <COND (.REALLY-DEAD <DEAD-VAR .ATM>)>)>>
100 <SETG ARGVEC <IVECTOR ,MAX-NUMBER-ARGS>>
102 <DEFINE FIRST-PROCESS FP (L "AUX" VAL)
103 #DECL ((L) <LIST [REST <OR FORM ATOM>]>)
108 (<AND <TYPE? .X FORM>
111 (<NOT <MEMQ ,<1 .X> ,PASS-OPS>>
112 <REPEAT ((PTR <REST .X>) ITEM ARG TTYP)
113 <COND (<EMPTY? .PTR> <RETURN>)>
114 <COND (<==? <SET ITEM <1 .PTR>> =>
115 <1 .PTR <CHTYPE .ITEM RES-IND>>
116 <SET PTR <REST .PTR>>
118 <COND (<==? .ITEM STACK>)
119 (<SET ITEM <FIND-VAR .ITEM>> <1 .PTR .ITEM>)
120 (<ERROR "NOT A VARIABLE"
124 <COND (<SET ARG <FIND-VAR .ITEM>>
125 <VARTBL-DEAD? .ARG <>>
127 (<AND <TYPE? .ITEM FORM>
128 <==? <LENGTH .ITEM> 2>
130 <==? <1 .X> CHTYPE!-MIMOP>>
131 <COND (<SET ARG <FIND-VAR <2 .ITEM>>>
132 <1 .PTR <FORM TYPE .ARG>>
133 <VARTBL-DEAD? .ARG <>>)>)
134 (<AND <TYPE? .ITEM FORM>
135 <==? <LENGTH .ITEM> 2>
136 <OR <==? <SET TTYP <1 .ITEM>> QUOTE>
137 <==? .TTYP TYPE-CODE>>
138 <TYPE? <2 .ITEM> ATOM>>
140 <AND <==? .TTYP TYPE-CODE>
141 <SET TTYP <CHECK-MIMOP-TYPE .ITEM>>
144 <SET PTR <REST .PTR>>>)
145 (<==? <1 .X> TEMP!-MIMOP>
146 <PROG ((FIRST-PROCESS? T))
147 #DECL ((FIRST-PROCESS?) <SPECIAL ATOM>)
148 <TEMP-PROCESS !<REST .X>>>
150 <FUNCTION (L "AUX" (X <1 .L>))
152 <COND (<TYPE? .X LIST>
153 <COND (<TYPE? <1 .X> ADECL>
154 <1 .X <FIND-VAR <1 <1 .X>>>>)
156 <1 .X <FIND-VAR <1 .X>>>)>)
157 (<TYPE? .X ADECL> <1 .L <FIND-VAR <1 .X>>>)
158 (T <1 .L <FIND-VAR .X>>)>>
160 (<OR <==? <1 .X> MAKTUP!-MIMOP>
161 <==? <1 .X> OPT-DISPATCH!-MIMOP>>
162 <MAPLEAVE TEMP!-MIMOP>)>)>>
166 <DEFINE PROCESS-ARGS (LST NUM PROTECT? "AUX" (CNT 1) (ARGS ,ARGVEC) ARG TTYP DISP)
167 #DECL ((LST) LIST (NUM) FIX)
169 <REPEAT ((PTR .LST) ITEM)
170 <COND (<EMPTY? .PTR> <RETURN>)>
171 <COND (<TYPE? <SET ITEM <1 .PTR>> RES-IND>
172 <SET PTR <REST .PTR>>
174 <COND (<==? .NUM ,CHANNEL-OP!-MIMOP>
175 <SETG HAS-RESULT .ITEM>
176 <SET PTR <REST .PTR>>
179 (<MEMQ .NUM ,DEAD-MIM-CODES>
180 <VARTBL-DEAD? .ITEM T>)>)
181 (<TYPE? .ITEM VARTBL>
182 <COND (.PROTECT? <PROTECT-VAL .ITEM>)>
183 <VARTBL-DEAD? .ITEM <>>)
184 (<AND <TYPE? .ITEM FORM>
185 <==? <LENGTH .ITEM> 2>
187 <==? .NUM ,CHTYPE!-MIMOP>>
188 <COND (.PROTECT? <PROTECT-VAL <2 .ITEM>>)>
189 <VARTBL-DEAD? <2 .ITEM> <>>)>
190 <COND (<G? .CNT <LENGTH .ARGS>>
191 <SETG ARGVEC <IVECTOR <+ <LENGTH .ARGS> 50>>>
192 <SET ARGS <SUBSTRUC .ARGS 0 <LENGTH .ARGS> ,ARGVEC>>)>
193 <PUT .ARGS .CNT .ITEM>
195 <SET PTR <REST .PTR>>>
196 <SET DISP <- <LENGTH .ARGS> <- .CNT 1>>>
197 <SUBSTRUC .ARGS 0 <- .CNT 1> <REST .ARGS .DISP>>>
199 <GDECL (DEAD-MIM-CODES) <UVECTOR [REST FIX]>>
201 <DEFINE INIT-ALL-STUFF (RESET-ALL)
202 #DECL ((RESET-ALL) BOOLEAN)
203 <SETG MAKTUP-FLAG <>>
205 <RESET-AC-STACK-MODEL>
211 <INIT-UNRESOLVED-CALLS>
213 <INIT-LABEL-TABLE .RESET-ALL>
216 <INIT-INTERNAL-ENTRYS>
218 <RESET-FRAME-LABEL-TABLE>
220 <RESET-PUSH-LABEL-TABLE>
221 <RESET-MOVE-LABEL-TABLE>>
223 <DEFINE FCN-PROCESS (NAME DCLS
225 "AUX" (VARLST ()) (NVARLST ())
226 (LAB <MAKE-LABEL "FNAME">))
227 #DECL ((DCLS) LIST (VARS) <TUPLE [REST ATOM]>)
228 <SETG FUNCTION-DECL .DCLS>
229 <COND (<=? <1 .DCLS> "VALUE">
230 <SET DCLS <REST .DCLS 2>>)>
231 <SETG FUNCTION-NAME .NAME>
232 <SETG ICALL-LABELS ()>
233 <REPEAT (VAR VDCL TBL)
234 <COND (<EMPTY? .VARS> <RETURN>)>
236 <COND (<TYPE? <SET VDCL <1 .DCLS>> STRING>
237 <SET DCLS <REST .DCLS>>
238 <SET VDCL <1 .DCLS>>)>
239 <SET TBL <CREATE-VAR .VAR <>>>
240 <COND (<EMPTY? .VARLST>
242 <SET NVARLST .VARLST>)
244 <PUTREST .NVARLST (.TBL)>
245 <SET NVARLST <REST .NVARLST>>)>
246 <INDICATE-VAR-DECL .TBL <ISTYPE? .VDCL>>
247 <SET VARS <REST .VARS>>
248 <SET DCLS <REST .DCLS>>>
249 <SETG ARGLIST-VARS .VARLST>
251 <ADD-INTERNAL-ENTRY -1 .LAB>
254 <DEFINE TEMP-PROCESS ("TUPLE" TEMPS
257 <AND <ASSIGNED? FIRST-PROCESS?>
259 #DECL ((TEMPS) <TUPLE [REST <OR VARTBL ATOM ADECL LIST>]>)
260 <COND (<NOT .NOT-YET?>
261 <SET SLABEL <MAKE-LABEL>>
262 <EMIT-LABEL .SLABEL <>>
263 <INDICATE-TEMP-PATCH <ADD-PATCH TEMPORARIES>>)>
265 <FCN (TMP "AUX" TBL TC)
266 <COND (<TYPE? .TMP VARTBL> <CREATE-VAR .TMP T .NOT-YET?>)
267 (<TYPE? .TMP ATOM> <CREATE-VAR .TMP T .NOT-YET?>)
269 <COND (<TYPE? <SET ADL <1 .TMP>> ADECL>
270 <SET TBL <CREATE-VAR <1 .ADL> T .NOT-YET?>>
271 <INDICATE-VAR-DECL .TBL <2 .ADL>>)
272 (ELSE <SET TBL <CREATE-VAR .ADL T .NOT-YET?>>)>
273 <COND (<NOT .NOT-YET?>
274 <COND (<AND <TYPE? <SET TC <2 .TMP>> FORM>
277 <TYPE? <2 .TC> ATOM>>
279 <INDICATE-VAR-INIT .TBL .TC>)>)
281 <SET TBL <CREATE-VAR <1 .TMP> T .NOT-YET?>>
282 <INDICATE-VAR-DECL .TBL <2 .TMP>>)
283 (<ERROR "BAD TEMP STATEMENT" TEMP-PROCESS>)>>
287 <DEFINE ISTYPE? (DCL)
288 #DECL ((DCL) <OR ATOM FORM>)
289 <COND (<TYPE? .DCL ATOM> <AND <VALID-TYPE? .DCL> .DCL>)
290 (<AND <TYPE? <SET DCL <1 .DCL>> ATOM> <VALID-TYPE? .DCL>> .DCL)>>
292 <DEFINE END-GEN () UNCONDITIONAL-BRANCH>
294 <DEFINE UCBRANCH-GEN (DIR LABEL)
295 #DECL ((DIR LABEL) ATOM)
296 <GEN-BRANCH ,INST-BRB .LABEL UNCONDITIONAL-BRANCH>
297 UNCONDITIONAL-BRANCH>
299 <DEFINE LOCATION-GEN (DIR LABEL RES "AUX" VAC)
300 #DECL ((DIR LABEL) ATOM (RES) VARTBL)
301 <PROTECT <SET VAC <GET-AC ANY-AC T>>>
302 <EMIT-MOVE-LABEL .LABEL <MA-REG .VAC>>
303 <DEST-DECL .VAC .RES FIX>
306 <DEFINE LOAD-VAR-APP (VAR
307 "OPTIONAL" (MUNG T) (DCL <VARTBL-DECL .VAR>) (USE? T))
309 <COND (<OR <NOT .DCL> <STRUCTURED-TYPE? .DCL>>
310 <LOAD-VAR .VAR VALUE .MUNG PREF-VAL .DCL .USE?>)
311 (ELSE <LOAD-VAR .VAR VALUE .MUNG PREF-VAL .DCL .USE?>)>>
313 <DEFINE PROCESS-DESTINATION-HINT (HINT DEST "AUX" DCL)
314 #DECL ((HINT) <OR FALSE HINT ATOM> (DEST) <OR ATOM VARTBL>)
315 <COND (<AND <TYPE? .DEST VARTBL>
316 <COND (<TYPE? .HINT LIST>
317 <SET DCL <PARSE-HINT .HINT TYPE>>)
318 (<TYPE? .HINT ATOM> <SET DCL .HINT>)>>
319 <INDICATE-VAR-TEMP-DECL .DEST .DCL>)>>
321 <DEFINE MOVE-TYPE (VAL TEADDR
322 "OPTIONAL" (CEADDR <>)
323 "AUX" DCL RADDR ADDR1 LVAR)
324 #DECL ((VAL) ANY (TEADDR) <OR AC EFF-ADDR> (CEADDR) <OR FALSE EFF-ADDR>)
325 <COND (<TYPE? .TEADDR AC> <SET RADDR <MA-REG .TEADDR>>)
326 (<SET RADDR .TEADDR>)>
327 <COND (<TYPE? .VAL VARTBL>
328 <COND (<OR <SAFE-TYPE-WORD? .VAL>
329 <AND <SET LVAR <FIND-CACHE-VAR .VAL>>
330 <OR <AND <NOT <LINKVAR-TYPE-AC .LVAR>>
331 <NOT <LINKVAR-TYPE-WORD-AC .LVAR>>
332 <NOT <LINKVAR-COUNT-AC .LVAR>>
333 <NOT <VARTBL-DECL .VAL>>>
334 <AND <LINKVAR-TYPE-STORED .LVAR>
335 <LINKVAR-COUNT-STORED .LVAR>>>>>
336 <EMIT-MOVE <VAR-TYPE-ADDRESS .VAL TYPE-WORD> .RADDR LONG>
337 <AND <TYPE? .TEADDR AC>
338 <LOAD-AC .TEADDR <VAR-TYPE-ADDRESS .VAL TYPE-WORD>>>)
339 (<SET DCL <VARTBL-DECL .VAL>>
340 <COND (<COUNT-NEEDED? .DCL>
341 <SET ADDR1 <VAR-COUNT-ADDRESS .VAL>>
342 <COND (<TYPE? .TEADDR AC>
343 <EMIT-MOVE <TYPE-WORD .DCL> .RADDR LONG>
344 <EMIT ,INST-BISW2 .ADDR1 <MA-REG .TEADDR>>
347 <EMIT-MOVE .ADDR1 .CEADDR WORD>
348 <EMIT-MOVE <TYPE-CODE .DCL WORD>
352 <EMIT-MOVE <TYPE-WORD .DCL> .RADDR LONG>
353 <AND <TYPE? .TEADDR AC>
354 <LOAD-AC .TEADDR <TYPE-WORD .DCL>>>)>)
355 (<ERROR "NO TYPE WORD" MOVE-TYPE>)>)
356 (<FIX-CONSTANT? .VAL>
357 <EMIT-MOVE <TYPE-WORD <TYPE .VAL>> .RADDR LONG>
358 <AND <TYPE? .TEADDR AC> <LOAD-AC .TEADDR <TYPE-WORD <TYPE .VAL>>>>)
360 <SET ADDR1 <ADDR-TYPE-M <ADD-MVEC .VAL>>>
361 <EMIT-MOVE .ADDR1 .TEADDR LONG>
362 <AND <TYPE? .TEADDR AC> <LOAD-AC .TEADDR .ADDR1>>)>>
364 <DEFINE GEN-CONSTANT (RCNS VALUE-AC TYPE-AC GEN-PREF
365 "AUX" (CNS .RCNS) VAC TAC (TYP <TYPE .CNS>))
366 #DECL ((CNS) ANY (VALUE-AC TYPE-AC) <OR ATOM AC> (GEN-PREF) ATOM)
367 <PROTECT <SET VAC <GET-AC .VALUE-AC T>>>
368 <MOVE-VALUE .CNS .VAC>
369 <COND (<AND <N==? .GEN-PREF TYPE-WORD> <NOT <COUNT-NEEDED? .TYP>>>
370 <SETG CONSTANT-TYPE-AC <>>
371 <SETG CONSTANT-COUNT-AC <>>)
373 <SET TAC <GET-AC PREF-TYPE>>
375 <COND (<==? .GEN-PREF TYPE-WORD>
376 <COND (<SET CNS <FIX-CONSTANT? .CNS>>
377 <EMIT-MOVE <TYPE-WORD .TYP> <MA-REG .TAC> LONG>
378 <LOAD-AC .TAC <TYPE-WORD .TYP>>)
380 <EMIT-MOVE <ADDR-TYPE-MQUOTE .RCNS>
383 <LOAD-AC .TAC <ADDR-TYPE-MQUOTE .RCNS>>)>
384 <SETG CONSTANT-TYPE-AC .TAC>)
386 <LOAD-CONSTANT .TAC <LENGTH .RCNS>>
387 <SETG CONSTANT-COUNT-AC .TAC>)>)>
390 <DEFINE LOAD-CONSTANT (DEST RVAL "AUX" VAL ADDR)
391 #DECL ((AC) AC (VAL) FIX)
392 <COND (<TYPE? .DEST AC> <SET ADDR <MA-REG .DEST>>)
393 (ELSE <SET ADDR .DEST>)>
394 <SET VAL <FIX-CONSTANT? .RVAL>>
395 <COND (<0? .VAL> <EMIT ,INST-CLRL .ADDR>)
396 (<AND <G=? .VAL 1> <L=? .VAL 63>>
397 <EMIT ,INST-MOVL <MA-LIT .VAL> .ADDR>)
398 (<AND <G=? .VAL -63> <L=? .VAL -1>>
399 <EMIT ,INST-MNEGL <MA-LIT <- .VAL>> .ADDR>)
400 (<AND <G=? .VAL 64> <L=? .VAL 255>>
401 <EMIT ,INST-MOVZBL <MA-BYTE-IMM .VAL> .ADDR>)
402 (<AND <G=? .VAL -127> <L=? .VAL -64>>
403 <EMIT ,INST-CVTBL <MA-BYTE-IMM .VAL> .ADDR>)
404 (<AND <G=? .VAL 255> <L=? .VAL ,MAXP16C>>
405 <EMIT ,INST-MOVZWL <MA-WORD-IMM .VAL> .ADDR>)
406 (<AND <G=? .VAL ,MIN16C> <L=? .VAL -128>>
407 <EMIT ,INST-CVTWL <MA-WORD-IMM .VAL> .ADDR>)
409 <COND (<G=? .RVAL 0.0>
410 <EMIT ,INST-MOVF <FLOAT-IMM .VAL> .ADDR>)
412 <EMIT ,INST-MNEGF <FLOAT-IMM <FLOATCONVERT <- .RVAL>>>
414 (ELSE <EMIT ,INST-MOVL <MA-LONG-IMM .VAL> .ADDR>)>>
416 <DEFINE DEST-DECL (AC DEST DCL "OPTIONAL" (STATUS? <>))
417 #DECL ((AC) AC (DEST) <OR ATOM VARTBL> (DCL) ATOM
418 (STATUS?) <OR FALSE ATOM>)
419 <COND (<==? .DEST STACK> <PUSH-PAIR .DCL .AC> <CLEAR-STATUS>)
420 (<TYPE? .DEST VARTBL>
422 <LINK-VAR-TO-AC .DEST .AC VALUE <>>
423 <INDICATE-CACHED-VARIABLE-DECL .DEST .DCL>
426 <SET-STATUS-VAR .DEST .STATUS?>)>)>>
428 <DEFINE DEST-COUNT-DECL (VAC CAC DEST DCL "OPTIONAL" (STATUS? <>))
429 #DECL ((VAC CAC) AC (DEST) <OR ATOM VARTBL> (DCL) ATOM
430 (STATUS?) <OR FALSE ATOM>)
431 <COND (<==? .DEST STACK>
432 <PUSH-PAIR-WITH-CNT .DCL .VAC .CAC>
434 (<TYPE? .DEST VARTBL>
436 <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
437 <INDICATE-CACHED-VARIABLE-DECL .DEST .DCL>
438 <LINK-VAR-TO-AC .DEST .CAC COUNT <>>
441 <SET-STATUS-VAR .DEST .STATUS?>)>)>>
443 <DEFINE DEST-PAIR (VAC CAC DEST "OPTIONAL" (STATUS? <>))
444 #DECL ((CAC VAC) AC (DEST) <OR ATOM VARTBL> (STATUS?) <OR FALSE ATOM>)
445 <COND (<==? .DEST STACK>
448 <MA-IMM ,SHORT-TYPE-MASK>
450 <COND (<==? <+ <AC-NUMBER .CAC> 1> <AC-NUMBER .VAC>>
451 <EMIT-PUSH <MA-REG .CAC> DOUBLE>)
453 <EMIT-PUSH <MA-REG .CAC> LONG>
454 <EMIT-PUSH <MA-REG .VAC> LONG>)>
456 (<TYPE? .DEST VARTBL>
458 <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
459 <LINK-VAR-TO-AC .DEST .CAC TYPE-WORD <>>
462 <SET-STATUS-VAR .DEST VALUE>)>)>>
464 <DEFINE DEST-TYPE-VALUE (VAC TAC DEST "OPTIONAL" (STATUS? <>) LVAR)
465 #DECL ((VAC TAC) AC (DEST) <OR ATOM VARTBL> (STATUS?) <OR FALSE ATOM>
467 <COND (<==? .DEST STACK>
468 <EMIT-PUSH <MA-REG .TAC> WORD>
470 <EMIT-PUSH <MA-REG .VAC> LONG>
472 (<TYPE? .DEST VARTBL>
474 <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
475 <LINK-VAR-TO-AC .DEST .TAC TYPE <>>
476 <SET LVAR <FIND-CACHE-VAR .DEST>>
477 <PUT .LVAR ,LINKVAR-COUNT-STORED T>
480 <SET-STATUS-VAR .DEST VALUE>)>)>>
482 <DEFINE PUSH-PAIR (TYP VAC)
483 #DECL ((TYP) ATOM (VAC) AC)
484 <EMIT-PUSH <TYPE-WORD .TYP> LONG>
485 <EMIT-PUSH <MA-REG .VAC> LONG>>
487 <DEFINE PUSH-PAIR-WITH-CNT (DCL VAC DAC)
488 #DECL ((VAC DAC) AC (DCL) ATOM)
489 <EMIT-PUSH <TYPE-CODE .DCL> WORD>
490 <EMIT-PUSH <MA-REG .DAC> WORD>
491 <EMIT-PUSH <MA-REG .VAC> LONG>>
493 <DEFINE PUSH-GEN (VAL)
495 <COND (<TYPE? .VAL VARTBL> <PUSH-VAR .VAL>) (<PUSH-CONSTANT .VAL>)>
498 <DEFINE POP-GEN (RES "AUX" VAC TAC)
500 <SET TAC <GET-AC DOUBLE>>
501 <EMIT-POP .TAC DOUBLE>
502 <DEST-PAIR <NEXT-AC .TAC> .TAC .RES>>
504 <DEFINE INIT-OPERATIONS ()
505 <SETG OP-APPLY-VECTOR <IVECTOR ,MAX-NUMBER-OPS ,BAD-OPERATION>>
507 <SETG MIMOP-OBLIST <MOBLIST MIMOP 51>>
508 <SETG VAR-OBLIST <MOBLIST VARS 51>>>
510 <DEFINE DEFINE-MIMOP (NAME FCN "OPT" (PROTECT? <>) "AUX" (CNT ,OP-COUNT) ANAME)
511 #DECL ((NAME) STRING)
512 <COND (<G? .CNT ,MAX-NUMBER-OPS>
513 <ERROR "TOO MANY OPERATIONS" DEFINE-MIMOP>)>
514 <PUT ,OP-APPLY-VECTOR .CNT .FCN>
516 <OR <LOOKUP .NAME ,MIMOP-OBLIST> <INSERT .NAME ,MIMOP-OBLIST>>>
517 <SETG .ANAME <COND (.PROTECT? <- .CNT>)
519 <SETG OP-COUNT <+ .CNT 1>>>
521 <DEFINE STRUCTURED-TYPE? (DCL)
523 <COND (<ISTYPE? .DCL>
524 <MEMQ <TYPEPRIM .DCL>
525 '[OFFSET RECORD UVECTOR STRING LIST VECTOR ATOM]>)
528 <DEFINE COUNT-NEEDED? (DCL)
530 <SET DCL <CLEAN-DECL .DCL>>
532 <MEMQ <TYPEPRIM .DCL>
533 '[OFFSET STRING VECTOR RECORD UVECTOR TUPLE BYTES]>>>
535 <DEFINE PARSE-HINT (HINT NAME "AUX" HTYP VAL)
536 #DECL ((HINT) HINT (NAME) ATOM)
537 <COND (<AND <TYPE? <SET HTYP <1 .HINT>> FORM>
538 <==? <LENGTH .HTYP> 2>
539 <==? <1 .HTYP> QUOTE>>
540 <SET HTYP <2 .HTYP>>)>
541 <COND (<==? .HTYP .NAME>
542 <COND (<AND <==? .HTYP TYPE>
543 <NOT <VALID-TYPE? <2 .HINT>>>
544 <SET VAL <CHECK-MIMOP-TYPE <2 .HINT>>>>
548 <DEFINE ADD-TO-AC (VAC VADDR)
549 #DECL ((VAC) AC (VADDR) EFF-ADDR)
550 <EMIT ,INST-ADDL2 .VADDR <MA-REG .VAC>>>
552 <DEFINE SUB-FROM-AC (VAC VADDR)
553 #DECL ((VAC) AC (VADDR) EFF-ADDR)
554 <EMIT ,INST-SUBL2 .VADDR <MA-REG .VAC>>>
556 <DEFINE MOVE-VALUE (VAL EADDR "AUX" FX? ADDR1)
557 #DECL ((VAL) ANY (EADDR) <OR AC EFF-ADDR>)
558 <COND (<TYPE? .VAL VARTBL>
559 <SET ADDR1 <VAR-VALUE-ADDRESS .VAL>>
560 <COND (<TYPE? .EADDR AC>
561 <EMIT-MOVE .ADDR1 <MA-REG .EADDR> LONG>
562 <LOAD-AC .EADDR .ADDR1>)
563 (<EMIT-MOVE .ADDR1 .EADDR LONG>)>)
564 (<FIX-CONSTANT? .VAL> <LOAD-CONSTANT .EADDR .VAL>)
566 <SET ADDR1 <ADDR-VALUE-MQUOTE .VAL>>
567 <COND (<TYPE? .EADDR AC>
568 <EMIT-MOVE .ADDR1 <MA-REG .EADDR> LONG>
569 <LOAD-AC .EADDR .ADDR1>)
570 (<EMIT-MOVE .ADDR1 .EADDR LONG>)>)>>
574 <DEFINE ADD-CONSTANT-TO-AC (VAL DEST
575 "AUX" SDATA (ACADDR <MA-REG .DEST>) SZ DADDR)
576 #DECL ((VAL) FIX (DEST) AC)
577 <SET VAL <FIX-CONSTANT? .VAL>>
579 (<==? .VAL 1> <EMIT ,INST-INCL .ACADDR>)
580 (<==? .VAL -1> <EMIT ,INST-DECL .ACADDR>)
581 (<AND <G=? .VAL 0> <L=? .VAL 63>>
582 <EMIT ,INST-ADDL2 <MA-LIT .VAL> .ACADDR>)
583 (<AND <G=? .VAL -63> <L=? .VAL 0>>
584 <EMIT ,INST-SUBL2 <MA-LIT <- .VAL>> .ACADDR>)
585 (ELSE <EMIT ,INST-ADDL2 <MA-LONG-IMM .VAL> .ACADDR>)>>
587 <DEFINE CLEAN-DECL (DCL "AUX" (NAME <SPNAME .DCL>) (SNAME .NAME))
589 <COND (<AND <G? <LENGTH .NAME> 2>
592 <SET NAME <LOOKUP <REST .NAME 2> <ROOT>>>
593 <OR <ISTYPE? .NAME> <MEMQ .NAME '[LBIND GBIND]>>>
595 (<ISTYPE? .DCL> .DCL)
596 (<LOOKUP .SNAME <ROOT>>)
599 <DEFINE CHECK-MIMOP-TYPE (ITEM)
601 <COND (<AND <==? <OBLIST? .ITEM> ,MIMOP-OBLIST>
602 <NOT <VALID-TYPE? .ITEM>>
603 <SET ITEM <LOOKUP <SPNAME .ITEM> <ROOT>>>
607 <DEFINE PRINT-MSUBR (BYTEOFF "OPTIONAL" (OUTCHAN .OUTCHAN))
608 #DECL ((OUTCHAN) CHANNEL)
609 <COND (<NOT ,BOOT-MODE>
610 <PRINC "<SETG
\1a" .OUTCHAN>
611 <PRIN1 ,FUNCTION-NAME .OUTCHAN>
612 <PRINC " " .OUTCHAN>)>
613 <PRINC "#MSUBR [" .OUTCHAN>
614 <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
616 <PRIN1 ,FUNCTION-NAME .OUTCHAN>
618 <PRIN1 ,FUNCTION-DECL .OUTCHAN>
620 <PRIN1 .BYTEOFF .OUTCHAN>
622 <OR ,BOOT-MODE <PRINC ">" .OUTCHAN>>
625 <MSETG INFINITY <CHTYPE <MIN> FIX>>
627 <DEFINE PRINT-IMSUBR ("OPTIONAL" (OUTCHAN .OUTCHAN) "AUX" (LLEN
629 #DECL ((OUTCHAN) CHANNEL)
631 <COND (<NOT ,BOOT-MODE>
632 <PRINC "<SETG
\1a" .OUTCHAN>
633 <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
634 <PRINC " " .OUTCHAN>)>
635 <PRINC "#IMSUBR [" .OUTCHAN>
636 <COND (,BOOT-MODE <PRINT-HEX-CODE .OUTCHAN>)
637 (ELSE <PRINT-NHEX-CODE .OUTCHAN>)>
639 <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
641 <PRINT-MVEC-ELEMENTS .OUTCHAN>
643 <OR ,BOOT-MODE <PRINC ">" .OUTCHAN>>
646 <GDECL (MSUBR-BUF) STRING (MSUBR-PTR) FIX>
647 <DEFINE PRINT-NHEX-CODE ("OPTIONAL" (OUTCHAN .OUTCHAN) (PTR 1)
648 (MAXPTR ,FBYTE-OFFSET)
649 (LEN </ <+ .MAXPTR 1> 4>))
650 #DECL ((OUTCHAN) CHANNEL (PTR MAXPTR) FIX)
651 <COND (<NOT <GASSIGNED? MSUBR-BUF>>
652 <SETG MSUBR-BUF <ISTRING 1024>>)
653 (<SETG MSUBR-BUF <TOP ,MSUBR-BUF>>)>
655 <SETG MSUBR-CHAN .OUTCHAN>
657 <PRINTBYTE </ .LEN 65536>>
658 <PRINTBYTE </ <MOD .LEN 65536> 256>>
659 <PRINTBYTE <MOD .LEN 256>>
661 <COND (<L=? <+ .PTR 3> .MAXPTR>
662 <PRINTBYTE <NTH-FCODE <+ .PTR 3>>>)
663 (ELSE <PRINTBYTE 0>)>
664 <COND (<L=? <+ .PTR 2> .MAXPTR>
665 <PRINTBYTE <NTH-FCODE <+ .PTR 2>>>)
666 (ELSE <PRINTBYTE 0>)>
667 <COND (<L=? <+ .PTR 1> .MAXPTR>
668 <PRINTBYTE <NTH-FCODE <+ .PTR 1>>>)
669 (ELSE <PRINTBYTE 0>)>
670 <PRINTBYTE <NTH-FCODE .PTR>>
671 <COND (<G? <SET PTR <+ .PTR 4>> .MAXPTR> <RETURN>)>>
673 <CHANNEL-OP .OUTCHAN WRITE-BUFFER <TOP ,MSUBR-BUF> ,MSUBR-PTR>>
675 <DEFINE PRINTBYTE (NUM)
677 <WRITE-BYTE <ASCII <+ <ASCII !\A> <CHTYPE <LSH .NUM -5> FIX>>>>
678 <WRITE-BYTE <ASCII <+ <ASCII !\A> <CHTYPE <ANDB .NUM 31> FIX>>>>>
680 <DEFINE WRITE-BYTE (BYTE "AUX" (S ,MSUBR-BUF))
681 #DECL ((BYTE) CHARACTER (S) STRING)
684 <CHANNEL-OP ,MSUBR-CHAN WRITE-BUFFER .S ,MSUBR-PTR>
687 <SETG MSUBR-BUF <REST .S>>
688 <SETG MSUBR-PTR <+ ,MSUBR-PTR 1>>>