14 <SETG BEAR-JSYS 9126805504>
16 <GDECL (MAX-IMMEDIATE) FIX>
23 <BLOCK (<SETG JSYS-OBLIST <MOBLIST JSYS>> <ROOT>)>
428 SETER ;"NEW JSYS'S FOR TOPS-20"
599 <REPEAT ((PNTR ,ALL-JSY) JSY) #DECL ((PNTR) <VECTOR [REST FIX ATOM]>)
600 <COND (<EMPTY? .PNTR> <RETURN>)>
601 <SET JSY <CHTYPE <+ ,BEAR-JSYS <1 .PNTR>> JSYS>>
602 <COND (<AND <GASSIGNED? <2 .PNTR>> <N==? ,<2 .PNTR> .JSY>>
603 <ERROR JSYS-ALREADY-ASSIGNED <1 .PNTR>>)>
604 <SETG <2 .PNTR> .JSY>
605 <SET PNTR <REST .PNTR 2>>>>
607 <COND (<GASSIGNED? SETUP-JSY> <SETUP-JSY>)>
609 <DEFINE SYSOP!-MIMOC (L "AUX" (MUNGED-REG 1) (DEST <>) THING DIR (LBL <>)
610 TT (LL ()) JSFCN JSATM JSFORM JSNUM XL1 XL2)
612 <COND (<EMPTY? .L> <MIMOCERR NO-JSYS-SUPPLIED!-ERRORS>)>
613 <COND (<OR <AND <TYPE? <SET JSFORM <1 .L>> FORM>
614 <==? <LENGTH .JSFORM> 2>
615 <==? <1 .JSFORM> QUOTE>
616 <TYPE? <SET JSATM <2 .JSFORM>> ATOM>
617 <TYPE? <SET JSATM <LOOKUP <SPNAME .JSATM>
621 <TYPE? <SET JSNUM ,.JSATM> JSYS>>
622 <AND <TYPE? <SET JSNUM .JSFORM> FIX JSYS>
623 <SET JSFORM <MEMQ <CHTYPE <ANDB .JSNUM *777777*> FIX>
625 <SET JSATM <2 .JSFORM>>>
627 <COND (<SET JSFCN <AND <ASSIGNED? JSATM>
628 <GETPROP .JSATM SPECIAL-JSYS-FUNCTION>>>
629 <APPLY .JSFCN .JSATM .L>)
631 <COND (<EMPTY? <SET L <REST .L>>>)
632 (<MEMQ <SET THING <1 .L>> '[= + -]>
633 <COND (<==? .THING =>
635 <SET L <REST .L 2>>)>
636 <COND (<NOT <EMPTY? .L>>
640 <COND (<SET TT <MEMQ = .L>> <SET DEST <2 .TT>>)>
641 <COND (<SET TT <OR <MEMQ + .L> <MEMQ - .L>>>
644 <REPEAT ((ACL <REST <CHTYPE ,ACS VECTOR> 2>) AC)
645 #DECL ((ACL) VECTOR (AC) ATOM)
646 <COND (<MEMQ <SET THING <1 .L>>
651 <COND (<EMPTY? <SET L <REST .L 2>>>
655 <COND (<AND <TYPE? .THING LIST>
656 <==? <LENGTH .THING> 2>
657 <==? <1 .THING> RETURN>>
658 <SET MUNGED-REG <2 .THING>>)
660 <SET LL (.THING VALUE <1 .ACL>
663 (<AND <TYPE? .THING ATOM>
664 <OR <==? .THING .DEST>
665 <AND <WILL-DIE? .THING>
672 <DEAD!-MIMOC (.THING) T>)>
673 <SET ACL <REST .ACL 2>>)>
674 <COND (<EMPTY? <SET L <REST .L>>>
679 <COND (<AND .LBL <==? .DIR ->>
680 <LABEL-UPDATE-ACS .LBL <>>)>
681 <COND (<TYPE? .JSNUM ATOM>
682 <SMASH-AC O* .JSNUM VALUE>
685 <OCEMIT .JSATM O* O*>)>
686 <COND (<AND .LBL <==? .DIR ->>
687 <OCEMIT JUMP TP* <XJUMP .LBL>>
688 <RESULT-JSYS .MUNGED-REG .DEST>)
689 (<AND .LBL <==? .DIR +>>
690 <OCEMIT JUMP TP* <XJUMP <SET XL1 <GENLBL "JS">>>>
691 <RESULT-JSYS .MUNGED-REG .DEST>
692 <LABEL-UPDATE-ACS .LBL <>>
693 <OCEMIT JRST <XJUMP .LBL>>
696 <OCEMIT JUMP P* <XJUMP IOERR>>
697 <COND (<==? .MUNGED-REG ALL>
698 <RESULT-JSYS ALL <>>)>)
700 <COND (<OR <==? .JSNUM ,SIBE!-JSYS>
701 <==? .JSNUM ,SOBE!-JSYS>>
704 <XJUMP <SET XL1 <GENLBL "JS">>>>)
707 <XJUMP <SET XL1 <GENLBL "JS">>>>)>
708 <RESULT-JSYS .MUNGED-REG .DEST>
709 <OCEMIT JRST <XJUMP <SET XL2 <GENLBL "JS">>>>
711 <OCEMIT MOVEI A1* *400000*>
713 <OCEMIT HRRZ B2* A2*>
714 <OCEMIT MOVSI B1* <TYPE-CODE FIX>>
716 <PUSHJ CONS .DEST <> FALSE>
718 (<ERROR CANT-COMPILE-SYSOP .L>)>>
720 <DEFINE RESULT-JSYS (MUNGED-REG DEST)
721 <COND (<==? .MUNGED-REG ALL>
722 <SMASH-AC T* <CHTYPE <PARSE "AC-VECTOR"> XGLOC> VALUE>
723 <OCEMIT MOVE T* 1 '(T*)>
725 <REPEAT ((I 0)) #DECL ((I) FIX)
726 <COND (<G? <SET I <+ .I 1>> ,MAX-ACS> <RETURN>)>
727 <OCEMIT MOVEM <NTH ,ACS <+ <* .I 2> 1>> <- .I 1> '(T*)>>
730 !<OBJ-VAL <CHTYPE <PARSE "AC-VECTOR"> XGLOC>>>
733 <COND (<N==? .MUNGED-REG 2>
734 <OCEMIT MOVE A2* .MUNGED-REG>)>
735 <OCEMIT MOVSI A1* <TYPE-CODE FIX>>
738 <DEFINE SIN-SOUT (JS L "AUX" (DEST <>) ECHAR JFN)
741 <COND (<==? <LENGTH .L> 7> <SET DEST <7 .L>> <SET ECHAR <5 .L>>)
742 (<==? <LENGTH .L> 6> <SET DEST <6 .L>>)
743 (ELSE <MIMOCERR BAD-SIN-SOUT-CALL!-ERRORS>)>)
744 (<==? <LENGTH .L> 5> <SET ECHAR <5 .L>>)
745 (<N==? <LENGTH .L> 4> <MIMOCERR BAD-SIN-SOUT-CALL!-ERRORS>)>
747 <COND (<AND <TYPE? <SET JFN <2 .L>> FIX> <L? .JFN ,MAX-IMMEDIATE>>
749 <OCEMIT MOVEI A1* .JFN>)
750 (ELSE <SMASH-AC A1* .JFN VALUE>)>
751 <SMASH-AC O* <3 .L> TYPE>
752 <SMASH-AC A2* <3 .L> VALUE>
753 <COND (<AND <TYPE? <SET JFN <4 .L>> FIX> <L? .JFN ,MAX-IMMEDIATE>>
755 <OCEMIT MOVEI B1* .JFN>)
756 (ELSE <SMASH-AC B1* .JFN VALUE>)>
757 <COND (<ASSIGNED? ECHAR>
758 <COND (<AND <==? <PRIMTYPE .ECHAR> WORD>
759 <L? <SET ECHAR <CHTYPE .ECHAR FIX>> ,MAX-IMMEDIATE>>
761 <OCEMIT MOVEI B2* .ECHAR>)
762 (ELSE <SMASH-AC B2* .ECHAR VALUE>)>)>
765 <SETG GJ-SHORT 262144>
769 <DEFINE GTJFN-S-DO (JS L "AUX" (FLAGS <2 .L>) (SOURCE <3 .L>) (DEST <5 .L>))
772 <COND (<TYPE? .FLAGS FIX WORD>
773 <SET FLAGS <ORB .FLAGS ,GJ-SHORT <COND (<==? .JS GTJFN-S-J>
776 <COND (<0? <CHTYPE <ANDB .FLAGS *777777*> FIX>>
777 <OCEMIT MOVSI A1* <CHTYPE <LSH .FLAGS -18> FIX>>)
779 <OCEMIT MOVE A1* !<OBJ-VAL .FLAGS>>)>)
781 <SMASH-AC A1* .FLAGS VALUE>
782 <OCEMIT TLO A1* <CHTYPE <ORB <LSH ,GJ-SHORT -18>
783 <LSH <COND (<==? .JS GTJFN-S-J>
787 <COND (<==? .JS GTJFN-S-J>
788 <COND (<AND <TYPE? .SOURCE FIX WORD>
789 <L? <CHTYPE .SOURCE FIX> *777777*>>
791 <OCEMIT MOVEI A2* .SOURCE>)
793 <SMASH-AC A2* .SOURCE VALUE>)>)
795 <SMASH-AC A2* <3 .L> VALUE>
797 <OCEMIT HRRZ B1* !<OBJ-TYP <3 .L>>>)>
800 <DEFINE GTJFN-L-DO (JS L "AUX" (LN <LENGTH .L>))
801 #DECL ((L) LIST (LN) FIX)
803 <COND (<N==? <NTH .L <- .LN 1>> =>
804 <MIMOCERR NO-PLACE-TO-RETURN!-ERRORS GTJFN>)>
807 <COND (<==? .ARG => <MAPLEAVE>)>
808 <OCEMIT PUSH TP* !<OBJ-TYP .ARG>>
809 <COND (,WINNING-VICTIM
810 <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
811 <OCEMIT PUSH TP* !<OBJ-VAL .ARG>>
812 <COND (,WINNING-VICTIM
813 <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>>
815 <OCEMIT MOVEI O1* <- .LN 3>>
816 <PUSHJ GTJFNL <NTH .L .LN>>>
818 <DEFINE JFNS-DO (JS L "AUX" (DEST <>) ARG1 ARG2 ARG3 ARG4)
821 <COND (<==? <LENGTH .L> 7> <SET DEST <7 .L>>)
822 (ELSE <MIMOCERR BAD-JFNS-CALL!-ERRORS>)>)
823 (<N==? <LENGTH .L> 5> <MIMOCERR BAD-JFNS-CALL!-ERRORS>)>
824 <COND (<OR <==? <SET ARG1 <2 .L>> .DEST>
825 <AND <TYPE? .ARG1 ATOM> <WILL-DIE? .ARG1>>>
826 <DEAD!-MIMOC (.ARG1) T>)>
827 <COND (<OR <==? <SET ARG2 <3 .L>> .DEST>
828 <AND <TYPE? .ARG2 ATOM> <WILL-DIE? .ARG2>>>
829 <DEAD!-MIMOC (.ARG2) T>)>
830 <COND (<OR <==? <SET ARG3 <4 .L>> .DEST>
831 <AND <TYPE? .ARG3 ATOM> <WILL-DIE? .ARG3>>>
832 <DEAD!-MIMOC (.ARG3) T>)>
833 <COND (<OR <==? <SET ARG4 <5 .L>> .DEST>
834 <AND <TYPE? .ARG4 ATOM> <WILL-DIE? .ARG4>>>
835 <DEAD!-MIMOC (.ARG4) T>)>
837 <GET-INTO-ACS .ARG1 VALUE A1* .ARG2 VALUE A2* .ARG3 VALUE B1*
839 <OCEMIT HRRZ C1* !<OBJ-TYP .ARG1>>
842 <DEFINE RFTAD-DO (JS L "AUX" (DEST <>) ARG1 ARG2 ARG3 TL)
844 <COND (<SET TL <MEMQ = .L>>
848 <SMASH-AC A1* <2 .L> VALUE>
850 <SMASH-AC A2* <3 .L> VALUE>
852 <SMASH-AC B1* <4 .L> VALUE>
855 <DEFINE ERSTR-DO (JS L "AUX" (DEST <>) ARG1 ARG2 ARG3)
858 <COND (<==? <LENGTH .L> 6> <SET DEST <6 .L>>)
859 (ELSE <MIMOCERR BAD-ERSTR-CALL!-ERRORS>)>)
860 (<N==? <LENGTH .L> 4> <MIMOCERR BAD-ERSTR-CALL!-ERRORS>)>
861 <COND (<OR <==? <SET ARG1 <2 .L>> .DEST>
862 <AND <TYPE? .ARG1 ATOM> <WILL-DIE? .ARG1>>>
863 <DEAD!-MIMOC (.ARG1) T>)>
864 <COND (<OR <==? <SET ARG2 <3 .L>> .DEST>
865 <AND <TYPE? .ARG2 ATOM> <WILL-DIE? .ARG2>>>
866 <DEAD!-MIMOC (.ARG2) T>)>
867 <COND (<OR <==? <SET ARG3 <4 .L>> .DEST>
868 <AND <TYPE? .ARG3 ATOM> <WILL-DIE? .ARG3>>>
869 <DEAD!-MIMOC (.ARG3) T>)>
871 <GET-INTO-ACS .ARG1 VALUE A1* .ARG2 VALUE A2* .ARG3 VALUE B1*>
874 <DEFINE LOAD-ARG (V AC)
875 <COND (<AND <TYPE? .V FIX WORD>
876 <L? <SET V <CHTYPE .V FIX>> *777777*>>
878 <OCEMIT MOVEI .AC .V>)
880 <SMASH-AC .AC .V VALUE>)>>
882 <PUTPROP SIN-JSYS!-JSYS SPECIAL-JSYS-FUNCTION ,SIN-SOUT>
884 <PUTPROP SOUT!-JSYS SPECIAL-JSYS-FUNCTION ,SIN-SOUT>
886 <PUTPROP GTJFN-S-S!-JSYS SPECIAL-JSYS-FUNCTION ,GTJFN-S-DO>
888 <PUTPROP GTJFN-S-J!-JSYS SPECIAL-JSYS-FUNCTION ,GTJFN-S-DO>
890 <PUTPROP JFNS!-JSYS SPECIAL-JSYS-FUNCTION ,JFNS-DO>
892 <PUTPROP ERSTR!-JSYS SPECIAL-JSYS-FUNCTION ,ERSTR-DO>
894 <PUTPROP GTJFN-L!-JSYS SPECIAL-JSYS-FUNCTION ,GTJFN-L-DO>
896 <COND (<GASSIGNED? RFTAD-DO>
897 <PUTPROP RFTAD!-JSYS SPECIAL-JSYS-FUNCTION ,RFTAD-DO>)>