Trailing-Edge
-
PDP-10 Archives
-
BB-D868C-BM
-
language-sources/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 Irwin L. Goverman/ILG/CER/MLB/DC/PJT/WLH Sept 27, 1979
;
;
;
; COPYRIGHT (c) 1975,1976,1977,1978,1979 BY
; 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
PROLOG(GLXTXT,TXT) ;PRODUCE PROLOG CODE
TXTEDT==35 ;MODULE EDIT LEVEL
ENTRY T%INIT ;INITIALIZATION
ENTRY T%TEXT ;$TEXT ENTRY POINT
ENTRY T%TTY ;DEFAULT TERMINAL OUTPUT
; 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. Table of Contents......................................... 2
; 2. Revision History.......................................... 3
; 3. Local Macros.............................................. 4
; 4. Global storage............................................ 5
; 5. T%INIT - Initialize the TEXT module....................... 6
; 6. T%TEXT - Routine to format text output.................... 7
; 7. T%TTY - Buffered terminal output routine................. 8
; 8. PROBLK - Process an entire T%TEXT argument block.......... 9
; 9. PROARG - Routine to process each T%TEXT argument.......... 10
; 10. PTAB - Dispatch table for argument processors........... 11
; 11. PROx - Processors for each type of formatting........... 12
; 12. PROT - Process a string of ASCIZ text................... 13
; 13. PRO3 - Process a an ASCIZ string created by $TEXT....... 13
; 14. PROQ - Process a byte pointer to an ASCIZ string........ 14
; 15. PROB - Process a GLXLIB object block.................... 15
; 16. PRO1 - Process an object type........................... 16
; 17. PRON - Process a node specification..................... 16
; 18. PROO - Process unsigned octal numbers................... 17
; 19. PROD - Process a signed decimal number.................. 17
; 20. PROF - Process a system dependent file specification... 18
; 21. PRO7 - Process a single 7 bit ASCII character........... 19
; 22. PRO6 - Process a single 6 bit ASCII character........... 19
; 23. PRO5 - Process ASCIZ single word........................ 19
; 24. PROW - Process a SIXBIT word............................ 19
; 25. PROP - Process a directory ID of either PPN or directory NUMBER 20
; 26. PROU - Process a user ID or either PPN or User number... 20
; 27. PROR - Process routine for Job Info Block............... 21
; 28. PROE - Process a GLXLIB error number.................... 23
; 29. PROI - Process an indirect text request................. 24
; 30. PROV - Process a program version number................. 25
; 31. PROM - Process a request for a CONTROL-M (Carriage Ret.) 26
; 32. PROJ - Process a request for a CONTROL-J (Line Feed).... 26
; 33. PROL - Process a request for a CONTROL-L (Form Feed).... 26
; 34. PROK - Process a request for a CONTROL-K (Vertical Tab). 26
; 35. PRO2 - Process a request for up-arrow................... 26
; 36. PROA - Process a request to supress free <CR-LF>........ 26
; 37. PRO0 - Process a request to put null (0) at end of line. 26
; 38. FETCH - Routine to get a word from caller's address space 27
; 39. SPACES - Routine to provide any padding requested......... 28
; 40. CNTDT - Convert UDT to TOPS-10 DATE UUO Time and MSTIME.. 29
; 41. Local output routines..................................... 31
; 42. PUTU
; 42.1 OUTPUT USER NAME OR PPN........................... 35
; 43. SAVLVL-RSTLVL - Save and restore TEXT levels.............. 36
SUBTTL Revision History
COMMENT \
Edit SPR/GCO Explanation
---- ------- ---------------------------------------------
0001 First attempt
0002 Convert to new OTS format
0003 Make multiple levels work
0004 Add PRO2 and PROQ
0005 Add PROB and PRO1
0006 G013 Add PRON/PUTN
0007 G014 FIX BUG IN ^I OF SPACING CAUSING SPACING TO
HAPPEN TWICE.
0010 FIX BUG WHICH DID NOT ALLOW THE
FIRST PARAMETER IN $TEXT MACRO TO USE
INDIRECT AND INDEXED ADDRESSING. THIS MOD NEEDS
ONLY TO JFCL 1 INSTRUCTION IN X.
0011 CHANGE T%INIT TO USE IIB SET UP BE I%INI1
0012 Add ^R for Job Info blocks and isolate PUTU for
Displaying User Info.
0013 Add STOPCODE IJU for Bad User Info in JIB (^R)
0014 Change ^R Display
0015 Convert to use I%JINF Routines
0016 Fix ^R on -10 with 0 second name word
0017 Fix ^N to Handle SIXBIT on the -10
0020 Make IQN $STOP give bad index, addr of error
0021 Make BTA $STOP give a hint of where we went south
0022 Removed usage of PJUMPE opdef
0023 Have ^E on the -20 accept 20 error codes and expand
them. Those are codes greater than 600000
0024 Allow Indexing and Indirect references for ^Q
0025 Generate Stopcode on invalid ^E function value
0026 Generate asciz pointer for ^Q if size and
position weren't set in fetched pointer.
(i.e. allow ^Q/KEYTAB(S1),LHMASK/)
0027 Change ^E to get dynamic buffer area and have -2
represent the last TOPS20 error.
0030 Fix -10 ^B to Check Node name and Number to decide
if at same node
0031 Modify PROB (Object Block Processor) so that if the
object type is .OTMNT then the unit is put out as a
sixbit value.
0032 Output Date/Time internally instead of using ODTIM.
0033 Convert CNTDT to accept and return arguments in S1 and
S2
0034 Change PUTU so that if the DIRST fails (-20 only),
we will put out 'User Unknown' instead of stopcode'ing
0035 Fix a bug. Initialize LINPTR in $TEXT init code.
\ ;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
EXT IIB ;EXTERNAL INITIALIZATION BLOCK
$DATA DEFERR ;DEFAULT ERROR EXIT ADDRESS FROM IB.
$DATA DEFOUT ;DEFAULT OUTPUT ROUTINE FROM IB
$GDATA TXTLVL ;LEVEL WE ARE AT
$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 CALLER'S OUTPUT ROUTINE
$DATA USRRET ;FIRST WORD AFTER $TEXT ARG BLOCK
TOPS20< $DATA ERRBUF> ;ERROR BUFFER AREA
$DATA CALOC ;CURRENT ARGUMENT EFFECTIVE ADDRESS
$DATA CAFLG ;CURRENT ARGUMENT'S FLAGS + RAW ADDRESS
$DATA CAPTR ;POINTER WORD FOR CURRENT ARG (IF ANY)
$DATA CASPAC ;SPACING WORD FOR CURRENT ARGUMENT (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
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: SKIPN S1,IIB+IB.OUT ;PICK UP USER DEFAULT OUTPUT ROUTINE
$STOP(DOR,Default output routine required) ;MUST BE THERE
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
TOPS20 <
PUSHJ P,CLCFCT ;CALCULATE A TIMEZONE CONVERSION FACTOR
>;END TOPS20 CONDITIONAL
$RETT ;AND RETURN
;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.
TOPS20 <
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 THE ADDRESS CALLED FROM
MOVE 0,1(S1) ;GET THE USER ROUTINE ADDRESS INSTR.
MOVE S1,USRACS+1 ;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
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
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: 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
SKIPT ;IF OK, DONT'T STOP NOW
$STOP(BTA,<Bad $TEXT argument given at address ^O/ARGADR/>)
LOAD S1,CASPAC,TXT.SP ;GET SPACING POSITIONS
LOAD S2,CASPAC,TXT.SS ;AND SIDE CODE
CAXE S1,0 ;IF NOT SPACING,
CAXN S2,TXT.SR ; OR RIGHT JUSTIFYING,
JRST PROBLK ;JUST LOOP FOR NEXT ARGUMENT
PUSHJ P,SPACES ;GIVE ANY SPACES NEEDED
JRST PROBLK ;THEN LOOP FOR NEXT ARGUMENT
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 CHARACTER COUNTER
SETZM CASPAC ;AND THE SPACING WORD
SETZM CAPTR ;AND POINTER WORD
MOVE S1,@ARGADR ;GET CONTENTS OF FIRST ARG WORD
MOVEM S1,CAFLG ;SAVE IT FOR ITS FLAGS
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,@CAFLG ;CALCULATE EFFECTIVE ADDRESS
MOVEM S1,CALOC ;STORE EFFECTIVE ADDR (0 FOR TXT.NA)
EXCH P,USRACS+P ;RESTORE STACK POINTER
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.1 ;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.1: LOAD S1,CAFLG,TXT.S ;IS THERE A SPACING WORD?
JUMPE S1,PARG.2 ;NO, DONT PROCESS IT
AOS S1,ARGADR ;GET THE ADDRESS OF SPACING WORD
MOVE S1,0(S1) ;GET THE SPACING WORD
MOVEM S1,CASPAC ;AND STORE IT
PARG.2: AOS ARGADR ;ADJUST CURRENT ADDRESS
LOAD S1,CAFLG,TXT.M ;GET THE QUALIFIER INDEX ALONE
CAILE S1,0 ;IF OUT OF RANGE,
CAIL S1,PTABL ;
$STOP(IQN,Illegal qualifier number ^O/S1/ at ^O/T1/)
LOAD T1,CASPAC,TXT.SP ;GET SPACING POSITIONS
MOVEM T1,CACMAX ;STORE AS MAXIMUM CHARS IN FIELD
LOAD S2,CASPAC,TXT.SS ;AND GET SIDE CODE
CAXE T1,0 ;IF NO SPACING,
CAXN S2,TXT.SL ;OR LEFT JUSTIFYING ONLY
PJRST @PTAB(S1) ;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.M ;GET QUALIFIER NUMBER AGAIN
PJRST @PTAB(S1) ;THEN FINALLY OUTPUT THE ARGUMENT
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 X(A,ARG)<
Z PRO'A
>
PTAB: PJRST .RETF ;FILL IN THE 0 (UNUSED) ENTRY
TQUALS ;AND THEN THE REST OF THE TABLE
PTABL==.-PTAB
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.
; CASPAC is the optional spacing information word, used only when the
; argument type-out is to have left justification, right justification, or be
; centered.
; 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 ;AND PROCESS IT
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
JUMPE S1,.RETT ;QUIT NOW IF NO NODE
MOVE T1,S1 ;SAVE THE NODE
SETOM S1 ;SET FOR MY JOB
MOVX S2,JI.LOC ;GET THE LOCATION
PUSHJ P,I%JINF ;GET THE DATA IN S2
SKIPT ;SKIP IF O.K.
SETZ S2, ;MAKE IT 0
MOVE S1,T1 ;PLACE VALUE IN S1
CAMN S2,S1 ;SAVE AS CURRENT
$RETT ;RETURN
TOPS10< MOVE T3,S2 ;COPY NODE NUMBER TO P2
MOVE T1,[XWD 2,T2] ;AC FOR NODE.
MOVX T2,.NDRNN ;FUNCTION FOR NODE.
NODE. T1, ;GET THE NODE NAME
JRST PROB.3 ;ERROR..PRINT OUT NODE
CAMN T1,S1 ;IS IT SAME NODE
$RETT ;YES..BYPASS NODE OUTPUT
>;END TOPS10
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
$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: $PUT7(<,>) ;PUT OUT A COMMA
MOVEI S1,.FDPAT(P1) ;GET SFD LOCATION
PUSHJ P,FETCH ;LOAD IT
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
JUMPE P2,PROR.2 ;ALL OUT CONTINUE ON
PROR.1: MOVEI S1,40 ;GET A BLANK
PUSHJ P,PUT7 ;OUTPUT THE BLANK
SOJG P2,PROR.1 ;FILL TO 6 CHARACTERS
PROR.2: MOVEI S1,JIB.NM+1(P1) ;GET USER NAME WORD 1
PUSHJ P,FETCH ;FETCH IT
SKIPE S1 ;ZERO..IGNORE SECOND WORD
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
SKIPE S1 ;ZERO ELEMENT..FATAL ERROR
PJRST PUTU ;DISPLAY USER NAME OR PPN AND RETURN
$STOP(IJU,INVALID USER ID IN JOB INFO BLOCK)
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 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 3600] ;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
IDIVI S1,^D60 ;GET MINS
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
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: PUSH P,ARGADR ;SAVE CURRENT ARGUMENT LIST LOCATION
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
POP P,ARGADR ;RESTORE OLD ARG BLOCK ADDRESS
SETZM CASPAC ;CLEAR SPACING WORD[:G014]
$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: CASPAC & CACCTR should be set up
;
; Return: Always TRUE
SPACES: PUSHJ P,.SAVE1 ;GET ONE PERMANENT REGISTER
LOAD P1,CASPAC,TXT.SP ;GET THE SPACING CODE WIDTH
SUB P1,CACCTR ;SUBTRACT CHARACTERS FOR OUTPUT
SETZM CACCTR ;THEN CLEAR CHARACTERS OUTPUT
LOAD S1,CASPAC,TXT.SS ;NOW GET THE SPACING CODE
CAXE S1,TXT.SM ;WANT THIS CENTERED?
JRST SPAC.1 ;NO, SO SKIP THIS
ASH P1,-1 ;DIVIDE SPACING NEEDED BY 2
MOVX S1,TXT.SL ;SET NOW FOR LEFT JUSTIFICATION ONLY
STORE S1,CASPAC,TXT.SS ;AND FALL INTO REGULAR SPACING CODE
SPAC.1: JUMPLE P1,.RETT ;CHECK FOR DONENESS
LOAD S1,CASPAC,TXT.SC ;GET THE CHARACTER TO OUTPUT
PUSHJ P,PUT7 ;AND PRINT IT
SOJA P1,SPAC.1 ;REPEAT TILL DONE
SUBTTL CNTDT - Convert UDT to TOPS-10 DATE UUO Time and Seconds
; This routine gratefully stolen from SCAN
;
;Call: MOVE S1,DATE/TIME
; PUSHJ P,.CNTDT
; Return with T1=Seconds since Midnight, 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,S1 ;SAVE TIME FOR LATER
JUMPL S1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ S1,S1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI S1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
;S1=DAYS SINCE JAN 1, 1501
IDIVI S1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY
LSH S2,2 ;CONVERT TO NUMBER OF QUARTER DAYS
IDIVI S2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY
IORI T1,3 ;DISCARD FRACTIONS OF DAY
IDIVI T1,4*365+1 ;SEPARATE INTO YEARS
LSH T2,-2 ;T2=NO DAYS THIS YEAR
LSH S1,2 ;S1=4*NO QUADRACENTURIES
ADD S1,S2 ;S1=NO CENTURIES
IMULI S1,100 ;S1=100*NO CENTURIES
ADDI S1,1501(T1) ;S1 HAS YEAR, S2 HAS DAY IN YEAR
MOVE S2,S1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE S2,3 ;IS THE YEAR A MULT OF 4?
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR
IDIVI S2,100 ;SEE IF YEAR IS MULT OF 100
SKIPN T1 ;IF NOT, THEN LEAP
TRNN S2,3 ;IS YEAR MULT OF 400?
TDZA T1,T1 ;YES--LEAP YEAR AFTER ALL
CNTDT0: MOVEI T1,1 ;SET LEAP YEAR FLAG
;T1 IS 0 IF LEAP YEAR
;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI S1,1964 ;SET TO SYSTEM ORIGIN
IMULI S1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T1,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T2,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T2 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI S2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T2,MONTAB+1(S2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI S1,31 ;NO--COUNT SYSTEM MONTH
AOBJN S2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T2,MONTAB(S2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD S1,T2 ;INCLUDE IN FINAL RESULT
CNTDT6: SKIPGE S1 ;TEST FOR JUNK
SETZ S1,0
EXCH S1,(P) ;SAVE ANSWER, GET TIME
TLZ S1,-1 ;CLEAR DATE
MULI S1,<EXP 24*60*60> ;CONVERT TO SECONDS/DAY
DIV S1,[1B17] ;SHIFT BINARY POINT
CAIL S2,<EXP 1B18> ;ROUND UP?
ADDI S1,1 ;YES, DO SO
POP P,S2 ;RECOVER DATE
$RETT ;RETURN
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
RADIX 8 ;BACK TO USUAL RADIX
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.
; 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.
ANDI S1,177 ;MAKE SURE ITS ONLY SEVEN BITS
AOS S2,CACCTR ;INCREASE CHARACTER COUNT
SKIPE NOOUTP ;SUPRESSING ACTUAL OUTPUT?
$RETT ;YES, RETURN TRUE NOW
SKIPN CACMAX ;IF FIELD IS NOT COUNTED
MOVX S2,1B0 ;MAKE ALL CHARACTERS BE PRINTED
CAMLE S2,CACMAX ;CHECK FOR MAXIMUM
$RETT ;IF TOO MANY, DON'T PRINT IT
PUSHJ P,@USROUT ;ELSE, OUTPUT IT
JUMPT .RETT ;IF RETURNED OK, RETURN NOW
SETOM ERREXT ;INDICATE AN ERROR OCCURED.
$RETT ;AND RETURN.
; 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
; 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: PUSHJ P,.SAVE2 ;SAVE P1 AND P2
MOVE P2,S1 ;COPY NODE NUMBER TO P2
MOVE S1,[2,,P1] ;AC FOR NODE.
MOVX P1,.NDRNN ;FUNCTION FOR NODE.
NODE. S1, ;GET THE NODE NAME
JRST [MOVE S1,P2 ;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 ;WAS IT SIXBIT
EXCH S1,P2 ;GET THE SIXBIT VALUE
PUSHJ P,PUTW ;OUTPUT THE NAME
$PUT7(<(>) ;THEN A LEFT BRACKET
MOVE S1,P2 ;COPY NUMBER TO S1
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: 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