historicalsource
/
zork
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
zork/tell.mud

1264 lines
28 KiB
Plaintext
Raw Normal View History

Original Source
2019-04-13 16:44:59 -07:00
<NEWTYPE PSTRING WORD>
<SETG RUBOUT? <>>
<SETG RUVEC <IUVECTOR 4>>
<SETG NO-TELL 0>
<SETG IN-TELL 0>
<SETG TELL-VEC <IUVECTOR 7>>
;"Print some strings to ,OUTCHAN"
<TITLE TELL>
<DECLARE ("VALUE" ATOM <PRIMTYPE STRING> "OPTIONAL" FIX
<OR STRING FALSE> <OR STRING FALSE>)>
<MOVE A* AB>
LOOP <PUSH TP* (AB)>
<PUSH TP* 1(AB)>
<ADD AB* [<(2) 2>]>
<JUMPL AB* LOOP>
<HLRES A>
<ASH A* -1>
<ADDI A* TABEND>
<PUSHJ P* @ (A) 1>
<JRST FINIS>
<TELL4>
<TELL3>
<TELL2>
TABEND <TELL1>
<INTERNAL-ENTRY TELL1 1> ; "push 1"
<PUSH TP* <TYPE-WORD FIX>>
<PUSH TP* [1]>
<INTERNAL-ENTRY TELL2 2>
<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<INTERNAL-ENTRY TELL3 3>
<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<INTERNAL-ENTRY TELL4 4>
<SUBM M* (P)>
<INTGO>
<PUSHJ P* SETUP> ; "SETUP FOR INTERRUPTS"
<JRST [<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<DPUSH TP* <PQUOTE <STRING <ASCII 13> <ASCII 10>>>>
<MOVE C* <MQUOTE <RGLOC OUTCHAN T>>>
<ADD C* GLOTOP 1>
<MOVE C* 1(C)>
<PUSH P* 1(C)>
<MOVEI C* 0>
<PUSHJ P* DOSIOT> ; "PRINT CRLF"
<SUB TP* [<(2) 2>]>
<JRST INTLV>]>
INTLV <JRST [<SUB P* [<(1) 1>]>
<JRST RLDONE1>]> ; "RETURN FROM NON-PRINT"
<MOVE C* <MQUOTE <RGLOC OUTCHAN T>>>
<ADD C* GLOTOP 1>
<MOVE C* 1(C)>
<MOVE C* 1(C)> ; "CHANNEL NUMBER IN C"
<PUSH P* C> ; "SAVE ON STACK"
<MOVE E* <MQUOTE <RGLOC SCRIPT-CHANNEL T>>>
<ADD E* GLOTOP 1>
<PUSH TP* (E)>
<PUSH TP* 1(E)>
<MOVE O* -6(TP)> ; "FIX SPECIFYING WHEN TO DO CR'S"
<TRNN O* 2> ; "SKIP IF PRINT CR BEFORE"
<JRST PTFST>
<PUSH TP* <PQUOTE <STRING <ASCII 13> <ASCII 10>>>>
<PUSH TP* <MQUOTE <STRING <ASCII 13> <ASCII 10>>>>
<MOVEI C* 0>
<PUSHJ P* DOSIOT>
PTFST <LDB C* [<(*220913*) -6>]> ; "MAYBE THE GUY GAVE A LENGTH FOR THIS?"
<PUSH TP* -9(TP)> ; "PUSH ARGS FOR DOSIOT"
<PUSH TP* -9(TP)>
<PUSHJ P* DOSIOT>
<INTGO>
<GETYP O* -5(TP)>
<CAIN O* <TYPE-CODE FALSE>> ; "IS IT FALSE?"
<JRST DONE>
<PUSH TP* -5(TP)>
<PUSH TP* -5(TP)> ; "ARGS"
<MOVEI C* 0>
<PUSHJ P* DOSIOT> ; "DO PRINT"
<GETYP O* -3(TP)>
<CAIN O* <TYPE-CODE FALSE>>
<JRST DONE>
<PUSH TP* -3(TP)>
<PUSH TP* -3(TP)>
<MOVEI C* 0>
<PUSHJ P* DOSIOT>
DONE <MOVE O* -6(TP)>
<TRNN O* 1> ; "CR AFTER?"
<JRST RLDONE>
<PUSH TP* <PQUOTE <STRING <ASCII 13> <ASCII 10>>>>
<PUSH TP* <MQUOTE <STRING <ASCII 13> <ASCII 10>>>>
<MOVEI C* 0>
<PUSHJ P* DOSIOT> ; "PRINT CRLF"
RLDONE <MOVE A* <MQUOTE <RGLOC IN-TELL T>>>
<ADD A* GLOTOP 1>
<SETZM 1(A)> ; "NO LONGER IN TELL"
<SUB P* [<(2) 2>]> ; "CLEAN UP P"
<SUB TP* [<(2) 2>]>
RLDONE1 <SUB TP* [<(8) 8>]>
<MOVE C* <MQUOTE <RGLOC TELL-FLAG T>>> ;"SETG TELL-FLAG"
<ADD C* GLOTOP 1>
<MOVE A* <TYPE-WORD ATOM>>
<MOVEM A* (C)>
<MOVE B* <MQUOTE T>>
<MOVEM B* 1(C)>
<JRST MPOPJ>
; "SET UP FOR INTERRUPTS"
SETUP <SUBM M* (P)>
<PUSH P* (P)>
<MOVE A* <MQUOTE <RGLOC NO-TELL T>>>
<ADD A* GLOTOP 1>
<SKIPGE 1(A)> ; "IF ALREADY TURNED OFF, JUST LEAVE"
<JRST SPOPJ>
<SKIPL -4(TP)> ; "DO THIS ONLY IF TOLD TO"
<JRST SETUPO>
<MOVE A* <MQUOTE <RGLOC TELL-VEC T>>>
<ADD A* GLOTOP 1>
<MOVE A* 1(A)>
<HLRE B* A>
<ADDI B* 1>
<MOVNS B>
<ADDI B* (A)>
<HRLI A* AB>
<SUB P* [<(1) 1>]>
<BLT A* (B)>
<ADD P* [<(1) 1>]>
<MOVE A* <MQUOTE <RGLOC IN-TELL T>>>
<ADD A* GLOTOP 1>
<SETOM 1(A)> ; "NOW IN TELL"
SETUPO <SOS (P)>
SPOPJ <SOS (P)> ; "SKIP TWICE NORMALLY, ONCE IF NOT PRINTING"
<JRST MPOPJ> ; "SKIP RETURN"
;"SYSTEM DEPENDENT"
;"PUSHJ DOSIOT WITH ARGS ON TOP OF TP STACK; CHANNEL/JFN IS -1(P); SCRIPT CHANNEL
IS NEXT FROB ON TP. FORTUNATELY, NO AC'S ARE SACRED. C HAS # CHARS TO PRINT
IF NON-ZERO."
DOSIOT <SUBM M* (P)>
<SKIPG C> ; "IF C>0, THEN ITS THE # OF CHARS TO PRINT"
<HRRZ C* -1(TP)> ; "GET STRING LENGTH"
<PUSH P* C>
<MOVE B* (TP)> ; "GET STRING"
<SKIPL -8(TP)>
<JRST DOSIOT1> ; "ONLY ENABLE IF TOLD TO"
<AOSN INTFLG>
<JSR LCKINT> ; "ENABLE INTERRUPTS"
DOSIOT1 <IFOPSYS (TENEX
<MOVNS C> ; "GET -LENGTH"
<JUMPE C* DODONE> ; "0 LENGTH STRING"
<MOVE A* -2(P)> ; "GET JFN"
<SOUT> ; "DO IT")
(ITS
<*CALL SIOT>
<JFCL>)>
<SKIPGE -6(TP)>
<SETZM INTFLG> ; "DISABLE INTERRUPTS"
<SKIPL -2(TP)> ; "SCRIPTING?"
<JRST DODONE>
<MOVSI A* <TYPE-CODE STRING>>
<HRR A* -1(TP)>
<PUSH TP* A> ; "PUSH STRING"
<PUSH TP* -1(TP)>
<PUSH TP* -5(TP)> ; "PUSH CHANNEL"
<PUSH TP* -5(TP)>
<PUSH TP* <TYPE-WORD FIX>>
<PUSH TP* (P)>
<MCALL 3 PRINTSTRING> ; "DO PRINTSTRING"
DODONE <SUB TP* [<(2) 2>]> ; "GET RID OF ARGS"
<SUB P* [<(1) 1>]>
<JRST MPOPJ>
<IFOPSYS (ITS
SIOT <SETZ>
<SIXBIT "SIOT">
<-2(P)>
<MOVE B>
<SETZ C>)>
<TITLE CTRL-S>
<DECLARE ("VALUE" <OR ATOM DISMISS> CHARACTER CHANNEL)>
<DPUSH TP* (AB)>
<DPUSH TP* 2(AB)>
<PUSHJ P* ICTRL>
<JRST FINIS>
<INTERNAL-ENTRY ICTRL 2>
<SUBM M* (P)>
<MOVE B* -2(TP)>
<CAIN B* 7> ; "CTRL-G?"
<JRST GACK>
<IFOPSYS
(TENEX
<CAIE B* %<ASCII !\>>)
(ITS
<CAIE B* %<ASCII !\>>)>
<JRST [<MOVSI A* <TYPE-CODE ATOM>>
<JRST ICTRL1>]> ; "NOT CTRL-S, SO FLUSH"
<SETZM INTFLG>
<MOVE A* <MQUOTE <RGLOC INCHAN T>>>
<ADD A* GLOTOP 1>
<DPUSH TP* (A)>
<MCALL 1 RESET>
<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<MCALL 1 TTY-INIT>
<MOVE A* <MQUOTE <RGLOC NO-TELL T>>>
<ADD A* GLOTOP 1>
<SKIPGE 1(A)> ; "ALREADY TRUE?"
<JRST ICTRLO> ; "YES, SO FLUSH"
<SETOM 1(A)> ; "NO, SO MAKE IT TRUE"
<MOVE A* <MQUOTE <RGLOC IN-TELL T>>>
<ADD A* GLOTOP 1>
<SKIPL 1(A)> ; "IN TELL?"
<JRST ICTRLO> ; "NO, FLUSH"
<SETZM 1(A)> ; "NOT ANY MORE"
<PUSH TP* <TYPE-WORD FIX>>
<PUSH TP* [0]>
<MCALL 1 INT-LEVEL> ; "FIX UP INTERRUPTS"
<MOVE A* <MQUOTE <RGLOC TELL-VEC T>>>
<ADD A* GLOTOP 1> ; "GET POINTER TO SAVED AC'S (N OF THEM)"
<MOVE A* 1(A)> ; "PICK UP POINTER"
<HLRE B* A> ; "# OF AC'S IS IN B"
<ADDI B* P 1> ; "FIRST ONE"
<HRLS A>
<HRR A* B> ; "BLT POINTER IN A"
<BLT A* P> ; "BLT THE AC'S BACK"
<JRST MPOPJ> ; "AND LEAVE"
ICTRLO <MOVSI A* <TYPE-CODE DISMISS>>
ICTRL1 <MOVEI B* <MQUOTE 'T>>
<SUB TP* [<(4) 4>]>
<JRST MPOPJ>
GACK <MOVE A* <MQUOTE <RGLOC INCHAN T>>>
<ADD A* GLOTOP 1>
<DPUSH TP* (A)>
<MCALL 1 RESET>
<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<MCALL 1 TTY-INIT>
<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<PUSH TP* <TYPE-WORD ATOM>>
<PUSH TP* <MQUOTE CONTROL-G?!-ERRORS>>
<MCALL 2 HANDLE>
<JRST ICTRLO>
;"Get current time in disk format"
;"SYSTEM DEPENDENT (GROSSLY)"
<TITLE DSKDATE>
<DECLARE ("VALUE" WORD)>
<PUSHJ P* IDSKDATE>
<JRST FINIS>
<INTERNAL-ENTRY IDSKDATE 0>
<SUBM M* (P)>
<IFOPSYS (TENEX
<HRROI B* -1> ; "-1 TO SAY CURRENT TIME"
<MOVEI D* 0> ; "NOTHING FANCY"
<ODCNV> ; "GET IT: B HAS YEAR,,MONTH; C DAY,,; D ,,TIME"
<TLZ D* -1> ; "CLEAN OUT LH OF D"
<ASH D* 1> ; "TIME IN HALF-SECONDS"
<HLRZS C> ; "GET DAY OF MONTH -1"
<ADDI C* 1> ; "DO THE RIGHT THING"
<DPB C* [<(*220500*) D>]> ; "STUFF DAY INTO D"
<IDIV B* [(1)]> ; "SPLIT B IN HALF"
<ADDI C* 1> ; "GET REAL MONTH"
<DPB C* [<(*270400*) D>]> ; "STUFF IN MONTH"
<IDIVI B* 100> ; "GET YEAR OF CENTURY IN C"
<DPB C* [<(*330700*) D>]> ; "STUFF IN YEAR"
<MOVE B* D>
<MOVE A* <TYPE-WORD WORD>>
<JRST MPOPJ>)
(ITS
<*CALL RQDATE>
<SETO B*>
<MOVE A* <TYPE-WORD WORD>>
<JRST MPOPJ>
RQDATE <SETZ>
<SIXBIT "RQDATE">
<SETZM B>)>
;"GET STRING OF USER NAME (OR SOMETHING LIKE THAT)"
<TITLE GXUNAME>
<DECLARE ("VALUE" STRING)>
<PUSHJ P* IXUNAME>
<JRST FINIS>
<INTERNAL-ENTRY IXUNAME 0>
<SUBM M* (P)>
<IFOPSYS (TENEX
<GJINF> ; "GET DIRECTORY NUMBER IN B"
<MOVE B* A>
<MOVE C* <MQUOTE <RGLOC SCRATCH-STR T>>>
<ADD C* GLOTOP 1>
<MOVE A* 1(C)>
<DIRST>
<JFCL>
<MOVE B* 1(C)>
<MOVE A* (C)>
<JRST MPOPJ>)
(ITS
<*SUSET [<(*74*) A>]>
<PUSH TP* <TYPE-WORD WORD>>
<PUSH TP* A>
<PUSHJ P* ISIXTO>
<JRST MPOPJ>
;"TAKES WORD ON TOP OF TP, RETURNS STRING"
ISIXTO <SUBM M* (P)>
<LDB O* [<(*000613*) 0>]> ; "LAST BYTE IN WORD"
<MOVEI C* 1>
<JUMPE O* CONTIN>
<MOVEI C* 2> ; "NUMBER OF WORDS REQUIRED"
CONTIN <PUSH P* C> ; "SAVE #WORDS"
<MOVE A* C>
<MOVEI O* IBLOCK>
<PUSHJ P* RCALL> ; "GET UVECTOR (IN A AND B)"
<MOVE A* <TYPE-WORD STRING>>
<POP P* C>
<MOVEI O* 4(C)> ; "LENGTH IS FIVE OR SIX"
<HRR A* O> ; "LENGTH OF STRING"
<ADD C* B>
<MOVEI O* <TYPE-CODE CHARACTER>>
<DPB O* [<(*221503*) 0>]> ; "CLOBBER TYPE SLOT IN DOPE WORDS"
<HRLI B* *440700*> ; "GET STRING POINTER TO UV"
; "AT THIS POINT, IN A AND B WE HAVE THE TYPE-VALUE WORD, ALMOST READY TO
RETURN. ON TOP OF TP, THE WORD TO BE HACKED."
START <PUSH P* B> ; "SAVE BP TO RETURN"
<MOVE C* (TP)> ; "GET WORD TO HACK IN C"
<MOVE D* [<(*440600*) C>]> ; "AND SIXBIT POINTER IN D"
<HRRZ E* A> ; "LENGTH OF STRING"
<JUMPE E* DONE> ; "CAN'T HACK EMPTY STRING"
<CAILE E* 6>
<MOVEI E* 6> ; "MAX # CHARS"
STRLOP <ILDB O* D> ; "GET CHAR IN O"
<ADDI O* *40*>
<IDPB O* B> ; "STUFF CHAR INTO STRING"
<SOJG E* STRLOP>
DONE <POP P* B> ; "GET OLD BP BACK"
<SUB TP* [<(2) 2>]>
<JRST MPOPJ>)>
;"Takes channel open to name file, returns string of name"
<IFOPSYS (TENEX
<TITLE GET-NAME>
<DECLARE ("VALUE" <OR FALSE STRING>)>
<PUSHJ P* IGETNAME>
<JRST FINIS>
<INTERNAL-ENTRY IGETNAME 1>
<SUBM M* (P)>
;"FIRST, WE NEED A JFN TO THE CRETIN FILE WITH THE RIGHT CRETIN BITS."
<MOVSI A* *100001*> ; "I HOPE THIS MEANS GET
EXISTING FILE, SHORT FORM"
<MOVE B* <MQUOTE "DSK:<IMSSS>DATSYS.PMAP">>
; "FILE NAME, ASCIZ"
<GTJFN>
<JRST OPLOST> ; "LOSE, LOSE"
<TLZ A* -1>
<MOVE B* [<(*440000*) *202200*>]>
; "36 BYTE SIZE, THAWED MODE, DON'T HANG"
<OPENF>
<JRST OPLOST>
<PUSH P* A> ; "SAVE JFN"
<MOVEI A* 4>
<PUSHJ P* PGFIND> ; "GET FOUR PAGES FROM INTERPRETER"
<JUMPL B* [<ERRUUO* <MQUOTE CANT-GET-PAGES>>]>
<ASH B* 1> ; "CRETIN TENEX"
<PUSH P* B> ; "SAVE PAGE NUMBER"
<TLO B* *400000*> ; "TURN ON 'ME' BIT"
<HRLZ A* -1(P)> ; "GET JFN"
<HRRI A* *60*> ; "PAGE IN FILE"
<HRLI C* *100000*>
<MOVEI D* *10*>
MLOP <PMAP> ; "DO MAP"
<ADDI A* 1>
<ADDI B* 1>
<SOJG D* MLOP> ; "WORK ON 10X/20X"
<GJINF> ; "DIRNUM IS IN A; B AND C HAVE GONE AWAY"
<IMULI A* 4> ; "OFFSET INTO BLOCK"
<MOVE B* (P)> ; "PAGE #, TENEX STYLE"
<ASH B* *11*> ; "MAKE IT AN ADDRESS"
<ADDI B* (A)> ; "ADDRESS OF BEGINNING OF STRING"
<PUSH P* B> ; "SAVE FOR EVENTUAL BLT"
<HRLI B* *440700*> ; "BYTE POINTER"
<MOVEI A* 0> ; "# OF CHARS"
LENLP <ILDB O* B> ; "GET CHAR"
<JUMPE O* ENDSTR> ; "DONE?"
<AOJA A* LENLP> ; "NO, INCREASE COUNT AND TRY AGAIN"
ENDSTR <PUSH P* A> ; "SAVE LENGTH"
<IDIVI A* 5> ; "# OF WORDS"
<CAIE B* 0> ; "REMAINDER 0?"
<ADDI A* 1> ; "NOPE"
<PUSH P* A> ; "SAVE # WORDS"
<MOVEI O* IBLOCK>
<PUSHJ P* RCALL> ; "GET UV"
; "# OF WORDS IN STRING IS (P); LENGTH OF STRING IS -1(P); ADDRESS OF SOURCE IS -2(P);
PAGE # OF MAPPED AREA IS -3(P)"
<MOVE D* B>
<HRL D* -2(P)> ; "SOURCE POINTER"
<MOVEI C* -1(D)> ; "DEST POINTER -1"
<ADD C* (P)> ; "END OF DESTINATION"
<BLT D* (C)> ; "GET STRING"
<MOVEI O* <TYPE-CODE STRING>>
<DPB O* [<(*221503*) 1>]> ; "CLOBBER DOPE WORDS"
<HRLI B* *440700*>
<MOVSI A* <TYPE-CODE STRING>>
<HRR A* -1(P)> ; "FINISH STRING POINTER"
<PUSH TP* A> ; "PUSH STRING"
<PUSH TP* B>
<HRROI A* -1> ; "A IS -1 FOR UNMAPPING"
<MOVE B* -3(P)> ; "PAGE #"
<TLO B* *400000*>
<MOVE C* [<(*400000*) *10*>]> ; "# PAGES"
<PMAP> ; "UNMAP"
<MOVE A* -4(P)> ; "JFN"
<CLOSF> ; "CLOSE, RELEASE JFN"
<JFCL>
<MOVE B* -3(P)>
<ASH B* -1>
<MOVEI A* *4*>
<PUSHJ P* PGGIVE> ; "GIVE BACK PAGES"
<POP TP* B>
<POP TP* A> ; "GET STRING BACK"
<SUB P* [<(5) 5>]> ; "CLEAN UP P"
<JRST MPOPJ> ; "DONE"
OPLOST <MOVE A* <TYPE-WORD FALSE>> ; "RETURN FALSE"
<MOVEI B* 0>
<JRST MPOPJ>)>
<TITLE STARTER>
<DECLARE ("VALUE" <OR FIX STRING>)>
<PUSHJ P* ISTART>
<JRST FINIS>
<INTERNAL-ENTRY ISTART 0>
<SUBM M* (P)>
<IFOPSYS (TENEX
; "NOW FIGURE OUT WHAT'S GOING ON WITH DIRECTORIES"
GETDIR <MOVEI A* *2500*> ; "ALMOST GUARANTEED--SHARING WITH SAVE FILE"
<LSH A* -9> ; "10X PAGE #"
<HRLI A* *400000*> ; "THIS PROCESS"
<RMAP> ; "GET JFN IN LH OF B"
<SKIPGE A>
<JRST D*>
<HLRZ B* A> ; "JFN TO THE RIGHT"
<MOVE D* <MQUOTE <RGLOC SCRATCH-STR T>>>
<ADD D* GLOTOP 1>
<MOVE A* 1(D)> ; "DESTINATION"
<MOVSI C* *010000*> ; "DIRECTORY FIELD ONLY"
<JFNS>
<MOVE B* 1(D)>
<MOVE A* (D)>
<JRST MPOPJ> ; "RETURN THE STRING"
OUT <MOVSI A* <TYPE-CODE FIX>>
<MOVEI B*>
<JRST MPOPJ>)
(ITS
<*CALL TTYGET>
<JFCL>
<TLO B* *300*>
<*CALL TTYSET>
<JFCL>
<*IOPUS>
<*CALL [<SETZ>
<SIXBIT "OPEN">
[<(0) 0>]
[<SIXBIT "DSK">]
[<SIXBIT "TRIVIA">]
[<SIXBIT "CURFEW">]
<SETZ [<SIXBIT "_MSGS_">]>]>
<JRST [<*IOPOP>
<JRST CORCHK>]>
<*SUSET [<(*74*) A>]>
<CAMN A* [<SIXBIT "GUEST">]>
<JRST FLUSHO>
<*CALL [<SETZ>
<SIXBIT "OPEN">
[<(0) 0>]
[<SIXBIT "DSK">]
[<SIXBIT ".FILE.">]
[<SIXBIT "(DIR)">]
<SETZ A>]>
<JRST FLUSHO>
<*CALL [<SETZ>
<SIXBIT "OPEN">
[<(*20*) 0>] ; "DON'T CHASE LINKS"
[<SIXBIT "DSK">]
[<SIXBIT "_MSGS_">]
<MOVE A>
<SETZ A>]>
<JRST FLUSHO>
<*IOPOP>
<JRST CORCHK>
FLUSHO <*IOPOP>
<MOVEI B* 5>
<JRST LEAVE>
CORCHK <MOVNI A* 1>
<*SUSET [<(*400021*) A>]> ; "FUNNY HACK"
<*CALL [<SETZ> ; "#SHARERS OF 200. INTO B"
<SIXBIT "CORTYP">
<MOVEI 201.>
<MOVEM C>
<MOVEM 0>
<MOVEM 0>
<SETZM B>]>
<*VALUE>
<JUMPL C* NOTPUR>
<TLZ B* -1> ; "CLEAR LH"
LEAVE <MOVSI A* <TYPE-CODE FIX>>
<JRST MPOPJ>
NOTPUR <MOVEI B* 5>
<JRST LEAVE>
TTYGET <SETZ>
<SIXBIT "TTYGET">
<MOVEI 2>
<MOVEM A>
<MOVEM B>
<MOVEM C>
<MOVEM D>
<SETZM E>
TTYSET <SETZ>
<SIXBIT "TTYSET">
<MOVEI 2>
<MOVE A>
<MOVE B>
<MOVE C>
<SETZ D>)
>
<IFOPSYS (TENEX
<TITLE GETSYS> ; "RETURN T IF 10X"
<DECLARE ("VALUE" <OR ATOM FALSE>)>
<PUSHJ P* IGETSYS>
<JRST FINIS>
<INTERNAL-ENTRY IGETSYS 0>
<SUBM M* (P)>
<HRROI A* 3>
<HRLOI B* *600015*> ; "NUL/NIL DEVICE"
<MOVEI C* 0>
<DEVST>
<JFCL>
<CAMN C* [<(*472531*) *400000*>]>
<JRST TOPS20>
<MOVSI A* <TYPE-CODE ATOM>>
<MOVE B* <MQUOTE T>>
<JRST MPOPJ>
TOPS20 <MOVSI A* <TYPE-CODE FALSE>>
<MOVEI B*>
<JRST MPOPJ>)>
; "ATMFIX takes an ATOM and returns a word which is the PNAME of the
atom appropriately XORed."
<TITLE ATMFIX>
<DECLARE ("VALUE" FIX <OR ATOM PSTRING>)>
<DPUSH TP* (AB)>
<PUSHJ P* ATMFIX1>
<JRST FINIS>
<INTERNAL-ENTRY ATMFIX1 1>
<SUBM M* (P)>
<MOVE A* <TYPE-WORD FIX>>
<MOVE B* (TP)>
<GETYP O* -1(TP)>
<CAIN O* <TYPE-CODE ATOM>>
<MOVE B* 3(B)>
<MOVE D* [<(*402010*) *040200*>]>
<AND D* B>
<LSH D* -1>
<TDO B* D>
<MOVE C* <MQUOTE <RGLOC SRUNM T>>>
<ADD C* GLOTOP 1>
<MOVE C* 1(C)>
<MOVE C* 1(C)>
<XOR B* C>
<SUB TP* [<2 (2)>]>
<JRST MPOPJ>
; "FIXSTR is the inverse of ATMFIX. It takes a FIX and returns a STRING
which is the PNAME of the ATOM which was previously given to ATMFIX."
<TITLE FIXSTR>
<DECLARE ("VALUE" STRING FIX)>
<DPUSH TP* (AB)>
<PUSHJ P* FIXSTR1>
<JRST FINIS>
<INTERNAL-ENTRY FIXSTR1 1>
<SUBM M* (P)>
<MOVE B* <MQUOTE <RGLOC SAVSTR T>>>
<ADD B* GLOTOP 1>
<MOVE A* (B)>
<MOVE B* 1(B)>
<SKIPN C* (TP)>
<JRST FIXFLS>
<MOVE D* <MQUOTE <RGLOC SRUNM T>>>
<ADD D* GLOTOP 1>
<MOVE D* 1(D)>
<XOR C* 1(D)>
<MOVE D* [<(*402010*) *040200*>]>
<AND D* C>
<LSH D* -1>
<TDZ C* D>
<MOVEM C* 1(B)>
FIXOUT <SUB TP* [<2 (2)>]>
<JRST MPOPJ>
FIXFLS <MOVE A* <TYPE-WORD FALSE>>
<SETZ B*>
<JRST FIXOUT>
<TITLE DISPATCH>
<DECLARE ("VALUE" ANY NOFFSET "OPTIONAL" ANY)>
<MOVE A* AB>
LOOP <DPUSH TP* (AB)>
<ADD AB* [<(2) 2>]>
<JUMPL AB* LOOP>
<HLRES A>
<ASH A* -1>
<ADDI A* TABEND>
<PUSHJ P* @ (A) 1>
<JRST FINIS>
<DISP2>
TABEND <DISP1>
<INTERNAL-ENTRY DISP1 1>
<PUSH TP* <TYPE-WORD FALSE>>
<PUSH TP* [0]>
<INTERNAL-ENTRY DISP2 2>
<SUBM M* (P)>
<MOVE A* <MQUOTE <RGLOC DISPATCH-TABLE T>>>
<ADD A* GLOTOP 1>
<MOVE A* 1(A)> ; "get dispatch table"
<GETYP C* -1(TP)>
<SKIPG B* -2(TP)> ; "pick up offset"
<JRST DOOPT>
<ADDI A* -1(B)> ; "point to instruction"
<CAIE C* <TYPE-CODE FALSE>>
<JRST ONEARG>
NOARG <XCT (A)>
<SUB TP* [<(4) 4>]>
<JRST MPOPJ>
ONEARG <XCT (A)>
<SUB TP* [<(2) 2>]>
<JRST MPOPJ>
DOOPT <MOVNS B>
<CAIE C* <TYPE-CODE FALSE>>
<JRST [<ADDI A* (B)> ; "point to next"
<JRST ONEARG>]>
<ADDI A* -1(B)>
<JRST NOARG>
;"READER FOR ZORK: TAKES INPUT BUFFER AND PROMPT, RETURNS NUMBER OF
CHARACTERS IN BUFFER.
AC USAGE:
O: RANDOM, MAINLY FOR SIOTING
A: ON ITS, .IOT <INCHAN>,B; ON 10X, PRIMARY INPUT JFN
B: USUALLY CHARACTER LAST READ, BUT CLOBBERED FOR SIOTS AND SOUTS
C: USUALLY COUNT OF CHARACTERS READ; MAY BE FROBBED TEMPORARILY WHEN SOUTING
D: ILDB POINTER TO NEXT CHAR IN BUFFER
E: <0 --> RUBOUT SHOULD FLUSH A CHAR
=0 --> RUBOUT SHOULD ECHO \<RUBBED OUT>
>0 --> RUBOUT SHOULD ECHO <RUBBED OUT>--USED BY WDFLS
PVP: OUTCHAN
P: # CHARS IN BUFFER
ARGS: INPUT BUFFER PROMPT ALTMODE ONLY TERMINATOR?"
<TITLE READST>
<DECLARE ("VALUE" FIX STRING STRING <OR ATOM FALSE>)>
<DPUSH TP* (AB)>
<DPUSH TP* 2(AB)>
<DPUSH TP* 4(AB)>
<PUSHJ P* IREADST>
<JRST FINIS>
<INTERNAL-ENTRY IREADST 3>
<SUBM M* (P)>
<IFOPSYS
(TENEX
<MOVEI E* 0>
<MOVEI A* *400000*>
<MOVEI B* 0>
<STIW> ; "NO INTERRUPTS IN HERE")
(ITS
<MOVE A* <MQUOTE <RGLOC RUBOUT? T>>>
<ADD A* GLOTOP 1>
<MOVEI E* 0>
<SKIPGE 1(A)>
<MOVNI E* 1>)>
<MOVE A* <MQUOTE <RGLOC OUTCHAN T>>>
<ADD A* GLOTOP 1>
<MOVE A* 1(A)>
<MOVE PVP* 1(A)> ; "OUTPUT CHANNEL/JFN"
<MOVE A* <MQUOTE <RGLOC INCHAN T>>>
<ADD A* GLOTOP 1>
<MOVE A* 1(A)>
<MOVE A* 1(A)> ; "GET CHANNEL #"
<IFOPSYS
(ITS
<LSH A* *27*>
<IOR A* [<*IOT B>]>)> ; "JFN FOR 10X, I/O INS FOR ITS"
<PUSHJ P* PPRMPT>
<HRRZ C* -5(TP)>
<PUSH P* C> ; "# CHARS IN STRING"
<MOVEI C* 0>
<MOVE D* -4(TP)> ; "BUFFER POINTER"
CHRLOP <IFOPSYS
(TENEX
<BIN>)
(ITS
<XCT A>)> ; "GET CHAR IN B"
<SKIPGE INTFLG>
<JRST INTHAK> ; "INTERRUPTS?"
INTBCK <CAIGE B* *40*> ; "NOT SPECIAL?"
<JRST SPCCHR>
<CAIN B* *177*> ; "RUBOUT?"
<JRST RUBOUT>
PUTCHR <PUSHJ P* PUTCHR1>
<JRST CHRLOP>
<MOVEI B* *33*> ; "PUTCHR1 SKIPS IF BUFFER FULL"
SPCCHR <CAIE B* *15*>
<CAIN B* *37*> ; "EOL"
<JRST CRHACK>
<CAIN B* *33*> ; "ALTMODE"
<JRST [<PUSHJ P* PCRLF>
<JRST RDDONE>]>
<JUMPE B* BUFFLS>
<CAIE B* %<ASCII !\>>
<CAIN B* %<ASCII !\>>
<JRST BUFFLS> ; "KILL BUFFER"
<CAIN B* %<ASCII !\>>
<JRST WDFLS>
<CAIN B* *10*>
<JRST RUBOUT> ; "BS=RUBOUT"
<CAIE B* %<ASCII !\>>
<CAIN B* %<ASCII !\>>
<JRST REBUF>
<CAIN B* *14*>
<JRST CREBUF> ; "BUFFER REDISPLAY"
<CAIN B* 7>
<JRST FAKINT> ; "CTRL-G SHOULD BE PROCESSED"
<CAIN B* *12*> ; "IGNORE CTRL-J, SINCE ^M ADDS IT"
<JRST CHRLOP>
<JRST PUTCHR>
PUTCHR1 <IDPB B* D> ; "STUFF IT OUT"
<ADDI C* 1>
<CAML C* -1(P)> ; "BUFFER FULL?"
<AOS (P)> ; "YES, SKIP"
<POPJ P*>
FAKINT <PUSH P* A>
<PUSH P* E>
<PUSH P* PVP>
<EXCH C* -3(P)>
<SUB C* -3(P)>
<HRLI C* <TYPE-CODE STRING>>
<PUSH TP* C>
<PUSH TP* D> ; "MAKE RESTED STRING TO PUSH"
<PUSH TP* <PQUOTE "CHAR">>
<PUSH TP* <MQUOTE "CHAR">>
<PUSH TP* <TYPE-WORD CHARACTER>>
<PUSH TP* B>
<PUSH TP* <TYPE-WORD CHANNEL>>
<MOVE B* <MQUOTE <RGLOC INCHAN T>>>
<ADD B* GLOTOP 1>
<PUSH TP* 1(B)>
<IFOPSYS
(TENEX
<MOVEI A* *400000*>
<MOVE B* [<(*002000*) *200000*>]>
<STIW>)>
<MCALL 3 INTERRUPT>
<IFOPSYS
(TENEX
<MOVEI A* *400000*>
<MOVEI B* 0>
<STIW>)>
<POP TP* D>
<POP TP* C>
<ADD C* -3(P)>
<EXCH C* -3(P)>
<POP P* PVP>
<POP P* E>
<POP P* A>
<PUSHJ P* PPRMPT> ; "REDISPLAY PROMPT TO SHOW THAT BACK FROM INT"
<JRST CHRLOP>
INTHAK <PUSH P* PVP> ; "SAVE OUTCHAN"
<EXCH C* -1(P)>
<SUB C* -1(P)>
<HRLI C* <TYPE-CODE STRING>> ; "MAKE C HAVE A VALID TYPE WORD FOR STRING"
<#OPCODE!-OP!-PACKAGE *5000000000* [<(*001111*) *000311*>]>
<POP P* PVP>
<HRRZS C>
<ADD C* (P)>
<EXCH C* (P)>
<JRST INTBCK> ; "RESTORE EVERYTHING, AND BACK"
CRHACK <IFOPSYS
(TENEX
<CAIE B* *37*> ; "TURN EOL INTO CRLF"
<JRST CRHACK1>
<MOVEI B* *15*>
<PUSHJ P* CHROUT>
<MOVEI B* *12*>
<PUSHJ P* CHROUT>
<MOVEI B* *15*>)>
CRHACK1 <SKIPL (TP)> ; "CAN CR TERMINATE?"
<JRST RDDONE> ; "YES!"
<PUSHJ P* PUTCHR1>
<CAIA>
<JRST RDDONE>
<MOVEI B* *12*> ; "FOLLOW WITH LF"
<JRST PUTCHR>
<IFOPSYS
(ITS
SIOT <SETZ>
<SIXBIT "SIOT">
<MOVE PVP>
<MOVE B>
<SETZ O>
DSIOT <SETZ>
<SIXBIT "SIOT">
<MOVSI *4000*> ; "TURN ON DISPLAY BIT"
<MOVE PVP>
<MOVE B>
<SETZ O>)>
CHROUT <IFOPSYS
(TENEX
<PUSH P* A>
<MOVE A* PVP>
<BOUT>
<POP P* A>)
(ITS
<*CALL [<SETZ>
<SIXBIT "IOT">
<MOVE PVP>
<SETZ B>]>
<*LOSE *1000*>)>
<POPJ P*>
RDDONE <MOVE A* <MQUOTE <RGLOC SCRIPT-CHANNEL T>>>
<ADD A* GLOTOP 1>
<SKIPL 1(A)> ; "SKIPS IF SCRIPTING ON"
<JRST RDDONE1>
<PUSH P* C> ; "SAVE CHARACTER COUNT"
<PUSH TP* (A)>
<PUSH TP* 1(A)>
<PUSH TP* -5(TP)> ; "PROMPT"
<PUSH TP* -5(TP)>
<PUSH TP* (A)>
<PUSH TP* 1(A)>
<MCALL 2 PRINTSTRING>
<PUSH TP* -7(TP)>
<PUSH TP* -7(TP)> ; "BUFFER"
<PUSH TP* -3(TP)>
<PUSH TP* -3(TP)> ; "SCRIPT CHANNEL"
<PUSH TP* <TYPE-WORD FIX>>
<PUSH TP* (P)> ; "# CHARACTERS"
<MCALL 3 PRINTSTRING>
<DPUSH TP* <PQUOTE <STRING <ASCII 13> <ASCII 10>>>>
<PUSH TP* -3(TP)>
<PUSH TP* -3(TP)>
<PUSH TP* <TYPE-WORD FIX>>
<PUSH TP* [2]>
<MCALL 3 PRINTSTRING>
<SUB TP* [<(2) 2>]>
<POP P* C>
RDDONE1 <IFOPSYS
(TENEX
<MOVEI A* *400000*>
<MOVE B* [<(*002004*) *000000*>]>
<STIW>)>
<MOVSI A* <TYPE-CODE FIX>>
<MOVE B* C>
<SUB P* [<(1) 1>]>
<SUB TP* [<(6) 6>]>
<JRST MPOPJ>
CREBUF <IFOPSYS
(TENEX
<JRST REBUF>)
(ITS
<MOVEI O* 2>
<MOVE B* <MQUOTE "C">>
<*CALL DSIOT> ; "THIS HAS DISPLAY BIT ON"
<*LOSE *1000*>
<JRST REBUF1>)>
REBUF <IFOPSYS
(TENEX
<PUSH P* C>
<PUSHJ P* PCRLF> ; "CR"
<PUSHJ P* PPRMPT>
<MOVE B* -4(TP)>
<MOVN C* (P)>
<SKIPE C>
<SOUT> ; "BUFFER"
<POP P* C>)
(ITS
<PUSHJ P* PCRLF>
REBUF1 <PUSHJ P* PPRMPT> ; "COMMON CODE FOR CTRL-D AND CTRL-L"
<MOVE B* -4(TP)>
<MOVE O* C>
<*CALL SIOT>
<*LOSE *1000*>)>
<JRST CHRLOP> ; "GO BACK FOR NEXT CHAR"
PCRLF <IFOPSYS
(TENEX
<MOVE B* <MQUOTE %<STRING <ASCII 13> <ASCII 10>>>>
<PUSH P* C>
<MOVNI C* 2>
<SOUT>
<POP P* C>)
(ITS
<MOVE B* <MQUOTE %<STRING <ASCII 13> <ASCII 10>>>>
<MOVEI O* 2>
<*CALL SIOT>
<*LOSE *1000*>)>
<POPJ P*>
PPRMPT <IFOPSYS
(TENEX
<MOVE B* -2(TP)>
<PUSH P* C>
<HRRZ C* -3(TP)>
<MOVNS C>
<SKIPE C>
<SOUT>
<POP P* C>)
(ITS
<MOVE B* -2(TP)>
<HRRZ O* -3(TP)>
<*CALL SIOT>
<*LOSE *1000*>)>
<POPJ P*>
BUFFLS <MOVEI C* 0> ; "THROW EVERYTHING AWAY"
<MOVE D* -4(TP)>
<PUSHJ P* PCRLF>
<PUSHJ P* PPRMPT>
<JRST CHRLOP>
RUBOUT <PUSHJ P* RRUBOUT>
<JRST CHRLOP>
RRUBOUT <JUMPE C* [<SUB P* [<(1) 1>]>
<JRST REBUF>]> ; "IF RUBBING OUT PAST BEG OF LINE, REDO PROMPT &C"
<IFOPSYS
(ITS
<JUMPL E* RUBFLS> ; "IF E IS 0, HAVE TO PRINT \ FIRST")>
<JUMPG E* RUBOUT1>
<MOVEI B* 92>
<PUSHJ P* CHROUT>
RUBOUT1 <LDB B* D> ; "GET CHAR BEING FLUSHED"
<PUSHJ P* CHROUT>
RUBOUT2 <ADD D* [<(*70000*) 0>]>
<TLNE D* *400000*>
<ADD D* [<(*347777*) *777777*>]>
<SUBI C* 1>
<POPJ P*>
<IFOPSYS
(ITS
RUBFLS <LDB B* D> ; "GET CHAR"
<CAIN B* *12*>
<JRST [<MOVE B* <MQUOTE <STRING "U">>> ; "LINE STARVE"
<JRST RUBFLO>]>
<CAIN B* *15*>
<JRST RUBFCR>
<MOVE B* <MQUOTE <STRING "X">>>
RUBFLO <MOVEI O* 2>
<*CALL DSIOT>
<*LOSE *1000*>
<JRST RUBOUT2>
RUBFCR <PUSH P* C>
<PUSH P* D>
<PUSH P* E>
<MOVE D* -4(TP)> ; "POINTER TO BUFFER"
<HRRZ E* -3(TP)> ; "CURRENT HORIZONTAL POSITION--PROMPT"
<SOJLE C* RUBCRE1> ; "FLUSH CR FROM END"
RUBCRL <ILDB B* D>
<CAIN B* *15*>
<JRST [<MOVEI E* 0>
<JRST RUBCRE>]>
<CAIN B* *12*>
<JRST RUBCRE>
<ADDI E* 1>
RUBCRE <SOJG C* RUBCRL>
RUBCRE1 <ADDI E* 8>
<MOVEI O* 2>
<MOVE B* <MQUOTE "H">>
<*CALL DSIOT>
<*LOSE *1000*>
<*CALL [<SETZ>
<SIXBIT "IOT">
<MOVSI *4000*>
<MOVE PVP>
<SETZ E>]> ; "SET HORIZONTAL POSITION"
<*LOSE *1000*>
<POP P* E>
<POP P* D>
<POP P* C>
<JRST RUBOUT2>)>
WDFLS <JUMPE C* REBUF> ; "NOTHING TO FLUSH"
<JUMPL E* WDFLS1> ; "CAN RUBOUTS HAPPEN?"
<MOVEI B* 92>
<PUSHJ P* CHROUT>
<ADDI E* 1> ; "INHIBIT \ WHEN DOING RUBOUTS"
WDFLS1 <LDB B* D> ; "GET CHAR BEING FLUSHED"
<CAIE B* *40*> ; "SPACE?"
<CAIN B* *15*> ; "CR?"
<JRST WDFLS11>
<CAIE B* *12*>
<CAIN B* *11*>
<JRST WDFLS11>
<CAIE B* *54*> ; "COMMA"
<CAIN B* *56*> ; "PERIOD"
<JRST WDFLS11>
<JRST WDFLS2> ; "REAL STUFF"
WDFLS11 <PUSHJ P* RRUBOUT> ; "RUB IT OUT"
<JUMPE C* WDFLSO> ; "EMPTY BUFFER"
<JRST WDFLS1>
WDFLS2 <LDB B* D>
<CAIE B* *40*>
<CAIN B* *15*>
<JRST WDFLSO>
<CAIE B* *12*>
<CAIN B* *11*>
<JRST WDFLSO>
<CAIE B* *54*>
<CAIN B* *56*>
<JRST WDFLSO>
<PUSHJ P* RRUBOUT>
<JUMPG C* WDFLS2>
WDFLSO <JUMPLE E* CHRLOP>
<MOVEI B* 92>
<PUSHJ P* CHROUT>
<MOVEI E* 0>
<JRST CHRLOP>
<TITLE TTY-INIT>
<DECLARE ("VALUE" ATOM <OR ATOM FALSE>)>
<DPUSH TP* (AB)>
<PUSHJ P* IINIT>
<JRST FINIS>
<INTERNAL-ENTRY IINIT 1>
<SUBM M* (P)>
<MOVE A* <MQUOTE <RGLOC OUTCHAN T>>>
<ADD A* GLOTOP 1>
<MOVE A* 1(A)> ; "OUTCHAN"
<IFOPSYS
(TENEX
<MOVEI B* 70>
<SKIPN 25(A)>
<MOVEM B* 25(A)> ; "MAKE CHANNEL WIDTH NON-ZERO")>
<MOVE A* 1(A)>
<IFOPSYS
(TENEX
<SKIPL (TP)> ; "SAVE CURRENT STATE?"
<JRST STMODE>
<MOVE E* <MQUOTE <RGLOC RUVEC T>>>
<ADD E* GLOTOP 1>
<MOVE E* 1(E)>
STMODE <RFMOD>
<SKIPGE (TP)>
<MOVEM B* (E)> ; "MODE WORD"
<TRO B* *140100*>
<TRZ B* *030200*>
<SFMOD>
<SKIPL (TP)>
<JRST SCMODE>
<RFCOC> ; "CONTROL CHARACTER FORMATTING"
<MOVEM B* 1(E)>
<MOVEM C* 2(E)>
SCMODE <MOVE B* <MQUOTE #2 {0 1 1 1 0 1 1 2 0 3 3 1 0 3 1 1 1 1}>>
<MOVE B* 1(B)>
<MOVE C* <MQUOTE #2 {1 1 1 1 1 0 0 1 1 1 1 1 1 0}>>
<MOVE C* 1(C)>
<SFCOC> ; "THIS DOES ECHOING FOR CTRL-CHARS"
<MOVEI A* *400000*>
<SKIPL (TP)>
<JRST SIMODE>
<RTIW>
<MOVEM B* 3(E)>
SIMODE <MOVE B* [<(*2004*) 0>]>
<STIW>
<SKIPL (TP)>
<JRST INTSET>
<MCALL 0 ACTIVATE-CHARS>
<MOVE C* <MQUOTE <RGLOC ACT-STRING T>>>
<ADD C* GLOTOP 1>
<MOVEM A* (C)>
<MOVEM B* 1(C)>
INTSET <DPUSH TP* <PQUOTE "">>
<MCALL 1 ACTIVATE-CHARS>)
(ITS
<*CALL [<SETZ>
<SIXBIT "CNSGET">
<MOVE A>
<MOVEM B>
<MOVEM B>
<MOVEM B>
<MOVEM B>
<SETZM B>]>
<*LOSE *1000*>
<TLNN B* *40000*> ; "TEST %TOERS"
<JRST INIT1>
<MOVE B* <MQUOTE <RGLOC RUBOUT? T>>>
<ADD B* GLOTOP 1>
<MOVE C* <MQUOTE T>>
<MOVEM C* 1(B)>
<MOVSI C* <TYPE-CODE ATOM>>
<MOVEM C* (B)> ; "SETG RUBOUT? TO T"
INIT1 <SKIPL (TP)>
<JRST DTTYST>
<MOVE B* <MQUOTE <RGLOC RUVEC T>>>
<ADD B* GLOTOP 1>
<MOVE B* 1(B)>
<*CALL [<SETZ>
<SIXBIT "TTYGET">
<MOVE A>
<MOVEM (B)>
<SETZM 1(B)>]>
<*LOSE *1000*>
DTTYST <*CALL [<SETZ>
<SIXBIT "TTYSET">
<MOVE A>
<MOVE [<(*022020*) *202020*>]>
<SETZ [<(*032022*) *220222*>]>]>
<*LOSE *1000*>)>
TTYIDN <SUB TP* [<(2) 2>]>
<MOVSI A* <TYPE-CODE ATOM>>
<MOVE B* <MQUOTE T>>
<JRST MPOPJ>
<TITLE TTY-UNINIT>
<DECLARE ("VALUE" ATOM)>
<PUSHJ P* IUNINIT>
<JRST FINIS>
<INTERNAL-ENTRY IUNINIT 0>
<SUBM M* (P)>
<MOVE A* <MQUOTE <RGLOC OUTCHAN T>>>
<ADD A* GLOTOP 1>
<MOVE A* 1(A)>
<MOVE A* 1(A)>
<IFOPSYS
(TENEX
<MOVE D* <MQUOTE <RGLOC RUVEC T>>>
<ADD D* GLOTOP 1>
<MOVE D* 1(D)>
<MOVE B* (D)>
<SFMOD> ; "RESTORE MODES"
<MOVE B* 1(D)>
<MOVE C* 2(D)>
<SFCOC>
<MOVEI A* *400000*>
<MOVE B* 3(D)>
<STIW>
<MOVE D* <MQUOTE <RGLOC ACT-STRING T>>>
<ADD D* GLOTOP 1>
<PUSH TP* (D)>
<PUSH TP* 1(D)>
<MCALL 1 ACTIVATE-CHARS> ; "RESTORE INTERRUPTS")
(ITS
<MOVE B* <MQUOTE <RGLOC RUVEC T>>>
<ADD B* GLOTOP 1>
<MOVE B* 1(B)>
<*CALL [<SETZ>
<SIXBIT "TTYSET">
<MOVE A>
<(B)>
<SETZ 1(B)>]>
<*LOSE *1000*>)>
<MOVE B* <MQUOTE T>>
<MOVSI A* <TYPE-CODE ATOM>>
<JRST MPOPJ>
<TITLE EXCRUCIATINGLY-UNTASTEFUL-CODE>
<DECLARE ("VALUE" ATOM)>
<PUSHJ P* IEUC>
<JRST FINIS>
<INTERNAL-ENTRY IEUC 0>
<SUBM M* (P)>
<MOVE A* <MQUOTE <RGLOC PRSVEC T>>>
<ADD A* GLOTOP 1>
<HRRZ A* 1 (A)>
<ADDI A* 1>
<MOVEM A* *60*>
<ADDI A* 2>
<MOVEM A* *61*>
<ADDI A* 2>
<MOVEM A* *62*>
<MOVE A* <TYPE-WORD ATOM>>
<MOVE B* <MQUOTE T>>
<JRST MPOPJ>
; "POBLIST HACKS"
<TITLE STRINGP>
<DECLARE ("VALUE" STRING <PRIMTYPE WORD>)>
<DPUSH TP* (AB)>
<PUSHJ P* ISTRP>
<JRST FINIS>
<INTERNAL-ENTRY ISTRP 1>
<SUBM M* (P)>
<MOVE A* <TYPE-WORD STRING>>
<MOVE B* <MQUOTE <RGLOC PPSTRING T>>>
<ADD B* GLOTOP 1>
<MOVE B* 1(B)>
<MOVE C* (TP)>
<MOVE D* [<(*440700*) C>]>
<SETZ E*>
STRPLP <ILDB D>
<JUMPE STRPGO>
<CAIN E* 5>
<JRST STRPGO>
<AOJA E* STRPLP>
STRPGO <HRR A* E>
<MOVEM C* 1(B)>
<SUB TP* [<(2) 2>]>
<JRST MPOPJ>
<TITLE PSTRING>
<DECLARE ("VALUE" PSTRING STRING)>
<DPUSH TP* (AB)>
<PUSHJ P* IPSTR>
<JRST FINIS>
<INTERNAL-ENTRY IPSTR 1>
<SUBM M* (P)>
<MOVE A* (TP)>
<HLRZ C* A>
<CAIN C* *10700*>
<JRST PSTR1>
<MOVE B* (A)>
<HRRZ C* -1(TP)>
<SUBI C* 5>
<MOVNS C>
<IMULI C* 7>
<LSH B* (C)>
<CAIA>
PSTR1 <MOVE B* 1(A)>
<MOVE A* <TYPE-WORD PSTRING>>
<SUB TP* [<(2) 2>]>
<JRST MPOPJ>