Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_1_19910112
-
5-galaxy/glxtxt.mac
There are 27 other files named glxtxt.mac in the archive. Click here to see a list.
TITLE GLXTXT -- Formatted Text Handler for GLXLIB
SUBTTL Preliminaries
;
;
; COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION
; 1975,1976,1977,1978,1979,1980,1981,1982,1983,1984
;
; 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
PROLOG(GLXTXT,TXT) ;PRODUCE PROLOG CODE
TXTMAN==:53 ;Maintenance edit number
TXTDEV==:61 ;Development edit number
VERSIN (TXT) ;Generate edit number
EXTERNAL IPCEDT,KBDEDT,LNKEDT
EXSYM1==:IPCEDT+KBDEDT+LNKEDT+TXTEDT ;Calculate part of GLXVRS
ENTRY T%INIT ;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.
SUBTTL Table of Contents
; Table of Contents for GLXTXT
;
;
; Section Page
; 1. Preliminaries. . . . . . . . . . . . . . . . . . . . . 1
; 2. Table of Contents. . . . . . . . . . . . . . . . . . . 2
; 3. Revision History . . . . . . . . . . . . . . . . . . . 3
; 4. Local Macros . . . . . . . . . . . . . . . . . . . . . 4
; 5. Global storage . . . . . . . . . . . . . . . . . . . . 5
; 6. T%INIT - Initialize the TEXT module. . . . . . . . . . 6
; 7. T%TEXT - Routine to format text output . . . . . . . . 7
; 8. T%TTY - Buffered terminal output routine. . . . . . . 9
; 9. PROBLK - Process an entire T%TEXT argument block . . . 10
; 10. PROARG - Routine to process each T%TEXT argument . . . 11
; 11. PROTXT
; 11.1. ROUTINE TO PROCESS THE ACTUAL FUNCTION. . . . 12
; 12. PTAB - Dispatch table for argument processors. . . . 13
; 13. PROx - Processors for each type of formatting. . . . 14
; 14. PROT - Process a string of ASCIZ text. . . . . . . . 15
; 15. PRO3 - Process a an ASCIZ string created by $TEXT. . 15
; 16. PROQ - Process a byte pointer to an ASCIZ string . . 16
; 17. PROB - Process a GLXLIB object block . . . . . . . . 17
; 18. PRO1 - Process an object type. . . . . . . . . . . . 18
; 19. PRON - Process a node specification. . . . . . . . . 18
; 20. PROO - Process unsigned octal numbers. . . . . . . . 19
; 21. PROD - Process a signed decimal number . . . . . . . 19
; 22. PROF - Process a system dependent file specification 20
; 23. PRO7 - Process a single 7 bit ASCII character. . . . 21
; 24. PRO6 - Process a single 6 bit ASCII character. . . . 21
; 25. PRO5 - Process ASCIZ single word . . . . . . . . . . 21
; 26. PROW - Process a SIXBIT word . . . . . . . . . . . . 21
; 27. PROP - Process a directory ID of either PPN or directory NUMBER 22
; 28. PROU - Process a user ID or either PPN or User number 22
; 29. PROR - Process routine for Job Info Block . . . . . 23
; 30. PROE - Process a GLXLIB error number . . . . . . . . 25
; 31. PROI - Process an indirect text request. . . . . . . 26
; 32. PROV - Process a program version number. . . . . . . 27
; 33. PROM - Process a request for a CONTROL-M (Carriage Ret.) 28
; 34. PROJ - Process a request for a CONTROL-J (Line Feed) 28
; 35. PROL - Process a request for a CONTROL-L (Form Feed) 28
; 36. PROK - Process a request for a CONTROL-K (Vertical Tab) 28
; 37. PRO2 - Process a request for up-arrow. . . . . . . . 28
; 38. PROA - Process a request to supress free <CR-LF> . . 28
; 39. PRO0 - Process a request to put null (0) at end of line 28
; 40. FETCH - Routine to get a word from caller's address space 29
; 41. SPACES - Routine to provide any padding requested. . . 30
; 42. Local output routines. . . . . . . . . . . . . . . . . 31
; 43. PUTU
; 43.1. Output user name or PPN . . . . . . . . . . . 35
; 44. SAVLVL-RSTLVL - Save and restore TEXT levels . . . . . 36
SUBTTL Revision History
COMMENT \
***** Release 4.2 -- begin maintenance edits *****
51 4.2.1216
Edit 34 prints 'User unknown' when DIRST JSYS fails.
Likewise for the -10, if the PPN is zero type 'PPN unknown'.
52 4.2.1551 14-Sep-83
Edit 50 doesn't make it. Go back to disabling interrupt when
evaluating arguments with P set funny. But be clever and
check first to see if indirect or indexed info is included in
argument and skip the whole thing if not.
53 4.2.1580 11-Jul-84
Add 500 milliseconds to the time returned by CNTDT to give the
correct time when showing the status of a print or batch job
submitted with the /AFTER switch using absolute time.
***** Release 5.0 -- begin development edits *****
60 5.1002 28-Dec-82
Move to new development area. Clean up edit organization. Update TOC.
61 5.1132 9-APR-84
Calculate part of GLXVRS in this module to get around the Polish
Notation stack limitation of MACRO.
\ ;End of Revision History
SUBTTL 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
SUBTTL 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 ARGUMENT
$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 TXTEND,0 ;END OF ZEROABLE $DATA SPACE
SUBTTL T%INIT - 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
T%INIT: 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
SUBTTL 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 TRIPLETS
; %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
;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)
TXNN TF,<@(17)> ;Check for index or indirect
JRST TEXT.4 ;None, no need to resolve address
PUSH P,TF ;Save pointer for a minute
$CALL I%IOFF ;Disable interrupts
POP P,TF ;Get the pointer back
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
PUSH P,TF ;Save the pointer for a minute
$CALL I%ION ;Enable interrupts
POP P,TF ;Get the pointer back
TEXT.4: 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
SUBTTL 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
SUBTTL 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/>)
SUBTTL 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
$CALL 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
$CALL I%ION ;TURN ON INTERRUPTS
PARG.4: PJRST PROTXT ;PROCESS THE TEXT
SUBTTL 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
SUBTTL 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 GLXTXT.
; 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
SUBTTL 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.
SUBTTL 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 WORD 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
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
ADDI S1,^D500 ;Round to the nearest second
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 MINUTES
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
SUBTTL 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 .ERET
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
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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL 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
SUBTTL Local output routines
;These routines are local to the TEXT module and are used to
; do output. GLXTXT 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.
; 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 THERE
; 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
; 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
SUBTTL 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
SUBTTL 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
TXT%L:
END