--- /dev/null
+TITLE PRINTER ROUTINE FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT DSK:MUDDLE >\r
+\r
+.GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL\r
+.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT\r
+.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID\r
+.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT\r
+.GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1\r
+.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR\r
+.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH\r
+\r
+BUFLNT==100 ; BUFFER LENGTH IN WORDS\r
+\r
+FLAGS==0 ;REGISTER USED TO STORE FLAGS\r
+CARRET==15 ;CARRIAGE RETURN CHARACTER\r
+ESCHAR=="\ ;ESCAPE CHARACTER\r
+SPACE==40 ;SPACE CHARACTER\r
+ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT\r
+NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)\r
+SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT\r
+SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)\r
+FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL\r
+HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL\r
+TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL\r
+UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL\r
+ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL\r
+BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL\r
+PJBIT==400000\r
+C.BUF==1\r
+C.PRIN==2\r
+C.BIN==4\r
+C.OPN==10\r
+C.READ==40\r
+\r
+\r
+\fMFUNCTION FLATSIZE,SUBR\r
+ DEFINE FLTMAX\r
+ 4(B) TERMIN\r
+ DEFINE FLTSIZ\r
+ 2(B)TERMIN\r
+;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND\r
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE\r
+;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX\r
+ ENTRY\r
+ CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS\r
+ CAMG AB,[-6,,0]\r
+ JRST WNA\r
+ PUSH P,3(AB)\r
+\r
+ GETYP A,2(AB)\r
+ CAIE A,TFIX\r
+ JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE\r
+\r
+ CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT\r
+ JRST .+3 ; RADIX SUPPLIED\r
+ PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN\r
+ JRST FLTGO\r
+ GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX\r
+ CAIE A,TFIX\r
+ JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE\r
+ MOVE C,5(AB)\r
+ PUSHJ P,GETARG ; GET ARGS INTO A AND B\r
+FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM\r
+ PUSHJ P,CIFLTZ\r
+ JFCL\r
+ JRST FINIS\r
+\r
+\r
+\r
+MFUNCTION UNPARSE,SUBR\r
+ DEFINE UPB\r
+ 0(B) TERMIN\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ MOVE E,TP ;SAVE TP POINTER\r
+\r
+\r
+\r
+;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE\r
+;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED\r
+ CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED\r
+ JRST .+3\r
+ PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN\r
+ JRST UNPRGO\r
+ CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY\r
+ JRST TMA\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TFIX ;SEE IF RADIX IS FIXED\r
+ JRST WTYP2\r
+ MOVE C,3(AB) ;GET RADIX\r
+ PUSHJ P,GETARG ;GET ARGS INTO A AND B\r
+UNPRGO: PUSHJ P,CIUPRS\r
+ JRST FINIS\r
+ JRST FINIS\r
+\r
+\r
+GTRADX: MOVE B,IMQUOTE OUTCHAN\r
+ PUSH P,0 ;SAVE FLAGS\r
+ PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN\r
+ POP P,0\r
+ GETYP A,A ;CHECK TYPE OF CHANNEL\r
+ CAIE A,TCHAN\r
+ JRST FUNCH1-1 ;IT IS A TP-POINTER\r
+ MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN\r
+ JRST FUNCH1\r
+ MOVE C,(B)+6 ;GET RADIX FROM STACK\r
+\r
+FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX\r
+ MOVEI C,10. ;DEFAULT IF THIS IS THE CASE\r
+GETARG: MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ POPJ P,\r
+\r
+\r
+MFUNCTION PRINT,SUBR\r
+ ENTRY \r
+ PUSHJ P,AGET ; GET ARGS\r
+ PUSHJ P,CIPRIN\r
+ JRST FINIS\r
+\r
+MFUNCTION PRINC,SUBR\r
+ ENTRY \r
+ PUSHJ P,AGET ; GET ARGS\r
+ PUSHJ P,CIPRNC\r
+ JRST FINIS\r
+\r
+MFUNCTION PRIN1,SUBR\r
+ ENTRY \r
+ PUSHJ P,AGET\r
+ PUSHJ P,CIPRN1\r
+ JRST FINIS\r
+ JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF\r
+\r
+\r
+MFUNCTION TERPRI,SUBR\r
+ ENTRY\r
+ PUSHJ P,AGET1\r
+ PUSHJ P,CITERP\r
+ JRST FINIS\r
+\r
+\f\r
+CITERP: SUBM M,(P)\r
+ MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL\r
+ MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN\r
+ PUSHJ P,PITYO ; PRINT IT OUT\r
+ MOVEI A,12 ; LINE-FEED\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TFALSE ; RETURN A FALSE\r
+ MOVEI B,0\r
+ JRST MPOPJ ; RETURN\r
+\r
+\r
+TESTR: GETYP E,A\r
+ CAIN E,TCHAN ; CHANNEL?\r
+ JRST TESTR1 ; OK?\r
+ CAIE E,TTP\r
+ JRST BADCHN\r
+ HLRZS 0\r
+ IOR 0,A ; RESTORE FLAGS\r
+ HRLZS 0\r
+ POPJ P,\r
+TESTR1: HRRZ E,-4(B) ; GET IN FLAGS FROM CHANNEL\r
+ TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD\r
+ TRNE E,C.PRIN+C.OPN\r
+ JRST BADCHN ; ITS A LOSER\r
+ TRNE E,C.BIN\r
+ JRST PSHNDL ; DON'T HANDLE BINARY\r
+ TLO ASCBIT ; ITS ASCII\r
+ POPJ P, ; ITS A WINNER\r
+ \r
+PSHNDL: PUSH TP,C ; SAVE ARGS\r
+ PUSH TP,D\r
+ PUSH TP,A ; PUSH CHANNEL ONTO STACK\r
+ PUSH TP,B\r
+ PUSHJ P,BPRINT ; CHECK BUFFER\r
+ POP TP,B\r
+ POP TP,A\r
+ POP TP,D\r
+ POP TP,C\r
+ POPJ P,\r
+\r
+\r
+\f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B\r
+\r
+CIUPRS: SUBM M,(P) ; MODIFY M-POINTER\r
+ MOVE E,TP ; SAVE TP-POINTER\r
+ PUSH TP,[0] ; SLOT FOR FIRST STRING COPY\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; AND SECOND STRING\r
+ PUSH TP,[0]\r
+ PUSH TP,A ; SAVE OBJECTS\r
+ PUSH TP,B\r
+ PUSH TP,$TTP ; SAVE TP POINTER\r
+ PUSH TP,E\r
+ PUSH P,C\r
+ MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE\r
+ PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING\r
+ FATAL UNPARSE BLEW IT\r
+ PUSH TP,$TFIX ; MOVE IN ARGUMENT FOR ISTRING\r
+ PUSH TP,B\r
+ MCALL 1,ISTRING\r
+ POP TP,E ; RESTORE TP-POINTER\r
+ SUB TP,[1,,1] ;GET RID OF TYPE WORD\r
+ MOVEM A,1(E) ; SAVE RESULTS\r
+ MOVEM A,3(E)\r
+ MOVEM B,2(E)\r
+ MOVEM B,4(E)\r
+ POP TP,B ; RESTORE THE WORLD\r
+ POP TP,A\r
+ POP P,C\r
+ MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS\r
+ PUSHJ P,CUSET\r
+ JRST MPOPJ ; RETURN\r
+\r
+\r
+\r
+; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,\r
+; A,B THE TYPE-OBJECT PAIR\r
+\r
+CIFLTZ: SUBM M,(P)\r
+ MOVE E,TP ; SAVE POINTER\r
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT\r
+ PUSH TP,[0]\r
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM\r
+ PUSH TP,D\r
+ MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG\r
+ PUSHJ P,CUSET ; CONTINUE\r
+ JRST MPOPJ\r
+ SOS (P) ; SKIP RETURN\r
+ JRST MPOPJ ; RETURN\r
+\r
+; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING\r
+; NEEDED TO GET A RESULT.\r
+\r
+CUSET: PUSH TP,$TFIX ; PUSH ON RADIX\r
+ PUSH TP,C\r
+ PUSH TP,$TPDL\r
+ PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE\r
+ PUSH TP,A ; SAVE OBJECTS\r
+ PUSH TP,B\r
+ MOVSI C,TTP ; CONSTRUCT TP-POINTER\r
+ HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER\r
+ MOVE D,E\r
+ PUSH TP,C ; PUSH ON CHANNEL\r
+ PUSH TP,D\r
+ PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER\r
+ POP TP,B ; GET IN TP POINTER\r
+ MOVE TP,B ; RESTORE POINTER\r
+ TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL\r
+ JRST FLTGEN ; ITS A FLATSIZE\r
+ MOVE A,UPB+3 ; RETURN STRING\r
+ MOVE B,UPB+4\r
+ POPJ P, ; DONE\r
+FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT\r
+ MOVE B,FLTSIZ\r
+ AOS (P)\r
+ POPJ P, ; EXIT\r
+\r
+\f\r
+; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME\r
+; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL\r
+\r
+CIPRIN: SUBM M,(P)\r
+ MOVSI 0,SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TPRT ; PRINT INITIALIZATION\r
+ PUSHJ P,IPRINT\r
+ JRST TPRTE ; EXIT\r
+\r
+CIPRN1: SUBM M,(P)\r
+ MOVEI FLAGS,0 ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,IPRINT ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+CIPRNC: SUBM M,(P)\r
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,IPRINT\r
+ JRST TPR1E ; EXIT\r
+\f\r
+; INITIALIZATION FOR PRINT ROUTINES\r
+\r
+TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK\r
+ PUSH TP,C ; SAVE ARGUMENTS\r
+ PUSH TP,D\r
+ PUSH TP,A ; SAVE CHANNEL\r
+ PUSH TP,B\r
+ MOVEI A,CARRET ; PRINT CARRIAGE RETURN\r
+ PUSHJ P,PITYO\r
+ MOVEI A,12 ; AND LF\r
+ PUSHJ P,PITYO\r
+ MOVE A,-3(TP) ; MOVE IN ARGS\r
+ MOVE B,-2(TP)\r
+ POPJ P,\r
+\r
+; EXIT FOR PRINT ROUTINES\r
+\r
+TPRTE: POP TP,B ; RESTORE CHANNEL\r
+ MOVEI A,SPACE ; PRINT TRAILING SPACE\r
+ PUSHJ P,PITYO\r
+ SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD\r
+ POP TP,B ; RETURN WHAT WAS PASSED\r
+ POP TP,A\r
+ JRST MPOPJ ; EXIT\r
+\r
+; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES\r
+\r
+TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK\r
+ PUSH TP,C ; SAVE ARGS\r
+ PUSH TP,D\r
+ PUSH TP,A ; SAVE CHANNEL\r
+ PUSH TP,B\r
+ MOVE A,-3(TP) ; GET ARGS\r
+ MOVE B,-2(TP)\r
+ POPJ P,\r
+\r
+; EXIT FOR PRIN1 AND PRINC ROUTINES\r
+\r
+TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL\r
+ POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN\r
+ POP TP,A\r
+ JRST MPOPJ ; EXIT\r
+\r
+\r
+\f\r
+CPATM: SUBM M,(P)\r
+ MOVSI C,TATOM ; GET TYPE FOR BINARY\r
+ MOVE 0,$SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TPRT ; PRINT INITIALIZATION\r
+ PUSHJ P,CPATOM ; PRINT IT OUT\r
+ JRST TPRTE ; EXIT\r
+\r
+CP1ATM: SUBM M,(P)\r
+ MOVE C,$TATOM\r
+ MOVEI FLAGS,0 ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPATOM ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+CPCATM: SUBM M,(P)\r
+ MOVE C,$TATOM\r
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPATOM ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+\r
+; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE \r
+; CHARACTER IS IN C.\r
+CPCH: SUBM M,(P)\r
+ MOVSI FLAGS,NOQBIT\r
+ MOVE C,$TCHRS\r
+ PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD\r
+ PUSH P,D\r
+ MOVE A,D ; MOVE IN CHARACTER FOR PITYO\r
+ PUSHJ P,PITYO\r
+ MOVE A,$TCHRST ; RETURN THE CHARACTER\r
+ POP P,B\r
+ JRST MPOPJ\r
+\r
+\r
+\r
+\r
+CPSTR: SUBM M,(P)\r
+ HRLI C,TCHSTR\r
+ MOVSI 0,SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TPRT ; PRINT INITIALIZATION\r
+ PUSHJ P,CPCHST ; PRINT IT OUT\r
+ JRST TPRTE ; EXIT\r
+\r
+CP1STR: SUBM M,(P)\r
+ HRLI C,TCHSTR\r
+ MOVEI FLAGS,0 ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPCHST ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+CPCSTR: SUBM M,(P)\r
+ HRLI C,TCHSTR\r
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPCHST ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+\r
+CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B\r
+ PUSH P,0 ; ATOM CALLER ROUTINE\r
+ PUSH P,C\r
+ JRST PATOM\r
+\r
+CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B\r
+ PUSH P,0 ; STRING CALLER ROUTINE\r
+ PUSH P,C\r
+ JRST PCHSTR\r
+\r
+\r
+\f\r
+AGET: MOVEI FLAGS,0\r
+ SKIPL E,AB ; COPY ARG POINTER\r
+ JRST TFA ;NO ARGS IS AN ERROR\r
+ ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL\r
+ JRST COMPT\r
+AGET1: MOVE E,AB ; GET COPY OF AB\r
+ MOVSI FLAGS,TERBIT\r
+\r
+COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL\r
+ PUSH TP,[0]\r
+ JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING\r
+ CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR\r
+ JRST TMA\r
+ MOVE A,(E) ;GET CHANNEL\r
+ MOVE B,(E)+1\r
+ JRST NEWCHN\r
+\r
+DEFCHN: MOVE B,IMQUOTE OUTCHAN\r
+ MOVSI A,TATOM\r
+ PUSH P,FLAGS ;SAVE FLAGS\r
+ PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN\r
+ POP P,0\r
+\r
+NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI\r
+ POPJ P,\r
+ MOVE C,(AB) ; GET ARGS\r
+ MOVE D,1(AB)\r
+ POPJ P,\r
+\r
+; HERE IF USING A PRINTB CHANNEL\r
+\r
+BPRINT: TLO FLAGS,BINBIT\r
+ SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?\r
+ POPJ P,\r
+\r
+; HERE TO GENERATE A STRING BUFFER\r
+\r
+ PUSH P,FLAGS\r
+ MOVEI A,BUFLNT ; GET BUFFER LENGTH\r
+ PUSHJ P,IBLOCK ; MAKE A BUFFER\r
+ MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE\r
+ MOVEM 0,BUFLNT(B)\r
+ SETOM (B)) ; -1 THE BUFFER\r
+ MOVEI C,1(B)\r
+ HRLI C,(B)\r
+ BLT C,BUFLNT-1(B)\r
+ HRLI B,440700\r
+ MOVE C,(TP)\r
+ MOVEM B,BUFSTR(C) ; STOR BYTE POINTER\r
+ MOVE 0,[TCHSTR,,BUFLNT*5]\r
+ MOVEM 0,BUFSTR-1(C)\r
+ POP P,FLAGS\r
+\r
+ MOVE B,(TP)\r
+ POPJ P,\r
+\f\r
+\r
+IPRINT: PUSH P,C ; SAVE C\r
+ PUSH P,FLAGS ;SAVE PREVIOUS FLAGS\r
+ PUSH TP,A ;SAVE ARGUMENT ON TP-STACK\r
+ PUSH TP,B\r
+ \r
+ INTGO ;ALLOW INTERRUPTS HERE\r
+ \r
+ GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM\r
+ SKIPE C,PRNTYP+1(TVP) ; USER TYPE TABLE?\r
+ JRST PRDISP\r
+NORMAL: CAIG A,NUMPRI ;PRIMITIVE?\r
+ JRST @PRTYPE(A) ;YES-DISPATCH\r
+ JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT\r
+\r
+; HERE FOR USER PRINT DISPATCH\r
+\r
+PRDISP: ADDI C,(A) ; POINT TO SLOT\r
+ ADDI C,(A)\r
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP\r
+ JRST PRDIS1 ; APPLY EVALUATOR\r
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP\r
+ JRST NORMAL\r
+ JRST (C)\r
+\r
+PRDIS1: PUSH P,C ; SAVE C\r
+ PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND\r
+ PUSH TP,IMQUOTE OUTCHAN\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ POP P,C ; RESTORE C\r
+ PUSH TP,(C) ; PUSH ARGS FOR APPLY\r
+ PUSH TP,1(C)\r
+ PUSH TP,-9(TP)\r
+ PUSH TP,-9(TP)\r
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT\r
+ MOVEI E,-8(TP)\r
+ PUSHJ P,SSPEC1 ;UNBIND OUTCHAN\r
+ SUB TP,[6,,6] ; POP OFF STACK\r
+ JRST PNEXT\r
+\r
+; PRINT DISPATCH TABLE\r
+\r
+DISTBL PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]\r
+[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]\r
+[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]\r
+[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]\r
+[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]]\r
+\r
+PUNK: MOVE C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS\r
+ GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B\r
+ LSH B,1 ; MULTIPLY BY TWO\r
+ HRL B,B ; DUPLICATE IT IN THE LEFT HALF\r
+ ADD C,B ; INCREMENT THE AOBJN-POINTER\r
+ JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE\r
+\r
+ MOVE B,-2(TP) ; MOVE IN CHANNEL\r
+ PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM\r
+ MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS\r
+ PUSHJ P,PITYO\r
+ MOVE A,(C) ; GET TYPE-ATOM\r
+ MOVE B,1(C)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT ATOM-NAME\r
+ SUB TP,[2,,2] ; POP STACK \r
+ MOVE B,-2(TP) ; MOVE IN CHANNEL\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER\r
+ HRRZ A,(C) ; GET THE STORAGE-TYPE\r
+ ANDI A,SATMSK\r
+ CAIG A,NUMSAT ; SKIP IF TEMPLATE\r
+ JRST @UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE\r
+ JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE\r
+\r
+DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]\r
+[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]\r
+[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]\r
+[SLOCT,LOCP]]\r
+\r
+ ; SELECK AN ILLEGAL\r
+\r
+ILLCH: MOVEI B,-1(TP)\r
+ JRST ILLCHO\r
+\r
+\f; PRINT INTERRUPT HANDLER\r
+\r
+PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B\r
+ PUSHJ P,RETIF1\r
+ MOVEI A,"#\r
+ PUSHJ P,PITYO ; SAY "FUNNY TYPE"\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE HANDLER\r
+ PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT THE TYPE NAME\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,SPACEQ ; SPACE MAYBE\r
+ SKIPN B,(TP) ; GET ARG BACK\r
+ JRST PNEXT\r
+ MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW\r
+ MOVE B,INTFCN+1(B)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT THE INT FUNCTION\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF\r
+ JRST PNEXT\r
+\r
+; PRINT INT HEADER\r
+\r
+PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1\r
+ MOVEI A,"#\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM ; AND NAME\r
+ MOVE B,MQUOTE IHEADER\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ SKIPN B,-2(TP) ; INT HEADER BACK\r
+ JRST PNEXT\r
+ MOVE A,INAME(B) ; GET NAME\r
+ MOVE B,INAME+1(B)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; CLEAN OFF STACK\r
+ JRST PNEXT\r
+\r
+\r
+; PRINT ASSOCIATION BLOCK\r
+\r
+ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; MAKE ROOM AND PRINT\r
+ SKIPA C,[-3,,0] ; # OF FIELDS\r
+ASSLP: PUSHJ P,SPACEQ\r
+ MOVE D,(TP) ; RESTORE GOODIE\r
+ ADD D,ASSOFF(C) ; POINT TO FIELD\r
+ MOVE A,(D) ; GET IT\r
+ MOVE B,1(D)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; AND PRINT IT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ AOBJN C,ASSLP\r
+\r
+ MOVEI A,")\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; CLOSE IT\r
+ JRST PNEXT\r
+\r
+ASSOFF: ITEM\r
+ INDIC\r
+ VAL\r
+\f; PRINT TYPE-C AND TYPE-W\r
+\r
+PTYPEW: HRRZ A,(TP) ; POSSIBLE RH\r
+ HLRZ B,(TP)\r
+ MOVE C,MQUOTE TYPE-W\r
+ JRST PTYPEX\r
+\r
+PTYPEC: HRRZ B,(TP)\r
+ MOVEI A,0\r
+ MOVE C,MQUOTE TYPE-C\r
+\r
+PTYPEX: PUSH P,B\r
+ PUSH P,A\r
+ PUSH TP,$TATOM\r
+ PUSH TP,C\r
+ MOVEI A,2\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ; ROOM TO START?\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ POP TP,B ; GET NAME\r
+ POP TP,A\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVE A,-1(P) ; TYPE CODE\r
+ ASH A,1\r
+ HRLI A,(A) ; MAKE SURE WINS\r
+ ADD A,TYPVEC+1(TVP)\r
+ JUMPL A,PTYPX1 ; JUMP FOR A WINNER\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-TYPE-CODE\r
+ JRST CALER1\r
+\r
+PTYPX1: MOVE B,1(A) ; GET TYPE NAME\r
+ HRRZ A,(A) ; AND SAT\r
+ ANDI A,SATMSK\r
+ MOVEM A,-1(P) ; AND SAVE IT\r
+ MOVSI A,TATOM\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; OUT IT GOES\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVE A,-1(P) ; GET SAT BACK\r
+ MOVE B,@STBL(A)\r
+ MOVSI A,TATOM ; AND PRINT IT\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP OFF STACK\r
+ SKIPN B,(P) ; ANY EXTRA CRAP?\r
+ JRST PTYPX2\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ MOVE B,(P)\r
+ MOVSI A,TFIX\r
+ PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT EXTRA\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+\r
+PTYPX2: MOVEI A,">\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF\r
+ SUB P,[2,,2] ; FLUSH CRUFT\r
+ JRST PNEXT\r
+\r
+\f; PRINT PURE CODE POINTER\r
+\r
+PPCODE: MOVEI A,2\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM ; PRINT SUBR CALL\r
+ MOVE B,MQUOTE PCODE\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE?\r
+ HLRZ A,-2(TP) ; OFFSET TO VECTOR\r
+ ADD A,PURVEC+1(TVP) ; SLOT TO A\r
+ MOVE A,(A) ; SIXBIT NAME\r
+ PUSH P,FLAGS\r
+ PUSHJ P,6TOCHS ; TO A STRING\r
+ POP P,FLAGS\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ HRRZ B,-2(TP) ; GET OFFSET\r
+ MOVSI A,TFIX\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVEI A,">\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; CLOSE THE FORM\r
+ JRST PNEXT\r
+\r
+\r
+\f; PRINT SUB-ENTRY TO RSUBR\r
+\r
+PENTRY: MOVE B,(TP) ; GET BLOCK\r
+ GETYP A,(B) ; TYPE OF 1ST ELEMENT\r
+ CAIE A,TRSUBR ; RSUBR, OK\r
+ JRST PENT1\r
+ MOVSI A,TATOM ; UNLINK\r
+ HLLM A,(B)\r
+ MOVE A,1(B)\r
+ MOVE A,3(A)\r
+ MOVEM A,1(B)\r
+PENT2: MOVEI A,2 ; CHECK ROOM\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"% ; SETUP READ TIME MACRO\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE RSUBR-ENTRY\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP)\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVEI A,"' ; QUOTE TO AVOID EVALING IT\r
+ PUSHJ P,PRETIF\r
+ MOVSI A,TVEC\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ MOVE B,-2(TP)\r
+ HRRZ B,2(B)\r
+ MOVSI A,TFIX\r
+ PUSHJ P,IPRINT\r
+ MOVEI A,">\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+PENT1: CAIN A,TATOM\r
+ JRST PENT2\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-ENTRY-BLOCK\r
+ JRST CALER1\r
+\r
+\f; HERE TO PRINT TEMPLATED DATA STRUCTURE\r
+\r
+TMPRNT: PUSH P,FLAGS ; SAVE FLAGS\r
+ MOVE A,(TP) ; GET POINTER\r
+ GETYP A,(A) ; GET SAT\r
+ PUSH P,A ; AND SAVE IT\r
+ MOVEI A,"{ ; OPEN SQUIGGLE\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; PRINT WITH CHECKING\r
+ HLRZ A,(TP) ; GET AMOUNT RESTED OFF\r
+ SUBI A,1\r
+ PUSH P,A ; AND SAVE IT\r
+ MOVE A,-1(P) ; GET SAT\r
+ SUBI A,NUMSAT+1 ; FIXIT UP\r
+ HRLI A,(A)\r
+ ADD A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE\r
+ JUMPGE A,BADTPL ; COMPLAIN\r
+ HRRZS C,(TP) ; GET LENGTH\r
+ XCT (A) ; INTO B\r
+ SUB B,(P) ; FUDGE FOR RESTS\r
+ MOVEI B,-1(B) ; FUDGE IT\r
+ PUSH P,B ; AND SAVE IT\r
+\r
+TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST\r
+ SOSGE (P) ; CHECK FOR ANY LEFT\r
+ JRST TMPRN2 ; ALL DONE\r
+\r
+ MOVE B,(TP) ; POINTER\r
+ HRRZ 0,-2(P) ; SAT\r
+ PUSHJ P,TMPLNT ; GET THE ITEM\r
+ MOVE FLAGS,-3(P) ; RESTORE FLAGS\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT THIS ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ SKIPE (P) ; IF NOT LAST ONE THEN\r
+ PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE\r
+ JRST TMPRN1\r
+\r
+TMPRN2: SUB P,[4,,4]\r
+ MOVE B,-2(TP)\r
+ MOVEI A,"} ; CLOSE THIS GUY\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\r
+\f; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT\r
+; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII\r
+\r
+PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION\r
+ GETYP A,(A) ; CHECK FOR PURE RSUBR\r
+ CAIN A,TPCODE\r
+ JRST PRSBRP ; PRINT IT SPECIAL WAY\r
+\r
+ TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT\r
+ JRST ARSUBR\r
+\r
+ PUSH P,FLAGS\r
+ MOVSI A,TRSUBR ; FIND FIXUPS\r
+ MOVE B,(TP)\r
+ HLRE D,1(B) ; -LENGTH OF CODE VEC\r
+ PUSH P,D ; SAVE SAME\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE RSUBR\r
+ PUSHJ P,IGET ; GO GET THEM\r
+ JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES\r
+ PUSH TP,A ; SAVE FIXUP LIST\r
+ PUSH TP,B\r
+\r
+ MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR\r
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS\r
+ MOVE B,-4(TP) ; GET CHANNEL FOR PITYO\r
+ PUSHJ P,PITYO ; OUT IT GOES\r
+\r
+PRSBR1: MOVE B,-4(TP)\r
+ PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER\r
+\r
+ MOVE B,-4(TP) ; CHANNEL BACK\r
+ MOVN E,(P) ; LENGTH OF CODE\r
+ PUSH P,E\r
+ HRROI A,(P) ; POINT TO SAME\r
+ PUSHJ P,DOIOTO ; OUT GOES COUNT\r
+ MOVSI C,TCODE\r
+ MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS\r
+ MOVE A,-2(TP) ; GET POINTER TO CODE\r
+ MOVE A,1(A)\r
+ PUSHJ P,DOIOTO ; IOT IT OUT\r
+ POP P,E\r
+ ADDI E,1 ; UPDATE ACCESS\r
+ ADDM E,ACCESS(B)\r
+ SETZM ASTO(PVP) ; UNSCREW A\r
+\r
+; NOW PRINT OUT NORMAL RSUBR VECTOR\r
+\r
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS\r
+ SUB P,[1,,1]\r
+ MOVE B,-2(TP) ; GET RSUBR VECTOR\r
+ PUSHJ P,PRBODY ; PRINT ITS BODY\r
+\r
+; HERE TO PRINT BINARY FIXUPS\r
+\r
+ MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS\r
+ SKIPN A,(TP) ; LIST TO A\r
+ JRST PRSBR5 ; EMPTY, DONE\r
+ JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM\r
+ ADDI E,1 ; FOR VERS\r
+\r
+PRSBR6: HRRZ A,(A) ; NEXT?\r
+ JUMPE A,PRSBR5\r
+ GETYP B,(A)\r
+ CAIE B,TDEFER ; POSSIBLE STRING\r
+ JRST PRSBR7 ; COULD BE ATOM\r
+ MOVE B,1(A) ; POSSIBLE STRINGER\r
+ GETYP C,(B)\r
+ CAIE C,TCHSTR ; YES!!!\r
+ JRST BADFXU ; LOSING FIXUPS\r
+ HRRZ C,(B) ; # OF CHARS TO C\r
+ ADDI C,5+5 ; ROUND AND ADD FOR COUNT\r
+ IDIVI C,5 ; TO WORDS\r
+ ADDI E,(C)\r
+ JRST FIXLST ; COUNT FOR USE LIST ETC.\r
+\r
+PRSBR7: GETYP B,(A) ; GET TYPE\r
+ CAIE B,TATOM\r
+ JRST BADFXU\r
+ ADDI E,1\r
+\r
+FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL\r
+ JUMPE A,BADFXU\r
+ GETYP B,(A) ; FIX?\r
+ CAIE B,TFIX\r
+ JRST BADFXU\r
+ MOVEI D,1\r
+ HRRZ A,(A) ; TO USE LIST\r
+ JUMPE A,BADFXU\r
+ GETYP B,(A)\r
+ CAIE B,TLIST\r
+ JRST BADFXU ; LOSER\r
+ MOVE C,1(A) ; GET LIST\r
+\r
+PRSBR8: JUMPE C,PRSBR9\r
+ GETYP B,(C) ; TYPE OK?\r
+ CAIE B,TFIX\r
+ JRST BADFXU\r
+ HRRZ C,(C)\r
+ AOJA D,PRSBR8 ; LOOP\r
+\r
+PRSBR9: ADDI D,2 ; ROUND UP\r
+ ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD\r
+ ADDI E,(D)\r
+ JRST PRSBR6\r
+\r
+PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS\r
+ PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER\r
+ PUSH TP,[0]\r
+\r
+PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS\r
+ PUSHJ P,BFCLS1 ; FLUSH BUFFER\r
+ MOVE B,-6(TP) ; CHANNEL BACK\r
+ MOVEI C,BUFSTR-1(B) ; SETUP BUFFER\r
+ PUSHJ P,BYTDOP ; FIND D.W.\r
+ SUBI A,BUFLNT+1\r
+ HRLI A,-BUFLNT\r
+ MOVEM A,(TP)\r
+ MOVE E,(P) ; LENGTH OF FIXUPS\r
+ SETZB C,D ; FOR EOUT\r
+ PUSHJ P,EOUT\r
+ MOVE C,-2(TP) ; FIXUP LIST\r
+ MOVE E,1(C) ; HAVE VERS\r
+ PUSHJ P,EOUT ; OUT IT GOES\r
+\r
+PFIXU2: HRRZ C,(C) ; FIRST THING\r
+ JUMPE C,PFIXU3 ; DONE?\r
+ GETYP A,(C) ; STRING OR ATOM\r
+ CAIN A,TATOM ; MUST BE STRING\r
+ JRST PFIXU4\r
+ MOVE A,1(C) ; POINT TO POINTER\r
+ HRRZ D,(A) ; LENGTH\r
+ IDIVI D,5\r
+ PUSH P,E ; SAVE REMAINDER\r
+ MOVEI E,1(D)\r
+ MOVNI D,(D)\r
+ MOVSI D,(D)\r
+ PUSH P,D\r
+ PUSHJ P,EOUT\r
+ MOVEI D,0\r
+PFXU1A: MOVE A,1(C) ; RESTORE POINTER\r
+ HRRZ A,1(A) ; BYTE POINTER\r
+ ADD A,(P)\r
+ MOVE E,(A)\r
+ PUSHJ P,EOUT\r
+ MOVE A,[1,,1]\r
+ ADDB A,(P)\r
+ JUMPL A,PFXU1A\r
+ MOVE D,-1(P) ; LAST WORD\r
+ MOVE A,1(C)\r
+ HRRZ A,1(A)\r
+ ADD A,(P)\r
+ SKIPE E,D\r
+ MOVE E,(A) ; LAST WORD OF CHARS\r
+ IOR E,PADS(D)\r
+ PUSHJ P,EOUT ; OUT\r
+ SUB P,[1,,1]\r
+ JRST PFIXU5\r
+\r
+PADS: ASCII /#####/\r
+ ASCII /####/\r
+ ASCII /\ 2###/\r
+ ASCII /\ 2##/\r
+ ASCII /\ 2\ 2#/\r
+\r
+PFIXU4: HRRZ E,(C) ; GET CURRENT VAL\r
+ MOVE E,1(E)\r
+ PUSHJ P,ATOSQ ; GET SQUOZE\r
+ JRST BADFXU\r
+ TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING\r
+ PUSHJ P,EOUT\r
+\r
+; HERE TO WRITE OUT LISTS\r
+\r
+PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE\r
+ HRLZ E,1(C)\r
+ HRRZ C,(C) ; POINT TO USES LIST\r
+ HRRZ D,1(C) ; GET IT\r
+\r
+PFIXU6: TLCE D,400000 ; SKIP FOR RH\r
+ HRLZ E,1(D) ; SETUP LH\r
+ JUMPG D,.+3\r
+ HRR E,1(D)\r
+ PUSHJ P,EOUT ; WRITE IT OUT\r
+ HRR D,(D)\r
+ TRNE D,-1 ; SKIP IF DONE\r
+ JRST PFIXU6\r
+\r
+ TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS\r
+ MOVEI E,0\r
+ PUSHJ P,EOUT\r
+ JRST PFIXU2 ; DO NEXT\r
+\r
+PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER\r
+ MOVN D,C ; PLUS SAME\r
+ ADDI C,BUFLNT ; WORDS USED TO C\r
+ JUMPE C,PFIXU7 ; NONE USED, LEAVE\r
+ MOVSS C ; START SETTING UP BTB\r
+ MOVN A,C ; ALSO FINAL IOT POINTER\r
+ HRR C,(TP) ; PDL POINTER PART OF BTB\r
+ SUBI C,1\r
+ HRLI D,C ; CONTINUE SETTING UP BTB\r
+ POP C,@D ; MOVE 'EM DOWN\r
+ TLNE C,-1\r
+ JRST .-2\r
+ HRRI A,@D ; OUTPUT POINTER\r
+ ADDI A,1\r
+ MOVSI B,TUVEC\r
+ MOVEM B,ASTO(PVP)\r
+ MOVE B,-6(TP)\r
+ PUSHJ P,DOIOTO ; WRITE IT OUT\r
+ SETZM ASTO(PVP)\r
+\r
+PFIXU7: SUB TP,[4,,4]\r
+ SUB P,[2,,2]\r
+ JRST PNEXT\r
+\r
+; ROUTINE TO OUTPUT CONTENTS OF E\r
+\r
+EOUT: MOVE B,-6(TP) ; CHANNEL\r
+ AOS ACCESS(B)\r
+ MOVE A,(TP) ; BUFFER POINTER\r
+ MOVEM E,(A)\r
+ AOBJP A,.+3 ; COUNT AND GO\r
+ MOVEM A,(TP)\r
+ POPJ P,\r
+\r
+ SUBI A,BUFLNT ; SET UP IOT POINTER\r
+ HRLI A,-BUFLNT\r
+ MOVEM A,(TP) ; RESET SAVED POINTER\r
+ MOVSI 0,TUVEC\r
+ MOVEM 0,ASTO(PVP)\r
+ MOVSI 0,TLIST\r
+ MOVEM 0,DSTO(PVP)\r
+ MOVEM 0,CSTO(PVP)\r
+ PUSHJ P,DOIOTO ; OUT IT GOES\r
+ SETZM ASTO(PVP)\r
+ SETZM CSTO(PVP)\r
+ SETZM DSTO(PVP)\r
+ POPJ P,\r
+\r
+; HERE IF UVECOR FORM OF FIXUPS\r
+\r
+UFIXES: PUSH TP,$TUVEC\r
+ PUSH TP,A ; SAVE IT\r
+\r
+UFIX1: MOVE B,-6(TP) ; GET SAME\r
+ PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER\r
+ HLRE C,(TP) ; GET LENGTH\r
+ MOVMS C\r
+ PUSH P,C\r
+ HRROI A,(P) ; READY TO ZAP IT OUT\r
+ PUSHJ P,DOIOTO ; ZAP!\r
+ SUB P,[1,,1]\r
+ HLRE C,(TP) ; LENGTH BACK\r
+ MOVMS C\r
+ ADDI C,1\r
+ ADDM C,ACCESS(B) ; UPDATE ACCESS\r
+ MOVE A,(TP) ; NOW THE UVECTOR\r
+ MOVSI C,TUVEC\r
+ MOVEM C,ASTO(PVP)\r
+ PUSHJ P,DOIOTO ; GO\r
+ SETZM ASTO(PVP)\r
+ SUB P,[1,,1]\r
+ SUB TP,[4,,4]\r
+ JRST PNEXT\r
+\r
+RCANT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE RSUBR-LACKS-FIXUPS\r
+ JRST CALER1\r
+\r
+\r
+BADFXU: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-FIXUPS\r
+ JRST CALER1\r
+\r
+PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE\r
+PRBOD1: MOVEI C,1 ; PRINT CODE ALSO\r
+ PUSH P,FLAGS\r
+ PUSH TP,$TRSUBR\r
+ PUSH TP,B\r
+ PUSH P,C\r
+ MOVEI A,"[ ; START VECTOR TEXT\r
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO\r
+ PUSHJ P,PITYO\r
+ POP P,C\r
+ MOVE B,(TP) ; RSUBR BACK\r
+ JUMPN C,PRSON ; GO START PRINTING\r
+ MOVEI A,"0 ; PLACE SAVER FOR CODE VEC\r
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO\r
+ PUSHJ P,PITYO\r
+\r
+PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR\r
+ ADDB B,(TP)\r
+ JUMPGE B,PRSBR3 ; NO SPACE IF LAST\r
+ MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ\r
+ PUSHJ P,SPACEQ\r
+ SKIPA B,(TP) ; GET BACK POINTER\r
+PRSON: JUMPGE B,PRSBR3\r
+ GETYP 0,(B) ; SEE IF RSUBR POINTED TO\r
+ CAIN 0,TENTER\r
+ JRST .+3 ; JUMP IF RSUBR ENTRY\r
+ CAIE 0,TRSUBR ; YES!\r
+ JRST PRSB10 ; COULD BE SUBR/FSUBR\r
+ MOVE C,1(B) ; GET RSUBR\r
+ PUSH P,0 ; SAVE TYPE FOUND\r
+ GETYP 0,2(C) ; SEE IF ATOM\r
+ CAIE 0,TATOM\r
+ JRST PRSBR4\r
+ MOVE B,3(C) ; GET ATOM NAME\r
+ PUSHJ P,IGVAL ; GO LOOK\r
+ MOVE C,(TP) ; ORIG RSUBR BACK\r
+ GETYP A,A\r
+ POP P,0 ; DESIRED TYPE\r
+ CAIE 0,(A) ; SAME TYPE\r
+ JRST PRSBR4\r
+ MOVE D,1(C)\r
+ MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION\r
+ CAME 0,3(B) ; WIN?\r
+ JRST PRSBR4\r
+ MOVEM 0,1(C)\r
+ MOVSI A,TATOM\r
+ MOVEM A,(C) ; UNLINK\r
+\r
+PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS\r
+ MOVE B,(TP)\r
+ MOVE A,(B)\r
+ MOVE B,1(B) ; PRINT IT\r
+ PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT\r
+ PUSH TP,-7(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ JRST PRSBR2\r
+\r
+PRSB10: CAIE 0,TSUBR ; SUBR?\r
+ CAIN 0,TFSUBR\r
+ JRST .+2\r
+ JRST PRSBR4\r
+ MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR\r
+ MOVE C,@-1(C) ; NAME OF IT\r
+ MOVEM C,1(B) ; SMASH\r
+ MOVSI C,TATOM ; AND TYPE\r
+ MOVEM C,(B)\r
+ JRST PRSBR4\r
+\r
+PRSBR3: MOVEI A,"]\r
+ MOVE B,-6(TP)\r
+ PUSHJ P,PRETIF ; CLOSE IT UP\r
+ SUB TP,[2,,2] ; FLUSH CRAP\r
+ POP P,FLAGS\r
+ POPJ P,\r
+\r
+\r
+\f; HERE TO PRINT PURE RSUBRS\r
+\r
+PRSBRP: MOVEI A,2 ; WILL "%<" FIT?\r
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE RSUBR\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT IT OUT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVEI A,"' ; QUOTE THE VECCTOR\r
+ PUSHJ P,PRETIF\r
+ MOVE B,(TP) ; GET RSUBR BODY BACK\r
+ PUSH TP,$TFIX ; STUFF THE STACK\r
+ PUSH TP,[0]\r
+ PUSHJ P,PRBOD1 ; PRINT AND UNLINK\r
+ SUB TP,[2,,2] ; GET JUNK OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+; HERE TO PRINT ASCII RSUBRS\r
+\r
+ARSUBR: PUSH P,FLAGS ; SAVE FROM GET\r
+ MOVSI A,TRSUBR\r
+ MOVE B,(TP)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE RSUBR\r
+ PUSHJ P,IGET ; TRY TO GET FIXUPS\r
+ POP P,FLAGS\r
+ JUMPE B,PUNK ; NO FIXUPS LOSE\r
+ GETYP A,A\r
+ CAIE A,TLIST ; ARE FIXUPS A LIST?\r
+ JRST PUNK ; NO, AGAIN LOSE\r
+ PUSH TP,$TLIST\r
+ PUSH TP,B ; SAVE FIXUPS\r
+ MOVEI A,17.\r
+\r
+ MOVE B,-4(TP)\r
+ PUSHJ P,RETIF\r
+ PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]\r
+\r
+AL1: ILDB A,(P) ; GET CHAR\r
+ JUMPE A,.+3\r
+ PUSHJ P,PITYO\r
+ JRST AL1\r
+\r
+ SUB P,[1,,1]\r
+ PUSHJ P,SPACEQ\r
+\r
+ MOVEI A,"'\r
+ PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL\r
+ MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE\r
+ PUSHJ P,PRBOD1\r
+ MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ\r
+ PUSHJ P,SPACEQ\r
+ MOVEI A,"' ; DONT EVAL FIXUPS EITHER\r
+ PUSHJ P,PRETIF\r
+ POP TP,B\r
+ POP TP,A\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)\r
+\r
+LOCP: PUSH TP,-1(TP)\r
+ PUSH TP,-1(TP)\r
+ PUSH P,0\r
+ MCALL 1,IN ; GET ITS CONTENTS FROM "IN"\r
+ POP P,0\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT IT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT\r
+;B CONTAINS CHANNEL\r
+;PRINTER ITYO USED FOR FLATSIZE FAKE OUT\r
+PITYO: TLNN FLAGS,FLTBIT\r
+ JRST ITYO\r
+PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER\r
+ PUSH TP,B\r
+ TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET\r
+ JRST ITYO+2\r
+ AOS FLTSIZ ;FLATSIZE DOESN'T PRINT\r
+ ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT\r
+ SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED\r
+ JRST .+4\r
+ POP TP,B ; GET CHANNEL BACK\r
+ SUB TP,[1,,1]\r
+ POPJ P,\r
+ MOVEI E,(B) ; GET POINTER FOR UNBINDING\r
+ PUSHJ P,SSPEC1\r
+ MOVE P,UPB+8 ; RESTORE P\r
+ POP TP,B ; GET BACK TP POINTER\r
+ PUSH P,0 ; SAVE FLAGS\r
+ MOVE TP,B ; RESTORE TP\r
+PITYO3: MOVEI C,(TB)\r
+ CAILE C,1(TP)\r
+ JRST PITYO2\r
+ POP P,0 ; RESTORE FLAGS\r
+ MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE\r
+ MOVEI B,0\r
+ POPJ P,\r
+\r
+PITYO2: HRR TB,OTBSAV(TB) ; RESTORE TB\r
+ JRST PITYO3\r
+\r
+\r
+\f;THE REAL THING\r
+;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG\r
+;CHARACTER STRINGS\r
+; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)\r
+ITYO: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH P,FLAGS ;SAVE STUFF\r
+ PUSH P,C\r
+ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER\r
+\r
+\r
+ITYO1: TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET\r
+ JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING\r
+ CAIE A,^L ;SKIP IF THIS IS A FORM-FEED\r
+ JRST NOTFF\r
+ SETZM LINPOS(B) ;ZERO THE LINE NUMBER\r
+ JRST ITYXT\r
+\r
+NOTFF: CAIE A,15 ;SKIP IF IT IS A CR\r
+ JRST NOTCR\r
+ SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION\r
+ PUSHJ P,WXCT ;OUTPUT THE C-R\r
+ PUSHJ P,AOSACC ; BUMP COUNT\r
+ AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER\r
+ CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END\r
+ JRST ITYXT1\r
+\r
+ SETZM LINPOS(B) ;ZERO THE LINE POSITION\r
+; PUSHJ P,WXCT ; REMOVED FOR NOW\r
+; PUSHJ P,AOSACC\r
+; MOVEI A,^L ; DITTO\r
+ JRST ITYXT1\r
+\r
+NOTCR: CAIN A,^I ;SKIP IF NOT TAB\r
+ JRST TABCNT\r
+ CAIE A,10 ; BACK SPACE\r
+ JRST .+3\r
+ SOS CHRPOS(B) ; BACK UP ONE\r
+ JRST ITYXT\r
+ CAIE A,^J ;SKIP IF LINE FEED\r
+ AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER\r
+\r
+ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS\r
+ITYXTA: PUSHJ P,WXCT ;OUTPUT THE CHARACTER\r
+ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER\r
+\r
+ITYRET: POP P,C ;RESTORE REGS & RETURN\r
+ POP P,FLAGS\r
+ POP TP,B ; GET CHANNEL BACK\r
+ SUB TP,[1,,1]\r
+ POPJ P,\r
+\r
+TABCNT: PUSH P,D\r
+ MOVE C,CHRPOS(B)\r
+ ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)\r
+ IDIVI C,8.\r
+ IMULI C,8.\r
+ MOVEM C,CHRPOS(B) ;REPLACE COUNT\r
+ POP P,D\r
+ JRST ITYXT\r
+\r
+UNPROUT: POP P,A ;GET BACK THE ORIG CHAR\r
+ IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO\r
+ SOS UPB+1\r
+ JRST ITYRET ;RETURN\r
+\r
+AOSACC: TLNN FLAGS,BINBIT\r
+ JRST NRMACC\r
+ AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD\r
+ CAMN C,[TFIX,,1]\r
+ AOS ACCESS(B)\r
+ CAMN C,[TFIX,,5]\r
+ HLLZS ACCESS-1(B)\r
+ POPJ P,\r
+\r
+NRMACC: AOS ACCESS(B)\r
+ POPJ P,\r
+\r
+SPACEQ: MOVEI A,40\r
+ TLNE FLAGS,FLTBIT+BINBIT\r
+ JRST PITYO ; JUST OUTPUT THE SPACE\r
+ PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE\r
+ MOVEI A,1\r
+ JRST RETIF2\r
+\r
+RETIF1: MOVEI A,1\r
+\r
+RETIF: PUSH P,[0]\r
+ TLNE FLAGS,FLTBIT+BINBIT\r
+ JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE\r
+RETIF2: PUSH P,FLAGS\r
+RETCH: PUSH P,A\r
+\r
+RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION\r
+ SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN\r
+ JRST RETXT\r
+ CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH\r
+ JRST RETXT1\r
+\r
+ MOVEI A,^M ;FORCE A CARRIAGE RETURN\r
+ SETZM CHRPOS(B)\r
+ PUSHJ P,WXCT\r
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT\r
+ MOVEI A,^J ;AND FORCE A LINE FEED\r
+ PUSHJ P,WXCT\r
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT\r
+ AOS A,LINPOS(B)\r
+ CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?\r
+ JRST RETXT\r
+; MOVEI A,^L ;IF SO FORCE A FORM FEED\r
+; PUSHJ P,WXCT\r
+; PUSHJ P,AOSACC ; BUMP CHAR COUNT\r
+ SETZM LINPOS(B)\r
+\r
+RETXT: POP P,A\r
+\r
+ POP P,FLAGS\r
+SPOPJ: SUB P,[1,,1]\r
+ POPJ P, ;RETURN\r
+\r
+PRETIF: PUSH P,A ;SAVE CHAR\r
+ PUSHJ P,RETIF1\r
+ POP P,A\r
+ JRST PITYO\r
+\r
+RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE\r
+ POPJ P,\r
+ PUSH P,[0]\r
+ PUSH P,FLAGS\r
+ HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL\r
+ PUSH P,A\r
+ JRST RETCH1\r
+\r
+RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK\r
+ JRST RETXT\r
+ MOVEI A,40\r
+ PUSHJ P,WXCT\r
+ AOS CHRPOS(B)\r
+ PUSH P,C\r
+ PUSHJ P,AOSACC\r
+ POP P,C\r
+ JRST RETXT\r
+\r
+\f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.\r
+;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE\r
+;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.\r
+PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH\r
+ MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL\r
+ PUSHJ P,PITYO ;TYPE IT\r
+\r
+ MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT\r
+ ;TYPE CODE MAY BE OBTAINED FOR PRINTING.\r
+ MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD\r
+OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE\r
+ IORI A,60 ;OR-IN 60 FOR ASCII DIGIT\r
+ PUSHJ P,PITYO ;PRINT IT\r
+ SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS\r
+\r
+PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD\r
+ PUSHJ P,PITYO\r
+\r
+ HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD\r
+ ;INDEXED OFF TP\r
+ MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD\r
+OCTLP2: LDB A,E ;GET 3 BITS\r
+ IORI A,60 ;CONVERT TO ASCII\r
+ PUSHJ P,PITYO ;PRINT IT\r
+ IBP E ;INCREMENT POINTER TO NEXT BYTE\r
+ SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS\r
+\r
+ MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT\r
+ PUSHJ P,PITYO ;REPRINT IT\r
+\r
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER\r
+\r
+POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF\r
+ JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"\r
+\r
+\f;PRINT BINARY INTEGERS IN DECIMAL.\r
+;\r
+PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)\r
+ JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ\r
+ PUSH P,FLAGS\r
+\r
+PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX\r
+ TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE\r
+ JRST PFIXU\r
+ MOVE D,RADX(B) ; GET OUTPUT RADIX\r
+PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX\r
+ MOVEI D,10. ; IF IN DOUBT USE 10.\r
+ PUSH P,D\r
+ MOVEI A,1 ; START A COUNTER\r
+ SKIPGE B,(TP) ; CHECK SIGN\r
+ MOVEI A,2 ; NEG, NEED CHAR FOR SIGN\r
+\r
+ IDIV B,D ; START COUNTING\r
+ JUMPE B,.+2\r
+ AOJA A,.-2\r
+\r
+ MOVE B,-2(TP) ; CHANNEL TO B\r
+ TLNN FLAGS,FLTBIT+BINBIT\r
+ PUSHJ P,RETIF3 ; CHECK FOR C.R.\r
+ MOVE B,-2(TP) ; RESTORE CHANNEL\r
+ MOVEI A,"- ; GET SIGN\r
+ SKIPGE (TP) ; SKIP IF NOT NEEDED\r
+ PUSHJ P,PITYO\r
+ MOVM C,(TP) ; GET MAGNITUDE OF #\r
+ MOVE B,-2(TP) ; RESTORE CHANNEL\r
+ POP P,E ; RESTORE RADIX\r
+ PUSHJ P,FIXTYO ; WRITE OUT THE #\r
+ MOVE FLAGS,-1(P)\r
+ SUB P,[1,,1] ; FLUSH P STUFF\r
+ JRST PNEXT\r
+\r
+FIXTYO: IDIV C,E\r
+ HRLM D,(P) ; SAVE REMAINDER\r
+ SKIPE C\r
+ PUSHJ P,FIXTYO\r
+ HLRZ A,(P) ; START GETTING #'S BACK\r
+ ADDI A,60\r
+ MOVE B,-2(TP) ; CHANNEL BACK\r
+ JRST PITYO\r
+\r
+\f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.\r
+;\r
+PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO)\r
+ JRST PFLT0 ; HACK THAT ZERO\r
+ MOVM E,A ; CHECK FOR NORMALIZED\r
+ TLNN E,400 ; NORMALIZED\r
+ JRST PUNK\r
+ MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE\r
+ MOVE D,[6,,6] ;# WORDS TO GET FROM STACK\r
+\r
+PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK\r
+ HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM\r
+ HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B\r
+ ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP\r
+ JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW\r
+PDLWIN: PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E\r
+\r
+ MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED\r
+ MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE\r
+PFLT1: PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ;START NEW LINE IF IT WON'T\r
+ POP P,B ; RESTORE B\r
+\r
+ HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE\r
+PNUM01: ILDB A,B ;GET NEXT BYTE\r
+ PUSH P,B ;SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PITYO ;PRINT IT\r
+\r
+ P,B ; RESTORE B\r
+ SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO\r
+\r
+ SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN\r
+ JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER\r
+\r
+\r
+PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000\r
+ MOVEI C,9. ; SEE ABOVE\r
+ MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING\r
+ MOVEI B,[ASCII /0.0000000/]\r
+ SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE\r
+\r
+\r
+\r
+\r
+PDLERR: SUB P,D ;REST STACK POINTER\r
+REPEAT 6,PUSH P,[0]\r
+ JRST PDLWIN\r
+\f;PRINT SHORT (ONE WORD) CHARACTER STRINGS\r
+;\r
+PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED\r
+ MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE\r
+ PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE\r
+ TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE\r
+ JRST PCASIS\r
+ MOVEI A,"! ;TYPE A EXCL\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"" ;AND A DOUBLE QUOTE\r
+ PUSHJ P,PITYO\r
+\r
+PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD\r
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)\r
+ JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING\r
+ CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER\r
+ JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER\r
+\r
+ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER\r
+ PUSHJ P,PITYO \r
+\r
+PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN\r
+ PUSHJ P,PITYO ;PRINT IT\r
+ JRST PNEXT\r
+\r
+\r
+\f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)\r
+;\r
+PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM\r
+ MOVE B,1(B) ;GET SECOND\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT IT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ JRST PNEXT ;GO EXIT\r
+\r
+\r
+; Print an ATOM. TRAILERS are added if the atom is not in the current\r
+; lexical path. Also escaping of charactets is performed to allow READ\r
+; to win.\r
+\r
+PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING\r
+ SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0\r
+ HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH\r
+\r
+PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC\r
+ PUSH TP,P\r
+ LDB A,[301400,,(P)] ; GET BYTE PTR POSITION\r
+ DPB A,[301400,,E] ; SAVE IN E\r
+ MOVE C,-2(TP) ; GET ATOM POINTER\r
+ ADD C,[3,,3] ; POINT TO PNAME\r
+ HLRE A,C ; -# WORDS TO A\r
+ PUSH P,A ; PUSH THAT FOR "AOSE"\r
+ MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO\r
+ JSP B,DOIDPB\r
+ HRLI C,440700 ; BUILD BYET POINTER\r
+\r
+PATOM1: ILDB A,C ; GET A CHAR\r
+ JUMPE A,PATDON ; END OF PNAME?\r
+ TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY\r
+ AOS (P) ; COUNT WORD\r
+ JRST PENTCH ; ENTER THE CHAR INTO OUTPUT\r
+\r
+PATDON: LDB A,[220600,,E] ; GET "STATE"\r
+ LDB A,STABYT+6 ; SIMULATE "END" CHARACTER\r
+ DPB A,[220600,,E] ; AND STORE\r
+ MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR\r
+ TLZ B,77\r
+ HRR B,(TP) ; POINT\r
+ SUB TP,[2,,2] ; FLUSH SAVED PDL\r
+ MOVE C,-1(P) ; GET BYE POINTER\r
+ SUB P,[2,,2] ; FLUSH\r
+ PUSH P,D\r
+ MOVEI A,0\r
+ IDPB A,B\r
+ AOS -1(TP) ; COUNT ATOMS\r
+ TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"\r
+ JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS\r
+ MOVEI A,"\ ; GET QUOTER\r
+ TLNN E,2 ; SKIP IF NEEDED\r
+ JRST PATDO1\r
+ SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH\r
+ DPB A,B ; CLOBBER\r
+PATDO1: MOVEI E,(E) ; CLEAR LH(E)\r
+ PUSH P,C ; SAVE BYTER\r
+ PUSH P,E ; ALSO CHAR COUNT\r
+\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSH P,FLAGS\r
+ PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE\r
+ POP P,FLAGS ; AND RESTORES FLAGS\r
+ MOVE C,(TP) ; GET ATOM BACK\r
+ SKIPN C,2(C) ; GET ITS OBLIST\r
+ AOJA A,NOOBL1 ; NONE, USE FALSE\r
+ JUMPL C,.+3 ; JUMP IF REAL OBLIST\r
+ ADDI C,(TVP) ; ELSE MUST BE OFFSET\r
+ MOVE C,(C)\r
+ CAME A,$TLIST ; SKIP IF A LIST\r
+ CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE\r
+ JRST CHOBL ; WINS, NOW LOCATE IT\r
+\r
+CHROOT: CAME C,ROOT+1(TVP) ; IS THIS ROOT?\r
+ JRST FNDOBL ; MUST FIND THE PATH NAME\r
+ POP P,E ; RESTORE CHAR COUNT\r
+ MOVE D,(P) ; AND PARTIAL WORD\r
+ EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD\r
+ MOVEI A,"! ; PUT OUT MAGIC\r
+ JSP B,DOIDPB ; INTO BUFFER\r
+ MOVEI A,"- \r
+ JSP B,DOIDPB\r
+ MOVEI A,40\r
+ JSP B,DOIDPB\r
+\r
+NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER\r
+ PUSH P,D ; PUSH NEXT WORD IF ANY\r
+ JRST NOLEX4\r
+\r
+NOLEX: MOVE E,(P) ; GET COUNT\r
+ SUB P,[2,,2]\r
+NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)\r
+ MOVE A,E ; COUNT TO A\r
+ SKIPN (P) ; FLUSH 0 WORD\r
+ SUB P,[1,,1]\r
+ HRRZ C,-1(TP) ; GET # OF ATOMS\r
+ SUBI A,(C) ; FIX COUNT\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ; MAY NEED C.R.\r
+ MOVEI C,-1(E) ; COMPUTE WORDS-1\r
+ IDIVI C,5 ; WORDS-1 TO C\r
+ HRLI C,(C)\r
+ MOVE D,P \r
+ SUB D,C ; POINTS TO 1ST WORD OF CHARS\r
+ MOVSI C,440700+D ; BYTEPOINTER TO STRING\r
+ PUSH TP,$TPDL ; SAVE FROM GC\r
+ PUSH TP,D\r
+\r
+PATOUT: ILDB A,C ; READ A CHAR\r
+ SKIPE A ; IGNORE NULS\r
+ PUSHJ P,PITYO ; PRINT IT\r
+ MOVE D,(TP) ; RESTORE POINTER\r
+ SOJG E,PATOUT\r
+\r
+NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK\r
+ MOVE P,D ; RESTORE P\r
+ SUB P,[1,,1]\r
+ JRST PNEXT\r
+\r
+\r
+PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?\r
+ JRST PENTC1 ; YES, AVOID SLASHING\r
+ IDIVI A,CHRWD ; GET CHARS TYPE\r
+ LDB B,BYTPNT(B)\r
+ CAIL B,6 ; SKIP IF NOT SPECIAL\r
+ JRST PENTC2 ; SLASH IMMEDIATE\r
+ LDB A,[220600,,E] ; GET "STATE"\r
+ LDB A,STABYT-1(B) ; GET NEW STATE\r
+ DPB A,[220600,,E] ; AND SAVE IT\r
+PENTC3: LDB A,C ; RESTORE CHARACTER\r
+PENTC1: JSP B,DOIDPB\r
+ SKIPGE (P) ; SKIP IF DONE\r
+ JRST PATOM1 ; CONTINUE\r
+ JRST PATDON\r
+\r
+PENTC2: MOVEI A,"\ ; GET CHAR QUOTER\r
+ JSP B,DOIDPB ; NEEDED, DO IT\r
+ MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED\r
+ JRST PENTC3-1\r
+\r
+; ROUTINE TO PUT ONE CHAR ON STACK BUFFER\r
+\r
+DOIDPB: IDPB A,-1(P) ; DEPOSIT\r
+ TRNN D,377 ; SKIP IF D FULL\r
+ AOJA E,(B)\r
+ PUSH P,(P) ; MOVE TOP OF STACK UP\r
+ MOVEM D,-2(P) ; SAVE WORDS\r
+ MOVE D,[440700,,D]\r
+ MOVEM D,-1(P)\r
+ MOVEI D,0\r
+ AOJA E,(B)\r
+\r
+; CHECK FOR UNIQUENESS LOOKING INTO PATH\r
+\r
+CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?\r
+ JRST LSTOBL ; NO, AL LIST THEREOF\r
+ CAME B,C ; THE RIGTH ONE?\r
+ JRST CHROOT ; NO, CHECK ROOT\r
+ JRST NOLEX ; WINNER, NO TRAILERS!\r
+\r
+LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+\r
+NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE\r
+ SKIPN C,-2(TP) ; SKIP IF NOT DONE\r
+ JRST CHROO1 ; EMPTY, CHECK ROOT\r
+ MOVE B,1(C) ; GET ONE\r
+ CAME B,(TP) ; WINNER?\r
+ JRST NXTOBL ; NO KEEP LOOKING\r
+ CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST\r
+ JRST NOLEX1\r
+ MOVE A,-6(TP) ; GET ATOM BACK\r
+ MOVEI D,0\r
+ ADD A,[3,,3] ; POINT TO PNAME\r
+ PUSH P,0 ; SAVE FROM RLOOKU\r
+ PUSH P,(A)\r
+ ADDI D,5\r
+ AOBJN A,.-2 ; PUSH THE PNAME\r
+ PUSH P,D ; AND CHAR COUNT\r
+ MOVSI A,TLIST ; TELL RLOOKU WE WIN\r
+ MOVE B,-4(TP) ; GET BACK OBLIST LIST\r
+ SUB TP,[6,,6] ; FLUSH CRAP\r
+ PUSHJ P,RLOOKU ; FIND IT\r
+ POP P,0\r
+ CAMN B,(TP) ; SKIP IF NON UNIQUE\r
+ JRST NOLEX ; UNIQUE , NO TRAILER!!\r
+ JRST CHROO2 ; CHECK ROOT\r
+\r
+NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST\r
+ MOVEM B,-2(TP)\r
+ JRST NXTOB2\r
+\r
+\r
+FNDOBL: MOVE C,(TP) ; GET ATOM\r
+ MOVSI A,TOBLS\r
+ MOVE B,2(C)\r
+ JUMPL B,.+3\r
+ ADDI B,(TVP)\r
+ MOVE B,(B)\r
+ MOVSI C,TATOM\r
+ MOVE D,IMQUOTE OBLIST\r
+ PUSH P,0\r
+ PUSHJ P,IGET\r
+ POP P,0\r
+NOOBL1: POP P,E ; RESTORE CHAR COUNT\r
+ MOVE D,(P) ; GET PARTIAL WORD\r
+ EXCH D,-1(P) ; AND BYTE POINTER\r
+ CAME A,$TATOM ; IF NOT ATOM, USE FALSE\r
+ JRST NOOBL\r
+ MOVEM B,(TP) ; STORE IN ATOM SLOT\r
+ MOVEI A,"!\r
+ JSP B,DOIDPB ; WRITE IT OUT\r
+ MOVEI A,"-\r
+ JSP B,DOIDPB\r
+ SUB P,[1,,1]\r
+ JRST PATOM0 ; AND LOOP\r
+\r
+NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]\r
+ ILDB A,C\r
+ JUMPE A,NOLEX0\r
+ JSP B,DOIDPB\r
+ JRST .-3\r
+\r
+\r
+NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF\r
+ JRST NOLEX\r
+\r
+CHROO1: SUB TP,[6,,6]\r
+CHROO2: MOVE C,(TP) ; GET ATOM\r
+ SKIPGE C,2(C) ; AND ITS OBLIST\r
+ JRST CHROOT\r
+ ADDI C,(TVP)\r
+ MOVE C,(C)\r
+ JRST CHROOT\r
+\r
+\r
+\f; STATE TABLES FOR \ OF FIRST CHAR\r
+\r
+RADIX 16.\r
+\r
+STATS: 431244000\r
+ 434444400\r
+ 222224200\r
+ 434564200\r
+ 444444400\r
+ 454564200\r
+ 487444200\r
+ 484444400\r
+ 484444200\r
+\r
+RADIX 8.\r
+\r
+STABYT: 400400,,STATS(A)\r
+ 340400,,STATS(A)\r
+ 300400,,STATS(A)\r
+ 240400,,STATS(A)\r
+ 200400,,STATS(A)\r
+ 140400,,STATS(A)\r
+ 100400,,STATS(A)\r
+\r
+\f;PRINT LONG CHARACTER STRINGS.\r
+;\r
+PCHSTR: MOVE B,(TP)\r
+ TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING\r
+ PUSH P,-1(TP) ; PUSH CHAR COUNT\r
+ MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS\r
+ SETZM E ;ZERO COUNT\r
+ PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING\r
+ MOVE A,E ;PUT COUNT RETURNED IN REG A\r
+ TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)\r
+ ADDI A,2 ;PLUS TWO FOR QUOTES\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ;START NEW LINE IF NO SPACE\r
+ POP P,B ; RESTORE B\r
+ TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)\r
+ JRST PCHS01 ;OTHERWISE, DON'T QUOTE\r
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,PITYO\r
+ POP P,B ; RESTORE B\r
+\r
+PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION\r
+ MOVEM B,(TP) ;RESET BYTE POINTER\r
+ POP P,-1(TP) ; RESET CHAR COUNT\r
+ PUSHJ P,PCHRST ;TYPE STRING\r
+\r
+ TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE\r
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER\r
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,PITYO\r
+ POP P,B ;RESTORE B\r
+ JRST PNEXT\r
+\r
+\r
+;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.\r
+;\r
+;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.\r
+;\r
+PCHRST: PUSH P,A ;SAVE REGS\r
+ PUSH P,B\r
+ PUSH P,C\r
+ PUSH P,D\r
+\r
+PCHR02: INTGO ; IN CASE VERY LONG STRING\r
+ HRRZ C,-1(TP) ;GET COUNT\r
+ SOJL C,PCSOUT ; DONE?\r
+ HRRM C,-1(TP)\r
+ ILDB A,(TP) ; GET CHAR\r
+\r
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)\r
+ JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING\r
+ CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER\r
+ JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER\r
+ CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE\r
+ JRST ESCPRN ;OTHERWISE, ESCAPE THE """\r
+ IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE\r
+ LDB B,BYTPNT(B) ; "\r
+ CAIGE B,6 ;SKIP IF NOT A NUMBER/LETTER\r
+ JRST PCSPRT ;OTHERWISE, PRINT IT\r
+ TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)\r
+ JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE\r
+\r
+ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ XCT (P)-1 \r
+ POP P,B ; RESTORE B\r
+\r
+PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ XCT (P)-1 ;PRINT IT\r
+ POP P,B ; RESTORE B\r
+ JRST PCHR02 ;LOOP THROUGH STRING\r
+\r
+PCSOUT: POP P,D\r
+ POP P,C ;RESTORE REGS & RETURN\r
+ POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+\r
+\f;PRINT AN ARGUMENT LIST\r
+;CHECK FOR TIME ERRORS\r
+\r
+PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER\r
+ PUSHJ P,CHARGS ;AND CHECK THEM\r
+ JRST PVEC ; CHEAT TEMPORARILY\r
+\r
+\r
+\r
+;PRINT A FRAME\r
+PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER\r
+ PUSHJ P,CHFRM\r
+ HRRZ B,(TP) ;POINT TO FRAME ITSELF\r
+ HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE\r
+ CAMGE B,VECTOP\r
+ CAMGE B,VECBOT\r
+ SKIPA B,@-1(B) ; SUBRS AND FSUBRS\r
+ MOVE B,3(B) ; FOR RSUBRS\r
+ MOVSI A,TATOM\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT FUNCTION NAME\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+PPVP: MOVE B,(TP) ; PROCESS TO B\r
+ MOVSI A,TFIX\r
+ JUMPE B,.+3\r
+ MOVE A,PROCID(B)\r
+ MOVE B,PROCID+1(B) ;GET ID\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+; HERE TO PRINT LOCATIVES\r
+\r
+LOCPT1: HRRZ A,-1(TP)\r
+ JUMPN A,PUNK\r
+LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK\r
+ PUSHJ P,CHLOCI\r
+ HRRZ A,-1(TP)\r
+ JUMPE A,GLOCPT\r
+ MOVE B,(TP)\r
+ MOVE A,(B)\r
+ MOVE B,1(B)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+GLOCPT: MOVEI A,2\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE GLOC\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,SPACEQ\r
+ MOVE B,(TP)\r
+ MOVSI A,TATOM\r
+ MOVE B,-1(B)\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,SPACEQ\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2]\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\f;PRINT UNIFORM VECTORS.\r
+;\r
+PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"[\r
+ PUSHJ P,PITYO\r
+\r
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR\r
+ TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO\r
+ JRST NULVEC ;ELSE, VECTOR IS EMPTY\r
+\r
+ HLRE A,C ;GET NEG COUNT\r
+ MOVEI D,(C) ;COPY POINTER\r
+ SUB D,A ;POINT TO DOPE WORD\r
+ HLLZ A,(D) ;GET TYPE\r
+ PUSH P,A ;AND SAVE IT\r
+\r
+PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A\r
+ MOVE B,(C) ;PUT DATUM INTO REG B\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;TYPE IT\r
+ SUB TP,[2,,2] ; POP CHANNEL OF STACK\r
+ MOVE C,(TP) ;GET AOBJN POINTER\r
+ AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO\r
+ MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ JRST PUVE02 ;LOOP THROUGH VECTOR\r
+\r
+NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP\r
+NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,"! ;TYPE CLOSE BRACKET\r
+ PUSHJ P,PRETIF\r
+ MOVEI A,"]\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\f;PRINT A GENERALIZED VECTOR\r
+;\r
+PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [\r
+ MOVEI A,"[ ;PRINT A LEFT-BRACKET\r
+ PUSHJ P,PITYO\r
+\r
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR\r
+ TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO\r
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR\r
+PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A\r
+ MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT THAT ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+\r
+ MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK\r
+ AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)\r
+ AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO\r
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR\r
+ MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR\r
+\r
+PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]\r
+ MOVEI A,"] ;PRINT A RIGHT-BRACKET\r
+ PUSHJ P,PITYO\r
+ JRST PNEXT\r
+\r
+\f;PRINT A LIST.\r
+;\r
+PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("\r
+ MOVEI A,"( ;TYPE AN OPEN PAREN\r
+ PUSHJ P,PITYO\r
+ PUSHJ P,LSTPRT ;PRINT THE INSIDES\r
+ MOVE B,-2(TP) ; RESTORE CHANNEL TO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN\r
+ MOVEI A,") ;TYPE A CLOSE PAREN\r
+ PUSHJ P,PITYO\r
+ JRST PNEXT\r
+\r
+PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)\r
+\r
+PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT\r
+\r
+PLMNT3: MOVE C,(TP)\r
+ JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY\r
+ MOVE B,1(C)\r
+ MOVEI D,0\r
+ CAMN B,MQUOTE LVAL\r
+ MOVEI D,".\r
+ CAMN B,MQUOTE GVAL\r
+ MOVEI D,",\r
+ CAMN B,MQUOTE QUOTE\r
+ MOVEI D,"'\r
+ JUMPE D,PLMNT1 ;NEITHER, LEAVE\r
+\r
+;ITS A SPECIAL HACK\r
+ HRRZ C,(C)\r
+ JUMPE C,PLMNT1 ;NIL BODY?\r
+\r
+;ITS VALUE OF AN ATOM\r
+ HLLZ A,(C)\r
+ MOVE B,1(C)\r
+ HRRZ C,(C)\r
+ JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY\r
+\r
+ PUSH P,D ;PUSH THE CHAR\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT\r
+ JRST PLMNT4 ;ELSE DON'T PRINT THE "."\r
+\r
+;ITS A SEGMENT CALL\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,2 ; ROOM FOR ! AND . OR ,\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"!\r
+ PUSHJ P,PITYO\r
+\r
+PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1\r
+ POP P,A ;RESTORE CHAR\r
+ PUSHJ P,PITYO\r
+ POP TP,B\r
+ POP TP,A\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+\r
+PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT\r
+ JRST PLMNT5 ;ELSE DON'T TYPE THE "!"\r
+\r
+;ITS A SEGMENT CALL\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,2 ; ROOM FOR ! AND <\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"!\r
+ PUSHJ P,PITYO\r
+\r
+PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B\r
+ PUSHJ P,RETIF1 \r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ PUSHJ P,LSTPRT\r
+ MOVEI A,"!\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT\r
+ PUSHJ P,PRETIF\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\r
+\f\r
+LSTPRT: SKIPN C,(TP)\r
+ POPJ P,\r
+ HLLZ A,(C) ;GET NEXT ELEMENT\r
+ MOVE B,1(C)\r
+ HRRZ C,(C) ;CHOP THE LIST\r
+ JUMPN C,PLIST1\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ POPJ P,\r
+\r
+PLIST1: MOVEM C,(TP)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ JRST LSTPRT ;REPEAT\r
+\r
+PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS\r
+ SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK\r
+ POP P,C ;RESTORE REG C\r
+ POPJ P,\r
+\r
+OPENIT: PUSH P,E\r
+ PUSH P,FLAGS\r
+ PUSHJ P,OPNCHN\r
+ POP P,FLAGS\r
+ POP P,E\r
+ JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED\r
+ POPJ P,\r
+\r
+\r
+END\r
+\f\r
projects / pdp10-muddle.git / blobdiff