97 <USE "CHKDCL" "COMPDEC" "ADVMESS">
99 <SETG RAT (`RECORD-TYPE ATOM)>
101 <SETG RBN (`RECORD-TYPE LBIND)>
103 <SETG RGBN (`RECORD-TYPE GBIND)>
105 <SETG QQ-BIND <FORM QUOTE BIND>>
113 <SETG QQ-M$$BINDID <FORM QUOTE M$$BINDID>>
117 <GDECL (MIMOPS) VECTOR>
137 <MANIFEST M$$FRM-MSUB
159 <MANIFEST M$$LVAL M$$GVAL M$$PNAM M$$OBLS M$$TYPE M$$ATML>
175 <MANIFEST M$$VALU M$$ATOM M$$DECL M$$PBND M$$PATM M$$UBID M$$BNDL>
274 ("TEMPLATE-TABLE" ANY)
329 ("STRING-EQUAL?" ANY)
337 <FUNCTION (L "AUX" (S <1 .L>) (TYP <2 .L>) A)
338 #DECL ((L) <LIST STRING ANY>)
339 <COND (<NOT <SET A <LOOKUP .S ,MIM-OBL>>>
340 <SET A <INSERT .S ,MIM-OBL>>)>
341 <COND (<N==? .TYP ANY> <PUTPROP .A TYPE .TYP>)>
342 <COND (<G? <LENGTH .L> 2> <PUTPROP .A `RECORD-TYPE T>)>>
345 "Generate function starting pseudo-op"
347 <DEFINE MIM-FCN (NAME DCL "OPT" (NEED-FR <>) "AUX" TT)
348 #DECL ((ARGS-NEXT) LIST)
349 <EMIT <SET TT <FORM <COND (.NEED-FR `FCN)
351 <CHTYPE .NAME FCN-ATOM>
352 <CHTYPE .DCL LIST>>>>
353 <SET ARGS-NEXT <REST .TT 2>>>
355 "Generate temp pseudo-op and return pointer to list so that others can
356 be dynamically added"
358 <DEFINE MIM-TEMPS-HOLD ()
359 #DECL ((TMPS) <SPECIAL FORM> (TMPS-NEXT) <SPECIAL LIST>)
360 <SET TMPS <FORM `TEMP>>
361 <SET TMPS-NEXT <CHTYPE .TMPS LIST>>
364 <DEFINE MIM-TEMPS-EMIT ()
368 "Here to change any TEMPS to ADECLs if possible"
370 <DEFINE TYPIFY-TEMPS (L)
371 #DECL ((L) <LIST [REST TEMP]>)
373 <FUNCTION (TMP "AUX" TYP)
375 <COND (<AND <SET TYP <TEMP-TYPE .TMP>>
376 <SET TYP <ISTYPE? .TYP>>
377 <N==? .TYP NO-RETURN>
379 <MUNG-TMP .TMP <REST <TEMP-FRAME .TMP>> .TYP>)>>
382 <DEFINE MUNG-TMP (TMP TL TYP "AUX" (NM <TEMP-NAME .TMP>))
383 #DECL ((TMP) TEMP (TL) LIST)
385 <FUNCTION (LL "AUX" (NM1 <1 .LL>))
386 <COND (<==? .NM1 .NM>
387 <PUT .LL 1 <CHTYPE [.NM .TYP] ADECL>>
391 "Here to create a temporary"
393 <DEFINE GEN-TEMP ("OPTIONAL" (ALLOCATE ANY) (NM "TEMP") (ARG-TEMP <>)
395 "AUX" TMP (TN .TMPS-NEXT) (FT .FREE-TEMPS))
396 #DECL ((TMP) TEMP (EVERY-TEMP TN FT FREE-TEMPS TMPS-NEXT) LIST)
398 (<OR <EMPTY? .FT> .ARG-TEMP>
399 <SET NM <MAKE-TAG .NM>>
400 <COND (.ALLOCATE <PUTREST .TN <SET TMPS-NEXT (<CHTYPE .NM ATOM>)>>)>
403 <COND (<OR .ALLOCATE <AND .NO-RECYC .ARG-TEMP>> 1) (ELSE 0)>
405 <COND (<OR .ALLOCATE .ARG-TEMP> T) (ELSE <>)>
407 <COND (.ALLOCATE <ISTYPE? .ALLOCATE>) (ELSE NO-RETURN)>]
409 <SET EVERY-TEMP (.TMP !.EVERY-TEMP)>
413 <REPEAT ((FT .FT) (OF .FT))
414 <COND (<EMPTY? .FT> <RETURN <>>)>
415 <COND (<OR <==? <TEMP-TYPE <SET TMP <1 .FT>>> NO-RETURN>
416 <AND <TEMP-TYPE .TMP>
417 <ISTYPE? <TYPE-MERGE <TEMP-TYPE .TMP>
419 <COND (<==? .OF .FT> <SET FREE-TEMPS <REST .FT>>)
420 (ELSE <PUTREST .OF <REST .FT>>)>
422 <SET FT <REST <SET OF .FT>>>>>
423 <USE-TEMP .TMP .ALLOCATE>
427 <SET FREE-TEMPS <REST .FT>>
428 <COND (.ALLOCATE <USE-TEMP .TMP .ALLOCATE>)>
431 ;"Special version of GEN-TEMP for in other frame"
433 <DEFINE SPEC-GEN-TEMP (TTMPS
434 "OPTIONAL" (ALLOCATE ANY) (NM "TEMP")
435 "AUX" TMP L (TMPS-NEXT .TMPS-NEXT)
436 (FREE-TEMPS .FREE-TEMPS) (TMPS .TMPS))
437 #DECL ((TMPS) <SPECIAL FORM> (TMPS-NEXT FREE-TEMPS) <SPECIAL LIST>
438 (ALL-TEMPS-LIST) <LIST [REST <LIST FORM LIST LIST ANY>]>)
439 <COND (<N==? .TMPS .TTMPS>
440 <SET L <FIND-FRAME <SET TMPS .TTMPS> T>>
442 <COMPILE-LOSSAGE "Bad frame model">)>
443 <SET TMPS-NEXT <2 .L>>
444 <SET FREE-TEMPS <3 .L>>
445 <SET TMP <GEN-TEMP .ALLOCATE .NM>>
446 <PUT .L 2 .TMPS-NEXT>
447 <PUT .L 3 .FREE-TEMPS>)
448 (ELSE <SET TMP <GEN-TEMP .ALLOCATE .NM>>)>
451 <DEFINE FIND-FRAME (TMPS "OPTIONAL" (LOC <>) "AUX" (L .ALL-TEMPS-LIST))
452 #DECL ((L ALL-TEMPS-LIST) <LIST [REST <LIST FORM LIST LIST TEMP>]>)
455 <COND (.LOC <RETURN ()>)
456 (ELSE <COMPILE-LOSSAGE "Bad frame model">)>)>
457 <COND (<N==? <1 <1 .L>> .TMPS> <SET L <REST .L>>)
458 (ELSE <RETURN <COND (.LOC <1 .L>) (ELSE <4 <1 .L>>)>>)>>>
460 <DEFINE USE-TEMP (TMP
462 "AUX" (NM <TEMP-NAME .TMP>) L (SPEC <CHTYPE .NM ATOM>))
463 #DECL ((TMPS-NEXT) LIST (NM) <PRIMTYPE ATOM> (TMP) TEMP)
464 <COND (<NOT <TEMP-ALLOC .TMP>>
465 <COND (<==? <TEMP-FRAME .TMP> .TMPS>
466 <PUTREST .TMPS-NEXT <SET TMPS-NEXT (.SPEC)>>)
468 <SET L <FIND-FRAME <TEMP-FRAME .TMP> T>>
469 <COND (<EMPTY? .L> <COMPILE-LOSSAGE "Bad frame model">)>
470 <PUTREST <2 .L> <2 <PUT .L 2 (.SPEC)>>>)>
471 <PUT .TMP ,TEMP-ALLOC T>)>
472 <COND (<AND .TY <TEMP-TYPE .TMP>>
474 <ISTYPE? <TYPE-MERGE <TEMP-TYPE .TMP> .TY>>>)
475 (<NOT .TY> <PUT .TMP ,TEMP-TYPE <>>)>
476 <PUT .TMP ,TEMP-REFS <+ <TEMP-REFS .TMP> 1>>>
478 <DEFINE FREE-TEMP (TMP "OPTIONAL" (KILL T) "AUX" REFS L)
479 #DECL ((REFS) FIX (L FREE-TEMPS) LIST)
480 <COND (<TYPE? .TMP TEMP>
481 <SET REFS <TEMP-REFS .TMP>>
482 <PUT .TMP ,TEMP-REFS <SET REFS <MAX <- .REFS 1> 0>>>
484 <COND (<NOT <TEMP-NO-RECYCLE .TMP>>
485 <COND (<AND <==? .TMPS <TEMP-FRAME .TMP>>
486 <NOT <MEMQ .TMP .FREE-TEMPS>>>
487 <SET FREE-TEMPS (.TMP !.FREE-TEMPS)>)
489 <SET L <FIND-FRAME <TEMP-FRAME .TMP> T>>
490 <COND (<AND <NOT <EMPTY? .L>>
491 <NOT <MEMQ .TMP <3 .L>>>>
492 <PUT .L 3 (.TMP !<3 .L>)>)>)>)>
493 <COND (.KILL <IEMIT `DEAD <TEMP-NAME .TMP>>)>)>)>
496 <DEFINE DEALLOCATE-TEMP (TMP "AUX" REFS)
498 <COND (<TYPE? .TMP TEMP>
499 <SET REFS <TEMP-REFS .TMP>>
500 <PUT .TMP ,TEMP-REFS <MAX <- .REFS 1> 0>>)>
503 "Generate a unique atom for label, temp name, var name etc."
505 <DEFINE MAKE-TAG ("OPTIONAL" (S "TAG") "AUX" LC TC)
506 #DECL ((S) <OR ATOM STRING>)
507 <COND (<TYPE? .S ATOM> <SET S <SPNAME .S>>)>
508 <SET TC <UNPARSE <SET TAG-COUNT <+ .TAG-COUNT 1>>>>
509 <COND (<AND <G=? <SET LC <- <CHTYPE <NTH .S <LENGTH .S>> FIX>
512 <SET S <STRING .S "-" .TC>>)
514 <SET S <STRING .S .TC>>)>
515 <OR <LOOKUP .S ,TMP-OBL> <INSERT .S ,TMP-OBL>>>
517 "Add an instruction to the output code"
520 #DECL ((CODE-PTR) <LIST ANY>)
521 <PUTREST .CODE-PTR <SET CODE-PTR (.THING !<REST .CODE-PTR>)>>>
523 <SETG INSTRUCTION ,FORM>
525 <DEFINE IEMIT ("TUPLE" X) <REAL-IEMIT <> .X>>
527 <DEFINE SPEC-IEMIT ("TUPLE" X) <REAL-IEMIT T .X>>
529 <DEFINE REAL-IEMIT (SKIP-DEAD X
530 "AUX" (DEAD-TEMPS ()) (INS <1 .X>) (PAST= <>) FOR-SETRL
531 (DO-LATER-SETRL <>) (FREED-TEMPS ()) TMP CP)
532 #DECL ((X) <TUPLE ANY> (DEAD-TEMPS FREED-TEMPS) LIST (CP CODE-PTR) LIST)
537 <FUNCTION (XP "AUX" (Y <1 .XP>) Z)
538 #DECL ((XP) <PRIMTYPE VECTOR> (Z) TEMP)
539 <COND (<==? .Y => <SET PAST= T>)>
541 (<TYPE? .Y MIM-SPECIAL> <PUT .XP 1 <CHTYPE .Y ATOM>>)
544 (<AND <N==? <TEMP-FRAME .Y> .TMPS>
545 <OR <N==? .INS `SETRL> <N==? .XP <REST .X 2>>>>
546 <COND (<==? .INS `SET>
547 <COND (<==? .XP <REST .X>>
549 <FIND-FRAME <TEMP-FRAME .Y>>
556 <FIND-FRAME <TEMP-FRAME .Y>>
561 <SET FREED-TEMPS (<SET Z <LOOP-FRAME .Y>> !.FREED-TEMPS)>
562 <SET DEAD-TEMPS (<TEMP-NAME .Z> !.DEAD-TEMPS)>)
564 <SET DO-LATER-SETRL <GEN-TEMP>>
565 <SET Z .DO-LATER-SETRL>
566 <SET FOR-SETRL .Y>)>)
568 <PUT .XP 1 <TEMP-NAME .Z>>
569 <COND (<==? <TEMP-REFS .Y> 0>
570 <SET DEAD-TEMPS (<TEMP-NAME .Y> !.DEAD-TEMPS)>)>)
571 (<AND <TYPE? .Y ATOM>
578 <N==? <OBLIST? .Y> ,TMP-OBL>>
579 <PUT .XP 1 <FORM QUOTE .Y>>)>
582 <SET INS <INSTRUCTION .INS !<REST .X>>>
583 <COND (<AND .SKIP-DEAD
584 <TYPE? <SET TMP <1 <SET CP .CODE-PTR>>> FORM>
586 <==? <1 .TMP> `DEAD>>
590 <COND (.DO-LATER-SETRL
592 <FIND-FRAME <TEMP-FRAME .FOR-SETRL>>
593 <TEMP-NAME .FOR-SETRL>
596 <FUNCTION (TMP) #DECL ((TMP) TEMP) <FREE-TEMP .TMP <>>>
598 <COND (<NOT <EMPTY? .DEAD-TEMPS>>
599 <EMIT <CHTYPE (`DEAD !.DEAD-TEMPS) FORM>>)>
602 <DEFINE LOOP-FRAME (TMP
603 "OPTIONAL" LTMP (TNAME <TEMP-NAME <4 <1 .ALL-TEMPS-LIST>>>)
605 <COND (<ASSIGNED? LTMP> .LTMP) (ELSE <GEN-TEMP>)>)
606 (TMPS <1 <1 .ALL-TEMPS-LIST>>)
607 (ALL-TEMPS-LIST <REST .ALL-TEMPS-LIST>))
608 #DECL ((TMPS) <SPECIAL FORM>
609 (ALL-TEMPS-LIST) <SPECIAL <LIST [REST
610 <LIST FORM LIST LIST TEMP>]>>)
611 <COND (<N==? .TMPS <TEMP-FRAME .TMP>>
615 <TEMP-NAME <4 <1 .ALL-TEMPS-LIST>>>>
616 <LOOP-FRAME .TMP .XTMP <TEMP-NAME .XTMP>>)
617 (ELSE <IEMIT `SETLR <TEMP-NAME .XTMP> .TNAME <TEMP-NAME .TMP>>)>
620 "Generate a label in the code"
622 <DEFINE LABEL-TAG (TG) <EMIT .TG>>
624 "Generate jump to label"
626 <DEFINE BRANCH-TAG (TG) <IEMIT `JUMP + .TG>>
628 "Generate code to PUSH something onto stack. It can be called with various
630 1) #TEMP - refernce to a named temporary
631 3) #MIM-SPECIAL atom - MIM special variable
632 4) other - quoted object "
635 <COND (<TYPE? .ITM MIM-SPECIAL> <IEMIT `PUSH <CHTYPE .ITM ATOM>>)
636 (<TYPE? .ITM TEMP> <IEMIT `PUSH .ITM>)
637 (<==? .ITM ,POP-STACK>)
638 (ELSE <IEMIT `PUSH <ATOMCHK .ITM>>)>
642 <COND (<TYPE? .ITM TEMP> <IEMIT `POP = <TEMP-NAME .ITM>>)
643 (<==? .ITM FLUSHED> <IEMIT `ADJ -2>)
644 (<AND <N==? .ITM ,TOP-STACK> <N==? .ITM DONT-CARE>>
645 <COMPILE-LOSSAGE "Bad arg to POP" .ITM>)
646 (ELSE <SET ITM ,POP-STACK>)>
649 <DEFINE PUSH-CONSTANT (X) <PUSH <ATOMCHK .X>>>
651 " Generate FIXBIND to wrap bindings pending by linking up atoms."
653 <DEFINE GEN-FIX-BIND () <IEMIT `FIXBIND>>
655 " Generate code for optional arguments."
657 <DEFINE GEN-ARG-NUM (N) #DECL ((N) FIX) <IEMIT `ARGNUM .N>>
659 <DEFINE SPECIAL-BINDING (SYM FIXB "OPTIONAL" INIT)
660 <COND (<ASSIGNED? INIT>
662 <ATOMCHK <NAME-SYM .SYM>>
663 <ATOMCHK <DECL-SYM .SYM>>
664 <COND (.FIXB ''FIX) (ELSE <>)>
668 <ATOMCHK <NAME-SYM .SYM>>
669 <ATOMCHK <DECL-SYM .SYM>>
670 <COND (.FIXB ''FIX) (ELSE <>)>>)>>
672 "Get the value of a special variable bound in the current function"
674 <DEFINE GET-VALUE-X (ATM TMP
676 "AUX" (BTMP <COND (<AND <TYPE? .TMP TEMP>
677 <OR <NOT <TEMP-NO-RECYCLE .TMP>>
678 <==? <TEMP-NO-RECYCLE .TMP>
680 <NOT <TEMP-TYPE .TMP>>
681 <==? <TEMP-FRAME .TMP> .TMPS>>
683 (ELSE <GEN-TEMP>)>) (FQA <ATOMCHK .ATM>)
684 (TG1 <MAKE-TAG>) (TG2 <MAKE-TAG>) BIDTMP1 BIDTMP2)
685 #DECL ((BTMP BIDTMP1 BIDTMP2) TEMP)
687 <IEMIT `GEN-LVAL .FQA = .TMP>)
690 <DEALLOCATE-TEMP .BTMP>
691 <IEMIT `NTHR .FQA ,M$$LVAL = .BTMP ,RAT '(`TYPE LBIND)>
692 <IEMIT `NTHR .BTMP ,M$$VALU = .TMP ,RBN>
693 <COND (<N==? .TMP .BTMP> <FREE-TEMP .BTMP>)>)>
696 "See if a special variable is assigned"
698 <DEFINE ASS-GEN (ATM TG DIR
700 "AUX" (BTMP <GEN-TEMP>) (FQA <ATOMCHK .ATM>) BIDTMP1 BIDTMP2
701 (TGX <COND (.DIR <MAKE-TAG>) (ELSE .TG)>))
702 #DECL ((BTMP BIDTMP1 BIDTMP2) TEMP)
703 <COND (.EXT <IEMIT `GEN-ASSIGNED? .FQA <COND (.DIR +) (ELSE -)> .TG>)
705 <IEMIT `NTHR .FQA ,M$$LVAL = .BTMP ,RAT '(`TYPE LBIND)>
706 <IEMIT `NTHR .BTMP ,M$$VALU = .BTMP ,RBN>
707 <GEN-TYPE? .BTMP UNBOUND .TG <NOT .DIR>>
710 "Set the value of a special variable bound in the current function"
712 <DEFINE SET-VALUE (ATM TMP
715 (FQA <ATOMCHK .ATM>) (TG1 <MAKE-TAG>) (TG2 <MAKE-TAG>)
717 #DECL ((BTMP BIDTMP1 BIDTMP2) TEMP)
719 <IEMIT `GEN-SET .FQA .TMP>)
721 <SET BTMP <GEN-TEMP LBIND>>
722 <IEMIT `NTHR .FQA ,M$$LVAL = .BTMP ,RAT '(`TYPE LBIND)>
723 <IEMIT `PUTR .BTMP ,M$$VALU <ATOMCHK .TMP> ,RBN>
727 "Generate code to set a MIM local"
729 <DEFINE SET-SYM (SYM "OPTIONAL" VAL (USE-IT <>)
730 "AUX" (TMP <TEMP-NAME-SYM .SYM>) (TY ANY)
731 (REFS <TEMP-REFS .TMP>))
732 #DECL ((SYM) SYMTAB (TMP) TEMP (REFS) FIX)
733 <COND (<ASSIGNED? VAL>
734 <SET TY <COND (<TYPE? .VAL TEMP> <TEMP-TYPE .VAL>)
736 <SET-TEMP .TMP .VAL>)>
739 <PUT .TMP ,TEMP-REFS <+ .REFS 1>>)>>
741 <DEFINE SET-TEMP (TMP "OPTIONAL" VAL XTRA "AUX" REFS (TY ANY))
742 #DECL ((TMP) TEMP (REFS) FIX)
743 <COND (<ASSIGNED? VAL>
745 <COND (<TYPE? .VAL TEMP> <TEMP-TYPE .VAL>)
746 (ELSE <TYPE .VAL>)>>)>
748 <COND (<ASSIGNED? VAL>
749 <COND (<TYPE? .VAL MIM-SPECIAL> <SET VAL <CHTYPE .VAL ATOM>>)
750 (ELSE <SET VAL <ATOMCHK .VAL>>)>
751 <COND (<ASSIGNED? XTRA> <IEMIT `SET .TMP .VAL .XTRA>)
752 (ELSE <IEMIT `SET .TMP .VAL>)>)>>
754 "Quote atom to protect the MIM assembler"
757 <COND (<REPEAT ((Y .X))
758 <COND (<TYPE? .Y ATOM> <RETURN T>)>
759 <COND (<AND <TYPE? .Y FORM>
767 " Return currently running FRAME "
769 <DEFINE CURRENT-FRAME ("OPTIONAL" (FR <GEN-TEMP FRAME>))
770 <IEMIT `CFRAME = .FR '(`TYPE FRAME)> .FR>
772 " Return TUPLE of arguments"
774 <DEFINE GET-ARG-TUPLE (FR)
776 <PUT .TMPS 1 `MAKTUP>
777 <SET TMP-DEST <TEMP-NAME .FR>>
780 "Compare # of args supplied with a constant and jump in appropriate case"
782 <DEFINE TEST-ARG (TMP TG)
783 #DECL ((TMP) TEMP (TG) ATOM)
784 <GEN-TYPE? .TMP UNBOUND .TG <>>
787 "Get current binding at top of world"
789 <DEFINE GET-BINDING (WHERE) <IEMIT `GETS ,QQ-BIND = .WHERE '(`TYPE LBIND)>>
791 "Get an arg by arg number and mung into a local"
793 <DEFINE ARG-TO-TEMP (SYM
794 "AUX" (TMP <TEMP-NAME-SYM .SYM>)
795 (ATMP <ARG-NAME-SYM .SYM>))
796 #DECL ((SYM) SYMTAB (TMP) TEMP)
797 <IEMIT `SET <TEMP-NAME .TMP> <TEMP-NAME .ATMP>>>
799 "Generate call to MSUBR"
801 <DEFINE MSUBR-CALL (NAM NARGS W)
802 <SET NAM <CHTYPE .NAM FCN-ATOM>>
803 <COND (<==? .W FLUSHED>
804 <IEMIT `CALL <FORM QUOTE .NAM> .NARGS>)
805 (ELSE <IEMIT `CALL <FORM QUOTE .NAM> .NARGS = .W>)>>
807 <DEFINE SEG-SUBR-CALL (NAM NARGS W COUNT LABEL)
808 <SET NAM <CHTYPE .NAM FCN-ATOM>>
809 <IEMIT `SCALL <FORM QUOTE .NAM> .NARGS = .W + .LABEL .COUNT>>
811 "Begin building a FRAME for a future call"
813 <DEFINE START-FRAME ("OPT" (NAME <>))
814 <COND (.NAME <IEMIT `FRAME <FORM QUOTE <CHTYPE .NAME FCN-ATOM>>>)
815 (ELSE <IEMIT `FRAME>)>>
817 "Generate a VECTOR of the top N things on the stack"
819 <DEFINE GEN-VECTOR (N V "OPT" (S? <>))
820 <IEMIT <COND (.S? `SBLOCK)
821 (ELSE `UBLOCK)> '<`TYPE-CODE VECTOR> .N = .V>
824 <DEFINE GEN-UVECTOR (N V "OPT" (S? <>))
825 <IEMIT <COND (.S? `SBLOCK)
826 (ELSE `UBLOCK)> '<`TYPE-CODE UVECTOR> .N = .V>
831 <DEFINE GEN-TUPLE (N V)
832 <IEMIT `TUPLE .N = .V '(`TYPE TUPLE)>
837 <DEFINE GEN-LIST (N L) <IEMIT `LIST .N = .L '(`TYPE LIST)>>
839 "Generate code to move datum from place to place"
841 <DEFINE MOVE-ARG (FROM TO "OPT" XTRA "AUX" (TY ANY))
842 <COND (<AND <NOT <ASSIGNED? XTRA>> <NOT <TYPE? .FROM TEMP>>>
843 <SET XTRA <COND (<AND <TYPE? .FROM FORM>
844 <==? <LENGTH .FROM> 2>
845 <==? <1 .FROM> QUOTE>
846 <TYPE? <2 .FROM> ATOM>>
848 (ELSE (`TYPE <TYPE .FROM>))>>
850 (<AND <ASSIGNED? XTRA> <TYPE? .XTRA LIST>> <SET TY <2 .XTRA>>)
851 (<TYPE? .FROM TEMP> <SET TY <TEMP-TYPE .FROM>>)
852 (ELSE <SET TY <TYPE .FROM>>)>
853 <COND (<==? .TO FLUSHED>
854 <COND (<==? .FROM ,POP-STACK> <POP FLUSHED>)>
859 <FUNCTION (TTO) <MOVE-ARG .FROM .TTO .XTRA>>
862 <COND (<==? .TO ,POP-STACK> <PUSH .FROM> <FREE-TEMP .FROM> .TO)
863 (<AND <ASSIGNED? THE-BOOL> <==? .THE-BOOL .TO>>
865 <IEMIT `AND .THE-BOOL .THE-BIT = .THE-BOOL>)
867 <IEMIT `OR .THE-BOOL .THE-BIT = .THE-BOOL>)
868 (ELSE <ERROR OH-SHIT!-ERRORS>)>
872 <COND (<TYPE? .FROM TEMP>
873 <COND (<ASSIGNED? XTRA>
874 <IEMIT `SET .TO .FROM .XTRA>)
876 <IEMIT `SET .TO .FROM>)>
879 <COND (<ASSIGNED? XTRA>
880 <IEMIT `SET .TO <ATOMCHK .FROM> .XTRA>)
882 <IEMIT `SET .TO <ATOMCHK .FROM>>)>)>
885 <COND (<==? .FROM ,TOP-STACK> ,POP-STACK)
889 <DEFINE REFERENCE (X) .X>
891 "Generate a TYPE? instruction"
893 <DEFINE GEN-TYPE? (ITM TYP TG DIR)
896 <COND (<TYPE? .TYP TEMP> .TYP) (ELSE <FORM `TYPE-CODE .TYP>)>
897 <COND (.DIR +) (ELSE -)>
900 <DEFINE GEN-VT (ITM TG DIR
902 "AUX" TMP (SIGN <COND (.DIR -) (+)>))
903 <COND (<ASSIGNED? RTMP> <SET TMP .RTMP>)
904 (ELSE <SET TMP <GEN-TEMP <>>>)>
906 <IEMIT `NTHR .ITM ,M$$TYPE = .TMP ,RAT (`BRANCH-FALSE .SIGN .TG)>
907 <SPEC-IEMIT `TYPE? .TMP '<`TYPE-CODE FALSE>
908 <COND (.DIR -)(ELSE +)> .TG>
909 <COND (<NOT <ASSIGNED? RTMP>> <FREE-TEMP .TMP>)>>
911 <DEFINE GEN-TC (TMP "OPT" RTMP)
912 <COND (<ASSIGNED? RTMP> <USE-TEMP .RTMP TYPE-C>)
913 (ELSE <SET RTMP <GEN-TEMP TYPE-C>>)>
915 <IEMIT `NTHR .TMP ,M$$TYPE = .RTMP ,RAT
916 '(`BRANCH-FALSE + `COMPERR)>
917 <SPEC-IEMIT `TYPE? .RTMP '<`TYPE-CODE FALSE> + `COMPERR>)
928 "Generate SETG/GVAL things"
930 <DEFINE GEN-GVAL (ATM W "OPT" (TYP <>) "AUX" TEM TG1 TG2)
931 <COND (<TYPE? .ATM ATOM> <SET ATM <FORM QUOTE .ATM>>)>
932 <COND (.TYP <IEMIT `GVAL .ATM = .W (`TYPE .TYP)>)
933 (ELSE <IEMIT `GVAL .ATM = .W>)>>
935 <DEFINE GEN-GASS (ATM TG DIR NM "AUX" (TG1 <COND (<N==? .NM GASSIGNED?> .TG)
937 (ELSE .TG)>) (SIGN +) TEM)
938 <COND (<AND .DIR <N==? .NM GASSIGNED?>> <SET SIGN ->)>
939 <IEMIT `NTHR <COND (<TYPE? .ATM ATOM> <FORM QUOTE .ATM>)
941 ,M$$GVAL = <SET TEM <GEN-TEMP>> ,RAT
942 (`BRANCH-FALSE .SIGN .TG1)>
943 <SPEC-IEMIT `TYPE? .TEM '<`TYPE-CODE FALSE> .SIGN .TG1>
944 <COND (<==? .NM GASSIGNED?>
945 <IEMIT `NTHR .TEM ,M$$VALU = .TEM ,RGBN>
946 <GEN-TYPE? .TEM UNBOUND .TG <NOT .DIR>>)>
947 <COND (<N==? .TG .TG1> <LABEL-TAG .TG1>)>
951 <DEFINE GEN-SETG (ATM VAL DCL WHERE "AUX" TEM TG1 TG2)
952 <COND (<TYPE? .ATM ATOM>
953 <IEMIT `SETG <FORM QUOTE .ATM> <ATOMCHK .VAL>>)
955 <IEMIT `NTHR .ATM ,M$$GVAL = <SET TEM <GEN-TEMP>> ,RAT
956 (`BRANCH-FALSE + <SET TG1 <MAKE-TAG>>)>
957 <SPEC-IEMIT `TYPE? .TEM '<`TYPE-CODE FALSE> + .TG1>
958 <IEMIT `PUTR .TEM ,M$$VALU .VAL ,RGBN>
960 <IEMIT .TEM `PUTR ,M$$DECL .DCL ,RGBN>)>
961 <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
966 <COND (.DCL <PUSH .DCL>)>
967 <COND (<N==? .WHERE FLUSHED>
968 <MSUBR-CALL SETG <COND (.DCL 3) (ELSE 2)> .VAL>)
970 <MSUBR-CALL SETG <COND (.DCL 3) (ELSE 2)> FLUSHED>)>
976 <DEFINE GEN-CHTYPE (ITM TYP W)
977 <IEMIT `CHTYPE .ITM <COND (<AND <TYPE? .TYP ATOM>
979 <FORM `TYPE-CODE .TYP>)
982 <DEFINE D-B-TAG (BR WH DIR TYP)
983 <COND (<AND <NOT <TYPE-OK? .TYP '<FALSE ANY>>>
984 <SET TYP <TYPE-AND .TYP '<NOT FALSE>>>
985 <NOT <TYPE-OK? .TYP '<PRIMTYPE FIX>>>
986 <OR <NOT <SET TYP <TYPE-AND .TYP '<PRIMTYPE LIST>>>>
988 <IEMIT `VEQUAL? .WH 0 <COND (.DIR -)(ELSE +)> .BR>)
990 <GEN-TYPE? .WH FALSE .BR <NOT .DIR>>)>>
992 <DEFINE MIM-RETURN ("OPTIONAL" (VAL ,POP-STACK))
993 <IEMIT `RETURN <ATOMCHK .VAL>>>
995 <DEFINE RET-TMP-AC (X) .X>
997 <DEFINE GEN-SHIFT (DAT AMT W) <IEMIT `LSH .DAT .AMT = .W '(`TYPE FIX)>>
999 <DEFINE NTH-LIST (SRC DST AMT "OPT" (RESTYP <>))
1000 <COND (.RESTYP <IEMIT `NTHL .SRC .AMT = .DST (`TYPE .RESTYP)>)
1001 (ELSE <IEMIT `NTHL .SRC .AMT = .DST>)>>
1003 <DEFINE NTH-UVECTOR (SRC DST AMT "OPT" (RESTYP <>))
1004 <COND (.RESTYP <IEMIT `NTHUU .SRC .AMT = .DST (`TYPE .RESTYP)>)
1005 (ELSE <IEMIT `NTHUU .SRC .AMT = .DST>)>>
1007 <DEFINE NTH-VECTOR (SRC DST AMT "OPT" (RESTYP <>))
1008 <COND (.RESTYP <IEMIT `NTHUV .SRC .AMT = .DST (`TYPE .RESTYP)>)
1009 (ELSE <IEMIT `NTHUV .SRC .AMT = .DST>)>>
1011 <DEFINE NTH-STRING (SRC DST AMT "OPT" (RESTYP <>))
1012 <COND (.RESTYP <IEMIT `NTHUS .SRC .AMT = .DST (`TYPE .RESTYP)>)
1013 (ELSE <IEMIT `NTHUS .SRC .AMT = .DST>)>>
1015 <DEFINE NTH-BYTES (SRC DST AMT "OPT" (RESTYP <>))
1016 <COND (.RESTYP <IEMIT `NTHUB .SRC .AMT = .DST (`TYPE .RESTYP)>)
1017 (ELSE <IEMIT `NTHUB .SRC .AMT = .DST>)>>
1019 <DEFINE NTH-RECORD (SRC DST AMT TPS "OPT" (RESTYP <>))
1021 <IEMIT `NTHR .SRC .AMT = .DST (`RECORD-TYPE .TPS)
1024 <IEMIT `NTHR .SRC .AMT = .DST (`RECORD-TYPE .TPS)>)>>
1026 <DEFINE REST-LIST (SRC DST AMT) <IEMIT `RESTL .SRC .AMT = .DST
1029 <DEFINE REST-UVECTOR (SRC DST AMT) <IEMIT `RESTUU .SRC .AMT = .DST
1032 <DEFINE REST-VECTOR (SRC DST AMT "OPT" TY)
1033 <COND (<ASSIGNED? TY>
1034 <IEMIT `RESTUV .SRC .AMT = .DST (`TYPE .TY)>)
1036 <IEMIT `RESTUV .SRC .AMT = .DST>)>>
1038 <DEFINE REST-STRING (SRC DST AMT) <IEMIT `RESTUS .SRC .AMT = .DST
1041 <DEFINE REST-BYTES (SRC DST AMT) <IEMIT `RESTUB .SRC .AMT = .DST
1044 <DEFINE EMPTY-LIST (SRC TG DIR "OPT" (TY <>))
1046 <IEMIT `EMPL? .SRC <COND (.DIR +) (ELSE -)> .TG
1049 <IEMIT `EMPL? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1051 <DEFINE EMPTY-UVECTOR (SRC TG DIR "OPT" (TY <>))
1053 <IEMIT `EMPUU? .SRC <COND (.DIR +) (ELSE -)> .TG
1056 <IEMIT `EMPUU? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1058 <DEFINE EMPTY-VECTOR (SRC TG DIR "OPT" (TY <>))
1060 <IEMIT `EMPUV? .SRC <COND (.DIR +) (ELSE -)> .TG
1063 <IEMIT `EMPUV? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1065 <DEFINE EMPTY-STRING (SRC TG DIR "OPT" (TY <>))
1067 <IEMIT `EMPUS? .SRC <COND (.DIR +) (ELSE -)> .TG
1070 <IEMIT `EMPUS? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1072 <DEFINE EMPTY-BYTES (SRC TG DIR "OPT" (TY <>))
1074 <IEMIT `EMPUB? .SRC <COND (.DIR +) (ELSE -)> .TG
1077 <IEMIT `EMPUB? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1079 <DEFINE EMPTY-RECORD (SRC TG DIR TPS)
1080 <IEMIT `EMPR? .SRC <COND (.DIR +) (ELSE -)> .TG
1081 (`RECORD-TYPE .TPS)>>
1083 <DEFINE LENGTH-LIST (SRC DST) <IEMIT `LENL .SRC = .DST '(`TYPE FIX)>>
1085 <DEFINE LENGTH-UVECTOR (SRC DST) <IEMIT `LENUU .SRC = .DST '(`TYPE FIX)>>
1087 <DEFINE LENGTH-VECTOR (SRC DST) <IEMIT `LENUV .SRC = .DST '(`TYPE FIX)>>
1089 <DEFINE LENGTH-STRING (SRC DST) <IEMIT `LENUS .SRC = .DST '(`TYPE FIX)>>
1091 <DEFINE LENGTH-BYTES (SRC DST) <IEMIT `LENUB .SRC = .DST '(`TYPE FIX)>>
1093 <DEFINE LENGTH-RECORD (SRC DST TPS) <IEMIT `LENR .SRC = .DST
1094 (`RECORD-TYPE .TPS) '(`TYPE FIX)>>
1096 <DEFINE PUT-LIST (SRC NUM NEW "OPT" (TY <>))
1097 <COND (.TY <IEMIT `PUTL .SRC .NUM <ATOMCHK .NEW> .TY>)
1098 (ELSE <IEMIT `PUTL .SRC .NUM <ATOMCHK .NEW>>)>>
1100 <DEFINE PUT-VECTOR (SRC NUM NEW "OPT" (TY <>))
1101 <COND (.TY <IEMIT `PUTUV .SRC .NUM <ATOMCHK .NEW> .TY>)
1102 (ELSE <IEMIT `PUTUV .SRC .NUM <ATOMCHK .NEW>>)>>
1104 <DEFINE PUT-UVECTOR (SRC NUM NEW) <IEMIT `PUTUU .SRC .NUM .NEW>>
1106 <DEFINE PUT-STRING (SRC NUM NEW) <IEMIT `PUTUS .SRC .NUM .NEW>>
1108 <DEFINE PUT-BYTES (SRC NUM NEW) <IEMIT `PUTUB .SRC .NUM .NEW>>
1110 <DEFINE PUT-RECORD (SRC NUM NEW TPS "OPT" (TY <>))
1111 <COND (.TY <IEMIT `PUTR .SRC .NUM <ATOMCHK .NEW> (`RECORD-TYPE .TPS) .TY>)
1112 (ELSE <IEMIT `PUTR .SRC .NUM <ATOMCHK .NEW> (`RECORD-TYPE .TPS)>)>>
1114 <DEFINE PROTECT (ITM)
1115 <COND (<AND <TYPE? .ITM TEMP>
1116 <0? <TEMP-REFS .ITM>>>
1121 <DEFINE GEN-VAL-==? (D1 D2 DIR BR)
1122 <IEMIT `VEQUAL? <ATOMCHK .D1> <ATOMCHK .D2> <COND (.DIR +) (ELSE -)> .BR>>
1124 <DEFINE GEN-==? (D1 D2 DIR BR)
1125 <IEMIT `EQUAL? <ATOMCHK .D1> <ATOMCHK .D2> <COND (.DIR +) (ELSE -)> .BR>>
1128 <DEFINE PREV-FRAME (WHERE)
1129 <IEMIT `CFRAME = .WHERE>
1130 <IEMIT `NTHR .WHERE ,M$$FRM-PREV = .WHERE (`RECORD-TYPE FRAME)>