Trailing-Edge
-
PDP-10 Archives
-
BB-W661B-BM_1984
-
tools/glxtxt.mac
There are 27 other files named glxtxt.mac in the archive. Click here to see a list.
TITLE TXTLIB -- Formatted Text Handler for GLXLIB
SUBTTL Irwin L. Goverman/ILG/CER/MLB/DC/PJT/WLH 1-Jan-82
;
;
;
; COPYRIGHT (c) 1975,1976,1977,1978,1979,1980,1981,1982
; DIGITAL EQUIPMENT CORPORATION, MAYNARD, MA.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED
; AND COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE
; AND WITH THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS
; SOFTWARE OR ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR
; OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON. NO TITLE TO
; AND OWNERSHIP OF THE SOFTWARE IS HEREBY TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE
; WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT
; BY DIGITAL EQUIPMENT CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
; OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY
; DIGITAL.
SEARCH GLXMAC ;GET AT GALAXY LIBRARY SYMBOLS
;*******************************************
FTJSYS==1
FTUUOS==0
DEFINE TOPS10 <IFN FTUUOS,> ;SETUP CONDITIONAL MACROS
DEFINE TOPS20 <IFN FTJSYS,>
^LSUBTTL Accumulator Definitions
;Pass FACT file accounting requirement along
FTFACT==FTFACT ;From GALCNF
;THE FOLLOWING ACCUMULATOR DEFINITIONS ARE STANDARD THROUGHOUT THE
; SUB-SYSTEMS GROUP AND MAY NOT BE CHANGED. THE ACCUMULATORS DEFINED ARE:
TF==0 ;TRUE/FALSE REGISTER, NEVER REFERENCED DIRECTLY
; USED BY $RETx AND JUMPT,JUMPF, SKIPT,SKIPF
.SAC==0 ;SCRATCH AC USED BY SOME NONE SKIPPABLE
;MACROS AND SOME MACRO CALLS TO GLXCOM
;.SAC MAY NOT BE CHANGED ON EXIT FROM A
;CO-ROUTINE SO THAT ANY ROUTINE MAY PASS
;A TRUE FALSE VALUE BACK TO IT'S CALLER.
S1==1 ;S1 & S2 ARE ARGUMENTS TO ROUTINES
S2==2 ;AND ARE OTHERWISE SCRATCH
T1==3 ;T1 - T4 ARE TEMPORARY REGS
T2==4
T3==5
T4==6
P1==7 ;P1 - P4 ARE PRESERVED REGS
P2==10
P3==11
P4==12
.A13==13 ;.A13 THRU .A16 NOT USED BY LIBRARY
.A14==14
.A15==15
.A16==16
.FP==16 ;FRAME POINTER USED BY TRVAR AND ASUBR
;MAY NOT BE CHANGED WITHIN THE SCOPE OF
;A ROUTINE USING TRVAR OR ASUBR
;HOWEVER -- IT IS PRESERVED OUTSIDE THE
;SCOPE OF THESE ROUTINES
P==17 ;PUSHDOWN POINTER
^LSUBTTL PROLOG - Uniform assembly set up
; The PROLOG macro is used to uniformly search all the right UNV files
; and setup the listing format and STOP CODE controls.
; Call: PROLOG (MODULE,OTSCOD)
;
; Where: 'MODULE' represents the module name
; 'OTSCOD' (optional) represents a GLXLIB module mnemonic
;
;%%.MOD==SIXBIT/NONAME/ ;;DEFAULT MODULE NAME INCASE NULL
;%%.OTS==0 ;;DEFAULT OTSCOD INCASE NULL
DEFINE PROLOG (MODULE,OTSCOD),<
SALL ;;FOR PRETTY LISTINGS
; LSTOF. XCREF ;;TURN OFF LISTING
; %%.GLX==%%.GLX ;;RECORD VERSION NUMBER
; GLXVRS==GLXVRS ;;...
; IFNB <MODULE>,<%%.MOD==SIXBIT/MODULE/> ;;MAKE NAME AVAILABLE
; IFNB <OTSCOD>,<%%.OTS==SIXBIT/OTSCOD/> ;;MAKE OTSCODE AVAILABLE
; GLOB I%INIT ;;ENTRY POINT CALLED BY THE USER
TOPS10 < ;;TOPS-10 ONLY
SEARCH UUOSYM ;;OPERATING SYSTEM SYMBOLS
%%UUOS==%%UUOS ;;RECORD VERSION NUMBER
> ;;END OF TOPS-10 CONDITIONAL
TOPS20 < ;;TOPS-20 ONLY
SEARCH MONSYM ;;OPERATING SYSTEM SYMBOLS
; %%MONS==%%MONS ;;RECORD VERSION NUMBER
> ;;END OF TOPS-20 CONDITIONAL
; IFB <OTSCOD>,< ;;IF NOT A GLXLIB MODULE
; .TEXT |,REL:GLXLIB/SEARCH/REQUIRE:I%INIT|
DEFINE $DATA (NAM,SIZ<1>),< ;;MACRO TO GENERATE DATA STORAGE
NAM: BLOCK SIZ
> ;;END OF $DATA MACRO
DEFINE CDO (X),<GLOB X> ;;MAKE ENTRY POINTS GLOBAL
; LIBVEC ;;GLOBALIZE ALL ENTRY POINTS
; > ;;END OF IFB <OTSCOD> CONDITIONAL
;
; IFNB <OTSCOD>,<CHKEDT (OTSCOD)> ;;CHECK GLXLIB MODULE EDIT NUMBERS
;
; IFNB <OTSCOD>,<IFDIF <OTSCOD><INI>,< ;;IF NOT GLXINI
; IFN GLXPURE,<.PSECT .HIGH.> ;;IF OTS
; IFE GLXPURE,< ;;IF LINKABLE LIBRARY
; TWOSEG 400000 ;;MAKE US SHARABLE
; RELOC 0 ;;DATA STORAGE STARTS HERE
; RELOC 400000 ;;START LOADING THE HIGH SEGMENT
; > ;;END OF IFE GLXPURE CONDITIONAL
;
; DEFINE $DATA(NAM,SIZ<1>),< ;;MACRO TO GENERATE DATA STORAGE
; IFN GLXPURE,<.PSECT DATA> ;;RELOCATE TO DATA PSECT
; IFE GLXPURE,<RELOC> ;;RELOCATE TO LOW SEGMENT
; IFNDEF OTSCOD'%D,<OTSCOD'%D::! OTSCOD'%DL==:0>
; NAM: BLOCK SIZ
; OTSCOD'%DL==:OTSCOD'%DL+SIZ ;;COUNT WORDS
; IFN GLXPURE,<.ENDPS DATA> ;;TERMINATE PSECT REFERENCE
; IFE GLXPURE,<RELOC> ;;BACK TO THE HIGH SEG
; > ;;END OF $DATA MACRO
;
; IFDIF <OTSCOD><OTS>,< ;;FOR ALL BUT GLXOTS...
; DEFINE CDO (X),<GLOB X> ;;MAKE ENTRY POINTS GLOBAL
; LIBVEC ;;GLOBALIZE ALL ENTRY POINTS
; > ;;END OF IFDIF <OTSCOD><OTS> CONDITIONAL
;
; >> ;;END OF IFDIF <OTSCOD><INI> CONDITIONAL
;
; IFNB <OTSCOD>,<IFIDN <OTSCOD><INI>,< ;;IF GLXINI
; DEFINE $DATA (NAM,SIZ<1>),< ;;MACRO TO GENERATE DATA STORAGE
; NAM: BLOCK SIZ
; > ;;END OF $DATA MACRO
; >> ;;END OF IFIDN <OTSCOD><INI> CONDITIONAL
;
; LSTON. ;;TURN LISTINGS ON
;
; GLOB <.POPJ, .RETT, .RETF> ;;SOME POPULAR RETURNS
OPDEF $RET [POPJ P,] ;;RETURN
OPDEF $RETT [PJRST .RETT] ;;RETURN TRUE
OPDEF $RETF [PJRST .RETF] ;;RETURN FALSE
OPDEF $RETIT [JUMPT .POPJ] ;;RETURN IF TRUE
OPDEF $RETIF [JUMPF .POPJ] ;;RETURN IF FALSE
; .NODDT $RET,$RETT,$RETF,$RETIT,$RETIF
> ;;END OF PROLOG MACRO
;******************************************
PROLOG(TXTLIB,TXT) ;PRODUCE PROLOG CODE
TXTEDT==51 ;MODULE EDIT LEVEL
ENTRY TXTINI ;INITIALIZATION
ENTRY T%TEXT ;$TEXT ENTRY POINT
ENTRY T%TTY ;DEFAULT TERMINAL OUTPUT
; GLOB <IIB> ;IIB is external
; GLOB <CNTDT> ;CNTDT is external
;TOPS10< GLOB <CNVNOD>> ;CNVNOD is external
; This file contains the support code for the $TEXT macro, which
; is responsible for formatting all static string and variable type
; output. For a more detailed explanation of the $TEXT macro, please
; refer to the GLXMAC and GLXLIB modules.
; This module differs from most members of the GLXLIB family in two respects.
; First, it is called via a pseudo instruction, $TEXT, rather than
; via the usual S1/S2 accumulator calls. Secondly, all ACs are preserved
; across calls, which are skippable.
; The user of the $TEXT instruction must provide one or several output routines.
; This routine must conform to the standard GLXLIB conventions.
^LSUBTTL Table of Contents
; TABLE OF CONTENTS FOR TXTLIB
;
;
; SECTION PAGE
; 1. Table of Contents......................................... 2
; 2. Revision History.......................................... 3
; 3. Local Macros.............................................. 4
; 4. Global storage............................................ 5
; 5. TXTINI - Initialize the TEXT module....................... 6
; 6. T%TEXT - Routine to format text output.................... 7
; 7. T%TTY - Buffered terminal output routine................. 9
; 8. PROBLK - Process an entire T%TEXT argument block.......... 10
; 9. PROARG - Routine to process each T%TEXT argument.......... 11
; 10. PROTXT -- ROUTINE TO PROCESS THE ACTUAL FUNCTION.......... 12
; 11. PTAB - Dispatch table for argument processors........... 13
; 12. PROx - Processors for each type of formatting........... 14
; 13. PROT - Process a string of ASCIZ text................... 15
; 14. PRO3 - Process a an ASCIZ string created by $TEXT....... 15
; 15. PROQ - Process a byte pointer to an ASCIZ string........ 16
; 16. PROB - Process a GLXLIB object block.................... 17
; 17. PRO1 - Process an object type........................... 18
; 18. PRON - Process a node specification..................... 18
; 19. PROO - Process unsigned octal numbers................... 19
; 20. PROD - Process a signed decimal number.................. 19
; 21. PROF - Process a system dependent file specification... 20
; 22. PRO7 - Process a single 7 bit ASCII character........... 21
; 23. PRO6 - Process a single 6 bit ASCII character........... 21
; 24. PRO5 - Process ASCIZ single word........................ 21
; 25. PROW - Process a SIXBIT word............................ 21
; 26. PROP - Process a directory ID of either PPN or directory NUMBER 22
; 27. PROU - Process a user ID or either PPN or User number... 22
; 28. PROR - Process routine for Job Info Block............... 23
; 29. PROE - Process a GLXLIB error number.................... 25
; 30. PROI - Process an indirect text request................. 26
; 31. PROV - Process a program version number................. 27
; 32. PROM - Process a request for a CONTROL-M (Carriage Ret.) 28
; 33. PROJ - Process a request for a CONTROL-J (Line Feed).... 28
; 34. PROL - Process a request for a CONTROL-L (Form Feed).... 28
; 35. PROK - Process a request for a CONTROL-K (Vertical Tab). 28
; 36. PRO2 - Process a request for up-arrow................... 28
; 37. PROA - Process a request to supress free <CR-LF>........ 28
; 38. PRO0 - Process a request to put null (0) at end of line. 28
; 39. FETCH - Routine to get a word from caller's address space 29
; 40. SPACES - Routine to provide any padding requested......... 30
; 41. Local output routines..................................... 31
; 42. PUTU -- Output user name or PPN........................... 35
; 43. SAVLVL-RSTLVL - Save and restore TEXT levels.............. 36
^LSUBTTL Revision History
COMMENT \
20/OCT/83 G.FAUSER 20/OCT/83 ISOLATED GLXTXT AND ITS MACROS OUT OF
GLXLIB AND NAMED IT TXTLIB AND TXTUNV
\ ;End of Revision History
^LSUBTTL Local Macros
; These macros are pseudo instructions, and as such they
; preserve all registers and are skippable.
; Define a local macro for printing single characters
DEFINE $PUT7(CHAR)<
PUSHJ P,PUT7X ;;CHARACTER OUTPUT ROUTINE
XLIST ;;NO NEED TO LIST
JUMP "CHAR" ;;NO-OP + CHARACTER
LIST
> ;END OF $PUT7 DEFINITION
; DEFINE A LOCAL MACRO FOR PRINTING STRINGS
DEFINE $PUTT(STRING)<
PUSHJ P,PUTTX
XLIST
JUMP [ASCIZ \STRING\]
LIST
> ;END OF $PUTT DEFINITION
SYSPRM TTXBFS,2,^D10 ;TEMPORARY TEXT BUFFER SIZE
ND LINSIZ,^D20 ;SIZE OF DEFAULT OUTPUT LINE
ND EBFSZ,^D20 ;SIZE OF BUFFER AREA
^LSUBTTL Global storage
;Global storage
$DATA TXTBEG,0 ;BEGINNING OF ZEROABLE $DATA SPACE
$GDATA TXTLVL ;LEVEL WE ARE AT
;Local storage
$DATA DEFERR ;DEFAULT ERROR EXIT ADDRESS FROM IB.
$DATA DEFOUT ;DEFAULT OUTPUT ROUTINE FROM IB
$DATA FSAVE,0 ;FIRST LOCATION TO SAVE AT EACH LEVEL
$DATA LINBUF,LINSIZ ;LINE BUFFER
LINMAX==<<LINSIZ>*^D5>-1 ;MAXIMUM CHARACTER COUNT
$DATA ARGADR ;ADDRESS OF CALLER'S ARG LIST
$DATA USRACS,20 ;USER-CONTEXT ACS
$DATA USROUT ;ADDRESS OF CALLING OUTPUT RTN.
$DATA USRARG ;ADDRESS OF USER ARGUMENTS
$DATA NXTARG ;POINTS TO NEXT ARGUMENT
$DATA MAXARG ;NUMBER OF ARGUMENTS SPECIFIED
$DATA USRRET ;FIRST WORD AFTER $TEXT ARG BLOCK
TOPS20< $DATA ERRBUF> ;ERROR BUFFER AREA
$DATA CAPNTR ;BYTE POINTER FOR PR03 PROCESSING
$DATA CALOC ;CURRENT ARGUMENT EFFECTIVE ADDRESS
$DATA CAFLG ;CURRENT ARGUMENTS FLAGS
$DATA CAPTR ;POINTER WORD FOR CURRENT ARG (IF ANY)
$DATA CACCTR ;NUMBER OF CHARACTERS IN CURRENT ARGUMEN
T
$DATA CACMAX ;MAXIMUM CHARACTERS FIELD MAY BE
$DATA ENDFLG ;-1=NOTHING,0=CR-LF,+1=NULL AT END
$DATA NOOUTP ;-1 WHEN ACTUAL OUTPUT IS SUPRESSED
$DATA ERREXT ;A USER EXIT ROUTINE HAS RETURNED FALSE.
$DATA TTXBUF,TTXBFS ;PLACE TO BUILD TEMPORARY STRINGS
$DATA LINCTR ;COUNTER FOR CURRENT LINE
$DATA LINPTR ;POINTER TO CURRENT LINE
$DATA TMFCTR ;TIME ADJUSTMENT FACTOR
$DATA DSTCHG ;TIME FACTOR IS BASED ON
$DATA LSAVE,0 ;LAST LOCATION TO SAVE
IF1,<SSAREA==<LSAVE-FSAVE-1>> ;SIZE OF THE SAVE AREA
$DATA SAREA,SSAREA ;PLACE TO SAVE EACH LEVEL
$DATA .LGERR,1 ;SAVE ERROR CODE ON $RETE
$DATA TXTEND,0 ;END OF ZEROABLE $DATA SPACE
$DATA GENBUF,^D 200 ;GEN-BUFF USED TO REPLACE M%GMEM
^LSUBTTL TXTINI - Initialize the TEXT module
;This routine puts the TEXT module into a known state and
; stores the user specified default output routine
;CALL IS: IIB setup by I%INI1 in GLXINI
;
;TRUE RETURN: Always
TXTINI: MOVE S1,[TXTBEG,,TXTBEG+1] ;BLT PTR TO BEGINNING OF $DATA SPACE
SETZM TXTBEG ;KILL THE FIRST WORD
BLT S1,TXTEND-1 ;NOW KILL THE REST
; SKIPN S1,IIB+IB.OUT ;PICKUP DEFAULT OUTPUT ROUTINE
MOVEI S1,T%TTY ;NONE SPECIFIED..USE OUR DEFAULT
MOVEM S1,DEFOUT ;SAVE IT FOR LATER
; MOVE S1,IIB+IB.ERR ;GET USER ERROR EXIT ROUTINE
; MOVEM S1,DEFERR ;SAVE IT FOR LATER.
SETOM TXTLVL ;INITIALIZE THE COUNT OF LEVELS
TOPS10< $RETT> ;RETURN FOR TOPS10
TOPS20<
;This routine is called to recompute the local time
; conversion factor. The factor takes into account
; the local time zone as well as the daylight savings
; time adjustment. Note that the routine calculates
; the next local time occurrence of 0200 hours and
; saves it for later comparison.
CLCFCT: MOVEI S1,.SFTMZ ;TIME ZONE FUNCTION
TMON ;GET THE ZONE
SETOM TMFCTR ;REVERSE NUMBER LINE VALUE
IMULM S2,TMFCTR ;CALCULATE BASE HOURS
GTAD ;GET DATE/TIME
MOVE S2,S1 ;RELOCATE
HRRI S2,25253*2 ;LOAD RIGHT WITH 0200
MOVEM S2,DSTCHG ;SAVE IT
HRRZ S2,S1
CAIG S2,25253*2 ;AFTER 0200?
JRST TINI.1 ;NO,WE'RE DONE
HRLZI S2,1 ;YUP, MAKE IT TOMORROW
ADDM S2,DSTCHG ;..
TINI.1: MOVE S2,S1 ;RELOCATE TIME
SETZ T2,0 ;..
ODCNV
SETZ S2,0 ;SET FOR NO DST ADJUSTMENT
TXNE T2,IC%ADS ;FACTOR FOR DST?
AOS TMFCTR ;YES, DO SO
HRLZI S1,1 ;SETUP FULL DAY FACTOR [1,,0]
IMUL S1,TMFCTR ;COMPUTE FACTOR HOURS
IDIVI S1,^D24 ;..AND THE BASE OFFSET
MOVEM S1,TMFCTR ;STORE IT AWAY
$RETT
>;END OF TOPS20 CONDITIONAL ASSEMBLY
^LSUBTTL T%TEXT - Routine to format text output
;Calls to T%TEXT come only through invokation of the $TEXT
; macro, described in GLXMAC.
; Call is: Pushdown list top entry points to start of argument block-1,
; which is a JRST around an argument block, formatted as follows:
;
; PUSHJ P,T%TEXT ;CALL
; JRST %L1 ;JUMP AROUND CALL
; OUTPUT ROUTINE OR B.P. ;ADDR OF CHAR OUTPUT ROUTINE OR -1,,ADDR
(BP)
; FLAGS+<QUAL.#>+ADDRESS ;DESCRIPTION AND ADDRESS OF ARG
; BYTE POINTER FOR ARG ;ONLY IF A BYTE POINTER IS NEEDED
; SPACING INFORMATION ;ONLY IF SPACING INFORMATION IS NEEDED
; .... ;MORE ARGUMENT SINGLETS,PAIRS OR TRIPLET
S
; %L1:
;Where: Flags tell us whether qualifier takes any argument
; and whether position and spacing words are present.
; The spacing information is: "CHAR"B6+<SIDE>B17+<Number of positions>B35
;
; Return: Return is to the location after the PUSHJ to T%TEXT, which
; is the JRST around the arg block. This makes $TEXT skippable.
T%TEXT: AOSE TXTLVL ;INCREMENT LEVEL COUNT
PUSHJ P,SAVLVL ;SAVE LEVEL IF NOT FIRST
MOVEM 0,USRACS ;STORE FIRST AC
MOVE 0,[XWD 1,USRACS+1] ;TRANSFER USER ACS TO THE
BLT 0,USRACS+17 ;SAVE AREA
SOS USRACS+P ;ADJUST SHADOW VERSION OF "P"
SETZM ENDFLG ;ASSUME WANTS CR-LF AT END
SETZM ERREXT ;NO USER EXIT ERROR.
SETZM NOOUTP ;NOT SUPRESSING OUTPUT
SETOM LINCTR ;FLAG THAT BUFFER IS NOT IN USE
MOVE S1,[POINT 7,LINBUF] ;GET POINTER TO TTY OUTPUT BUFFER
MOVEM S1,LINPTR ;AND SAVE IT
HRRZ S1,0(P) ;Get return address
HLRZ TF,0(S1) ;Get return instruction
CAIN TF,(JUMP) ;New style call?
JRST TEXT.2 ;Yes..Process it
MOVE TF,1(S1) ;GET THE USER ROUTINE ADDRESS INSTR.
MOVE S1,USRACS+S1 ;RESTORE S1 TO ORIGIONAL VALUE.
XCT 0 ;GET THE USER REUTINE/BYTE PTR ADDR.
HRRZ S1,0(P) ;RE-GET THE ADDRESS CALLED FROM.
HRRZ S2,0(S1) ;GET FIRST WORD PAST ARGUMENT BLOCK
MOVEM S2,USRRET ;REMEMBER WHERE IT IS
SKIPN S2,0 ;FETCH USER OUTPUT ROUTINE ADDRESS
MOVE S2,DEFOUT ;IF NONE SPECIFIED, USE DEFAULT
SKIPN S2 ;HAVE WE GOT ONE SOME WAY?
MOVEI S2,T%TTY ;NO, MUST NOT BE INITED YET
JUMPG S2,TEXT.1 ;HAVE WE GOT A DEFAULT BYTE POINTER?
HRLI S2,(POINT 7,0) ;MAKE IT A BYTE POINTER.
MOVEM S2,LINPTR ;AND STORE POINTER
MOVEI S2,TDPB ;GET ADDR OF ROUTINE TO USE THE POINTER
TEXT.1: MOVEM S2,USROUT ;STORE IT AWAY FOR LATER
ADDI S1,2 ;COMPUTE THE START OF PARAMETER BLOCK
MOVEM S1,ARGADR ;REMEMBER IT
TEXT.3: PUSHJ P,PROBLK ;PROCESS THE ARGUMENT BLOCK
PUSHJ P,PEND ;GIVE PROPER ENDING TO STRING
SKIPL LINCTR ;IF WE USED DEFAULT ROUTINE,
PUSHJ P,TDMP ;DUMP BUFFER NOW
MOVE 0,[XWD USRACS+1,1] ;RESTORE USER ACS
BLT 0,16 ;EXCEPT FOR PDL POINTER
MOVE 0,USRACS ;RESTORE AC USED FOR BLT
SOSL TXTLVL ;DECREMENT COUNT, IF NOT
PUSHJ P,RSTLVL ;AT PRIMARY, RESTORE THE LEVEL
SKIPE ERREXT ;DO WE TAKE THE ERROR EXIT ???
SKIPN DEFERR ;IS THE ROUTINE ADDRESS THERE ???
SKIPA ;NO,,JUST RETURN NORMALLY.
JRST @DEFERR ;YES,,DO IT.
POPJ P, ;RETURN WITHOUT AFFECTING TF
^L
;This calling convention is extensible and superceeds the previous
;calling sequence.
;Thus $TEXT(RTN,<STRING>,<ARGS>) would produce the following call:
; $CALL T%TEXT
; JUMP [XWD 2,0 ;Length of header
; EXP <RTN> ;Text output routine or pointer
; ITEXT(<STRING>,<ARGS>)];Start of ITEXT arguments
TEXT.2: HRRZ S1,0(S1) ;Get address of argument list
HLRZ TF,(S1) ;Get the header count
ADDI TF,(S1) ;Get ITEXT address
MOVEM TF,ARGADR ; and save it
SETZM USRRET ;Clear return address
MOVE TF,1(S1) ;Get calling TOR or pointer
TLC TF,777777 ;MAKE -1 INTO A WORD POINTER
TLCN TF,777777
HRLI TF,(POINT 7)
MOVE S1,USRACS+S1 ;RESTORE USERS S1
EXCH P,USRACS+P ; AND STACK POINTER
HRRI TF,@TF ;REMOVE INDEXING AND INDIRECTION
EXCH P,USRACS+P ;RESTORE OUR POINTER
TLZ TF,(@(17)) ;CLEAR THE BITS
TLNE TF,777777 ;IS THIS A POINTER?
JRST [MOVEM TF,LINPTR ;YES..SAVE IT
MOVEI TF,TDPB ;GET POINTER ROUTINE ADDRESS
JRST .+1] ;AND SAVE THAT
SKIPN TF ;Do we have a routine?
MOVE TF,DEFOUT ;No..use the default
MOVEM TF,USROUT ;SAVE ROUTINE ADDRESS
JRST TEXT.3 ;Back to process arguments
^LSUBTTL T%TTY - Buffered terminal output routine
;If a $TEXT instruction has a blank first argument, then the
; default output routine is used. This routine is identified
; in the Initialization Block.
;T%TTY is a default output routine which buffers output to
; the terminal controlling this job.
; Call is: S1/ contains 1 character, 7 bit, right justified
;
; Return: TRUE always
T%TTY: SOSGE LINCTR ;ROOM IN THE BUFFER?
JRST [ PUSHJ P,TDMP ;NO, DUMP THE BUFFER
JRST T%TTY ] ;AND RETRY
JUMPE S1,.RETT ;IF NULL CHARACTER, RETURN NOW
IDPB S1,LINPTR ;DEPOSIT THE CHARACTER
$RETT ;ALWAYS RETURN TRUE
TDMP: PUSH P,S1 ;SAVE CHARACTER
MOVEI S1,0 ;GET NULL CHARACTER
IDPB S1,LINPTR ;STORE TERMINATING NULL INTO BUFFER
MOVE S1,[POINT 7,LINBUF] ;GET BUFFER POINTER
MOVEM S1,LINPTR ;STORE IT
SKIPE LINBUF ;IF NULL BUFFER, SKIP IT
PUSHJ P,K%SOUT ;ELSE PRINT IT
SETZM LINBUF ;CLEAR FIRST WORD OF BUFFER
MOVEI S1,LINMAX ;RESET THE BUFFER COUNTER
MOVEM S1,LINCTR ;TO ITS MAXIMUM
POP P,S1 ;RESTORE THE CHARACTER
$RETT ;AND RETURN
TDPB: IDPB S1,LINPTR ;STORE WHERE CALLER SPECIFIED
$RETT ;AND RETURN
^LSUBTTL PROBLK - Process an entire T%TEXT argument block
;PROBLK is used to process a list of T%TEXT arguments. The
; lower level routine, PROARG, is called to process each
; argument and errors are checked for.
; Call: ARGADR/ Address of start of argument block
;
; Return: Always TRUE
PROBLK: SETZM USRARG ;ASSUME NO ARGUMENTS BLOCK
SETZM MAXARG ;ZERO THE COUNT
SETZM NXTARG ;CLEAR POINTER TO NEXT ARGUMENT
MOVE S1,ARGADR ;GET ADDRESS OF ITEXT BLOCK
LOAD S2,0(S1),TXT.FN ;GET THE FUNCTION
CAIE S2,0 ;IS ARGUMENT BLOCK PRESENT?
JRST PROBL1 ;NO..PROCESS NORMALLY
MOVEM S1,USRARG ;SAVE ADDRESS OF ARGUMENTS
HLRZ S2,0(S1) ;YES..GET HEADER LENGTH
ADD S2,S1 ;COMPUTE START OF ITEXT
MOVEM S2,ARGADR ;AND SAVE THAT
SUBI S2,1 ;COMPUTE MAXIMUM ARG ADDRESS
MOVEM S2,MAXARG ;SAVE MAXIMUM ARGUMENT ADDRESS
ADDI S1,1 ;COMPUTE NEXT ARGUMENT ADDRESS
MOVEM S1,NXTARG
PROBL1: MOVE S1,ARGADR ;GET ADDRESS OF CURRENT ARGUMENT WORD
CAME S1,USRRET ;ARE WE PAST THE END?
SKIPN 0(S1) ; OR INTO ZERO WORD (ITEXT BLOCK END)?
$RETT ;YES, SO RETURN NOW TO CALLER
PUSHJ P,PROARG ;PROCESS THE ARGUMENT POINTED TO
JUMPT PROBL1 ;IF OK, DON'T STOP NOW
$STOP(BTA,<Bad $TEXT argument given at address ^O/ARGADR/>)
^LSUBTTL PROARG - Routine to process each T%TEXT argument
;PROARG is responsible for setting up argument specific data
; areas for the processing routines and adjusting ARGADR.
; CALL IS: NO ARGUMENTS
;
; RETURN: TRUE IF NO BAD ARGUMENTS DETECTED
; FALSE IF SOMETHING IS WRONG
;
PROARG: SETZM CACCTR ;CLEAR JUSTIFICATION COUNTER
SETZM CALOC ;CLEAR LOCATION WORD
MOVE S1,@ARGADR ;GET CONTENTS OF FIRST ARG WORD
TXNN S1,TXT.AD ;IS ADDRESS WORD PRESENT?
JRST PARG.1 ;NO..PROCESS OLD BLOCK
MOVEM S1,CAFLG ;YES..PROCESS 2 WORD BLOCK
AOS S1,ARGADR
MOVE S1,@ARGADR ;GET POINTER TO ARGUMENT
STORE S1,CALOC,TXT.EA ;SAVE EFFECTIVE ADDRESS
ANDX S1,TXT.PT ;MASK POINTER PORTION
MOVEM S1,CAPTR ;SAVE IT
JRST PARG.3 ;GO FINISH UP
PARG.1: STORE S1,CALOC,TXT.EA ;SAVE EFFECTIVE ADDRESS
TXZ S1,TXT.EA ;CLEAR IT
MOVEM S1,CAFLG ;SAVE THE FLAGS
SETZM CAPTR ;CLEAR POINTER WORD
MOVEI T1,@ARGADR ;Get address of this arg, for $STOP
LOAD S1,CAFLG,TXT.P ;IS THIS A TWO WORD TYPE OF ARG?
JUMPE S1,PARG.2 ;NO, SO ADJUST BY ONLY ONE WORD
AOS S1,ARGADR ;ELSE ADJUST FOR THE SECOND WORD NOW
MOVE S1,0(S1) ;GET THE BYTE POINTER WORD
MOVEM S1,CAPTR ;AND STORE FOR LATER
PARG.2: LOAD S1,CAFLG,TXT.S ;IS THERE A SPACING WORD?
JUMPE S1,PARG.3 ;NO, DONT PROCESS IT
AOS S1,ARGADR ;GET THE ADDRESS OF SPACING WORD
MOVE S1,0(S1) ;GET THE SPACING WORD
LOAD S2,S1,TXT.SC ;YES..GET THE FILL CHARACTER
STORE S2,CAFLG,TXT.FC
LOAD S2,S1,TXT.SS ;GET JUSTIFICATION CODE
STORE S2,CAFLG,TXT.JU
LOAD S2,S1,TXT.SP ;GET WIDTH
STORE S2,CAFLG,TXT.WD
PARG.3: AOS ARGADR ;ADJUST CURRENT ADDRESS
MOVE S1,CALOC ;GET ADDRESS
TXNN S1,<@(17)> ;INDEXING OR INDIRECT
JRST PARG.4 ;NO..THEN SKIP THIS
; PUSHJ P,I%IOFF## ;TURN OFF INTERRUPTS
MOVE 0,[XWD USRACS+1,1] ;RESTORE THE ACS
BLT 0,16 ;THAT WE MAY RESEMBLE
MOVE 0,USRACS ;THE USER'S CONTEXT
EXCH P,USRACS+P ;SET UP PUSHDOWN LIST TOO
MOVEI S1,@CALOC ;CALCULATE EFFECTIVE ADDRESS
MOVEM S1,CALOC ;STORE ACTUAL ADDRESS
EXCH P,USRACS+P ;RESTORE STACK POINTER
; PUSHJ P,I%ION## ;TURN ON INTERRUPTS
PARG.4: PJRST PROTXT ;PROCESS THE TEXT
^LSUBTTL PROTXT -- ROUTINE TO PROCESS THE ACTUAL FUNCTION
PROTXT: LOAD S1,CAFLG,TXT.FN ;GET THE QUALIFIER INDEX ALONE
CAILE S1,0 ;IF OUT OF RANGE,
CAIL S1,PTABL ;
$STOP(IQN,Illegal qualifier number ^O/S1/ at ^O/ARGADR/)
LOAD T1,CAFLG,TXT.WD ;GET SPACING POSITIONS
MOVEM T1,CACMAX ;STORE AS MAXIMUM CHARS IN FIELD
LOAD S2,CAFLG,TXT.JU ;AND GET SIDE CODE
CAXE T1,0 ;IF NO SPACING,
CAXN S2,.TXTJL ;OR LEFT JUSTIFYING ONLY
JRST PROTX1 ;THEN JUST DO THE OUTPUT
SETOM NOOUTP ;SUPRESS THE OUTPUT,
PUSHJ P,@PTAB(S1) ;THEN, CALL THE PROCESSOR
SETZM NOOUTP ;CLEAR THE SUPRESS FLAG
PUSHJ P,SPACES ;GIVE ANY PADDING NECESSARY,
LOAD S1,CAFLG,TXT.FN ;GET QUALIFIER NUMBER AGAIN
PROTX1: PUSHJ P,@PTAB(S1) ;DO THE OUTPUT
LOAD S1,CAFLG,TXT.WD ;GET SPACING POSITIONS
LOAD S2,CAFLG,TXT.JU ;AND SIDE CODE
CAXE S1,0 ;IF NOT SPACING,
CAXN S2,.TXTJR ; OR RIGHT JUSTIFYING,
$RETT ;JUST RETURN
PUSHJ P,SPACES ;GIVE ANY SPACES NEEDED
$RETT
^LSUBTTL PTAB - Dispatch table for argument processors
; Note well: Any changes in the order or contents of the TQUALS
; macro in GLXMAC should be reflected by recompilation and/or
; code changes in TXTLIB.
; Define processor table creation mechanism
DEFINE TQ(CHR,ARGS,TYP,PROC) <EXP PRO'CHR>
PTAB: PJRST .RETF ;FILL IN THE 0 (UNUSED) ENTRY
TQUALS ;AND THEN THE REST OF THE TABLE
PTABL==.-PTAB
DEFINE TQ(CHR,ARGS,TYP,PROC) <XWD ARGS,"CHR">
PTAB2: EXP 0 ;FILL IN THE 0 (UNUSED) ENTRY
TQUALS ;AND THEN THE REST OF THE TABLE
^LSUBTTL PROx - Processors for each type of formatting
;The following are the separate processors for each type of
; ASCII formatting that we might have to do. Most are system
; independent, a couple are not. for all intents and
; purposes, these are the top level routines, and they have
; access to all AC's etc.
;Several locations are set up for these routines to use:
; CALOC is the effective address of the current argument
; or 0 (which will be unused) for TXT.NA (argument-less) qualifers
; CAFLG is the flag word for this argument
; CAPTR is the optional pointer word, used to get only a byte from the
; word containing the argument.
; ARGADR points to the word immediately following this argument in the list
; USRACS contain registers 0-17 inclusive of the caller's ACS
; USRRET contains the address of the first word not part of this $TEXT's
; argument block. It is used to calculate the end of the T%TEXT arg block
.
;USROUT contains the address of the user routine for
; outputting each byte The supplied routine takes its byte as
; 7 bit ASCII, right justified in AC S1, and returns either
; TRUE or FALSE. A return of FALSE will cause a STOP CODE to
; occur. The output routine supplied may destroy both S1 and
; S2, but must preserve all other registers.
;Each of the following routines is named 'PROx' where x is
; the letter or digit corresponding to the $TEXT qualifier
; that follows the '^' (up-arrow) to indicate that this type
; of output is wanted.
^LSUBTTL PROT - Process a string of ASCIZ text
;Since a user created string could be in the ACs or be a field or
; something odd like that, we process it one word at at a time if we
; have to. If we do not, then we go to PRO3 which is faster.
PROT: MOVE P1,CALOC ;GET LOCATION OF STRING
MOVEI P2,0 ;FAKE EXHAUSTED COUNT
SKIPN CAPTR ;IS THIS A FIELD ONLY?
CAIGE P1,20 ;OR IN THE ACS?
SOSA P1 ;YES, BACK ADDR OF ONE FOR LOOP, USE WOR
D BY WORD
JRST PRO3 ;ELSE DO AS PURE ASCIZ STRING
PROT.1: SOJGE P2,PROT.2 ;ANY MORE BYTES IN WORD?
AOS S1,P1 ;NO, NEED NEXT WORD
PUSHJ P,FETCH ;SO GET IT
MOVE P3,S1 ;AND MOVE INTO PERMANENT PLACE
MOVE P4,[POINT 7,P3] ;MAKE UP A BYTE POINTER
MOVEI P2,4 ;GET NEW COUNT
PROT.2: ILDB S1,P4 ;GET A BYTE
JUMPE S1,.RETT ;RETURN NOW IF WE GET A NULL
PUSHJ P,PUT7 ;PUT OUT THE BYTE
JRST PROT.1 ;LOOP FOR NEXT BYTE
SUBTTL PRO3 - Process a an ASCIZ string created by $TEXT
;PRO3 is used to process strings created by the $TEXT instruction itself.
; These strings do not have to be processed word by word since
; they are created in a literal.
PRO3: MOVE S1,CALOC ;GET LOCATION STRING STARTS AT
PJRST PUTT ;STORE THE STRING
^LSUBTTL PROQ - Process a byte pointer to an ASCIZ string
;PROQ is used to process an ASCIZ string which does not start on a word
; boundary. The address fed to the ^Q qualifer is that of a byte
; pointer to the string to be output.
PROQ: PUSHJ P,.SAVE1 ;PRESERVE AN AC
MOVE S1,CALOC ;GET LOCATION OF BYTE POINTER
PUSHJ P,FETCH ;FETCH IT NOW
TLNN S1,777700 ;WAS POINTER SPECIFIED?
TLO S1,(POINT 7,0) ;NO..MAKE STANDARD POINTER
TLC S1,-1
TLCN S1,-1 ;WAS POINTER -1,,X
HRLI S1,(POINT 7,0) ;YES..CREATE BYTE POINTER
PROQ.1: TXNN S1,<@(17)> ;INDIRECT OR INDEXED?
JRST PROQ.3 ;NO..PROCESS IT
LDB S2,[POINT 4,S1,17] ;GET THE INDEX FIELD
JUMPE S2,PROQ.2 ;JUMP IF NO INDEXING
HRRZ S2,USRACS(S2) ;GET THE INDEX VALUE
ADDI S2,(S1) ;DO INDEX CALCULATION
HRR S1,S2 ;STORE NEW EFFECTIVE ADDRESS
TLZ S1,17 ;CLEAR INDEXING
PROQ.2: TXNN S1,<@> ;INDIRECT?
JRST PROQ.3 ;NO..FINISH UP
MOVE P1,S1 ;SAVE THE POINTER
HRRZ S1,S1 ;EXTRACT THE ADDRESS
PUSHJ P,FETCH ;GET THE INDIRECT WORD
LDB S2,[POINT 12,P1,11] ;GET POSITION AND SIZE
DPB S2,[POINT 12,S1,11] ;STORE IN NEW POINTER
JRST PROQ.1 ;PROCESS POINTER
PROQ.3: HRRZ S2,S1 ;GET ADDRESS
CAIGE S2,20 ;POINT TO THE AC'S?
ADDI S2,USRACS ;YES..POINT TO OUR COPY
JRST PUTQ ;OUTPUT IT
^LSUBTTL PROB - Process a GLXLIB object block
PROB: MOVE P1,CALOC ;GET ARG LOC
MOVEI S1,OBJ.TY(P1) ;GET ADDRESS OF TYPE WORD
PUSHJ P,FETCH ;GET ITS CONTENTS
MOVE T1,S1 ;SAVE THE OBJECT TYPE IN T1
MOVSI P2,-OBJLEN ;MAKE AN AOBJN PTR TO TABLE OF OBJECTS
PROB.1: HLRZ S2,OBJTAB(P2) ;GET OBJECT TYPE FROM TABLE
CAME S2,S1 ;MATCH?
AOBJN P2,PROB.1 ;NO, LOOP
JUMPGE P2,.RETF ;AOBJN EXPIRED, LOSE
HRRZ S1,OBJTAB(P2) ;GET ADDRESS OF APPROPRIATE TEXT
PUSHJ P,PUTT ;AND OUTPUT IT
$PUT7(< >) ;OUTPUT A SPACE
MOVEI S1,OBJ.UN(P1) ;GET ADDRESS OF UNIT NUMBER WORD
PUSHJ P,FETCH ;FETCH IT
CAXN T1,.OTMNT ;IS THIS A TAPE/DISK OBJECT TYPE
JRST [PUSHJ P,PUTW ;YES,,PUT OUT THE UNIT AS SIXBIT
PJRST PROB.2 ] ;AND CONTINUE ON
MOVE P2,S1 ;COPY IT
LOAD S1,P2,OU.LRG ;GET LOW END OF RANGE
PUSHJ P,PUTD ;OUTPUT IT IN DECIMAL
LOAD S1,P2,OU.HRG ;GET HIGH END OF RANGE
JUMPE S1,PROB.2 ;SKIP IF NO HIGH UNIT
$PUT7(<:>) ;OUTPUT RANGE SEPARATOR
PUSHJ P,PUTD ;AND THEN HIGH END OF RANGE
PROB.2: MOVEI S1,OBJ.ND(P1) ;GET ADDRESS OF USER'S NODE WORD
PUSHJ P,FETCH ;GO GET ITS CONTENTS
SKIPN T1,S1 ;SAVE THE SUPPLIED NODE
JRST PROB.4 ;DONT DISPLAY IF NULL
TOPS10< TLNN S1,770000 ;MAKE SURE WE HAVE SIXBIT
$CALL CNVNOD
JUMPF [MOVE S1,T1 ;FAILURE..RESTORE SUPPLIED NODE
JRST PROB.3] ;AND DISPLAY IT
MOVE T1,S1 ;SAVE SIXBIT NODE
> ;End TOPS10
SETOM S1 ;SET FOR MY JOB
MOVX S2,JI.LOC ;GET MY LOCATION
PUSHJ P,I%JINF
JUMPF [MOVE S1,T1 ;RESTORE THE SUPPLIED NODE
JRST PROB.3] ;AND DISPLAY IT
MOVE S1,T1 ;PLACE SIXBIT IN S1
CAMN S2,S1 ;SAME LOCATION?
JRST PROB.4 ;YES..RETURN
PROB.3: PUSH P,S1 ;SAVE THE NODE SPEC
$PUTT(< [>) ;OPENER
POP P,S1 ;RESTORE IT
PUSHJ P,PUTN ;PUT OUT THE NODE NAME
$PUT7(<]>) ;AND CLOSER
PROB.4: $RETT
^LSUBTTL PRO1 - Process an object type
PRO1: MOVE S1,CALOC ;GET ADDR OF ARGUMENT
PUSHJ P,FETCH ;FETCH IT
MOVSI P1,-OBJLEN ;MAKE AN AOBJN PTR TO TABLE OF OBJECTS
PRO1.1: HLRZ S2,OBJTAB(P1) ;GET OBJECT TYPE FROM TABLE
CAME S2,S1 ;MATCH?
AOBJN P1,PRO1.1 ;NO, LOOP
JUMPGE P1,.RETF ;AOBJN EXPIRED, LOSE
HRRZ S1,OBJTAB(P1) ;GET ADDRESS OF APPROPRIATE TEXT
PJRST PUTT ;AND OUTPUT IT
;Define the X macro so we can generate the table of strings
; for the object types.
DEFINE X(A,B),<
XWD A,[ASCIZ/B/]
>
;Now generate the table of object type strings.
OBJTAB: OBJCTS
OBJLEN==.-OBJTAB
SUBTTL PRON - Process a node specification
PRON: MOVE S1,CALOC ;GET ADDRESS OF ARGUMENT
PUSHJ P,FETCH ;FETCH FROM USER SPACE
PJRST PUTN ;AND PRINT IT OUT
^LSUBTTL PROO - Process unsigned octal numbers
PROO: MOVE S1,CALOC ;GET ARGUMENT LOCATION
PUSHJ P,FETCH ;FETCH IT
PJRST PUTO ;JUST PRINT THE NUMBER
SUBTTL PROD - Process a signed decimal number
PROD: MOVE S1,CALOC ;GET ADDRESS OF CURRENT ARGUMENT
PUSHJ P,FETCH ;GET IT
PJRST PUTD ;JUST PRINT THE NUMBER
^LSUBTTL PROF - Process a system dependent file specification
TOPS10 <
PROF: MOVE P1,CALOC ;GET LOCATION OF THE FD
MOVEI S1,.FDSTR(P1) ;LOCATION OF STRUCTURE NAME
PUSHJ P,FETCH ;GET IT
JUMPE S1,PROF.1 ;IF NULL, FORGET IT
PUSHJ P,PUTW ;PRINT IT
$PUT7(<:>) ;FOLLOW IT WITH COLON
PROF.1: MOVEI S1,.FDNAM(P1) ;GET NAME OF FILE
PUSHJ P,FETCH ;FROM USER
SKIPE S1 ;IF NULL, DON'T PRINT IT
PUSHJ P,PUTW ;PRINT AS SIXBIT WORD
MOVEI S1,.FDEXT(P1) ;NOW GET EXTENSION
PUSHJ P,FETCH ;FROM USER
JUMPE S1,PROF.2 ;IF NULL, IGNORE IT
$PUT7(<.>) ;PUT OUT DOT AS FILE.EXT SEPARATOR
PUSHJ P,PUTW ;NOW PRINT THE SIXBIT EXTENSION
PROF.2: MOVEI S1,.FDPPN(P1) ;GET LOCATION OF PPN
PUSHJ P,FETCH ;GET THE PPN
JUMPE S1,.RETT ;IF NULL,SKIP PPN AND PATH
PUSH P,S1 ;SAVE PPN
$PUT7(<[>) ;PUT OUT A BRACKET TO OPEN PPN
HLRZ S1,0(P) ;ISOLATE PROJECT NUMBER
PUSHJ P,PUTO ;PUT IT OUT
$PUT7(<,>) ;SEPARATE HALVES
POP P,S1 ;RESTORE PPN
ANDI S1,-1 ;ISOLATE THE PROGRAMMER NUMBER
PUSHJ P,PUTO ;PRINT IT
MOVEI S1,.FDLEN(P1) ;GET ADDRESS OF FD LENGTH
PUSHJ P,FETCH ;FETCH IT
LOAD S1,S1,FD.LEN ;GET LENGTH ONLY
CAIG S1,.FDPAT ;IS THERE A PATH?
JRST PROF.4 ;NO
SUBI S1,.FDPAT ;GET NUMBER OF SFDS
MOVNS S1 ;NEGATE IT
HRL P1,S1 ;GET COUNT INTO PLACE
PROF.3: MOVEI S1,.FDPAT(P1) ;GET SFD LOCATION
PUSHJ P,FETCH ;LOAD IT
JUMPE S1,PROF.4 ;Null SFD? All done then...
$PUT7(<,>) ;Nonnull, type a comma
PUSHJ P,PUTW ;PRINT IT
AOBJN P1,PROF.3 ;LOOP FOR ALL
PROF.4: $PUT7(<]>) ;CLOSE PPN WITH A BRACKET
> ;END TOPS10 CONDITIONAL
TOPS20 <
PROF: MOVEI S1,.FDSTG ;GET OFFSET TO DESCRIPTIVE STRING
PUSH P,CALOC ;SAVE LOCATION OF ARGUMENT
ADDM S1,CALOC ;POINT TO "STRING PART" OF FD
PUSHJ P,PROT ;HANDLE AS ASCIZ TEXT
POP P,CALOC ;RESTORE ORIGINAL LOCATION
> ;END TOPS20 CONDITIONAL
$RETT ;THEN RETURN
^LSUBTTL PRO7 - Process a single 7 bit ASCII character
PRO7: MOVE S1,CALOC ;GET LOCATION
PUSHJ P,FETCH ;FETCH THE CHARACTER
PJRST PUT7 ;PRINT IT AND RETURN FROM THERE
SUBTTL PRO6 - Process a single 6 bit ASCII character
PRO6: MOVE S1,CALOC ;GET LOCATION
PUSHJ P,FETCH ;LOAD IT
PJRST PUT6 ;PRINT IT AND RETURN FROM THERE
SUBTTL PRO5 - Process ASCIZ single word
PRO5: MOVE S1,CALOC ;GET LOCATION OF WORD TO PRINT
PUSHJ P,FETCH ;LOAD IT
MOVEM S1,TTXBUF ;STORE INTO TEMPORARY BUFFER
SETZM S1,TTXBUF+1 ;INSURE 6TH CHARACTER IS NULL
MOVEI S1,TTXBUF ;GET LOCATION TO PUT OUT STRING AT
PJRST PUTT ;AND PUT OUT THE TEXT
SUBTTL PROW - Process a SIXBIT word
PROW: MOVE S1,CALOC ;GET LOCATION OF ARGUMENT
PUSHJ P,FETCH ;LOAD FROM USER ADDRESS SPACE
SKIPN CAPTR ;IF NOT A BYTE,
PJRST PUTW ;JUST PRINT IT OUT
JUMPE S1,.RETT ;IF NULL, RETURN NOW
PROW.1: TXNE S1,77B5 ;IS FIELD LEFT JUSTIFIED?
PJRST PUTW ;YES, PRINT IT OUT NOW
LSH S1,6 ;SHIFT OVER ONE PLACE
JRST PROW.1 ;AND TRY AGAIN
^LSUBTTL PROP - Process a directory ID of either PPN or directory NUMBER
SUBTTL PROU - Process a user ID or either PPN or User number
PROU: SKIPA T1,[EXP JI.USR] ;USE JOB'S USER NUMBER
PROP: MOVX T1,JI.CDN ;USE JOB'S DIRECTORY NUMBER
MOVE S1,CALOC ;GET CURRENT ARGUMENT'S LOCATION
PUSHJ P,FETCH ;NOW FETCH THAT ARGUMENT
CAME S1,[EXP -1] ;DO THEY WANT THE DEFAULT?
PJRST PUTU ;NO,OUTPUT USER INFO
MOVE S2,T1 ;PLACE FUNCTION CODE IN S2
PUSHJ P,I%JINF ;GET THE DATA
MOVE S1,S2 ;PLACE VALUE IN S1
PROP.1: PJRST PUTU ;OUTPUT USER INFO
^LSUBTTL PROR - Process routine for Job Info Block
;This routine will output the Job Info Block for the Galaxy
; Spoolers or anyone formating a JIB according to GLXMAC
; Specification.
PROR: MOVEI S1,[ASCIZ/Job /] ;START JOBNAME
PUSHJ P,PUTT ;OUTPUT THE TEXT
MOVE P1,CALOC ;GET ADDR OF ARGUMENT
MOVEI S1,JIB.JN(P1) ;GET THE ADDRESS OF JOBNAME FIELD
PUSHJ P,FETCH ;FETCH IT
JUMPE S1,.RETF ;NONE..ERROR..RETURN FALSE
PUSHJ P,PUTW ;DISPLAY THE JOBNAME
MOVEI S1,[ASCIZ/ Req #/] ;REQUEST IDENTIFIER
PUSHJ P,PUTT ;OUTPUT BLOCK
MOVEI S1,JIB.ID(P1) ;GET ADDRESS OF REQUEST ID
PUSHJ P,FETCH ;FETCH IT
JUMPLE S1,.RETF ;ERROR...RETURN
PUSHJ P,PUTD ;OUTPUT THE NUMBER
MOVEI S1,[ASCIZ/ for /] ;USER NAME IDENTIFIER
PUSHJ P,PUTT ;OUTPUT THE TEXT
TOPS10 <
MOVEI S1,JIB.NM(P1) ;GET USER NAME WORD 1
PUSHJ P,FETCH ;FETCH IT
JUMPE S1,PROR.3 ;NO NAME GO TO PPN
MOVE P2,CACCTR ;GET CURRENT CHARACTER COUNT
ADDI P2,6 ;EXPECTED COUNT AFTER OUTPUT
PUSHJ P,PUTW ;OUTPUT THE NAME
SUB P2,CACCTR ;GET COUNT OUTPUT
MOVEI S1,JIB.NM+1(P1) ;GET USER NAME WORD 2
PUSHJ P,FETCH ;FETCH IT
JUMPE S1,PROR.3 ;ANYTHING ELSE TO PRINT ?
JUMPE P2,PROR.2 ;ALL OUT CONTINUE ON
PUSH P,S1 ;SAVE USER NAME WORD 2
PROR.1: MOVEI S1,40 ;GET A BLANK
PUSHJ P,PUT7 ;OUTPUT THE BLANK
SOJG P2,PROR.1 ;FILL TO 6 CHARACTERS
POP P,S1 ;GET SAVED S1
PROR.2: PUSHJ P,PUTW ;OUTPUT THE NAME
PROR.3: MOVEI S1,40 ;GET A BLANK
PUSHJ P,PUT7 ;OUTPUT THE CHARACTER
>;END TOPS10
MOVEI S1,JIB.US(P1) ;GET USER NUMBER OR PPN
PUSHJ P,FETCH ;FETCH THE ARGUMENT
PJRST PUTU ;DISPLAY USER NAME OR PPN AND RETURN
^L
PROH: TDZA P1,P1 ;USE FOR FLAG THAT DATE IS WANTED
PROC: SETO P1, ;-1 MEANS TIME ONLY
MOVE S1,CALOC ;GET LOCATION OF ARGUMENT
PUSHJ P,FETCH ;GRAB IT
CAMN S1,[EXP -1] ;IS IT -1, FOR "NOW"?
PUSHJ P,I%NOW ;GET CURRENT DATE AND TIME
TOPS20 <
PUSH P,S1 ;SAVE S1
CAML S1,DSTCHG ;HAVE WE PASSED NEXT 0200?
PUSHJ P,CLCFCT ;YUP, RECOMPUTE LOCAL ADJUSTMENT FACTOR
POP P,S1 ;RESTORE S1
ADD S1,TMFCTR ;MAKE LOCAL TIME ADJUSTMENT
SKIPGE S1 ;GUARD AGAINST GARBAGE DATES
SETZ S1,0 ;AND SET TO EARLIEST POSSIBLE
>;;END OF TOPS20 CONDITIONAL ASSEMBLY
PROH.1: PUSHJ P,CNTDT ;TAKE IT APART
DMOVE T1,S1 ;GET THE RETURNED VALUES
PUSH P,S1 ;SAVE TIME
JUMPL P1,PROH.2 ;IF FLAG IS UP, GIVE TIME ONLY
MOVE T1,T2 ;POSITION DATE
IDIVI T1,^D31 ;GET DAYS
MOVE T4,T1 ;SAVE REST
MOVEI S1,1(T2) ;GET DAYS AS 1-31
CAIGE S1,^D10 ;IF ONE DIGIT,
$PUT7(< >) ; FILL WITH A SPACE
PUSHJ P,PUTD ;PRINT DECIMAL NUMBER
IDIVI T4,^D12 ;GET MONTHS
MOVEI S1,[ASCIZ /-Jan/
ASCIZ /-Feb/
ASCIZ /-Mar/
ASCIZ /-Apr/
ASCIZ /-May/
ASCIZ /-Jun/
ASCIZ /-Jul/
ASCIZ /-Aug/
ASCIZ /-Sep/
ASCIZ /-Oct/
ASCIZ /-Nov/
ASCIZ /-Dec/](P1) ;GET ASCII
PUSHJ P,PUTT ;TYPE ^C
$
X29PAD>clo
***** Log file closed at 11:46:00-EST on February 26, 1984 *****
***** Log file opened at 11:52:50-EST on February 26, 1984 *****
X29PAD>co
type <fauser>txtlib.mac
TITLE TXTLIB -- Formatted Text Handler for GLXLIB
SUBTTL Irwin L. Goverman/ILG/CER/MLB/DC/PJT/WLH 1-Jan-82
;
;
;
; COPYRIGHT (c) 1975,1976,1977,1978,1979,1980,1981,1982
; DIGITAL EQUIPMENT CORPORATION, MAYNARD, MA.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED
; AND COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE
; AND WITH THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS
; SOFTWARE OR ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR
; OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON. NO TITLE TO
; AND OWNERSHIP OF THE SOFTWARE IS HEREBY TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE
; WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT
; BY DIGITAL EQUIPMENT CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
; OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY
; DIGITAL.
SEARCH GLXMAC ;GET AT GALAXY LIBRARY SYMBOLS
;*******************************************
FTJSYS==1
FTUUOS==0
DEFINE TOPS10 <IFN FTUUOS,> ;SETUP CONDITIONAL MACROS
DEFINE TOPS20 <IFN FTJSYS,>
^LSUBTTL Accumulator Definitions
;Pass FACT file accounting requirement along
FTFACT==FTFACT ;From GALCNF
;THE FOLLOWING ACCUMULATOR DEFINITIONS ARE STANDARD THROUGHOUT THE
; SUB-SYSTEMS GROUP AND MAY NOT BE CHANGED. THE ACCUMULATORS DEFINED ARE:
TF==0 ;TRUE/FALSE REGISTER, NEVER REFERENCED DIRECTLY
; USED BY $RETx AND JUMPT,JUMPF, SKIPT,SKIPF
.SAC==0 ;SCRATCH AC USED BY SOME NONE SKIPPABLE
;MACROS AND SOME MACRO CALLS TO GLXCOM
;.SAC MAY NOT BE CHANGED ON EXIT FROM A
;CO-ROUTINE SO THAT ANY ROUTINE MAY PASS
;A TRUE FALSE VALUE BACK TO IT'S CALLER.
S1==1 ;S1 & S2 ARE ARGUMENTS TO ROUTINES
S2==2 ;AND ARE OTHERWISE SCRATCH
T1==3 ;T1 - T4 ARE TEMPORARY REGS
T2==4
T3==5
T4==6
P1==7 ;P1 - P4 ARE PRESERVED REGS
P2==10
P3==11
P4==12
.A13==13 ;.A13 THRU .A16 NOT USED BY LIBRARY
.A14==14
.A15==15
.A16==16
.FP==16 ;FRAME POINTER USED BY TRVAR AND ASUBR
;MAY NOT BE CHANGED WITHIN THE SCOPE OF
;A ROUTINE USING TRVAR OR ASUBR
;HOWEVER -- IT IS PRESERVED OUTSIDE THE
;SCOPE OF THESE ROUTINES
P==17 ;PUSHDOWN POINTER
^LSUBTTL PROLOG - Uniform assembly set up
; The PROLOG macro is used to uniformly search all the right UNV files
; and setup the listing format and STOP CODE controls.
; Call: PROLOG (MODULE,OTSCOD)
;
; Where: 'MODULE' represents the module name
; 'OTSCOD' (optional) represents a GLXLIB module mnemonic
;
;%%.MOD==SIXBIT/NONAME/ ;;DEFAULT MODULE NAME INCASE NULL
;%%.OTS==0 ;;DEFAULT OTSCOD INCASE NULL
DEFINE PROLOG (MODULE,OTSCOD),<
SALL ;;FOR PRETTY LISTINGS
; LSTOF. XCREF ;;TURN OFF LISTING
; %%.GLX==%%.GLX ;;RECORD VERSION NUMBER
; GLXVRS==GLXVRS ;;...
; IFNB <MODULE>,<%%.MOD==SIXBIT/MODULE/> ;;MAKE NAME AVAILABLE
; IFNB <OTSCOD>,<%%.OTS==SIXBIT/OTSCOD/> ;;MAKE OTSCODE AVAILABLE
; GLOB I%INIT ;;ENTRY POINT CALLED BY THE USER
TOPS10 < ;;TOPS-10 ONLY
SEARCH UUOSYM ;;OPERATING SYSTEM SYMBOLS
%%UUOS==%%UUOS ;;RECORD VERSION NUMBER
> ;;END OF TOPS-10 CONDITIONAL
TOPS20 < ;;TOPS-20 ONLY
SEARCH MONSYM ;;OPERATING SYSTEM SYMBOLS
; %%MONS==%%MONS ;;RECORD VERSION NUMBER
> ;;END OF TOPS-20 CONDITIONAL
; IFB <OTSCOD>,< ;;IF NOT A GLXLIB MODULE
; .TEXT |,REL:GLXLIB/SEARCH/REQUIRE:I%INIT|
DEFINE $DATA (NAM,SIZ<1>),< ;;MACRO TO GENERATE DATA STORAGE
NAM: BLOCK SIZ
> ;;END OF $DATA MACRO
DEFINE CDO (X),<GLOB X> ;;MAKE ENTRY POINTS GLOBAL
; LIBVEC ;;GLOBALIZE ALL ENTRY POINTS
; > ;;END OF IFB <OTSCOD> CONDITIONAL
;
; IFNB <OTSCOD>,<CHKEDT (OTSCOD)> ;;CHECK GLXLIB MODULE EDIT NUMBERS
;
; IFNB <OTSCOD>,<IFDIF <OTSCOD><INI>,< ;;IF NOT GLXINI
; IFN GLXPURE,<.PSECT .HIGH.> ;;IF OTS
; IFE GLXPURE,< ;;IF LINKABLE LIBRARY
; TWOSEG 400000 ;;MAKE US SHARABLE
; RELOC 0 ;;DATA STORAGE STARTS HERE
; RELOC 400000 ;;START LOADING THE HIGH SEGMENT
; > ;;END OF IFE GLXPURE CONDITIONAL
;
; DEFINE $DATA(NAM,SIZ<1>),< ;;MACRO TO GENERATE DATA STORAGE
; IFN GLXPURE,<.PSECT DATA> ;;RELOCATE TO DATA PSECT
; IFE GLXPURE,<RELOC> ;;RELOCATE TO LOW SEGMENT
; IFNDEF OTSCOD'%D,<OTSCOD'%D::! OTSCOD'%DL==:0>
; NAM: BLOCK SIZ
; OTSCOD'%DL==:OTSCOD'%DL+SIZ ;;COUNT WORDS
; IFN GLXPURE,<.ENDPS DATA> ;;TERMINATE PSECT REFERENCE
; IFE GLXPURE,<RELOC> ;;BACK TO THE HIGH SEG
; > ;;END OF $DATA MACRO
;
; IFDIF <OTSCOD><OTS>,< ;;FOR ALL BUT GLXOTS...
; DEFINE CDO (X),<GLOB X> ;;MAKE ENTRY POINTS GLOBAL
; LIBVEC ;;GLOBALIZE ALL ENTRY POINTS
; > ;;END OF IFDIF <OTSCOD><OTS> CONDITIONAL
;
; >> ;;END OF IFDIF <OTSCOD><INI> CONDITIONAL
;
; IFNB <OTSCOD>,<IFIDN <OTSCOD><INI>,< ;;IF GLXINI
; DEFINE $DATA (NAM,SIZ<1>),< ;;MACRO TO GENERATE DATA STORAGE
; NAM: BLOCK SIZ
; > ;;END OF $DATA MACRO
; >> ;;END OF IFIDN <OTSCOD><INI> CONDITIONAL
;
; LSTON. ;;TURN LISTINGS ON
;
; GLOB <.POPJ, .RETT, .RETF> ;;SOME POPULAR RETURNS
OPDEF $RET [POPJ P,] ;;RETURN
OPDEF $RETT [PJRST .RETT] ;;RETURN TRUE
OPDEF $RETF [PJRST .RETF] ;;RETURN FALSE
OPDEF $RETIT [JUMPT .POPJ] ;;RETURN IF TRUE
OPDEF $RETIF [JUMPF .POPJ] ;;RETURN IF FALSE
; .NODDT $RET,$RETT,$RETF,$RETIT,$RETIF
> ;;END OF PROLOG MACRO
;******************************************
PROLOG(TXTLIB,TXT) ;PRODUCE PROLOG CODE
TXTEDT==51 ;MODULE EDIT LEVEL
ENTRY TXTINI ;INITIALIZATION
ENTRY T%TEXT ;$TEXT ENTRY POINT
ENTRY T%TTY ;DEFAULT TERMINAL OUTPUT
; GLOB <IIB> ;IIB is external
; GLOB <CNTDT> ;CNTDT is external
;TOPS10< GLOB <CNVNOD>> ;CNVNOD is external
; This file contains the support code for the $TEXT macro, which
; is responsible for formatting all static string and variable type
; output. For a more detailed explanation of the $TEXT macro, please
; refer to the GLXMAC and GLXLIB modules.
; This module differs from most members of the GLXLIB family in two respects.
; First, it is called via a pseudo instruction, $TEXT, rather than
; via the usual S1/S2 accumulator calls. Secondly, all ACs are preserved
; across calls, which are skippable.
; The user of the $TEXT instruction must provide one or several output routines.
; This routine must conform to the standard GLXLIB conventions.
^LSUBTTL Table of Contents
; TABLE OF CONTENTS FOR TXTLIB
;
;
; SECTION PAGE
; 1. Table of Contents......................................... 2
; 2. Revision History.......................................... 3
; 3. Local Macros.............................................. 4
; 4. Global storage............................................ 5
; 5. TXTINI - Initialize the TEXT module....................... 6
; 6. T%TEXT - Routine to format text output.................... 7
; 7. T%TTY - Buffered terminal output routine................. 9
; 8. PROBLK - Process an entire T%TEXT argument block.......... 10
; 9. PROARG - Routine to process each T%TEXT argument.......... 11
; 10. PROTXT -- ROUTINE TO PROCESS THE ACTUAL FUNCTION.......... 12
; 11. PTAB - Dispatch table for argument processors........... 13
; 12. PROx - Processors for each type of formatting........... 14
; 13. PROT - Process a string of ASCIZ text................... 15
; 14. PRO3 - Process a an ASCIZ string created by $TEXT....... 15
; 15. PROQ - Process a byte pointer to an ASCIZ string........ 16
; 16. PROB - Process a GLXLIB object block.................... 17
; 17. PRO1 - Process an object type........................... 18
; 18. PRON - Process a node specification..................... 18
; 19. PROO - Process unsigned octal numbers................... 19
; 20. PROD - Process a signed decimal number.................. 19
; 21. PROF - Process a system dependent file specification... 20
; 22. PRO7 - Process a single 7 bit ASCII character........... 21
; 23. PRO6 - Process a single 6 bit ASCII character........... 21
; 24. PRO5 - Process ASCIZ single word........................ 21
; 25. PROW - Process a SIXBIT word............................ 21
; 26. PROP - Process a directory ID of either PPN or directory NUMBER 22
; 27. PROU - Process a user ID or either PPN or User number... 22
; 28. PROR - Process routine for Job Info Block............... 23
; 29. PROE - Process a GLXLIB error number.................... 25
; 30. PROI - Process an indirect text request................. 26
; 31. PROV - Process a program version number................. 27
; 32. PROM - Process a request for a CONTROL-M (Carriage Ret.) 28
; 33. PROJ - Process a request for a CONTROL-J (Line Feed).... 28
; 34. PROL - Process a request for a CONTROL-L (Form Feed).... 28
; 35. PROK - Process a request for a CONTROL-K (Vertical Tab). 28
; 36. PRO2 - Process a request for up-arrow................... 28
; 37. PROA - Process a request to supress free <CR-LF>........ 28
; 38. PRO0 - Process a request to put null (0) at end of line. 28
; 39. FETCH - Routine to get a word from caller's address space 29
; 40. SPACES - Routine to provide any padding requested......... 30
; 41. Local output routines..................................... 31
; 42. PUTU -- Output user name or PPN........................... 35
; 43. SAVLVL-RSTLVL - Save and restore TEXT levels.............. 36
^LSUBTTL Revision History
COMMENT \
20/OCT/83 G.FAUSER 20/OCT/83 ISOLATED GLXTXT AND ITS MACROS OUT OF
GLXLIB AND NAMED IT TXTLIB AND TXTUNV
\ ;End of Revision History
^LSUBTTL Local Macros
; These macros are pseudo instructions, and as such they
; preserve all registers and are skippable.
; Define a local macro for printing single characters
DEFINE $PUT7(CHAR)<
PUSHJ P,PUT7X ;;CHARACTER OUTPUT ROUTINE
XLIST ;;NO NEED TO LIST
JUMP "CHAR" ;;NO-OP + CHARACTER
LIST
> ;END OF $PUT7 DEFINITION
; DEFINE A LOCAL MACRO FOR PRINTING STRINGS
DEFINE $PUTT(STRING)<
PUSHJ P,PUTTX
XLIST
JUMP [ASCIZ \STRING\]
LIST
> ;END OF $PUTT DEFINITION
SYSPRM TTXBFS,2,^D10 ;TEMPORARY TEXT BUFFER SIZE
ND LINSIZ,^D20 ;SIZE OF DEFAULT OUTPUT LINE
ND EBFSZ,^D20 ;SIZE OF BUFFER AREA
^LSUBTTL Global storage
;Global storage
$DATA TXTBEG,0 ;BEGINNING OF ZEROABLE $DATA SPACE
$GDATA TXTLVL ;LEVEL WE ARE AT
;Local storage
$DATA DEFERR ;DEFAULT ERROR EXIT ADDRESS FROM IB.
$DATA DEFOUT ;DEFAULT OUTPUT ROUTINE FROM IB
$DATA FSAVE,0 ;FIRST LOCATION TO SAVE AT EACH LEVEL
$DATA LINBUF,LINSIZ ;LINE BUFFER
LINMAX==<<LINSIZ>*^D5>-1 ;MAXIMUM CHARACTER COUNT
$DATA ARGADR ;ADDRESS OF CALLER'S ARG LIST
$DATA USRACS,20 ;USER-CONTEXT ACS
$DATA USROUT ;ADDRESS OF CALLING OUTPUT RTN.
$DATA USRARG ;ADDRESS OF USER ARGUMENTS
$DATA NXTARG ;POINTS TO NEXT ARGUMENT
$DATA MAXARG ;NUMBER OF ARGUMENTS SPECIFIED
$DATA USRRET ;FIRST WORD AFTER $TEXT ARG BLOCK
TOPS20< $DATA ERRBUF> ;ERROR BUFFER AREA
$DATA CAPNTR ;BYTE POINTER FOR PR03 PROCESSING
$DATA CALOC ;CURRENT ARGUMENT EFFECTIVE ADDRESS
$DATA CAFLG ;CURRENT ARGUMENTS FLAGS
$DATA CAPTR ;POINTER WORD FOR CURRENT ARG (IF ANY)
$DATA CACCTR ;NUMBER OF CHARACTERS IN CURRENT ARGUMEN
T
$DATA CACMAX ;MAXIMUM CHARACTERS FIELD MAY BE
$DATA ENDFLG ;-1=NOTHING,0=CR-LF,+1=NULL AT END
$DATA NOOUTP ;-1 WHEN ACTUAL OUTPUT IS SUPRESSED
$DATA ERREXT ;A USER EXIT ROUTINE HAS RETURNED FALSE.
$DATA TTXBUF,TTXBFS ;PLACE TO BUILD TEMPORARY STRINGS
$DATA LINCTR ;COUNTER FOR CURRENT LINE
$DATA LINPTR ;POINTER TO CURRENT LINE
$DATA TMFCTR ;TIME ADJUSTMENT FACTOR
$DATA DSTCHG ;TIME FACTOR IS BASED ON
$DATA LSAVE,0 ;LAST LOCATION TO SAVE
IF1,<SSAREA==<LSAVE-FSAVE-1>> ;SIZE OF THE SAVE AREA
$DATA SAREA,SSAREA ;PLACE TO SAVE EACH LEVEL
$DATA .LGERR,1 ;SAVE ERROR CODE ON $RETE
$DATA TXTEND,0 ;END OF ZEROABLE $DATA SPACE
$DATA GENBUF,^D 200 ;GEN-BUFF USED TO REPLACE M%GMEM
^LSUBTTL TXTINI - Initialize the TEXT module
;This routine puts the TEXT module into a known state and
; stores the user specified default output routine
;CALL IS: IIB setup by I%INI1 in GLXINI
;
;TRUE RETURN: Always
TXTINI: MOVE S1,[TXTBEG,,TXTBEG+1] ;BLT PTR TO BEGINNING OF $DATA SPACE
SETZM TXTBEG ;KILL THE FIRST WORD
BLT S1,TXTEND-1 ;NOW KILL THE REST
; SKIPN S1,IIB+IB.OUT ;PICKUP DEFAULT OUTPUT ROUTINE
MOVEI S1,T%TTY ;NONE SPECIFIED..USE OUR DEFAULT
MOVEM S1,DEFOUT ;SAVE IT FOR LATER
; MOVE S1,IIB+IB.ERR ;GET USER ERROR EXIT ROUTINE
; MOVEM S1,DEFERR ;SAVE IT FOR LATER.
SETOM TXTLVL ;INITIALIZE THE COUNT OF LEVELS
TOPS10< $RETT> ;RETURN FOR TOPS10
TOPS20<
;This routine is called to recompute the local time
; conversion factor. The factor takes into account
; the local time zone as well as the daylight savings
; time adjustment. Note that the routine calculates
; the next local time occurrence of 0200 hours and
; saves it for later comparison.
CLCFCT: MOVEI S1,.SFTMZ ;TIME ZONE FUNCTION
TMON ;GET THE ZONE
SETOM TMFCTR ;REVERSE NUMBER LINE VALUE
IMULM S2,TMFCTR ;CALCULATE BASE HOURS
GTAD ;GET DATE/TIME
MOVE S2,S1 ;RELOCATE
HRRI S2,25253*2 ;LOAD RIGHT WITH 0200
MOVEM S2,DSTCHG ;SAVE IT
HRRZ S2,S1
CAIG S2,25253*2 ;AFTER 0200?
JRST TINI.1 ;NO,WE'RE DONE
HRLZI S2,1 ;YUP, MAKE IT TOMORROW
ADDM S2,DSTCHG ;..
TINI.1: MOVE S2,S1 ;RELOCATE TIME
SETZ T2,0 ;..
ODCNV
SETZ S2,0 ;SET FOR NO DST ADJUSTMENT
TXNE T2,IC%ADS ;FACTOR FOR DST?
AOS TMFCTR ;YES, DO SO
HRLZI S1,1 ;SETUP FULL DAY FACTOR [1,,0]
IMUL S1,TMFCTR ;COMPUTE FACTOR HOURS
IDIVI S1,^D24 ;..AND THE BASE OFFSET
MOVEM S1,TMFCTR ;STORE IT AWAY
$RETT
>;END OF TOPS20 CONDITIONAL ASSEMBLY
^LSUBTTL T%TEXT - Routine to format text output
;Calls to T%TEXT come only through invokation of the $TEXT
; macro, described in GLXMAC.
; Call is: Pushdown list top entry points to start of argument block-1,
; which is a JRST around an argument block, formatted as follows:
;
; PUSHJ P,T%TEXT ;CALL
; JRST %L1 ;JUMP AROUND CALL
; OUTPUT ROUTINE OR B.P. ;ADDR OF CHAR OUTPUT ROUTINE OR -1,,ADDR
(BP)
; FLAGS+<QUAL.#>+ADDRESS ;DESCRIPTION AND ADDRESS OF ARG
; BYTE POINTER FOR ARG ;ONLY IF A BYTE POINTER IS NEEDED
; SPACING INFORMATION ;ONLY IF SPACING INFORMATION IS NEEDED
; .... ;MORE ARGUMENT SINGLETS,PAIRS OR TRIPLET
S
; %L1:
;Where: Flags tell us whether qualifier takes any argument
; and whether position and spacing words are present.
; The spacing information is: "CHAR"B6+<SIDE>B17+<Number of positions>B35
;
; Return: Return is to the location after the PUSHJ to T%TEXT, which
; is the JRST around the arg block. This makes $TEXT skippable.
T%TEXT: AOSE TXTLVL ;INCREMENT LEVEL COUNT
PUSHJ P,SAVLVL ;SAVE LEVEL IF NOT FIRST
MOVEM 0,USRACS ;STORE FIRST AC
MOVE 0,[XWD 1,USRACS+1] ;TRANSFER USER ACS TO THE
BLT 0,USRACS+17 ;SAVE AREA
SOS USRACS+P ;ADJUST SHADOW VERSION OF "P"
SETZM ENDFLG ;ASSUME WANTS CR-LF AT END
SETZM ERREXT ;NO USER EXIT ERROR.
SETZM NOOUTP ;NOT SUPRESSING OUTPUT
SETOM LINCTR ;FLAG THAT BUFFER IS NOT IN USE
MOVE S1,[POINT 7,LINBUF] ;GET POINTER TO TTY OUTPUT BUFFER
MOVEM S1,LINPTR ;AND SAVE IT
HRRZ S1,0(P) ;Get return address
HLRZ TF,0(S1) ;Get return instruction
CAIN TF,(JUMP) ;New style call?
JRST TEXT.2 ;Yes..Process it
MOVE TF,1(S1) ;GET THE USER ROUTINE ADDRESS INSTR.
MOVE S1,USRACS+S1 ;RESTORE S1 TO ORIGIONAL VALUE.
XCT 0 ;GET THE USER REUTINE/BYTE PTR ADDR.
HRRZ S1,0(P) ;RE-GET THE ADDRESS CALLED FROM.
HRRZ S2,0(S1) ;GET FIRST WORD PAST ARGUMENT BLOCK
MOVEM S2,USRRET ;REMEMBER WHERE IT IS
SKIPN S2,0 ;FETCH USER OUTPUT ROUTINE ADDRESS
MOVE S2,DEFOUT ;IF NONE SPECIFIED, USE DEFAULT
SKIPN S2 ;HAVE WE GOT ONE SOME WAY?
MOVEI S2,T%TTY ;NO, MUST NOT BE INITED YET
JUMPG S2,TEXT.1 ;HAVE WE GOT A DEFAULT BYTE POINTER?
HRLI S2,(POINT 7,0) ;MAKE IT A BYTE POINTER.
MOVEM S2,LINPTR ;AND STORE POINTER
MOVEI S2,TDPB ;GET ADDR OF ROUTINE TO USE THE POINTER
TEXT.1: MOVEM S2,USROUT ;STORE IT AWAY FOR LATER
ADDI S1,2 ;COMPUTE THE START OF PARAMETER BLOCK
MOVEM S1,ARGADR ;REMEMBER IT
TEXT.3: PUSHJ P,PROBLK ;PROCESS THE ARGUMENT BLOCK
PUSHJ P,PEND ;GIVE PROPER ENDING TO STRING
SKIPL LINCTR ;IF WE USED DEFAULT ROUTINE,
PUSHJ P,TDMP ;DUMP BUFFER NOW
MOVE 0,[XWD USRACS+1,1] ;RESTORE USER ACS
BLT 0,16 ;EXCEPT FOR PDL POINTER
MOVE 0,USRACS ;RESTORE AC USED FOR BLT
SOSL TXTLVL ;DECREMENT COUNT, IF NOT
PUSHJ P,RSTLVL ;AT PRIMARY, RESTORE THE LEVEL
SKIPE ERREXT ;DO WE TAKE THE ERROR EXIT ???
SKIPN DEFERR ;IS THE ROUTINE ADDRESS THERE ???
SKIPA ;NO,,JUST RETURN NORMALLY.
JRST @DEFERR ;YES,,DO IT.
POPJ P, ;RETURN WITHOUT AFFECTING TF
^L
;This calling convention is extensible and superceeds the previous
;calling sequence.
;Thus $TEXT(RTN,<STRING>,<ARGS>) would produce the following call:
; $CALL T%TEXT
; JUMP [XWD 2,0 ;Length of header
; EXP <RTN> ;Text output routine or pointer
; ITEXT(<STRING>,<ARGS>)];Start of ITEXT arguments
TEXT.2: HRRZ S1,0(S1) ;Get address of argument list
HLRZ TF,(S1) ;Get the header count
ADDI TF,(S1) ;Get ITEXT address
MOVEM TF,ARGADR ; and save it
SETZM USRRET ;Clear return address
MOVE TF,1(S1) ;Get calling TOR or pointer
TLC TF,777777 ;MAKE -1 INTO A WORD POINTER
TLCN TF,777777
HRLI TF,(POINT 7)
MOVE S1,USRACS+S1 ;RESTORE USERS S1
EXCH P,USRACS+P ; AND STACK POINTER
HRRI TF,@TF ;REMOVE INDEXING AND INDIRECTION
EXCH P,USRACS+P ;RESTORE OUR POINTER
TLZ TF,(@(17)) ;CLEAR THE BITS
TLNE TF,777777 ;IS THIS A POINTER?
JRST [MOVEM TF,LINPTR ;YES..SAVE IT
MOVEI TF,TDPB ;GET POINTER ROUTINE ADDRESS
JRST .+1] ;AND SAVE THAT
SKIPN TF ;Do we have a routine?
MOVE TF,DEFOUT ;No..use the default
MOVEM TF,USROUT ;SAVE ROUTINE ADDRESS
JRST TEXT.3 ;Back to process arguments
^LSUBTTL T%TTY - Buffered terminal output routine
;If a $TEXT instruction has a blank first argument, then the
; default output routine is used. This routine is identified
; in the Initialization Block.
;T%TTY is a default output routine which buffers output to
; the terminal controlling this job.
; Call is: S1/ contains 1 character, 7 bit, right justified
;
; Return: TRUE always
T%TTY: SOSGE LINCTR ;ROOM IN THE BUFFER?
JRST [ PUSHJ P,TDMP ;NO, DUMP THE BUFFER
JRST T%TTY ] ;AND RETRY
JUMPE S1,.RETT ;IF NULL CHARACTER, RETURN NOW
IDPB S1,LINPTR ;DEPOSIT THE CHARACTER
$RETT ;ALWAYS RETURN TRUE
TDMP: PUSH P,S1 ;SAVE CHARACTER
MOVEI S1,0 ;GET NULL CHARACTER
IDPB S1,LINPTR ;STORE TERMINATING NULL INTO BUFFER
MOVE S1,[POINT 7,LINBUF] ;GET BUFFER POINTER
MOVEM S1,LINPTR ;STORE IT
SKIPE LINBUF ;IF NULL BUFFER, SKIP IT
PUSHJ P,K%SOUT ;ELSE PRINT IT
SETZM LINBUF ;CLEAR FIRST WORD OF BUFFER
MOVEI S1,LINMAX ;RESET THE BUFFER COUNTER
MOVEM S1,LINCTR ;TO ITS MAXIMUM
POP P,S1 ;RESTORE THE CHARACTER
$RETT ;AND RETURN
TDPB: IDPB S1,LINPTR ;STORE WHERE CALLER SPECIFIED
$RETT ;AND RETURN
^LSUBTTL PROBLK - Process an entire T%TEXT argument block
;PROBLK is used to process a list of T%TEXT arguments. The
; lower level routine, PROARG, is called to process each
; argument and errors are checked for.
; Call: ARGADR/ Address of start of argument block
;
; Return: Always TRUE
PROBLK: SETZM USRARG ;ASSUME NO ARGUMENTS BLOCK
SETZM MAXARG ;ZERO THE COUNT
SETZM NXTARG ;CLEAR POINTER TO NEXT ARGUMENT
MOVE S1,ARGADR ;GET ADDRESS OF ITEXT BLOCK
LOAD S2,0(S1),TXT.FN ;GET THE FUNCTION
CAIE S2,0 ;IS ARGUMENT BLOCK PRESENT?
JRST PROBL1 ;NO..PROCESS NORMALLY
MOVEM S1,USRARG ;SAVE ADDRESS OF ARGUMENTS
HLRZ S2,0(S1) ;YES..GET HEADER LENGTH
ADD S2,S1 ;COMPUTE START OF ITEXT
MOVEM S2,ARGADR ;AND SAVE THAT
SUBI S2,1 ;COMPUTE MAXIMUM ARG ADDRESS
MOVEM S2,MAXARG ;SAVE MAXIMUM ARGUMENT ADDRESS
ADDI S1,1 ;COMPUTE NEXT ARGUMENT ADDRESS
MOVEM S1,NXTARG
PROBL1: MOVE S1,ARGADR ;GET ADDRESS OF CURRENT ARGUMENT WORD
CAME S1,USRRET ;ARE WE PAST THE END?
SKIPN 0(S1) ; OR INTO ZERO WORD (ITEXT BLOCK END)?
$RETT ;YES, SO RETURN NOW TO CALLER
PUSHJ P,PROARG ;PROCESS THE ARGUMENT POINTED TO
JUMPT PROBL1 ;IF OK, DON'T STOP NOW
$STOP(BTA,<Bad $TEXT argument given at address ^O/ARGADR/>)
^LSUBTTL PROARG - Routine to process each T%TEXT argument
;PROARG is responsible for setting up argument specific data
; areas for the processing routines and adjusting ARGADR.
; CALL IS: NO ARGUMENTS
;
; RETURN: TRUE IF NO BAD ARGUMENTS DETECTED
; FALSE IF SOMETHING IS WRONG
;
PROARG: SETZM CACCTR ;CLEAR JUSTIFICATION COUNTER
SETZM CALOC ;CLEAR LOCATION WORD
MOVE S1,@ARGADR ;GET CONTENTS OF FIRST ARG WORD
TXNN S1,TXT.AD ;IS ADDRESS WORD PRESENT?
JRST PARG.1 ;NO..PROCESS OLD BLOCK
MOVEM S1,CAFLG ;YES..PROCESS 2 WORD BLOCK
AOS S1,ARGADR
MOVE S1,@ARGADR ;GET POINTER TO ARGUMENT
STORE S1,CALOC,TXT.EA ;SAVE EFFECTIVE ADDRESS
ANDX S1,TXT.PT ;MASK POINTER PORTION
MOVEM S1,CAPTR ;SAVE IT
JRST PARG.3 ;GO FINISH UP
PARG.1: STORE S1,CALOC,TXT.EA ;SAVE EFFECTIVE ADDRESS
TXZ S1,TXT.EA ;CLEAR IT
MOVEM S1,CAFLG ;SAVE THE FLAGS
SETZM CAPTR ;CLEAR POINTER WORD
MOVEI T1,@ARGADR ;Get address of this arg, for $STOP
LOAD S1,CAFLG,TXT.P ;IS THIS A TWO WORD TYPE OF ARG?
JUMPE S1,PARG.2 ;NO, SO ADJUST BY ONLY ONE WORD
AOS S1,ARGADR ;ELSE ADJUST FOR THE SECOND WORD NOW
MOVE S1,0(S1) ;GET THE BYTE POINTER WORD
MOVEM S1,CAPTR ;AND STORE FOR LATER
PARG.2: LOAD S1,CAFLG,TXT.S ;IS THERE A SPACING WORD?
JUMPE S1,PARG.3 ;NO, DONT PROCESS IT
AOS S1,ARGADR ;GET THE ADDRESS OF SPACING WORD
MOVE S1,0(S1) ;GET THE SPACING WORD
LOAD S2,S1,TXT.SC ;YES..GET THE FILL CHARACTER
STORE S2,CAFLG,TXT.FC
LOAD S2,S1,TXT.SS ;GET JUSTIFICATION CODE
STORE S2,CAFLG,TXT.JU
LOAD S2,S1,TXT.SP ;GET WIDTH
STORE S2,CAFLG,TXT.WD
PARG.3: AOS ARGADR ;ADJUST CURRENT ADDRESS
MOVE S1,CALOC ;GET ADDRESS
TXNN S1,<@(17)> ;INDEXING OR INDIRECT
JRST PARG.4 ;NO..THEN SKIP THIS
; PUSHJ P,I%IOFF## ;TURN OFF INTERRUPTS
MOVE 0,[XWD USRACS+1,1] ;RESTORE THE ACS
BLT 0,16 ;THAT WE MAY RESEMBLE
MOVE 0,USRACS ;THE USER'S CONTEXT
EXCH P,USRACS+P ;SET UP PUSHDOWN LIST TOO
MOVEI S1,@CALOC ;CALCULATE EFFECTIVE ADDRESS
MOVEM S1,CALOC ;STORE ACTUAL ADDRESS
EXCH P,USRACS+P ;RESTORE STACK POINTER
; PUSHJ P,I%ION## ;TURN ON INTERRUPTS
PARG.4: PJRST PROTXT ;PROCESS THE TEXT
^LSUBTTL PROTXT -- ROUTINE TO PROCESS THE ACTUAL FUNCTION
PROTXT: LOAD S1,CAFLG,TXT.FN ;GET THE QUALIFIER INDEX ALONE
CAILE S1,0 ;IF OUT OF RANGE,
CAIL S1,PTABL ;
$STOP(IQN,Illegal qualifier number ^O/S1/ at ^O/ARGADR/)
LOAD T1,CAFLG,TXT.WD ;GET SPACING POSITIONS
MOVEM T1,CACMAX ;STORE AS MAXIMUM CHARS IN FIELD
LOAD S2,CAFLG,TXT.JU ;AND GET SIDE CODE
CAXE T1,0 ;IF NO SPACING,
CAXN S2,.TXTJL ;OR LEFT JUSTIFYING ONLY
JRST PROTX1 ;THEN JUST DO THE OUTPUT
SETOM NOOUTP ;SUPRESS THE OUTPUT,
PUSHJ P,@PTAB(S1) ;THEN, CALL THE PROCESSOR
SETZM NOOUTP ;CLEAR THE SUPRESS FLAG
PUSHJ P,SPACES ;GIVE ANY PADDING NECESSARY,
LOAD S1,CAFLG,TXT.FN ;GET QUALIFIER NUMBER AGAIN
PROTX1: PUSHJ P,@PTAB(S1) ;DO THE OUTPUT
LOAD S1,CAFLG,TXT.WD ;GET SPACING POSITIONS
LOAD S2,CAFLG,TXT.JU ;AND SIDE CODE
CAXE S1,0 ;IF NOT SPACING,
CAXN S2,.TXTJR ; OR RIGHT JUSTIFYING,
$RETT ;JUST RETURN
PUSHJ P,SPACES ;GIVE ANY SPACES NEEDED
$RETT
^LSUBTTL PTAB - Dispatch table for argument processors
; Note well: Any changes in the order or contents of the TQUALS
; macro in GLXMAC should be reflected by recompilation and/or
; code changes in TXTLIB.
; Define processor table creation mechanism
DEFINE TQ(CHR,ARGS,TYP,PROC) <EXP PRO'CHR>
PTAB: PJRST .RETF ;FILL IN THE 0 (UNUSED) ENTRY
TQUALS ;AND THEN THE REST OF THE TABLE
PTABL==.-PTAB
DEFINE TQ(CHR,ARGS,TYP,PROC) <XWD ARGS,"CHR">
PTAB2: EXP 0 ;FILL IN THE 0 (UNUSED) ENTRY
TQUALS ;AND THEN THE REST OF THE TABLE
^LSUBTTL PROx - Processors for each type of formatting
;The following are the separate processors for each type of
; ASCII formatting that we might have to do. Most are system
; independent, a couple are not. for all intents and
; purposes, these are the top level routines, and they have
; access to all AC's etc.
;Several locations are set up for these routines to use:
; CALOC is the effective address of the current argument
; or 0 (which will be unused) for TXT.NA (argument-less) qualifers
; CAFLG is the flag word for this argument
; CAPTR is the optional pointer word, used to get only a byte from the
; word containing the argument.
; ARGADR points to the word immediately following this argument in the list
; USRACS contain registers 0-17 inclusive of the caller's ACS
; USRRET contains the address of the first word not part of this $TEXT's
; argument block. It is used to calculate the end of the T%TEXT arg block
.
;USROUT contains the address of the user routine for
; outputting each byte The supplied routine takes its byte as
; 7 bit ASCII, right justified in AC S1, and returns either
; TRUE or FALSE. A return of FALSE will cause a STOP CODE to
; occur. The output routine supplied may destroy both S1 and
; S2, but must preserve all other registers.
;Each of the following routines is named 'PROx' where x is
; the letter or digit corresponding to the $TEXT qualifier
; that follows the '^' (up-arrow) to indicate that this type
; of output is wanted.
^LSUBTTL PROT - Process a string of ASCIZ text
;Since a user created string could be in the ACs or be a field or
; something odd like that, we process it one word at at a time if we
; have to. If we do not, then we go to PRO3 which is faster.
PROT: MOVE P1,CALOC ;GET LOCATION OF STRING
MOVEI P2,0 ;FAKE EXHAUSTED COUNT
SKIPN CAPTR ;IS THIS A FIELD ONLY?
CAIGE P1,20 ;OR IN THE ACS?
SOSA P1 ;YES, BACK ADDR OF ONE FOR LOOP, USE WOR
D BY WORD
JRST PRO3 ;ELSE DO AS PURE ASCIZ STRING
PROT.1: SOJGE P2,PROT.2 ;ANY MORE BYTES IN WORD?
AOS S1,P1 ;NO, NEED NEXT WORD
PUSHJ P,FETCH ;SO GET IT
MOVE P3,S1 ;AND MOVE INTO PERMANENT PLACE
MOVE P4,[POINT 7,P3] ;MAKE UP A BYTE POINTER
MOVEI P2,4 ;GET NEW COUNT
PROT.2: ILDB S1,P4 ;GET A BYTE
JUMPE S1,.RETT ;RETURN NOW IF WE GET A NULL
PUSHJ P,PUT7 ;PUT OUT THE BYTE
JRST PROT.1 ;LOOP FOR NEXT BYTE
SUBTTL PRO3 - Process a an ASCIZ string created by $TEXT
;PRO3 is used to process strings created by the $TEXT instruction itself.
; These strings do not have to be processed word by word since
; they are created in a literal.
PRO3: MOVE S1,CALOC ;GET LOCATION STRING STARTS AT
PJRST PUTT ;STORE THE STRING
^LSUBTTL PROQ - Process a byte pointer to an ASCIZ string
;PROQ is used to process an ASCIZ string which does not start on a word
; boundary. The address fed to the ^Q qualifer is that of a byte
; pointer to the string to be output.
PROQ: PUSHJ P,.SAVE1 ;PRESERVE AN AC
MOVE S1,CALOC ;GET LOCATION OF BYTE POINTER
PUSHJ P,FETCH ;FETCH IT NOW
TLNN S1,777700 ;WAS POINTER SPECIFIED?
TLO S1,(POINT 7,0) ;NO..MAKE STANDARD POINTER
TLC S1,-1
TLCN S1,-1 ;WAS POINTER -1,,X
HRLI S1,(POINT 7,0) ;YES..CREATE BYTE POINTER
PROQ.1: TXNN S1,<@(17)> ;INDIRECT OR INDEXED?
JRST PROQ.3 ;NO..PROCESS IT
LDB S2,[POINT 4,S1,17] ;GET THE INDEX FIELD
JUMPE S2,PROQ.2 ;JUMP IF NO INDEXING
HRRZ S2,USRACS(S2) ;GET THE INDEX VALUE
ADDI S2,(S1) ;DO INDEX CALCULATION
HRR S1,S2 ;STORE NEW EFFECTIVE ADDRESS
TLZ S1,17 ;CLEAR INDEXING
PROQ.2: TXNN S1,<@> ;INDIRECT?
JRST PROQ.3 ;NO..FINISH UP
MOVE P1,S1 ;SAVE THE POINTER
HRRZ S1,S1 ;EXTRACT THE ADDRESS
PUSHJ P,FETCH ;GET THE INDIRECT WORD
LDB S2,[POINT 12,P1,11] ;GET POSITION AND SIZE
DPB S2,[POINT 12,S1,11] ;STORE IN NEW POINTER
JRST PROQ.1 ;PROCESS POINTER
PROQ.3: HRRZ S2,S1 ;GET ADDRESS
CAIGE S2,20 ;POINT TO THE AC'S?
ADDI S2,USRACS ;YES..POINT TO OUR COPY
JRST PUTQ ;OUTPUT IT
^LSUBTTL PROB - Process a GLXLIB object block
PROB: MOVE P1,CALOC ;GET ARG LOC
MOVEI S1,OBJ.TY(P1) ;GET ADDRESS OF TYPE WORD
PUSHJ P,FETCH ;GET ITS CONTENTS
MOVE T1,S1 ;SAVE THE OBJECT TYPE IN T1
MOVSI P2,-OBJLEN ;MAKE AN AOBJN PTR TO TABLE OF OBJECTS
PROB.1: HLRZ S2,OBJTAB(P2) ;GET OBJECT TYPE FROM TABLE
CAME S2,S1 ;MATCH?
AOBJN P2,PROB.1 ;NO, LOOP
JUMPGE P2,.RETF ;AOBJN EXPIRED, LOSE
HRRZ S1,OBJTAB(P2) ;GET ADDRESS OF APPROPRIATE TEXT
PUSHJ P,PUTT ;AND OUTPUT IT
$PUT7(< >) ;OUTPUT A SPACE
MOVEI S1,OBJ.UN(P1) ;GET ADDRESS OF UNIT NUMBER WORD
PUSHJ P,FETCH ;FETCH IT
CAXN T1,.OTMNT ;IS THIS A TAPE/DISK OBJECT TYPE
JRST [PUSHJ P,PUTW ;YES,,PUT OUT THE UNIT AS SIXBIT
PJRST PROB.2 ] ;AND CONTINUE ON
MOVE P2,S1 ;COPY IT
LOAD S1,P2,OU.LRG ;GET LOW END OF RANGE
PUSHJ P,PUTD ;OUTPUT IT IN DECIMAL
LOAD S1,P2,OU.HRG ;GET HIGH END OF RANGE
JUMPE S1,PROB.2 ;SKIP IF NO HIGH UNIT
$PUT7(<:>) ;OUTPUT RANGE SEPARATOR
PUSHJ P,PUTD ;AND THEN HIGH END OF RANGE
PROB.2: MOVEI S1,OBJ.ND(P1) ;GET ADDRESS OF USER'S NODE WORD
PUSHJ P,FETCH ;GO GET ITS CONTENTS
SKIPN T1,S1 ;SAVE THE SUPPLIED NODE
JRST PROB.4 ;DONT DISPLAY IF NULL
TOPS10< TLNN S1,770000 ;MAKE SURE WE HAVE SIXBIT
$CALL CNVNOD
JUMPF [MOVE S1,T1 ;FAILURE..RESTORE SUPPLIED NODE
JRST PROB.3] ;AND DISPLAY IT
MOVE T1,S1 ;SAVE SIXBIT NODE
> ;End TOPS10
SETOM S1 ;SET FOR MY JOB
MOVX S2,JI.LOC ;GET MY LOCATION
PUSHJ P,I%JINF
JUMPF [MOVE S1,T1 ;RESTORE THE SUPPLIED NODE
JRST PROB.3] ;AND DISPLAY IT
MOVE S1,T1 ;PLACE SIXBIT IN S1
CAMN S2,S1 ;SAME LOCATION?
JRST PROB.4 ;YES..RETURN
PROB.3: PUSH P,S1 ;SAVE THE NODE SPEC
$PUTT(< [>) ;OPENER
POP P,S1 ;RESTORE IT
PUSHJ P,PUTN ;PUT OUT THE NODE NAME
$PUT7(<]>) ;AND CLOSER
PROB.4: $RETT
^LSUBTTL PRO1 - Process an object type
PRO1: MOVE S1,CALOC ;GET ADDR OF ARGUMENT
PUSHJ P,FETCH ;FETCH IT
MOVSI P1,-OBJLEN ;MAKE AN AOBJN PTR TO TABLE OF OBJECTS
PRO1.1: HLRZ S2,OBJTAB(P1) ;GET OBJECT TYPE FROM TABLE
CAME S2,S1 ;MATCH?
AOBJN P1,PRO1.1 ;NO, LOOP
JUMPGE P1,.RETF ;AOBJN EXPIRED, LOSE
HRRZ S1,OBJTAB(P1) ;GET ADDRESS OF APPROPRIATE TEXT
PJRST PUTT ;AND OUTPUT IT
;Define the X macro so we can generate the table of strings
; for the object types.
DEFINE X(A,B),<
XWD A,[ASCIZ/B/]
>
;Now generate the table of object type strings.
OBJTAB: OBJCTS
OBJLEN==.-OBJTAB
SUBTTL PRON - Process a node specification
PRON: MOVE S1,CALOC ;GET ADDRESS OF ARGUMENT
PUSHJ P,FETCH ;FETCH FROM USER SPACE
PJRST PUTN ;AND PRINT IT OUT
^LSUBTTL PROO - Process unsigned octal numbers
PROO: MOVE S1,CALOC ;GET ARGUMENT LOCATION
PUSHJ P,FETCH ;FETCH IT
PJRST PUTO ;JUST PRINT THE NUMBER
SUBTTL PROD - Process a signed decimal number
PROD: MOVE S1,CALOC ;GET ADDRESS OF CURRENT ARGUMENT
PUSHJ P,FETCH ;GET IT
PJRST PUTD ;JUST PRINT THE NUMBER
^LSUBTTL PROF - Process a system dependent file specification
TOPS10 <
PROF: MOVE P1,CALOC ;GET LOCATION OF THE FD
MOVEI S1,.FDSTR(P1) ;LOCATION OF STRUCTURE NAME
PUSHJ P,FETCH ;GET IT
JUMPE S1,PROF.1 ;IF NULL, FORGET IT
PUSHJ P,PUTW ;PRINT IT
$PUT7(<:>) ;FOLLOW IT WITH COLON
PROF.1: MOVEI S1,.FDNAM(P1) ;GET NAME OF FILE
PUSHJ P,FETCH ;FROM USER
SKIPE S1 ;IF NULL, DON'T PRINT IT
PUSHJ P,PUTW ;PRINT AS SIXBIT WORD
MOVEI S1,.FDEXT(P1) ;NOW GET EXTENSION
PUSHJ P,FETCH ;FROM USER
JUMPE S1,PROF.2 ;IF NULL, IGNORE IT
$PUT7(<.>) ;PUT OUT DOT AS FILE.EXT SEPARATOR
PUSHJ P,PUTW ;NOW PRINT THE SIXBIT EXTENSION
PROF.2: MOVEI S1,.FDPPN(P1) ;GET LOCATION OF PPN
PUSHJ P,FETCH ;GET THE PPN
JUMPE S1,.RETT ;IF NULL,SKIP PPN AND PATH
PUSH P,S1 ;SAVE PPN
$PUT7(<[>) ;PUT OUT A BRACKET TO OPEN PPN
HLRZ S1,0(P) ;ISOLATE PROJECT NUMBER
PUSHJ P,PUTO ;PUT IT OUT
$PUT7(<,>) ;SEPARATE HALVES
POP P,S1 ;RESTORE PPN
ANDI S1,-1 ;ISOLATE THE PROGRAMMER NUMBER
PUSHJ P,PUTO ;PRINT IT
MOVEI S1,.FDLEN(P1) ;GET ADDRESS OF FD LENGTH
PUSHJ P,FETCH ;FETCH IT
LOAD S1,S1,FD.LEN ;GET LENGTH ONLY
CAIG S1,.FDPAT ;IS THERE A PATH?
JRST PROF.4 ;NO
SUBI S1,.FDPAT ;GET NUMBER OF SFDS
MOVNS S1 ;NEGATE IT
HRL P1,S1 ;GET COUNT INTO PLACE
PROF.3: MOVEI S1,.FDPAT(P1) ;GET SFD LOCATION
PUSHJ P,FETCH ;LOAD IT
JUMPE S1,PROF.4 ;Null SFD? All done then...
$PUT7(<,>) ;Nonnull, type a comma
PUSHJ P,PUTW ;PRINT IT
AOBJN P1,PROF.3 ;LOOP FOR ALL
PROF.4: $PUT7(<]>) ;CLOSE PPN WITH A BRACKET
> ;END TOPS10 CONDITIONAL
TOPS20 <
PROF: MOVEI S1,.FDSTG ;GET OFFSET TO DESCRIPTIVE STRING
PUSH P,CALOC ;SAVE LOCATION OF ARGUMENT
ADDM S1,CALOC ;POINT TO "STRING PART" OF FD
PUSHJ P,PROT ;HANDLE AS ASCIZ TEXT
POP P,CALOC ;RESTORE ORIGINAL LOCATION
> ;END TOPS20 CONDITIONAL
$RETT ;THEN RETURN
^LSUBTTL PRO7 - Process a single 7 bit ASCII character
PRO7: MOVE S1,CALOC ;GET LOCATION
PUSHJ P,FETCH ;FETCH THE CHARACTER
PJRST PUT7 ;PRINT IT AND RETURN FROM THERE
SUBTTL PRO6 - Process a single 6 bit ASCII character
PRO6: MOVE S1,CALOC ;GET LOCATION
PUSHJ P,FETCH ;LOAD IT
PJRST PUT6 ;PRINT IT AND RETURN FROM THERE
SUBTTL PRO5 - Process ASCIZ single word
PRO5: MOVE S1,CALOC ;GET LOCATION OF WORD TO PRINT
PUSHJ P,FETCH ;LOAD IT
MOVEM S1,TTXBUF ;STORE INTO TEMPORARY BUFFER
SETZM S1,TTXBUF+1 ;INSURE 6TH CHARACTER IS NULL
MOVEI S1,TTXBUF ;GET LOCATION TO PUT OUT STRING AT
PJRST PUTT ;AND PUT OUT THE TEXT
SUBTTL PROW - Process a SIXBIT word
PROW: MOVE S1,CALOC ;GET LOCATION OF ARGUMENT
PUSHJ P,FETCH ;LOAD FROM USER ADDRESS SPACE
SKIPN CAPTR ;IF NOT A BYTE,
PJRST PUTW ;JUST PRINT IT OUT
JUMPE S1,.RETT ;IF NULL, RETURN NOW
PROW.1: TXNE S1,77B5 ;IS FIELD LEFT JUSTIFIED?
PJRST PUTW ;YES, PRINT IT OUT NOW
LSH S1,6 ;SHIFT OVER ONE PLACE
JRST PROW.1 ;AND TRY AGAIN
^LSUBTTL PROP - Process a directory ID of either PPN or directory NUMBER
SUBTTL PROU - Process a user ID or either PPN or User number
PROU: SKIPA T1,[EXP JI.USR] ;USE JOB'S USER NUMBER
PROP: MOVX T1,JI.CDN ;USE JOB'S DIRECTORY NUMBER
MOVE S1,CALOC ;GET CURRENT ARGUMENT'S LOCATION
PUSHJ P,FETCH ;NOW FETCH THAT ARGUMENT
CAME S1,[EXP -1] ;DO THEY WANT THE DEFAULT?
PJRST PUTU ;NO,OUTPUT USER INFO
MOVE S2,T1 ;PLACE FUNCTION CODE IN S2
PUSHJ P,I%JINF ;GET THE DATA
MOVE S1,S2 ;PLACE VALUE IN S1
PROP.1: PJRST PUTU ;OUTPUT USER INFO
^LSUBTTL PROR - Process routine for Job Info Block
;This routine will output the Job Info Block for the Galaxy
; Spoolers or anyone formating a JIB according to GLXMAC
; Specification.
PROR: MOVEI S1,[ASCIZ/Job /] ;START JOBNAME
PUSHJ P,PUTT ;OUTPUT THE TEXT
MOVE P1,CALOC ;GET ADDR OF ARGUMENT
MOVEI S1,JIB.JN(P1) ;GET THE ADDRESS OF JOBNAME FIELD
PUSHJ P,FETCH ;FETCH IT
JUMPE S1,.RETF ;NONE..ERROR..RETURN FALSE
PUSHJ P,PUTW ;DISPLAY THE JOBNAME
MOVEI S1,[ASCIZ/ Req #/] ;REQUEST IDENTIFIER
PUSHJ P,PUTT ;OUTPUT BLOCK
MOVEI S1,JIB.ID(P1) ;GET ADDRESS OF REQUEST ID
PUSHJ P,FETCH ;FETCH IT
JUMPLE S1,.RETF ;ERROR...RETURN
PUSHJ P,PUTD ;OUTPUT THE NUMBER
MOVEI S1,[ASCIZ/ for /] ;USER NAME IDENTIFIER
PUSHJ P,PUTT ;OUTPUT THE TEXT
TOPS10 <
MOVEI S1,JIB.NM(P1) ;GET USER NAME WORD 1
PUSHJ P,FETCH ;FETCH IT
JUMPE S1,PROR.3 ;NO NAME GO TO PPN
MOVE P2,CACCTR ;GET CURRENT CHARACTER COUNT
ADDI P2,6 ;EXPECTED COUNT AFTER OUTPUT
PUSHJ P,PUTW ;OUTPUT THE NAME
SUB P2,CACCTR ;GET COUNT OUTPUT
MOVEI S1,JIB.NM+1(P1) ;GET USER NAME WORD 2
PUSHJ P,FETCH ;FETCH IT
JUMPE S1,PROR.3 ;ANYTHING ELSE TO PRINT ?
JUMPE P2,PROR.2 ;ALL OUT CONTINUE ON
PUSH P,S1 ;SAVE USER NAME WORD 2
PROR.1: MOVEI S1,40 ;GET A BLANK
PUSHJ P,PUT7 ;OUTPUT THE BLANK
SOJG P2,PROR.1 ;FILL TO 6 CHARACTERS
POP P,S1 ;GET SAVED S1
PROR.2: PUSHJ P,PUTW ;OUTPUT THE NAME
PROR.3: MOVEI S1,40 ;GET A BLANK
PUSHJ P,PUT7 ;OUTPUT THE CHARACTER
>;END TOPS10
MOVEI S1,JIB.US(P1) ;GET USER NUMBER OR PPN
PUSHJ P,FETCH ;FETCH THE ARGUMENT
PJRST PUTU ;DISPLAY USER NAME OR PPN AND RETURN
^L
PROH: TDZA P1,P1 ;USE FOR FLAG THAT DATE IS WANTED
PROC: SETO P1, ;-1 MEANS TIME ONLY
MOVE S1,CALOC ;GET LOCATION OF ARGUMENT
PUSHJ P,FETCH ;GRAB IT
CAMN S1,[EXP -1] ;IS IT -1, FOR "NOW"?
PUSHJ P,I%NOW ;GET CURRENT DATE AND TIME
TOPS20 <
PUSH P,S1 ;SAVE S1
CAML S1,DSTCHG ;HAVE WE PASSED NEXT 0200?
PUSHJ P,CLCFCT ;YUP, RECOMPUTE LOCAL ADJUSTMENT FACTOR
POP P,S1 ;RESTORE S1
ADD S1,TMFCTR ;MAKE LOCAL TIME ADJUSTMENT
SKIPGE S1 ;GUARD AGAINST GARBAGE DATES
SETZ S1,0 ;AND SET TO EARLIEST POSSIBLE
>;;END OF TOPS20 CONDITIONAL ASSEMBLY
PROH.1: PUSHJ P,CNTDT ;TAKE IT APART
DMOVE T1,S1 ;GET THE RETURNED VALUES
PUSH P,S1 ;SAVE TIME
JUMPL P1,PROH.2 ;IF FLAG IS UP, GIVE TIME ONLY
MOVE T1,T2 ;POSITION DATE
IDIVI T1,^D31 ;GET DAYS
MOVE T4,T1 ;SAVE REST
MOVEI S1,1(T2) ;GET DAYS AS 1-31
CAIGE S1,^D10 ;IF ONE DIGIT,
$PUT7(< >) ; FILL WITH A SPACE
PUSHJ P,PUTD ;PRINT DECIMAL NUMBER
IDIVI T4,^D12 ;GET MONTHS
MOVEI S1,[ASCIZ /-Jan/
ASCIZ /-Feb/
ASCIZ /-Mar/
ASCIZ /-Apr/
ASCIZ /-May/
ASCIZ /-Jun/
ASCIZ /-Jul/
ASCIZ /-Aug/
ASCIZ /-Sep/
ASCIZ /-Oct/
ASCIZ /-Nov/
ASCIZ /-Dec/](P1) ;GET ASCII
PUSHJ P,PUTT ;TYPE THE ASCIZ STRING
MOVEI S1,^D64(T4) ;GET YEAR SINCE 1900
IDIVI S1,^D100 ;GET JUST YEARS IN CENTURY
MOVN S1,S2 ;NEGATE TO GET - SIGN
PUSHJ P,PUTD ;TYPE IT OUT
$PUT7(< >) ;NOW SPACE OVER ONE
PROH.2: POP P,S1 ;GET TIME BACK
IDIV S1,[DEC 3600000] ;GET HOURS
MOVE T4,S2 ;SAVE REST
CAIGE S1,^D10 ;IF ONLY ONE DIGIT,
$PUT7(< >) ;SPACE OVER
PUSHJ P,PUTD ;PUT DECIMAL NUMBER OUT
$PUT7(<:>) ;NOW A COLON TO DIVIDE HOURS FROM MINUTE
S
MOVE S1,T4 ;RESTORE REST
IDIV S1,[DEC 60000] ;GET MINUTES
MOVE T4,S2 ;SAVE REST
CAIGE S1,^D10 ;IF NOT TWO DIGITS,
$PUT7(<0>) ;GIVE A ZERO FILL
PUSHJ P,PUTD ;PRINT DECIMAL MINUTES
$PUT7(<:>) ;AND SEPARATING COLON
MOVE S1,T4 ;RESTORE THE REST
IDIV S1,[DEC 1000] ;EXTRACT THE SECONDS
CAIGE S1,^D10 ;IF ITS NOT TWO DIGITS,
$PUT7(<0>) ; ZERO FILL IT
PJRST PUTD ;THEN PRINT IT, RETURN
^LSUBTTL PROE - Process a GLXLIB error number
PROE: MOVE S1,CALOC ;GET LOCATION OF THE ARGUMENT
PUSHJ P,FETCH ;GET IT
TOPS20<
CAMN S1,[EXP -2] ;WANT LAST TOPS20 ERROR
JRST PROE.4 ;YES..SETUP ERRO VALUES
>;END TOPS20
CAMN S1,[EXP -1] ;WANT 'LAST ERROR'?
SKIPA S1,.LGERR ;YES, PICK UP LAST ERROR PROCESS VIA .ER
ET
CAIL S1,0 ;IF LESS THAN 0 OR
CAIL S1,ERRSLN ; OFF THE END OF THE TABLE
PJRST PROE.1 ;CHECK FOR -20 ERRORS
HRRZ S1,ERRTAB(S1) ;GET STRING ADDRESS
PJRST PUTT ;RETURN AFTER PUTTING OUT THE STRING
PROE.1:
TOPS20< MOVE S2,S1 ;PLACE CODE IN S2
CAIGE S1,.ERBAS ;CHECK FOR -20 ERROR
PJRST PROE.3 ;BAD ERROR CODE
PROE.2: PUSH P,S2 ;SAVE S2
MOVEI S1,EBFSZ ;SIZE OF THE BUFFER
; PUSHJ P,M%GMEM ;GET BUFFER ADDRESS
MOVEI S2,GENBUF ;**GET GEN BUFFER FOR
MOVEM S2,ERRBUF ;SAVE THE ADDRESS
POP P,S2 ;RESTORE ERROR CODE
HRLI S2,.FHSLF ;FOR THIS PROCESS
HRROI S1,@ERRBUF ;STORE IN ERROR BUFFER
HRLZI T1,-<EBFSZ*5> ;MAXIMUM NUMBER OF CHARACTERS
ERSTR ;DO THE FUNCTION
PJRST PROE.3 ;BAD ERROR CODE
$RETF ;BAD STRING SIZE
MOVEI S1,@ERRBUF ;POINT TO ERROR BUFFER
PUSHJ P,PUTT ;DUMP THE TEXT
MOVEI S1,EBFSZ ;SIZE OF AREA
MOVE S2,ERRBUF ;ADDRESS OF BUFFER
; PUSHJ P,M%RMEM ;RETURN THE MEMORY
$RETT ;RETURN
PROE.3: PUSH P,S2 ;SAVE S2
MOVEI S1,[ASCIZ/Invalid Error Code /]
PUSHJ P,PUTT ;PUT OUT THE TEXT
POP P,S2 ;RESTORE S2
HRRZ S1,S2 ;GET THE ERROR CODE ONLY
PUSHJ P,PUTO ;DUMP THE NUMBER
$RETT ;RETURN
PROE.4: MOVEI S2,-1 ;GET LAST ERROR
JRST PROE.2 ;FINISH OFF ERROR
>;END TOPS20
TOPS10< $RETF > ;ERROR..JUST RETURN
;Make a table of known errors, for each we have the address
; of expanded string.
DEFINE ERR(A,B)<
Z [ASCIZ \B\]
> ;END OF ERR DEFINITION
ERRTAB: [ASCIZ /No errors yet/] ;0 ENTRY FOR LAST ERROR, BUT NONE SEEN
ERRORS ;PRODUCE THE TABLE
ERRSLN==.-ERRTAB ;LENGTH OF TABLE
^LSUBTTL PROI - Process an indirect text request
;Just as ^T can be used to include remote ASCIZ strings in a
; $TEXT call, the ^I qualifier can be used to include strings
; that are more complex. The address specified with an ^I
; qualifier specifies the location of a block, built with the
; ITEXT macro, which will be included at this point in the
; $TEXT string. Any qualifier may appear in the ITEXT string,
; including more ^I qualifiers.
PROI: $SAVE <CAFLG,ARGADR,USRARG,MAXARG,NXTARG>
MOVE S1,CALOC ;GET ADDRESS GIVEN AS ^I ARGUMENT
MOVEM S1,ARGADR ;MAKE IT NEW ARG ADDR
PUSHJ P,PROBLK ;PROCESS THE BLOCK POINTED TO
$RETT ;THEN RETURN
^LSUBTTL PROV - Process a program version number
; Type out a specially formatted program version number. This is the
; standard version number, containing version number, major and
; minor edit numbers and a code indicating who editted the code last.
; Define the fields of the version number
VI%WHO==7B2 ;WHO EDITTED LAST
VI%MAJ==777B11 ;MAJOR VERSION NUMBER
VI%MIN==77B17 ;MINOR VERSION NUMBER
VI%EDT==777777B35 ;EDIT NUMBER
PROV: MOVE S1,CALOC ;GET LOCATION OF VERSION NUMBER
PUSHJ P,FETCH ;FETCH IT
MOVE P1,S1 ;GET INTO SAFER PLACE
LOAD S1,P1,VI%MAJ ;GET MAJOR VERSION NUMBER
PUSHJ P,PUTO ;PRINT IT OUT
LOAD P2,P1,VI%MIN ;GET MINOR VERSION NUMBER
JUMPE P2,PROV.2 ;SKIP MINOR VERSION IF ZERO
SUBI P2,1 ;BACK OFF ONE
IDIVI P2,^D26 ;PICK APART LETTERS
JUMPE P2,PROV.1 ;IF FIRST LETTER NULL, SKIP IT
MOVEI S1,"A"-1(P2) ;GET FIRST PART
PUSHJ P,PUT7 ;PUT OUT THE LETTER
PROV.1: MOVEI S1,"A"(P3) ;CONVERT IT
PUSHJ P,PUT7 ;AND PRINT IT
PROV.2: $PUT7(<(>) ;PUT OUT PARENTHESIS
LOAD S1,P1,VI%EDT ;GET THE EDIT NUMBER
PUSHJ P,PUTO ;PRINT IT
$PUT7(<)>) ;AND CLOSE PARENTHESIS
LOAD S1,P1,VI%WHO ;GET FINAL PART
JUMPE S1,.RETT ;IF NULL, WE ARE DONE
$PUT7(-) ;ELSE SEPARATE "WHO" FIELD AND
PJRST PUTO ;RETURN PRINTING IT
^LSUBTTL PROM - Process a request for a CONTROL-M (Carriage Ret.)
PROM: MOVEI S1,"M"-100 ;LOAD ^M
PJRST PUT7 ;PUT IT OUT,RETURN
SUBTTL PROJ - Process a request for a CONTROL-J (Line Feed)
PROJ: MOVEI S1,"J"-100 ;LOAD ^J
PJRST PUT7 ;PUT IT OUT,RETURN
SUBTTL PROL - Process a request for a CONTROL-L (Form Feed)
PROL: MOVEI S1,"L"-100 ;LOAD ^L
PJRST PUT7 ;PUT IT OUT, RETURN
SUBTTL PROK - Process a request for a CONTROL-K (Vertical Tab)
PROK: MOVEI S1,"K"-100 ;LOAD ^K
PJRST PUT7 ;PUT IT OUT, RETURN
SUBTTL PRO2 - Process a request for up-arrow
PRO2: MOVEI S1,"^" ;GET UP-ARROW OR CARET
PJRST PUT7 ;AND PUT IT OUT
SUBTTL PROA - Process a request to supress free <CR-LF>
PROA: SETOM ENDFLG ;SET FLAG TO SUPRESS END OF TEXT STUFF
$RETT ;TAKE GOOD RETURN
SUBTTL PRO0 - Process a request to put null (0) at end of line
PRO0: MOVEI S1,1 ;SET END TO PUT NULL INSTEAD
MOVEM S1,ENDFLG ;OF CR-LF AT END OF LINE
$RETT ;AND RETURN
^LSUBTTL FETCH - Routine to get a word from caller's address space
;FETCH is responsible for getting a word from the user,
; checking for it's being in the AC shadow block and masking
; for proper size and place if the argument has a byte-mode
; address.
; Call: S1/ Address to fetch word from
;
; Return: S1/Contents of that word or byte
FETCH: CAIG S1,17 ;IS THE VALUE IN THE ACS?
SKIPA S1,USRACS(S1) ;YES, FETCH IT FROM THERE
MOVE S1,0(S1) ;OTHERWISE, PICK IT UP FROM MEMORY
SKIPN S2,CAPTR ;IS THERE A POINTER WORD?
$RETT ;NO, SO RETURN NOW
HRRI S2,S1 ;POINT TO REGISTER WITH WHOLE WORD
LDB S1,S2 ;GET PROPER PART
$RETT ;AND TAKE GOOD RETURN
^LSUBTTL SPACES - Routine to provide any padding requested
;Spaces is actually a misnomer, since the pad character may
; be any character that the user specifies. The spacing
; information is passed in an optional word associated with
; each argument. The user may specify the number of spaces
; that the field will take up, the side to justify to, and the
; character to pad with. Only the width actually must be
; given, as the side and character are defaulted by the $TEXT
; macros. The default justification is right justification
; for numeric items (^D and ^O) and left justification for all
; others. The default padding character is always a blank
; (octal 40).
;This routine places X pad characters into the output stream,
; where X is computed as the difference between the number in
; CACCTR and the user specified width. It also provides the
; centering.
; Call: CACCTR should be set up
;
; Return: Always TRUE
SPACES: PUSHJ P,.SAVE1 ;GET ONE PERMANENT REGISTER
LOAD P1,CAFLG,TXT.WD ;GET THE SPACING CODE WIDTH
SUB P1,CACCTR ;SUBTRACT CHARACTERS FOR OUTPUT
SETZM CACCTR ;THEN CLEAR CHARACTERS OUTPUT
LOAD S1,CAFLG,TXT.JU ;NOW GET THE SPACING CODE
CAXE S1,.TXTJC ;WANT THIS CENTERED?
JRST SPAC.1 ;NO, SO SKIP THIS
ASH P1,-1 ;DIVIDE SPACING NEEDED BY 2
MOVX S1,.TXTJL ;SET NOW FOR LEFT JUSTIFICATION ONLY
STORE S1,CAFLG,TXT.JU ;AND FALL INTO REGULAR SPACING CODE
SPAC.1: JUMPLE P1,.RETT ;CHECK FOR DONENESS
LOAD S1,CAFLG,TXT.FC ;GET THE CHARACTER TO OUTPUT
PUSHJ P,PUT7 ;AND PRINT IT
SOJA P1,SPAC.1 ;REPEAT TILL DONE
^LSUBTTL Local output routines
;These routines are local to the TEXT module and are used to
; do output. TXTLIB cannot use the $TEXT macro because it
; would overwrite the callers AC's with its own.
; PUTTX -- Output an ASCIZ string, called via the $PUTT macro
PUTTX: PUSH P,S1 ;SAVE ACS S1 AND S2
PUSH P,S2 ;
AOS S1,-2(P) ;UPDATE STACK, GET ADDRESS
HRRZ S1,-1(S1) ;PICK UP ADDRESS OF STRING
PUSHJ P,PUTT ;CALL ROUTINE
PJRST S2POPJ ;RETURN, RESTORING THE ACS
; PUTT -- Output an ASCIZ string, address of string is in S1
PUTT: PUSHJ P,.SAVE1 ;GET ONE PERMANENT AC
HRRZ P1,S1 ;GET ADDRESS INTO IT
HRLI P1,(POINT 7,0) ;CONVERT IT TO A BYTE POINTER
PUTT1: ILDB S1,P1 ;GET A BYTE
JUMPE S1,.RETT ;IF NULL, RETURN
PUSHJ P,PUT7 ;PRINT THE CHARACTER
JRST PUTT1 ;LOOP FOR NEXT ONE
; PUT7X -- Output a character, called via the $PUT7 macro
PUT7X: PUSH P,S1 ;SAVE S1
PUSH P,S2 ;AND S2
AOS S1,-2(P) ;UPDATE STACK, GET ADDRESS
HRRZ S1,-1(S1) ;GET CHARACTER
PUSHJ P,PUT7 ;PUT OUT THE CHARACTER
S2POPJ: POP P,S2 ;RESTORE THE AC
POP P,S1 ;AND THE OTHER
POPJ P, ;RETURN
; PUT7 -- Output a character, character in S1
PUT7: SKIPE ERREXT ;IF AN ERROR HAS OCCURED,,
$RETT ; THEN JUST RETURN.
MOVX TF,177 ;MASK SEVEN BITS
AND TF,S1 ;PUT CHARACTER IN TF
AOS S1,CACCTR ;INCREASE CHARACTER COUNT
SKIPE NOOUTP ;SUPRESSING ACTUAL OUTPUT?
$RETT ;YES, RETURN TRUE NOW
SKIPN CACMAX ;IF FIELD IS NOT COUNTED
MOVX S1,1B0 ;MAKE ALL CHARACTERS BE PRINTED
CAMLE S1,CACMAX ;CHECK FOR MAXIMUM
$RETT ;IF TOO MANY, DON'T PRINT IT
MOVE S1,TF ;RESTORE CHARACTER
PUSHJ P,@USROUT ;OUTPUT IT
PORTAL .+1 ;ALLOW EXECUTE-ONLY RETURN
JUMPT .RETT ;IF RETURNED OK, RETURN NOW
SETOM ERREXT ;INDICATE AN ERROR OCCURED.
$RETT ;AND RETURN.
^L; PUTQ -- Output an ASCIZ string, byte pointer to string is in S1
PUTQ: PUSHJ P,.SAVE1 ;SAVE ONE PERM AC
MOVE P1,S1 ;COPY POINTER
JRST PUTT1 ;AND CONTINUE
; PUTO -- Output an unsigned octal number, number in S1
PUTO: PUSHJ P,.SAVE3 ;GET 3 REGISTERS
MOVEI P1,0 ;CLEAR SHIFT REGISTER
MOVE P2,S1 ;GET INTO GOOD PLACE
MOVEI P3,^D12 ;TWELVE POSSIBLE DIGITS
PUTO.1: LSHC P1,3 ;DELETE LEADING 0
SKIPN P1 ;IF STILL ZERO,
SOJG P3,PUTO.1 ;LOOP
PUTO.2: ANDI P1,7 ;ISOLATE THE BYTE
MOVEI S1,"0"(P1) ;MAKE IT ASCII
PUSHJ P,PUT7 ;PUT OUT THE BYTE
LSHC P1,3 ;GET NEXT BYTE
SOJG P3,PUTO.2 ;REPEAT
$RETT ;OR RETURN NOW
; PUTD -- Put out a signed decimal number, number in S1
PUTD: PUSHJ P,.SAVE2 ;NEED TWO ACS
MOVE P1,S1 ;GET INTO PERMANENT PLACE
JUMPGE P1,PUTD.1 ;IS IT NEGATIVE?
$PUT7(<->) ;YES, SO PRINT A MINUS SIGN
MOVMS P1 ;AND CONVERT TO POSITIVE
PUTD.1: IDIVI P1,^D10 ;PICK OFF A DIGIT
HRLM P2,0(P) ;BET YOU'VE SEEN THIS BEFORE
SKIPE P1 ;ANY DIGITS LEFT?
PUSHJ P,PUTD.1 ;YES, GET NEXT ONE
HLRZ S1,0(P) ;GET A DIGIT
ADDI S1,"0" ;CONVERT TO ASCII
PJRST PUT7 ;PUT OUT DIGIT, LOOP OR RETURN FORM THER
E
^L; PUTW -- Put out a SIXBIT word, word in S1
PUTW: PUSHJ P,.SAVE2 ;NEED TWO ACS
MOVE P2,S1 ;GET WORD INTO SAFE PLACE
PUTW.1: JUMPE P2,.RETT ;RETURN IF ONLY BLANKS LEFT
LSHC P1,6 ;GET A CHARACTER
MOVE S1,P1 ;GET INTO PLACE
PUSHJ P,PUT6 ;PRINT THE CHARACTER
JRST PUTW.1 ;LOOP FOR ALL
; PUT6 -- Put Out A Single SIXBIT character, character in S1
PUT6: ANDI S1,77 ;INSURE ITS SIXBIT
ADDI S1," " ;CONVERT TO ASCII
PJRST PUT7 ;OUTPUT AS AN ASCII CHARACTER
; PEND -- Put proper ending on the text line
PEND: SKIPGE ENDFLG ;WANT SOMETHING DONE?
$RETT ;NO, RETURN NOW
SETZM CACMAX ;NOT PART OF ANY COUNTED FIELD
SKIPG ENDFLG ;WANT A NULL?
JRST PEND.1 ;NO, MUST WANT CR-LF
MOVX S1,0 ;ASCII NULL
PJRST PUT7 ;RETURN, PRINT IT
PEND.1: MOVEI S1,.CHCRT ;GET A 'CARRIAGE-RETURN'
PUSHJ P,PUT7 ;PRINT IT
MOVEI S1,.CHLFD ;GET A 'LINE-FEED'
PJRST PUT7 ;PRINT IT, RETURN
^L; PUTN -- Put out a node specification (in S1)
TOPS20 <
PUTN: PJRST PUTW ;PUT IT OUT AS SIXBIT AND RETURN
> ;END TOPS20 CONDITIONAL
TOPS10 <
PUTN: MOVE S2,S1 ;COPY NODE NUMBER TO S2
$CALL CNVNOD ;CONVERT NAME/NUMBER
JUMPF [MOVE S1,S2 ;RESTORE THE NODE NUMBER
TLNN S1,770000 ;WAS IT SIXBIT
PJRST PUTO ;JUST OUTPUT THE NODE NUMBER.
PJRST PUTW] ;OUTPUT NODE NAME AND RETURN
TLNN S1,770000 ;PUT NAME IN S1
EXCH S1,S2 ;PUT NUMBER IN S2
PUSH P,S2 ;SAVE THE NUMBER
PUSHJ P,PUTW ;OUTPUT THE NAME
POP P,S1 ;PUT THE NUMBER IN S1
$PUT7(<(>) ;THEN A LEFT BRACKET
PUSHJ P,PUTO ;OUTPUT IT IN OCTAL
$PUT7(<)>) ;THEN THE RIGHT BRACKET
$RETT ;AND RETURN
> ;END TOPS10 CONDITIONAL
^LSUBTTL PUTU -- Output user name or PPN
;This routine will take PPN or user number in S1 and output contents
TOPS10 <
PUTU: SKIPN S1 ;HAVE A GOOD PPN?
JRST [MOVEI S1,[ASCIZ |(PPN unknown)|]
PJRST PUTT] ;THE BEST WE CAN DO
PUSH P,S1 ;SAVE IT
$PUT7(<[>) ;GET AN OPEN BRACKET PRINTED
HLRZ S1,0(P) ;GET PROJECT PART OF PPN
PUSHJ P,PUTO ;PRINT IT
$PUT7(<,>) ;SEPARATE THE P FROM THE PN
POP P,S1 ;RESTORE PPN
ANDI S1,-1 ;DISCARD PROJECT NUMBER
PUSHJ P,PUTO ;PRINT IT
MOVEI S1,"]" ;GET CLOSE BRACKET
PJRST PUT7 ;PRINT IT AND RETURN
>;END TOPS10
TOPS20 <
PUTU: MOVE S2,S1 ;GET LOGGED IN DIRECTORY NUMBER
HRROI S1,TTXBUF ;POINT TO TEMPORARY TEXT BUFFER
DIRST ;AND PUT DOWN THE STRING
ERJMP [MOVEI S1,[ASCIZ/(User unknown)/] ;IF BAD,,POINT TO 'UNKNOWN'
PJRST PUTT ] ;AND PUT THAT OUT !!!
MOVEI S1,TTXBUF ;POINT TO TEXT BUFFER
PJRST PUTT ;PUT IT OUT AND RETURN
>;END TOPS20
^LSUBTTL SAVLVL-RSTLVL - Save and restore TEXT levels
;In order to make the $TEXT instruction work at both normal
; and interrupt level, the T%TEXT routine must detect calls
; made while inside itself. IF such a call is made, these
; routines are used to save away the data base.
SAVLVL: PUSH P,S1 ;SAVE AN AC
MOVE S1,TXTLVL ;GET LEVEL
CAIE S1,1 ;ONLY SUPPORT TWO LEVELS
$STOP(TML,Too many levels of call)
MOVE S1,[XWD FSAVE,SAREA] ;PREPARE FOR THE BLT
BLT S1,SAREA+SSAREA-1 ;SAVE AWAY OUR DATA BASE
POP P,S1 ;RESTORE THE AC
POPJ P, ;AND RETURN
RSTLVL: PUSH P,S1 ;SAVE S1
MOVE S1,[XWD SAREA,FSAVE] ;RESTORE THE AREA
BLT S1,LSAVE-1 ;THAT WAS WIPED BY THIS LEVEL
POP P,S1 ;RESTORE S1
POPJ P, ;RETURN
SUBTTL CNTDT,CNVDT DATE/TIME CONVERSION ROUTINES
;CNTDT CONVERTS UDT TO TWO WORD DATE/TIME
;ACCEPTS S1/ UDT
;RETURNS S1/ TIME IN MILLISECONDS
; S2/ DATE IN SYSTEM FORMAT
CNTDT:: PUSHJ P,.SAVET ;SAVE THE TEMPS WE USE
MOVE T1,S1 ;PUT UDT IN S1
PUSHJ P,.CNTDT ;CONVERT IT
DMOVE S1,T1 ;RETURN SECONDS SINCE MIDNIGHT
$RETT ;AND DATE IN SYSTEM FORMAT
;CNVDT CONVERTS TWO WORD DATE/TIME TO UDT
;ACCEPTS S1/ TIME IN MILLISECONDS
; S2/ DATE IN SYSTEM FORMAT
;RETURNS S1/ UDT
CNVDT:: PUSHJ P,.SAVET ;SAVE THE TEMPS WE USE
DMOVE T1,S1 ;GET SECONDS AND DATE
PUSHJ P,.CNVDT
MOVE S1,T1 ;RETURN THE UDT
$RETT
^LSUBTTL .CNTDT -- GENERALIZED DATE/TIME SUBROUTINE
;.CNTDT -- SUBROUTINE TO CONVERT FROM INTERNAL DATE/TIME FORMAT
;CALL: MOVE T1,DATE/TIME
; PUSHJ P,.CNTDT
; RETURN WITH T1=TIME IN MS., T2=DATE IN SYSTEM FORMAT (.LT. 0 IF ARG .LT.
0)
;BASED ON IDEAS BY JOHN BARNABY, DAVID ROSENBERG, PETER CONKLIN
;USES T1-4
.CNTDT: PUSH P,T1 ;SAVE TIME FOR LATER
JUMPL T1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ T1,T1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI T1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400
+31+28+31+30+31+30+31+31+30+31+17
;T1=DAYS SINCE JAN 1, 1501 [311]
IDIVI T1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY [311]
LSH T2,2 ;CONVERT TO NUMBER OF QUARTER DAYS [311]
IDIVI T2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY [311]
IORI T3,3 ;DISCARD FRACTIONS OF DAY [311]
IDIVI T3,4*365+1 ;SEPARATE INTO YEARS [311]
LSH T4,-2 ;T4=NO DAYS THIS YEAR [311]
LSH T1,2 ;T1=4*NO QUADRACENTURIES [311]
ADD T1,T2 ;T1=NO CENTURIES [311]
IMULI T1,100 ;T1=100*NO CENTURIES [311]
ADDI T1,1501(T3) ;T1 HAS YEAR, T4 HAS DAY IN YEAR [311]
MOVE T2,T1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE T2,3 ;IS THE YEAR A MULT OF 4? [311]
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR [311]
IDIVI T2,100 ;SEE IF YEAR IS MULT OF 100 [311]
SKIPN T3 ;IF NOT, THEN LEAP [311]
TRNN T2,3 ;IS YEAR MULT OF 400? [311]
TDZA T3,T3 ;YES--LEAP YEAR AFTER ALL [311]
CNTDT0: MOVEI T3,1 ;SET LEAP YEAR FLAG [311]
;T3 IS 0 IF LEAP YEAR
^L ;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI T1,1964 ;SET TO SYSTEM ORIGIN
IMULI T1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T3,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T4,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T4 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI T2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T4,MONTAB+1(T2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI T1,31 ;NO--COUNT SYSTEM MONTH
AOBJN T2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T4,MONTAB(T2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD T1,T4 ;INCLUDE IN FINAL RESULT
CNTDT6: EXCH T1,(P) ;SAVE ANSWER, GET TIME
TLZ T1,-1 ;CLEAR DATE
MUL T1,[24*60*60*1000] ;CONVERT TO MILLI-SEC.
ASHC T1,17 ;POSITION RESULT
POP P,T2 ;RECOVER DATE
POPJ P, ;RETURN
^L ;UNDER RADIX 10 **** NOTE WELL ****
;.CNVDT -- CONVERT ARBITRARY DATE TO SPECIAL FORMAT
;CALL: MOVE T1,TIME IN MILLISEC.
; MOVE T2,DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
; PUSHJ P,.CNVDT
;RETURNS WITH RESULT IN T1 (.GT.0; OR -1 IF BEYOND SEPT. 27,2217)
; NOTE THAT IN SPECIAL FORMAT, THE LEFT HALF DIVIDED
; BY 7 GIVES THE DAY OF THE WEEK (0=WED.)
;USES T2, T3, T4
.CNVDT: PUSHJ P,.SAVE1 ;PRESERVE P1
PUSH P,T1 ;SAVE TIME FOR LATER
IDIVI T2,12*31 ;T2=YEARS-1964
CAILE T2,2217-1964 ;SEE IF BEYOND 2217
JRST GETNW2 ;YES--RETURN -1
IDIVI T3,31 ;T3=MONTHS-JAN, T4=DAYS-1
ADD T4,MONTAB(T3) ;T4=DAYS-JAN 1
MOVEI P1,0 ;LEAP YEAR ADDITIVE IF JAN, FEB
CAIL T3,2 ;CHECK MONTH
MOVEI P1,1 ;ADDITIVE IF MAR-DEC
MOVE T1,T2 ;SAVE YEARS FOR REUSE
ADDI T2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
IDIVI T2,4 ;HANDLE REGULAR LEAP YEARS
CAIE T3,3 ;SEE IF THIS IS LEAP YEAR
MOVEI P1,0 ;NO--WIPE OUT ADDITIVE
ADDI T4,<1964-1859>*365+<1964-1859>/4+<31-18>+31(T2)
;T4=DAYS BEFORE JAN 1,1964 +SINCE JAN 1
; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
MOVE T2,T1 ;RESTORE YEARS SINCE 1964
IMULI T2,365 ;DAYS SINCE 1964
ADD T4,T2 ;T4=DAYS EXCEPT FOR 100 YR. FUDGE
HRREI T2,64-100-1(T1) ;T2=YEARS SINCE 2001
JUMPLE T2,GETNW1 ;ALL DONE IF NOT YET 2001
IDIVI T2,100 ;GET CENTURIES SINCE 2001
SUB T4,T2 ;ALLOW FOR LOST LEAP YEARS
CAIE T3,99 ;SEE IF THIS IS A LOST L.Y.
GETNW1: ADD T4,P1 ;ALLOW FOR LEAP YEAR THIS YEAR
CAILE T4,^O377777 ;SEE IF TOO BIG
GETNW2: SETOM T4 ;YES--SET -1
POP P,T1 ;GET MILLISEC TIME
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-17 ;POSITION
DIV T1,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS
;**;[574] Insert @ GETNW2+6L JNG 4-May-76
CAMLE T2,[^D24*^D60*^D60*^D1000/2] ;[574] OVER 1/2 TO NEXT?
ADDI T1,1 ;[574] YES, SHOULD ACTUALLY ROUND UP
HRL T1,T4 ;INCLUDE DATE
GETNWX: POPJ P, ;RETURN
^L ;UNDER RADIX 10 **** NOTE WELL ****
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
^LSUBTTL .SAVEx routines -- save permanent ACs
; These routines act as co-routines with the routines which call them.
; Therefore, no corresponding "restore" routines are needed. When the
; calling routine returns to its caller, it actually returns via the
; restore routines automatically. These unconventional looking routines
; actually run about 30% to 40% faster than those in SCAN or the TOPS-10
; monitor.
.SAVE1: PUSH P,P1 ;SAVE P1
PUSHJ P,@-1(P) ;CALL THE CALLER
PORTAL .+3 ;NON-SKIP RETURN
PORTAL .+1 ;SKIP RETURN
AOS -2(P) ;ADJUST RETURN PC
POP P,P1 ;RESTORE P1
SUB P,[1,,1] ;ADJUST STACK
POPJ P, ;RETURN
.SAVE2: ADD P,[2,,2] ;ADJUST STACK
DMOVEM P1,-1(P) ;SAVE P1 AND P2
PUSHJ P,@-2(P) ;CALL THE CALLER
PORTAL .+3 ;NON-SKIP RETURN
PORTAL .+1 ;SKIP RETURN
AOS -3(P) ;ADJUST RETURN PC
DMOVE P1,-1(P) ;RESTORE P1 AND P2
SUB P,[3,,3] ;ADJUST STACK
POPJ P, ;RETURN
.SAVE3: ADD P,[3,,3] ;ADJUST STACK
DMOVEM P1,-2(P) ;SAVE P1 AND P2
MOVEM P3,0(P) ;SAVE P3
PUSHJ P,@-3(P) ;CALL THE CALLER
PORTAL .+3 ;NON-SKIP RETURN
PORTAL .+1 ;SKIP RETURN
AOS -4(P) ;ADJUST RETURN PC
DMOVE P1,-2(P) ;RESTORE P1 AND P2
MOVE P3,0(P) ;RESTORE P3
SUB P,[4,,4] ;ADJUST STACK
POPJ P, ;RETURN
.SAVET: ADD P,[4,,4] ;ADJUST STACK
DMOVEM T1,-3(P) ;SAVE T1 AND T2
DMOVEM T3,-1(P) ;SAVE T3 AND T4
PUSHJ P,@-4(P) ;CALL THE CALLER
PORTAL .+3 ;NON-SKIP RETURN
PORTAL .+1 ;SKIP RETURN
AOS -5(P) ;ADJUST RETURN PC
DMOVE T1,-3(P) ;RESTORE T1 AND T2
DMOVE T3,-1(P) ;RESTORE T3 AND T4
SUB P,[5,,5] ;ADJUST STACK
POPJ P, ;RETURN
^LSUBTTL .POPJ, .POPJ1, .RETE,.RETT & .RETF -- Common return routines
; $RETE calls .RETE to set up the last GALAXY error and location
; then set TF = FALSE and return.
.RETE: XMOVEI S1,@(P) ;GET RETURN PC
HRRZ S1,(S1) ;GET ERROR CODE
MOVEM S1,.LGERR ;AND REMEMBER IT
POP P,(P) ;TRIM STACK
;FALL INTO .RETF (RETURN TO CALLER'S CALLER)
; .RETT AND .RETF are called via the $RETT and $RETF macros and can also
; be called directly. They both set the value of TF, one to TRUE and the other
; to FALSE. After doing this, they return via a POPJ P,
;
.RETF: TDZA TF,TF ;ZEROS MEAN FALSE
.RETT: SETO TF, ;ONES MEAN TRUE
POPJ P, ;RETURN
; The .POPJ and .POPJ1 routines can be jumped
; to get a return, without changing the value in the TF register
;
.POPJ1: AOS (P) ;SKIP
.POPJ: POPJ P, ;RETURN
^LSUBTTL I%HOST -- Get Host Name/Number of Central Site
;THIS ROUTINE WILL RETURN THE NODE NAME AND NUMBER (-10 ONLY)
;FOR THE CENTRAL SITE.
;
;CALL: NO ARGUMENTS
;
;RETURN: S1/ HOST NAME IN SIXBIT
; S2/ HOST NUMBER
;
IFN FTUUOS,<
I%HOST: MOVEI S2,.GTLOC ;GET LOCATION OF JOB 0
GETTAB S2, ;...
JRST NOHOST ;No network if this fails
MOVE S1,S2 ;Copy node numer
$CALL CNVNOD ;Convert S1 to node name
JUMPF NOHOST ;Use local defaults
$RETT
CNVNOD:: $SAVE <T1,T2,T3,T4> ;Convert S1 to its compliment
MOVE T1,[.NDRNN,,T2] ;Function is convert name/num
MOVEI T2,2 ;2 Args specified
MOVE T3,S1 ;Put the node number in T3
NODE. T1, ;Get the sixbit
SKIPA ;Failed,,look into the error
JRST [MOVE S1,T1 ;Win,,get answer in S1
$RETT ] ;Return
CAMN T1,[.NDRNN,,T2] ;Are networks supported ???
SKIPE S1 ;No,,is the node number 0 ??
$RETE(NSN) ;Network support or non zero node number
MOVE S1,['LOCAL '] ;Use local as default
$RETT ;return
>;END FTUUOS
IFN FTJSYS,<
I%HOST: PUSHJ P,.SAVET ;SAVE THE T REGS
MOVX S1,.NDGLN ;GET LOCAL NODE NAME JSYS CODE
MOVEI S2,TF ;GET ARGUMENT BLOCK ADDRESS
HRROI TF,T1 ;MAKE BYTE POINTER TO T1
NODE ;GET THE LOCAL NODE NAME
ERJMP NOHOST ;NO NETWORKS
MOVE T3,[POINT 7,T1] ;GET POINTER TO NODE NAME
MOVE T4,[POINT 6,S1] ;GET OUTPUT POINTER
SETZ S1, ;SET OUTPUT BUFFER TO NULLS
HOST.1: ILDB S2,T3 ;GET AN INPUT BYTE
JUMPE S2,HOST.2 ;NULL,,GO FINISH UP
SUBI S2,40 ;MAKE IT SIXBIT
IDPB S2,T4 ;SAVE IT
JRST HOST.1 ;AND GO PROCESS ANOTHER
HOST.2: SETZ S2, ;0 FOR NODE NUMBER
$RETT ;AND RETURN
>;END FTJSYS
NOHOST: MOVE S1,['LOCAL '] ;Use local as default
SETZ S2,
$RETT
^LSUBTTL I%JINF -- Canonical Job Information
;This Call is designed to provide a system independent way of getting Job
;information.
;
; CALL : S1/ JOB NUMBER OR -1 FOR CURRENT JOB
; S2/ FUNCTION CODE
;
;
; RETURN TRUE: S1/ JOB NUMBER PRESERVED FROM CALL
; S2/ RETURNED VALUE FOR FUNCTION
; RETURN FALSE: S1/ ERROR CODE
;
; DEFINED ERROR CODES
;
; ERUJI$ - UNDEFINED JOB INFO FUNCTION
; ERIJN$ - INVALID JOB NUMBER
I%JINF: CAIL S2,JI.MIN ;CHECK FUNCTION RANGE
CAILE S2,JI.MAX ;WITHIN BOUNDS
$RETE(UJI) ;UNDEFINED JOB INFO FUNCTION
MOVE S2,JINFTB-1(S2) ;GET THE DATA
SKIPL S2 ;FUNCTION CODE OR ROUTINE
JRST GJBGTB ;FUNCTION CODE DO THE WORK
HRRZS S2 ;GET ROUTINE ADDRESS
PJRST (S2) ;PROCESS THE FUNCTION
TOPS10<
GJBGTB: HRL S2,S1 ;PLACE JOB NUMBER IN LEFT HALF
GETTAB S2, ;GET THE INFO
$RETE(IJN) ;INVALID JOB NUMBER
$RETT ;RETURN TRUE
>;END TOPS10
TOPS20<
GJBGTB: $SAVE T1 ;SAVE T1
MOVE T1,S2 ;GET THE FUNCTION CODE
MOVSI S2,-1 ;1 WORD TO RETURN
HRRI S2,T1 ;RESULT IN T1
GETJI ;GET THE INFO
$RETE(IJN) ;INVALID JOB NUMBER
MOVE S2,T1 ;GET RETURNED DATA
$RETT ;RETURN TRUE
>;END TOPS20
;JOB INFO FUNCTION DISPATCH TABLE
DEFINE X(A,B,C),<
JI.'A==JI.'A ;GET SYMBOLS
TOPS10<C>
TOPS20<B>
>;END X
JINFTB: JBTAB ;EXPAND THE TABLE
^LSUBTTL I%JINF ROUTINES FOR THE -10
TOPS10<
;GET THE PATH DIRECTORY
GJBPTH: PUSHJ P,.SAVET ;SAVE THE T REGS
MOVS T1,S1 ;PUT JOB NUMBER IN T1
HRRI T1,.PTFRD ;READ DIRECTORY PATH
MOVSI S2,3 ;LENGTH OF BLOCK
HRRI S2,T1 ;ADDRESS OF BLOCK
PATH. S2, ;DO THE FUNCTION
$RETE(IJN) ;INVALID JOB NUMBER
MOVE S2,T3 ;GET THE PPN
$RETT ;RETURN TRUE
;GET THE CONTROLLING JOB NUMBER
GJBCJB: MOVE S2,S1 ;GET JOB NUMBER
CTLJOB S2, ;GET CONTROLLING JOB
$RETE(IJN) ;INVALID JOB NUMBER
$RETT ;CONTROLLING JOB OR -1 IF NOT CONTROLLED
;GET THE JOB NUMBER OF MY JOB
GJBJNO: SKIPL S2,S1 ;CHECK IF FOR ME
$RETE(IJN) ;INVALID JOB NUMBER
PJOB S2, ;GET THE JOB NUMBER
$RETT ;RETURN TRUE
GJBTLC: $SAVE <T1> ;SAVE AN AC
MOVE T1,S1 ;SAVE THE JOB NUMBER
SETZM S2 ;RETURN A ZERO FOR EARLY FAILURE
TRMNO. S1, ;GET THIS JOB'S TERMINAL #
$RETE(TLU) ;ERROR IF NO TERMINAL
GTNTN. S1, ;FIND OUT WHERE THAT TTY LIVES
$RETE(TLU) ;ERROR IF NO NODE,,TERMINAL
HLRZS S1 ;GET JUST THE TERM #
$CALL CNVNOD ;Convert S1 to sixbit
$RETIF ;Return any failures
MOVE S2,S1 ;Return node name in S2
MOVE S1,T1 ;Return Job number in S1
$RETT
;GET THE JOBS TERMINAL NUMBER
GJBTTY: MOVE S2,S1 ;SAVE THE JOB NUMBER
TRMNO. S2, ;GET THE TERMINAL NUMBER
JRST GJBT.1 ;ERROR..CHECK FOR DETACHED
TRZ S2,.UXTRM ;MAKE TERMINAL NUMBER
$RETT ;RETURN TRUE
GJBT.1: MOVN S2,S1 ;GET NEGATIEV JOB NUMBER IN S1
JOBSTS S2, ;DO JOBSTS UUO
$RETE(IJN) ;INVALID JOB NUMBER
TXNN S2,JB.UJA ;JOB NUMBER ASSIGNED
$RETE(IJN) ;INVALID JOB NUMBER
SETOM S2 ;-1 IF DETACHED
$RETT ;RETURN
GJBVER::MOVE S1,.JBVER ;Yes, get our version
$RETT ;Done
GJBRTM: SKIPGE S1 ;Want our job (-1)?
SETZ S1, ;Yes, adjust to RUNTIm UUO convetion
MOVE S2,S1 ;SAVE THE NUMBER AND GET VALUE IN S2
RUNTIM S2, ;Ask the monitor
$RETT ;Give it to user
GJBLOC: MOVEI S2,.GTLOC ;Function is get my location
$CALL GJBGTB ;Do the GETTAB
$RETIF ;Return any failure
EXCH S1,S2 ;Put number in S1
$CALL CNVNOD ;Convert to sixbit
$RETIF ;Return any failure
EXCH S1,S2 ;Else return sixbit in S2
$RETT ;With job number in S1
> ;End TOPS10
^LSUBTTL I%JINF SPECIAL ROUTINES FOR THE -20
TOPS20<
GJBLOC:
PUSHJ P,.SAVET ;SAVE THE ACS
HRRI T1,.JILLO ;GET THE FUNCTION CODE
MOVSI S2,-1 ;1 WORD TO RETURN
HRRI S2,T2 ;RESULT IN T2
HRROI T2,T3 ;POINTER TO T3
GETJI ;GET THE INFO
$RETE(IJN) ;INVALID JOB NUMBER
MOVE T1,[POINT 7,T3] ;SETUP INPUT POINTER
MOVE TF,[POINT 6,S2] ;GET OUTPUT POINTER
SETZ S2, ;SET OUTPUT BUFFER TO NULLS
GJBL.1: ILDB T2,T1 ;GET AN INPUT BYTE
JUMPE T2,.RETT ;NULL,,GO FINISH UP
SUBI T2,40 ;MAKE IT SIXBIT
IDPB T2,TF ;SAVE IT
JRST GJBL.1 ;AND GO PROCESS ANOTHER
GJBTLC: $SAVE <S1>
$CALL I%HOST
MOVE S2,S1 ;ONLY KNOW ABOUT OUR HOST FOR NOW
$RETT
GJBVER:: MOVX S1,.FHSLF ;Yes, aim at my process
GEVEC ;Get my entry info
HLRZ S1,S2 ;Get length
CAIN S1,(JRST) ;Is it an old entry vector (JRST start)
JRST [MOVE S1,137 ;Yes, get version ala TOPS-10
$RETT] ;Give that to user
CAIGE S1,2 ;Does it contain a version?
TDZA S1,S1 ;No, return 0
MOVE S1,2(S2) ;Yes, get it
$RETT ;Done
>;END TOPS20
^LSUBTTL I%NOW - Get time of day
; Return local date/time in Smithsonian Universal date/time format
; CALL IS: No arguments
;
; TRUE RETURN: S1/ Greenwich time and date in UDT format
;
I%NOW:
TOPS10 < ;TOPS-10 ONLY
MOVX S1,%CNDTM ;GET UNIVERSAL DATE/TIME (GMT)
GETTAB S1, ;THE MONITOR
$STOP(DTU,Date/Time unavailable)
> ;END OF TOPS-10 CONDITIONAL
TOPS20 < ;TOPS-20 ONLY
GTAD ;GET DATE AND TIME
> ;END OF TOPS-20 CONDITIONAL
$RETT ;RETURN WITH UDT IN S1
^LSUBTTL K%SOUT -- Type an ASCIZ string on TTY
;Call: S1/ address of string (word-aligned)
;
;True Return: always
TOPS10 <
K%SOUT: OUTSTR 0(S1) ;TYPE THE STRING
$RETT ;AND RETURN
> ;END TOPS10 CONDITIONAL
TOPS20 <
K%SOUT: PSOUT ;TYPE THE STRING
$RETT ;AND RETURN
> ;END TOPS20 CONDITIONAL
; This routine handles the call caused by the $STOP and $FATAL macros
.STOP: HALTF
REPEAT 0,<
AOSE STPFLG ;ALREADY PROCESSING A STOPCODE
JRST STOP.4 ;YES - JUST TYPE OUT DUMP ON TTY
MOVEM 0,.SACS ;STORE FIRST AC
MOVE 0,[XWD 1,.SACS+1] ;SET FOR THE REST
BLT 0,.SACS+17 ;STORE THEM ALL
MOVE P,[IOWD STPPSZ,STPPDL] ;SET UP NEW PDL
PUSHJ P,I%IOFF ;TURN OFF INTERRUPTS
MOVE S1,.SACS+P ;GET OLD PDL POINTER
MOVE S1,0(S1) ;GET LOCATION CALLED FROM
MOVE S2,@0(S1) ;THEN GET POINTER WORD TO CODE
HLLZM S2,.SCODE ;STORE SIXBIT CODE
HRRZM S2,.SRSN ;SAVE ADDRESS OF REASON
MOVEI S2,@0(S1) ;GET LOCATION THAT XWD FETCHED FROM
MOVE S2,1(S2) ;GET MODULE NAME
MOVEM S2,.SMOD ;STORE IT
MOVEI S2,-1(S1) ;GET ACTUAL LOCATION OF 'PUSHJ P,.STOP'
MOVEM S2,.SPC ;REMEMBER IT
MOVE S1,.SCODE ;GET REASON CODE
SKIPE IIB+IB.ERR ;ERROR PROCESSOR?
PUSHJ P,@IIB+IB.ERR ;YES..CALL IT
PORTAL .+1 ;CLEAR PUBLIC, SET CONCEALED
PUSHJ P,M%GPAG ;SETUP WTO MESSAGE
MOVEM S1,WTOADR ;Save start of page for storing
SETOM TXTLVL## ;MAKE SURE TEXT WON'T STOP US
HRLI S1,(POINT 7,) ;Make a byte pointer
MOVEM S1,WTOPTR ;Save it for output
SKIPE .SCODE ;Processing a $FATAL message?
JRST STOP.1 ;No..do full stop code
$TEXT (STPDEP,<? ^W/.SPRGM/^A>) ;Output program name
CAME S1,.SPRGM ;Same as module name?
$TEXT (STPDEP,< ^W/.SMOD/^A>) ;No..output module name
DMOVE S1,.SACS+S1 ;RELOAD ACS THAT WE STEPPED ON
$TEXT (STPDEP,< ^I/@.SRSN/>) ;Output reason
JRST STOP.4 ;Finish up
^LSTOP.1: DMOVE S1,.SACS+S1 ;RELOAD ACS THAT WE STEPPED ON
$TEXT (STPDEP,<^I/STPHDR/^A>) ;OUTPUT STOPCODE HEADER
TOPS20 <
MOVX S1,.FHSLF ;FOR SELF,
GETER ;LOOK UP MOST RECENT ERROR
ERJMP .+1 ;IGNORE ANY ERRORS
MOVEM S2,.SERR ;SAVE THE ERROR
$TEXT (STPDEP,< Last TOPS-20 error: ^O/.SERR,RHMASK/ (^E/.SERR,RHMASK/
)>)
PUSHJ P,SAVCRS ;SAVE THE CRASH
> ;END TOPS20 CONDITIONAL
MOVX S1,IP.STP ;GET STOPCODE TO ORION FLAG
TDNN S1,IIB##+IB.FLG ;CHECK IF SET
JRST STOP.4 ;NO - ONLY TO TTY, NO AC DUMP
$TEXT (STPDEP,<^I/STPACS/^A>) ;DUMP ACS
MOVE T1,.SACS+P ;PICK UP PDL POINTER
$TEXT (STPDEP,<^I/STPSTK/^A>) ;DUMP LAST FEW STACK LOCATIONS
SKIPE MYPID## ;Do we have any PIDs at all?
SKIPE IMOPR## ;Yes, Yes, Am I ORION?
JRST STOP.4 ;No PID, or I'm ORION,
;Just output to terminal
$WTO (< ^W/.SPRGM/ terminated >,<^T/@WTOADR/>,,$WTFLG(WT.NFO))
STOP.4: SKIPE S1,WTOADR ;GET MESSAGE ADDRESS
PUSHJ P,K%SOUT ;DUMP THE DATA
MOVEI S1,[ASCIZ/
?Recursion in stopcode handler--Can not continue
/] ;IN CASE WE ARE REALLY SICK
SKIPE STPFLG ;FIRST TIME?
PUSHJ P,K%SOUT ;NO--REALLY DEAD
MOVSI 17,.SACS ;RESTORE THE ACS
BLT 17,17 ;TO THE USER
PUSHJ P,I%ION ;TURN ON INTERRUPTS
STPXIT: $HALT ;Stop without RESET
JRST .-1 ;Don't allow CONTINUE
^L; A little routine to output bytes, and advance a pointer
;
STPDEP: IDPB S1,WTOPTR ;Just dump the byte
$RETT ;And return
; ITEXT block for stopcode header
;
STPHDR: ITEXT (<
?Stopcode - ^W/.SCODE,LHMASK/ - in module ^W/.SMOD/ on ^H9/[-1]/ on ^C/[-1]/
Reason: ^I/@.SRSN/
Program is ^W/.SPRGM/ version ^V/.SPVER/ using GLXLIB version ^V/.SPLIB/
Crash block starts at location ^O/[.SPC]/
Last GLXLIB error: ^O/.LGERR,RHMASK/ (^E/.LGERR/)
>)
; ITEXT block for stopcode AC dump
;
STPACS: ITEXT (<
Contents of the ACs:
0/^O15/.SACS+00/^O15/.SACS+01/^O15/.SACS+02/^O15/.SACS+03/
4/^O15/.SACS+04/^O15/.SACS+05/^O15/.SACS+06/^O15/.SACS+07/
10/^O15/.SACS+10/^O15/.SACS+11/^O15/.SACS+12/^O15/.SACS+13/
14/^O15/.SACS+14/^O15/.SACS+15/^O15/.SACS+16/^O15/.SACS+17/
>)
; ITEXT block for stopcode PDL dump
;
STPSTK: ITEXT(<
Last 9 stack locations:
-1(P)/^O15/-1(T1)/ -2(P)/^O15/-2(T1)/ -3(P)/^O15/-3(T1)/
-4(P)/^O15/-4(T1)/ -5(P)/^O15/-5(T1)/ -6(P)/^O15/-6(T1)/
-7(P)/^O15/-7(T1)/ -8(P)/^O15/-8(T1)/ -9(P)/^O15/-9(T1)/
>)
^L SUBTTL SAVCRS -- Save Crash on Stopcodes
;This Routine will save the crash for programs that have
;stopcoded and requested that ORION be informed.
TOPS20 <
SAVCRS: SKIPE DEBUGW ;ARE WE DEBUGGING?
$RETT ;YES..IGNORE SAVE
MOVX S1,IP.STP ;GET THE STOPCODE FLAG
TDNN S1,IIB##+IB.FLG ;CHECK IF SET?
$RETT ;NO..IGNORE SAVE
$TEXT (<-1,,SAVBUF##>,<^T/SAVNM1/^W/.SPRGM/-^W/.SCODE/-CRASH.EXE^0>)
MOVX S1,GJ%FOU!GJ%SHT ;CREATE NEW GENERATION
HRROI S2,SAVBUF## ;POINT TO THE STRING
GTJFN ;GET THE JFN
$RETT ;IGNORE IT ..AND RETURN
HRLI S1,.FHSLF ;PUT HANDLE IN LEFT HALF (JFN IN RIGHT)
MOVE S2,[777760,,20] ;SAVE ALL ASSIGNED NON-ZERO MEMORY
JSYS 202 ;SAVE JSYS (SINCE THERE IS SAVE MACRO)
ERJMP .RETT ;IGNORE THE SAVE FAILURE
$TEXT (STPDEP,< Crash saved in file: ^T/SAVBUF/>)
$RETT ;RETURN
SAVNM1: ASCIZ/DSK:/
>;END TOPS20
> ;END REAPEAT
END