Trailing-Edge
-
PDP-10 Archives
-
bb-v895a-bm_tops20_v41_2020_dist_2of2
-
language-sources/sprint.mac
There are 37 other files named sprint.mac in the archive. Click here to see a list.
TITLE SPRINT DECsystem-10/20 Control Card Interpreter
SUBTTL Larry Samberg/LSS/JHT/JNG/WLH/NT 1-Jan-82
;
;
;
ASCIZ /
COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION
1973,1974,1975,1976,1977,1978,1979,1980,1981,1982
/
; 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.
SALL ;Generate clean listing
SEARCH GLXMAC ;Get GLXLIB symbols
PROLOGUE(SPRINT)
SEARCH QSRMAC ;Get QUASAR symbols
SEARCH ORNMAC ;GET ORION SYMBOLS (WTO STUFF)
SEARCH ACTSYM ;GET ACCOUNTING SYMBOLS
; Version Information
SPTVER==104 ;Major Version Number
SPTMIN==0 ;Minor Version Number
SPTEDT==4303 ;Edit Level
SPTWHO==0 ;Who Last Patched
%SPT==<BYTE (3)SPTWHO(9)SPTVER(6)SPTMIN(18)SPTEDT>
; Store Version number in JOBVER
LOC 137
.JBVER::EXP %SPT
RELOC
DEFINE FACT,<IFN FTFACT>
; TABLE OF CONTENTS FOR SPRINT
;
;
; SECTION PAGE
; 1. Revision History.......................................... 3
; 2. Conditional Assembly Switches And Parameters.............. 4
; 3. Conditional Assembly Macros............................... 4
; 4. $TEXT Macros for CTL and LOG files........................ 4
; 5. Symbol Definitions........................................ 5
; 6. Card Code Conversion Table Generation..................... 6
; 7. File Block Definitions.................................... 12
; 8. AUXACC.SYS Table Definitions.............................. 13
; 9. Argument Blocks for QUEUE. UUOs........................... 14
; 10. TBLUK Table Generation Macro.............................. 15
; 11. Control Card Tables....................................... 16
; 12. Switch Tables............................................. 20
; 13. Lowsegment Storage Cells.................................. 23
; 14. Non-zero storage.......................................... 28
; 15. Entry and Initialization.................................. 29
; 16. Receive a Message
; 16.1 IDLE - Idle Loop.................................. 31
; 16.2 IDLNEX - Process NEXTJOB Message.................. 32
; 16.3 IDLSUP - Process SETUP Message.................... 33
; 16.4 IDLTXT - Process TEXT Message..................... 34
; 17. PROCJS - Process A Job Stream............................. 35
; 18. MAIN - Main Program Loop.................................. 36
; 19. STRTJB - Start up the job................................. 37
; 20. Control Cards
; 20.1 CONTRL - Setup and Dispatch....................... 39
; 20.2 $JOB and $SITGO Cards............................. 40
; 20.3 $LANGUAGE......................................... 45
; 20.4 $DECK - $CREATE................................... 48
; 20.5 $RELOC............................................ 49
; 20.6 $INCLUDE.......................................... 50
; 20.7 $DATA............................................. 51
; 20.8 $EXECUTE.......................................... 52
; 20.9 $DUMP............................................. 53
; 20.10 $PASSWORD......................................... 53
; 20.11 $MESSAGE.......................................... 54
; 20.12 BATCH Commands.................................... 55
; 20.13 $IF Command....................................... 56
; 20.14 LABEL Command..................................... 57
; 20.15 $EOD.............................................. 58
; 20.16 $EOJ.............................................. 58
; 20.17 $SEQUENCE......................................... 58
; 20.18 $TOPS10 - $TOPS20................................. 59
; 21. Routines To Finish A Job
; 21.1 TRMJOB - Normal Job Termination................... 60
; 21.2 ABORT - Abort the current job..................... 61
; 22. Switch Processing Routines
; 22.1 DOSWCH - Process switches......................... 63
; 22.2 $JOB Card Switch Subroutines...................... 65
; 22.3 Non-$JOB Card Switch Routines..................... 73
; 22.4 RCKOCT - Range ck octal value..................... 76
; 22.5 RCKDEC - Range ck decimal value................... 76
; 23. LOG File I/O Utilities
; 23.1 MAKLOG - Create the LOG File...................... 77
; 23.2 LOGTXT - Output text to LOG File.................. 78
; 23.3 LOGCRD - Output a card to LOG File................ 78
; 23.4 LOGCLS - Close the LOG File....................... 78
; 23.5 SUMARY - Place summary lines in LOG............... 79
; 24. CTL File I/O Utilities
; 24.1 MAKCTL - Create the CTL File...................... 80
; 24.2 CTLCRD - Output card to CTL file.................. 81
; 24.3 CTLTXT - Output text to CTL file.................. 82
; 24.4 CTLEOL - Output EOL to CTL file................... 82
; 25. General File I/O Utilities
; 25.1 CLRFOB - Clear File Open Block.................... 83
; 25.2 SETFAB - Set File Attributes...................... 83
; 25.3 FILENT - Open a User File......................... 84
; 25.4 MAKFUN - Create a filename...................... 85
; 26. File Block Utilities
; 26.1 FBENT - Make a File Block entry................... 87
; 26.2 FBCLOD - Clear File Block LOaD bits............... 88
; 27. String scanning routines
; 27.1 CHEKCC - Check for a control card................. 89
; 27.2 S$OCT / S$DEC - Number scanners................... 91
; 27.3 S$ASCZ - Scan an ASCIZ string................... 92
; 27.4 S$DTIM - Scan a date/time string.................. 93
; 27.5 S$QUOT - Scan a quoted string..................... 94
; 27.6 S$PPN - Scan a PPN string......................... 95
; 27.7 S$TIM -- Scan a time specification................ 97
; 27.8 S$FILE - Scan off a filespec...................... 98
; 27.9 S$FSPC - Flush leading spaces..................... 102
; 27.10 S$FCOL - Flush over colon......................... 103
; 27.11 S$INIT - Init Scanner............................. 104
; 27.12 S$INCH - Get a character.......................... 105
; 27.13 GETCHR - Get and map a character.................. 106
; 28. Card reading routines
; 28.1 CRD$CC - Read a $ Control Card.................... 107
; 28.2 CRDEOJ - Flush to end of job...................... 108
; 28.3 CDRASC - Read ASCII text.......................... 109
; 28.4 CDR.SA - Read in Stream ASCII mode................ 110
; 28.5 CDR.AI - Read in Augmented Image mode............. 112
; 28.6 CDR.FA - Read in Fixed ASCII mode................. 113
; 28.7 CDRBIN - Read a Chksummed Binary Card............. 114
; 28.8 CDRIMG - Read an Image Card....................... 117
; 28.9 INFAIL - Input failure from source file........... 118
; 29. Deck Stacking Routines
; 29.1 STASC - Stack ASCII Deck.......................... 119
; 29.2 STIMG - Stack Image Deck.......................... 120
; 29.3 STBIN - Stack Binary Deck......................... 121
; 29.4 FILERR - Error writing user file.................. 122
; 29.5 CARDID - Identify card with error................. 122
; 30. Usage Accounting Routines
; 30.1 DOFACT - Fact Accounting.......................... 123
; 30.2 ACTLST - Usage Accounting Data.................... 125
; 30.3 ACTINI - Set Up Usage Accounting.................. 126
; 31. TOPS-10 Accounting Routines
; 31.1 .................................................. 127
; 31.2 ACTOPN - Open accounting file..................... 128
; 31.3 AUXSCN - Scan for next AUXACC entry............... 129
; 31.4 SRHAUX - Search AUXACC for entry.................. 130
; 31.5 MAKSL - Make a search list........................ 131
; 31.6 MAKPTH - Create UFD and SFD on a STR.............. 132
; 31.7 FIXXPD - Expiration date conversion............... 134
; 31.8 .CNVDT - Convert to UDT........................... 135
; 31.9 SETUFL - Set UFD interlock........................ 137
; 31.10 CLRUFL - Clear UFD interlock...................... 137
; 31.11 GETSRC/SETSRC - GET/SET Search-List............... 138
; 31.12 DELSRL - Delete Search-List....................... 140
; 31.13 DOACCT - Do all job accounting.................... 141
; 31.14 Error traps....................................... 142
; 32. TOPS-20 Accounting Routines
; 32.1 DOACCT - Do all job accounting.................... 143
; 33. QUASAR Message Routines
; 33.1 QUEJOB - Create batch entry....................... 144
; 33.2 QUELOG - LOG file PRINT request................... 145
; 33.3 QUEFIL - User file request........................ 146
; 33.4 UPDQSR - Send Update Message...................... 147
; 33.5 RELREQ - Release a Request........................ 148
; 33.6 Utility subroutines............................... 149
; 34. $TEXT Utilities........................................... 150
; 35. Interrupt System Database................................. 151
SUBTTL Revision History
; Edit SPR # Comment
; 4000 N/A 1) Make this SPRINT version 104 for
; GALAXY release 4.
; 4001 20-11339 1) Parenthesized switches on the
; $COBOL card on the 20 don't
; produce a reasonable error.
; 4002 10-24080 1) Don't put %ERR:: into CTL file,
; so /OUTPUT:ERROR will work.
; 4003 N/A 1) If /TIME: is the last thing on
; the $JOB card, give the job a
; default time instead of 72 plus
; hours.
; 4004 10-26239 1) Don't create UFD's on any
; structure with a FCFS quota of
; zero.
; 4005 10-25504 1) When SPRINT processes a job that
; doesn't have an AUXACC entry it
; uses the search list from the
; previous job. Make a null search
; list and allow the job to die
; gracefully.
; 4006 N/A 1) Make accounting code more
; efficient.
; 4007 N/A 1) Use PHASE/DEPHASE pseudo-ops to
; define accounting records.
; 2) Replace L.ACC block with CSHIDX
; word and SAVCHR. Avoids
; confusion.
; 3) Remove L.MTCH symbol and
; storage. No longer needed.
; 4) Add QUASAR dispatch table.
; 4010 N/A 1) Process comment cards properly.
; 4011 N/A 1) Fix W$WIDT routine to properly
; save the width argument.
; 4012 N/A 1) Make job card area large enough
; to accomodate full 80-column
; card plus a null for ASCIZ.
; 2) Make SUPPRESS and WIDTH
; combination work correctly.
; 3) Allow SPROUT's header and
; trailer cards to pass through
; the system correctly.
; 4013 N/A 1) After processing a job-control
; card call the "default" suppress
; routine, ie. don't assume the
; default condition is suppress.
; 4014 N/A 1) Start adding ASCII mode support
; 4015 N/A 1) Implement further 4014
; 4016 N/A 1) Do SETNAM UUO to clear JACCT
; bit.
; 2) Allow for wider lines in a
; stream ASCII file.
;
; 4017 N/A 1) Make TOPS10 name switch work
; again.
; 4020 N/A 1) Make mode change switches
; illegal when interpreting ASCII
; mode decks.
;
; 4021 N/A 1) References to .EQOWN converted
; to .EQOID (library change).
; 4022 N/A 1) Enter switches for batch log
; creation, operator intervention
; and user notification.
;
; 4023 N/A 1) Update IB to reflect library
; change.
;
; 4024 N/A 1) Put in USAGE accounting.
;
; 4025 20-11860 1) USAGE accounting. Charge the
; reading of cards to the user who
; is reading the cards not to the
; operator.
;
; 4026 N/A 1) Don't default deletion of the
; input "deck". only delete it if
; either FP.SPL or FP.DEL is set.
;
; 4027 N/A 1) Create a new entry point for the
; FILENT subroutine calling it
; FRCENT. The entry point is
; defined to prevent the library
; from doing the CHKAC JSYS when
; we're trying to write files into
; <SPOOL>.
; 2) Change the "ERROR" option to the
; OUTPUT switch to "ERRORS"(Note
; the plurality).
; 3) Improve error reporting.
; 4) Start allowing for pass-thru of
; certain parameters in the EQ.
; 5) Change the current /WRITE and
; /WRITE-LOG switches to /BATLOG
; and /BATCH-LOG respectively.
; The arguments SUPERSEDE, APPEND
; AND SPOOL Will remain unchanged.
; 6) Do STR Accounting bypass.
; 7) "Remember" the AFTER parameter
; from the NEXTJOB for the CREATE
; message.
; 8) Put IB.PRG back into the IB.
; 9) Make the USAGE entry list work.
; Specifically, remove all
; references to immediate mode
; data (US%IMM). Also, add entries
; that are now required by the
; USAGE JSYS that were missing.
;
; 4030 N/A 1) Get rid of all default items in
; the USAGE Accounting list.
; 2) Make switches work on $LANGUAGE
; card. Problem was that GTJFN
; bumped the byte pointer past the
; slash. Solution was to
; decrement the BP after the
; GTJFN.
;
; 4031 N/A 1) Provide for machine independent
; control files.
; 4032 N/A 1) Make $RELOCATABLE card illegal
; except when taken from card
; reader.
; 2) Suppress Job Information when
; sending WTO's.
; 4033 N/A 1) Allow for multiple Job decks to
; be processed in a single Job
; request. This affects the
; current processing done on
; detection of $EOJ, EOF and $JOB.
; 4034 N/A 1) Implement $LABEL card.
; 2) Modify the $IF card logic to
; examine the first non-blank
; character following the CPAREN
; and if it's a DOLLAR then
; convert it to the system prompt
; character, ie. make the $IF
; card truly system independent.
; 3) Allow the $PASSWORD card to be
; optional when the specified
; directory on the job card
; matches the submitter's
; directory.
; 4035 1) If there is not a blank
; character immediately following
; the language control card then a
; filespec error will result
; because the GTJFN wonT "see" the
; slash character. This fix
; should finish up the problems
; incurred by using GTJFN that
; were started in edit 4030.
; 4036 1) Allow "REQUEST FOR CHECKPOINT"
; messages to be ignored by
; SPRINT.
; 2) Solve the problems involved with
; not resetting the previous
; line's width when scanning blank
; cards.
; 4037 N/A 1) Handle the FP in a different
; way.
; 4040 N/A 1) Stop connecting to user
; directories. Instead, expand all
; FD's.
; 4041 N/A 1) Do fixup to make the destination
; node the same as the originating
; node in the QUOLOG routine.
; 4042 N/A 1) Fix the null filespec problem on
; control cards so that they give
; the proper error in the user's
; log file.
; 4043 N/A 1) Setup FILRFD block correctly.
; 4044 N/A 1) Fix blank card problem in CDRASC
; routine. Character count was not
; being cleared properly.
; 4045 N/A 1) Make first pass at allowing
; mixed-case alphabetics in
; control cards.
; 4046 N/A 1) Make SPRINT run on the 10. This
; includes fixups to handle MACRO
; Assembler incompatibilities.
; 4047 N/A 1) File loading order wasn't being
; cleared on appropriate control
; cards.
; 2) Fix improper handling of CRLF on
; Stream ASCII FILES.
; 4050 N/A 3) Change the format of WTOJ's.
; 4051 N/A 1) Fix manifestation of LOG file
; deletion when OUTPUT:NOLOG is
; specified and the job is not
; submitted to the input spooler.
; 4052 N/A 1) Provide support for a system
; independent control card to
; stack decks into the control
; file, al la $TOPS10.
; 4053 N/A 1) Use S%TBLK routine for scanners.
; 4054 N/A 1) Continue edit 4053 (S%TBLK stuff).
; 4055 N/A 1) Fix bug in switch scanner(S$ASCZ).
; 4056 N/A 1) Report illegal switch arguments
; as well as illegal switches.
; 2) Don't log illegal control cards
; twice.
; 4057 N/A 1) Validate conditional in $IF card.
; 4060 N/A 1) Make S$ASCZ routine clear first
; word of storage area.
; 4061 N/A 1) Remove the S$SIX routine and
; instead use the S%SIXB routine
; in the library.
; 4062 N/A 1) Make $INCLUDE follow the same
; logic as the $language cards.
; 4063 N/A 1) When doing Usage accounting make
; that no extraneous bits appear in
; the sequence number entry.
; 4064 N/A 1) Set the FNDJOB flag sooner.
; 4065 N/A 1) Change error message for Invalid
; Password card.
; 2) Reset byte pointer in the ASCII
; card stacking routine, STASC.
; 4066 N/A 1) Minor fix to S$ASCZ routine. Make
; it accept all digits, (0-9).
; 4067 N/A 1) Move Node from Next Job Message to WTOOBJ
; for Real Readers otherwise use default Node
; 4070 23-Aug-79 1) Queue up Log for User if Job Card is valid
; 4071 27-Aug-79 1) Stopcodes to ORION
; 2) On Null Jobname Use Funny name
; 4072 30-Aug-79 1) SET ONOD field on Creates to Quasar so
; Output will get located properly
; 4073 24-Apr-80 1) Add usage accounting for TOPS-10
; 4074 25-Apr-80 1) Supress DDT type out of ACCT.SYS symbols
; 2) Supress DDT type out of AUXACC.SYS symbols
; 4075 23-Jun-80 1) If a job is aborted, QUELOG is called before
; DOFACT which deletes the EQ page. DOFACT
; on AC 'Q' pointing to something useful.
; Solution: call DOFACT before QUELOG.
; 4076 3-Jul-80 1) Add SITGO support
;
; 4077 5-AUG-80 SPR 20-14313 Delete the 3 lines which prevent
; SPRINT from overwriting an existing file when
; processing the $CREATE card.
;
; 4100 5-aug-80 SPR 20-14274 Card decks with sub-directories
; do not work. Allow periods in S$ASCZ.
; 4101 15-SEP-80 ALLOW LOWER CASE PASSWORDS
; 4102 22-Sep-80 Use new feature IB.DET to detach from FRCLIN.
; 4103 1-OCT-80 DELETE IB.DET (GLXLIB DEFAULTS TO DETACH)
;
; 4104 2-Oct-80 Fix miscellaneous accounting problems
;
; 4105 2-Oct-80 Remove SETNAM to turn off JACCT since no
; Galaxy component requires it be set. The
; correct solution also requires removing
; the PRVTAB entry in COMCON as well.
;
; 4106 3-Oct-80 Edit 4034 doesn't work correctly if the
; submitting job's PPN and the batch job's
; PPN are the same. It ended up eating one
; to many cards. Do it right this time.
;
; 4107 10-Oct-80 SPRINT has the /UNIQUE values all screwed up.
; In addition, /UNIQUE:2 will cause the job to
; run in a unique SFD as always, but imply
; /UNIQUE:NO.
;
; 4110 19-Nov-80 Fix $EOD to call QUEFIL first before
; releasing the file to prevent IFN stopcd.
; Fix QUEFIL routine to save page number in
; P1 instead of T1 since it is destroyed in
; a called routine.
;
; 4111 19-Nov-80 Fix $DECK card processing so that extensions
; are correct. (place under TOPS20 conditionals)
;
; 4112 1-Dec-80 Code to parse /CORE argument thinks value is
; in words and converts to pages. Remove ASH.
;
; 4113 31-Dec-80 Add support for the SIMULA compiler.
;
; 4114 1-Jan-81 Seperate new log file from old ones by a
; form-feed.
;
; 4115 12-Jan-81 Fix problem with /CREF switch on $FORTRAN
; card being ignored.
;
; 4116 12-Jan-81 Allow line sequence numbers in CTL file.
;
; 4117 12-Jan-81 Don't assume control cards are in ASCII when
; they get logged. Use L.DMOD instead of L.CASC
;
; 4120 12-Jan-81 Fix bad byte pointer that caused card reading
; not to work if job submitted with /READER
; switch. Once again, ASCII cards were assumed.
;
; 4121 20-Jan-81 Don't stopcode if a text message is received,
; just bitch to the operator and ignore it.
;
; 4122 23-Jan-81 More problems with ASCII/BCD card confusion.
;
; 4123 30-Jan-81 Only set bit to strip line sequence numbers
; if talking ASCII in IDLN.3
;
; 4124 9-Feb-81 Use ACTSYM definitions for ACCT.SYS
;
; 4125 9-Feb-81 Check for expired PPN.
;
; 4126 9-Feb-81 Set the spooled file bit when creating 'SPRINT
; ERROR' log files so it doesn't get created in
; the user's area.
;
; 4127 11-Feb-81 Add FACT file accounting support
;
; 4130 27-Feb-81 Fix QUEFIL - change HLLZ to HLRZ to get device
;
; 4131 6-Mar-81 Fix account string parsing.
;
; 4132 11-Mar-81 Don't echo passwords on $PASSWORD cards.
;
; 4133 27-Mar-81 Make /LOGDISP:DELETE the default
;
; 4134 27-Mar-81 Change code at DO10E6:+1 to call error
; routine ACTCER rather than ACTERR
;
; Fix all error calls that transfer to
; ABORT: so that AC B points to a text block
;
; 4135 27-Mar-81 Remove setting of feature test switch
; for FACT accounting
; (Moved to GALCNF)
;
; 4136 30-Mar-81 Clear rescan flag during switch
; processing to prevent incorrect
; error messages.
;
; 4137 30-Mar-81 Fix problem with duplicate definition of
; CD.BTC bit.
;
; 4140 30-Mar-81 Remove duplicate instruction at CDRD.6
;
; 4141 1-Apr-81 Fix the mode problems for the last time.
; (Note that this is April Fool's Day!)
; L.DHOL contains the pointer to the card
; buffer in the default mode for this job.
; Don't reference the buffer as L.CASC or
; L.C026 or even L.DMOD because these are
; fixed at assembly time and cannot be
; changed during the processing of a job.
;
; 4142 1-Apr-81 Rework the input routines for Stream
; ASCII and Augmented Image. Make sure
; AI buffers are terminated by a zero byte
; since they are printed as ASCIZ strings.
; Ignore zero bytes on input.
;
; 4143 6-Apr-81 Change the structure of the main
; processing loop and control card
; dispatch. Eliminate direct branches
; back to the IDLE loop. Make routines
; adher to the Galaxy register conventions
; (that is, don't expect values in T
; registers to be preserved across
; subroutine calls) as well as return
; success or failure.
;
; 4144 15-Apr-81 Fix /LOCATE so that it will take a
; node name as well as a number.
;
; 4145 15-Apr-81 Change the way /WIDTH is handled so that
; $EOD will still terminate a deck even if
; /WIDTH:2 has been specified.
;
; 4146 30-Apr-81 Fixup the command scanning routines so
; that they are not so sensitive to
; blanks. Add routine CHEKCC to localize
; the checking for a control card.
;
; 4147 8-May-81 Replace calls to S$DATE with calls to
; the GLXLIB routine S%DATI to remove
; code that does UUOs under TOPS-20.
;
; 4150 8-May-81 LOG files written to spooled area don't
; get deleted. Furthermore, if LPTSPL
; later does an access check on a spooled
; file, it will fail. Have QUEJOB and
; QUELOG set FP.DEL and FP.SPL for these
; files so everything works right.
;
; 4151 11-May-81 LOG files included in a create message
; should always have %BAPND mode set in
; the limit word, so QUASAR doesn't try
; to create a new file name.
;
; 4152 11-May-81 Fix QUEFIL so that $CREATE files with a
; queue switch end up at the right node.
;
; 4153 12-May-81 Fix MAKLOG so that if a job is being
; aborted and no log file exists yet,
; SPRINT will try to create the LOG in
; the spooled area of SSL: which should
; have a high probability of success.
;
; 4154 13-May-81 When a job is aborted due to a bad
; control card, have the error message
; sent to the operator include more
; information.
;
; 4155 15-May-81 Fix coding error in DOFACT. Change bad
; PUSHJ instruction to a JRST DOFA.1.
;
; 4156 15-May-81 Have QUEFIL put a message in the log
; when it queues a file. This edit
; changes code put in at edit 4103.
;
; 4157 15-May-81 Use .OTBIN for all SPRINT operator
; messages rather than .OTBIN for /READER
; files and .OTRDR for real reader files.
;
; 4160 15-May-81 Fix error in ABORT code so that jobcard
; is included in error message sent to
; operator if a valid jobcard has been
; processed for the job.
;
; 4161 15-May-81 Fatal errors should be prefaced with
; FATAL message rather than STERR message.
;
; 4162 18-May-81 Make the following switches legal on
; TOPS-20, too: /CARDS, /CPUNCH, /FEET,
; /PLOT, /PROTECT, /TPLOT, /TPUNCH.
;
; 4163 18-May-81 Fix initial message to LOG so that form-
; feed is first character. Then, LPTSPL
; will prevent blank pages in log.
;
; 4164 19-May-81 Undo 4163; Let LPTSPL worry about it.
;
; 4165 19-May-81 For control cards, trim the length to
; L.CSUP so trailing blanks are not put in
; error messages and LOG file entries.
;
; 4166 19-May-81 Use the EQ pointed to by register Q for
; FACT accounting rather than the copy
; starting at L.EQCP.
;
; 4167 20-May-81 Under certain sequences of error
; conditions, CTL files may not get
; released. Fix ABORT code to always get
; rid of the CTL file if one exits. Also,
; don't let ABORT try to create a LOG file
; just because the job is not "logged in."
; Check first! The LOG could have already
; been successfully created.
;
; 4170 20-May-81 Clear out Job Text at beginning of each
; job. Then OPR messages from a "pre-job
; abort" (e.g., jobcard error) will not
; display the job text of the previous
; successful job.
;
; 4171 21-May-81 Have STRTJB log any cards that begin
; with a $ while it it searching for a
; valid $JOB card.
;
; 4172 22-May-81 Define the $TEXTC and $TEXTL macros
; for outputting $TEXT messages to the
; CTL and LOG files. Then we can detect
; when the Text Output Routine has failed
; and pass on the failure to the caller.
;
; 4173 25-May-81 Add flag CDRAIM to indicate when a file
; is in augmented image mode and can
; therefore be interpreted in different
; modes (/026, /029, etc.).
;
; 4174 27-May-81 Change DOACCT routine for -20 to use
; common routine CRD$CC to read $PASSWORD
; card.
;
; 4175 27-May-81 Change RELJOB routine to RELREQ and only
; send one release message per request.
;
; 4176 28-May-81 Add CRDEOJ routine to flush the remain-
; ing cards of an aborted job.
;
; 4177 29-May-81 Change $TOPSxx processing so that
; the lines written to the CTL file don't
; contain trailing blanks. Some CUSPS
; can't swallow a line that long.
;
; 4200 29-May-81 Have SPRINT remove structures from its
; search list at the end of a job rather
; than at the beginning. Then SPRINT does
; not go to sleep with the structures from
; the previous job still mounted.
;
; 4201 30-May-81 Change the /PROTECT switch to
; /PROTECTION. (/PROTECT will still work)
; Make the switch work.
;
; 4202 30-May-81 Include the right account string for all
; files created by SPRINT.
;
; 4203 30-May-81 Include the expiration date in any UFD
; created by SPRINT.
;
; 4204 30-May-81 Change DOACCT on -10 so SPRINT no longer
; reads ACCT.SYS directly.
; SPRINT still must read AUXACC.SYS, but
; it will open and close the file for
; every job. Then if the system crashes
; while SPRINT is running, a large
; number of disk blocks will not be lost.
;
; 4205 30-May-81 Have SPRINT check the version # of the
; ACCT.SYS entry to make sure it can be
; processed.
;
; 4206 3-Jun-81 In QUEJOB, set the batch output
; destination node to the originating
; node for jobs coming from a physical
; card reader.
;
; 4207 4-Jun-81 Expand the table for creating USAGE
; accounting entries for TOPS-20.
;
; 4210 9-Jun-81 Shorten the error message that displays
; a card with Hollerith errors so that
; it will fit on 1 line in the LOG file.
;
; 4211 22-Jun-81 Fix parameter block (VALBLK) used for
; validating account strings.
;
; 4212 23-Jun-81 Modify edit 4177 so that null lines do
; not get written to the CTL file; instead
; write <space> <cr> <lf>. (This allows
; one to input a blank line to LIBOL.)
;
; 4213 24-Jun-81 Modify routine SETFAB so that parameter
; list arguments do not require a recal-
; culation of the effective address.
;
; 4214 22-Jul-81 Allow S$QUOT to parse strings containing blanks
; Add routine S$SIXB to convert ascii strings
; containing special characters to sixbit. This
; is required for quoted strings.
;
; 4215 23-Jul-81 Add instruction to store header length
; in EQ entry. (In routine STRTJB)
; Also, do validate accounts is ST%ACV is not
; on in the second monitor states word (%CNST2)
; is required for quoted strings.
;
; 4216 3-Aug-81 Fix S$FILE routine for TOPS-20 so that
; values are not stored in volatile regs
; across routine calls.
;
; 4217 3-Aug-81 Change CRDEOJ so that it will return
; failure only on EOF or an input error.
; Thus, other errors, like Hollerith
; errors, will not terminate the flush.
;
; 4220 4-Aug-81 Routines FILENT and FRCENT could fail
; and invoke ABORT processing. Have all
; routines calling FILENT and FRCENT check
; for failure before proceeding.
;
; 4221 11-Aug-81 Change routine MAKSL so that it does
; not keep counters in T regs across
; subroutine calls.
;
; 4222 21-Aug-81 Fix routine S$FILE for TOPS-10 so that
; blanks between the file name and PPN
; don't cause the PPN to be ignored.
;
; 4223 21-Aug-81 Fix routine FBENT for TOPS-10 so that
; entries for the .REL files created
; during the batch job specify the correct
; PPN and path. This will be the default
; directory path, rather than the same PPN
; as the source file.
;
; 4224 24-Aug-81 Have routine DOACCT initally zero the
; path block in the EQ entry. Otherwise,
; /UNIQUE:2 will not work if the file
; originated from an SFD more than 3 deep.
;
; 4225 27-Aug-81 Change instruction in routine JOBOS
; so byte pointer B is adjusted correctly
; when an ASCII deck is read under TOPS-10
; and SPRINT is assembled with BCD as the
; default.
;
; 4226 31-Aug-81 Add modifications from Stevens Institute
; to support SITGO.
;
; 4227 14-Sep-81 Fix a protection problem for $language
; cards on TOPS-20 which denied access to
; the user for his created files.
;
; 4230 22-Sep-81 Installed SITGO edit from Stevens at
; $DAT.1 + a few, and FBENT+1.
;
; 4231 29-Sep-81 Fix an error parsing file-specs in TOPS-20
; sub-directories which would use the directory
; name for the file name.
;
; 4232 9-Oct-81 Make parentheses legal directory
; delimiters to conform to the PPN
; conventions.
;
; 4233 23-Oct-81 Fix TOPS-20 spooled data files to
; allow for multiple $DATA cards per job.
; NOTE: An entry must be made in the
; .BWR file to set PS:<SPOOL> directories
; to infinite generation retention.
;
; 4234 20-Nov-81 Fixed /AFTER switch to give error on
; past times, and accept +times.
;
; 4235 23-Nov-81 Fixed /IMAGE mode processing.
;
; 4236 8-Jan-82 Fixed ILM stopcode obtained from outputting
; too many characters when LOGCNT goes negative.
;
; 4237 15-jan-82 Don't clear /NOTIFY field. QUASAR needs it
; intact.
;
; 4240 19-Jan-82 Allow long file names on TOPS-20.
;
; 4241 26-Jan-82 Take out CD.RNC.
;
; 4242 2-Feb-82 1) Fixed a syntax consistency check.
;
; 4243 7-JUN-82 Fix accounting so that runtime is not
; negative. answer to QAR 20-01007 GCO 4.2.1373
;
; 4300 5-Aug-82 Teach SPRINT about false returns from GLXLNK.
;
; 4301 6-Aug-82 Allow NULs in cards. GCO 1479
;
; 4302 2-Nov-82 Fix some GLXLNK calls. GCO 4.2.1526
;
; 4303 9-Nov-82 Fix copyright. GCO 4.2.1528
;
;End of revision history.
SUBTTL Conditional Assembly Switches And Parameters
;;DEFAULTS FOR THE /ERROR SWITCH
ND A%HLER,^D100 ;DEF NUMBER OF HOLLERITH ERRORS
ND A%ICER,5 ;DEF NUMBER OF ILL BINARY CARDS
ND A%CSER,5 ;DEF NUMBER OF CHECKSUM ERRORS
;;Defaults for the /LOGDISP switch
ND A%LGDS,1 ; 1=DELETE
; 0=PRESERVE
;;INTERNAL PARAMETERS
ND A%PDSZ,100 ;PUSHDOWN STACK LENGTH
ND A%DFMD,0 ;DEFAULT INPUT MODE
; 0=ASCII
; 1=026
; 2=BCD
ND A%SPRS,0 ;DEFAULT /SUPP-/NOSUPP
; 0=/NOSUPPRESS
; 1=/SUPPRESS
ND JIFFIE,^D60 ;TICKS PER SECOND
SUBTTL Conditional Assembly Macros
DEFINE $SUPPRESS,<IFN A%SPRS,>
DEFINE $NOSUPPRESS,<IFE A%SPRS,>
SUBTTL $TEXT Macros for CTL and LOG files
;
; These macros expand into code that tests for an output
; error that could have happened during $TEXT processing.
;
DEFINE $TEXTL(S),
<$TEXT(LOGTXT,<S>)
TXNE F,F.LOGF
$RETF>
DEFINE $TEXTC(S),
<$TEXT(CTLTXT,<S>)
TXNE F,F.FATE
$RETF>
SUBTTL Symbol Definitions
;Accumulator assignments
B==13 ;UTILITY BYTE POINTER
Q==14 ;INDEX TO QUEUE PARAMETER AREA
F==15 ;FLAG REGISTER
C==16 ;INPUT/OUTPUT CHARACTER
;I/O Device channels
UFD==5 ;FOR LOOKING UP AND CREATING UFDS
;FLAGS (IN ACCUMULATOR F)
F.LOGF==1B24 ;Error while trying to output to LOG
F.USFD==1B25 ;JOB RUNS IN A UNIQUE SFD
F.SITG==1B26 ;QUEUE JOB FOR SITGO BATCH PROCESSING
F.FATE==1B27 ;ABORTING DUE TO FATAL ERROR
F.BTCH==1B28 ;SUBMIT JOB TO BATCH
F.MAP==1B29 ;/MAP WAS SPECIFIED
F.EOF==1B30 ;EOF was detected on input file
F.IFE==1B31 ;Error while reading input file
F.NAME==1B32 ;A name was supplied with /NAME
F.ACCT==1B33 ;An account string was supplied with
; /ACCOUNT
F.RSCN==1B34 ;CHARACTER INPUT INHIBIT
F.DOLR==1B35 ;HE SAID /DOLLAR FOR THIS DECK
;USEFUL SYMBOLS
IWPC==^D27 ;IMAGE WORDS/CARD
BWPC==^D26 ;BINARY WORDS/CARD
CPC==^D80 ;COLUMNS/CARD
SMA==^D133 ;MAXIMUM LINE WIDTH FOR ASCII FILES
;IMPORTANT ASCII CHARACTER IMAGES
.IMDOL==2102 ;DOLLAR SIGN
.IM79==5 ;7-9 PUNCH
;SOME RANDOM SYMBOLS
SLLEN==^D36*3 ;LENGTH OF A SEARCH LIST BLOCK
PTLEN==12 ;PATH EXTENSION TO S/L BLOCK
FIL.LN==3 ;NUMBER OF FILES TO DELETE PER LINE
;Default mode strings
IFE A%DFMD,<S.DMOD==[ASCIZ /ASCII/]
S.NMOD==[ASCIZ /026/]>
IFN A%DFMD,<S.NMOD==[ASCIZ /ASCII/]
S.DMOD==[ASCIZ /026/]>
SUBTTL Card Code Conversion Table Generation
;CALL IS:
; CODE(.COD,.P026,.PASC,.K)
;
;WHERE
; .COD iS the ASCII character or it's
; octal equivalent.
; .P026 is the 026 punch code
; .PASC is the ASCII punch code
; .K is non-blank if .COD is the
; octal equivalent of the character.
;TABLE FIELD MASKS
CODASC==0,,-1 ;ASCII CHARACTER
COD026==-1,,0 ;026/BCD CHARACTER
;OFFSET TO GENERATE FOR HOLLERITH ERROR
CODHER==100000 ;WILL GENERATE A "\"
;ROW PUNCH DEFINITIONS
..12== 20 ;A 12 PUNCH
..11== 10 ;A 11 PUNCH
..0== 4 ;A 0 PUNCH
..1== 40 ;A 1 PUNCH
..2== 100 ;A 2 PUNCH
..3== 140 ;A 3 PUNCH
..4== 200 ;A 4 PUNCH
..5== 240 ;A 5 PUNCH
..6== 300 ;A 6 PUNCH
..7== 340 ;A 7 PUNCH
..8== 2 ;A 8 PUNCH
..9== 1 ;A 9 PUNCH
;THE MACRO FOLLOWS
DEFINE CODE(.COD,.P026,.PASC,.K),<
XLIST
IF1 <
.T026==0
.TASC==0
IRP .P026,<
.T026==.T026+..'.P026
>
IRP .PASC,<
.TASC==.TASC+..'.PASC
>
IFB <.K>,<
.OCOD==<".COD">B17
SETSPI(\.T026,.OCOD)
.OCOD==".COD"
SETSPI(\.TASC,.OCOD)
>
IFNB <.K>,<
.OCOD==<.COD>B17
SETSPI(\.T026,.OCOD)
SETSPI(\.TASC,.COD)
>
>
LIST
SALL
>
;MACRO TO GENERATE SPIXXX SYMBOL AND DEFINE IT
DEFINE SETSPI(.A,.B),<
IFNDEF SPI'.A,<SPI'.A==0>
IFN <<SPI'.A>&777777>,<
IFN <.B&777777>,<
PRINTX ?MULT. DEF. CARD CODE - .A
PASS2
END
>>
IFN <<SPI'.A>&<777777>B17>,<
IFN <.B&<777777>B17>,<
PRINTX ?MULT. DEF. CARD CODE - .A
PASS2
END
>>
SPI'.A==SPI'.A+.B
>
;NOW, GENERATE THE SPIXXX SYMBOLS FOR THE CARD CODES
;DIGITS
CODE(0,<0>,<0>)
CODE(1,<1>,<1>)
CODE(2,<2>,<2>)
CODE(3,<3>,<3>)
CODE(4,<4>,<4>)
CODE(5,<5>,<5>)
CODE(6,<6>,<6>)
CODE(7,<7>,<7>)
CODE(8,<8>,<8>)
CODE(9,<9>,<9>)
;UPPER-CASE ALPHABETICS
CODE(A,<12,1>,<12,1>)
CODE(B,<12,2>,<12,2>)
CODE(C,<12,3>,<12,3>)
CODE(D,<12,4>,<12,4>)
CODE(E,<12,5>,<12,5>)
CODE(F,<12,6>,<12,6>)
CODE(G,<12,7>,<12,7>)
CODE(H,<12,8>,<12,8>)
CODE(I,<12,9>,<12,9>)
CODE(J,<11,1>,<11,1>)
CODE(K,<11,2>,<11,2>)
CODE(L,<11,3>,<11,3>)
CODE(M,<11,4>,<11,4>)
CODE(N,<11,5>,<11,5>)
CODE(O,<11,6>,<11,6>)
CODE(P,<11,7>,<11,7>)
CODE(Q,<11,8>,<11,8>)
CODE(R,<11,9>,<11,9>)
CODE(S,<0,2>,<0,2>)
CODE(T,<0,3>,<0,3>)
CODE(U,<0,4>,<0,4>)
CODE(V,<0,5>,<0,5>)
CODE(W,<0,6>,<0,6>)
CODE(X,<0,7>,<0,7>)
CODE(Y,<0,8>,<0,8>)
CODE(Z,<0,9>,<0,9>)
;LOWER CASE ALPHABETICS
CODE(141,<12,0,1>,<12,0,1>,O)
CODE(142,<12,0,2>,<12,0,2>,O)
CODE(143,<12,0,3>,<12,0,3>,O)
CODE(144,<12,0,4>,<12,0,4>,O)
CODE(145,<12,0,5>,<12,0,5>,O)
CODE(146,<12,0,6>,<12,0,6>,O)
CODE(147,<12,0,7>,<12,0,7>,O)
CODE(150,<12,0,8>,<12,0,8>,O)
CODE(151,<12,0,9>,<12,0,9>,O)
CODE(152,<12,11,1>,<12,11,1>,O)
CODE(153,<12,11,2>,<12,11,2>,O)
CODE(154,<12,11,3>,<12,11,3>,O)
CODE(155,<12,11,4>,<12,11,4>,O)
CODE(156,<12,11,5>,<12,11,5>,O)
CODE(157,<12,11,6>,<12,11,6>,O)
CODE(160,<12,11,7>,<12,11,7>,O)
CODE(161,<12,11,8>,<12,11,8>,O)
CODE(162,<12,11,9>,<12,11,9>,O)
CODE(163,<11,0,2>,<11,0,2>,O)
CODE(164,<11,0,3>,<11,0,3>,O)
CODE(165,<11,0,4>,<11,0,4>,O)
CODE(166,<11,0,5>,<11,0,5>,O)
CODE(167,<11,0,6>,<11,0,6>,O)
CODE(170,<11,0,7>,<11,0,7>,O)
CODE(171,<11,0,8>,<11,0,8>,O)
CODE(172,<11,0,9>,<11,0,9>,O)
;CONTROL CHARACTERS
CODE(0,<12,9,8,1,0>,<12,9,8,1,0>,O)
CODE(1,<12,9,1>,<12,9,1>,O)
CODE(2,<12,9,2>,<12,9,2>,O)
CODE(3,<12,9,3>,<12,9,3>,O)
CODE(4,<9,7>,<9,7>,O)
CODE(5,<0,9,8,5>,<0,9,8,5>,O)
CODE(6,<0,9,8,6>,<0,9,8,6>,O)
CODE(7,<0,9,8,7>,<0,9,8,7>,O)
CODE(10,<11,9,6>,<11,9,6>,O)
CODE(11,<12,9,5>,<12,9,5>,O)
CODE(12,<0,9,5>,<0,9,5>,O)
CODE(13,<12,9,8,3>,<12,9,8,3>,O)
CODE(14,<12,9,8,4>,<12,9,8,4>,O)
CODE(15,<12,9,8,5>,<12,9,8,5>,O)
CODE(16,<12,9,8,6>,<12,9,8,6>,O)
CODE(17,<12,9,8,7>,<12,9,8,7>,O)
CODE(20,<12,11,9,8,1>,<12,11,9,8,1>,O)
CODE(21,<11,9,1>,<11,9,1>,O)
CODE(22,<11,9,2>,<11,9,2>,O)
CODE(23,<11,9,3>,<11,9,3>,O)
CODE(24,<9,8,4>,<9,8,4>,O)
CODE(25,<9,8,5>,<9,8,5>,O)
CODE(26,<9,2>,<9,2>,O)
CODE(27,<0,9,6>,<0,9,6>,O)
;MORE CONTROL CHARACTERS AND OTHER SPECIAL CHARACTERS
CODE(30,<11,9,8>,<11,9,8>,O)
CODE(31,<11,9,8,1>,<11,9,8,1>,O)
CODE(32,<9,8,7>,<9,8,7>,O)
CODE(33,<0,9,7>,<0,9,7>,O)
CODE(34,<11,9,8,4>,<11,9,8,4>,O)
CODE(35,<11,9,8,5>,<11,9,8,5>,O)
CODE(36,<11,9,8,6>,<11,9,8,6>,O)
CODE(37,<11,9,8,7>,<11,9,8,7>,O)
CODE(<!>,<12,8,7>,<12,8,7>)
CODE(42,<0,8,5>,<8,7>,O)
CODE(<#>,<0,8,6>,<8,3>)
CODE(<$>,<11,8,3>,<11,8,3>)
CODE(<%>,<0,8,7>,<0,8,4>)
CODE(<&>,<11,8,7>,<12>)
CODE(<'>,<8,6>,<8,5>)
CODE(<(>,<0,8,4>,<12,8,5>)
CODE(<)>,<12,8,4>,<11,8,5>)
CODE(<*>,<11,8,4>,<11,8,4>)
CODE(<+>,<12>,<12,8,6>)
CODE(<,>,<0,8,3>,<0,8,3>)
CODE(<->,<11>,<11>)
CODE(<.>,<12,8,3>,<12,8,3>)
CODE(</>,<0,1>,<0,1>)
CODE(<:>,<11,8,2>,<8,2>)
CODE(<;>,<0,8,2>,<11,8,6>)
CODE(74,<12,8,6>,<12,8,4>,O)
CODE(<=>,<8,3>,<8,6>)
CODE(76,<11,8,6>,<0,8,6>,O)
CODE(<?>,<12,8,2>,<0,8,7>)
CODE(<@>,<8,4>,<8,4>)
CODE(133,<11,8,5>,<12,8,2>,O)
CODE(<\>,<8,7>,<0,8,2>)
CODE(135,<12,8,5>,<11,8,2>,O)
CODE(<^>,<8,5>,<11,8,7>)
CODE(137,<8,2>,<0,8,5>,O)
CODE(140,<8,1>,<8,1>,O)
CODE(173,<12,0>,<12,0>,O)
CODE(174,<12,11>,<12,11>,O)
CODE(175,<11,0>,<11,0>,O)
CODE(176,<11,0,1>,<11,0,1>,O)
CODE(177,<12,9,7>,<12,9,7>,O)
; Now generate the code conversion table
DEFINE CTGEN(K),<
IF1 <
IFNDEF SPI'K,<SPI'K==<"\",,"\">>
IFE <SPI'K & 777777>,<
SPI'K==SPI'K+"\">
IFE <SPI'K & <777777>B17>,<
SPI'K==SPI'K+<"\"B17>>
>
.XCREF
EXP SPI'K
.CREF
>
; The table generation is XLISTed because of size, for those
; of you reading the assembly listing, the following is
; XLISTed:
;REPEAT 377,<
; CTGEN(\K)
; K==K+1>
K==1
CODTBL: XWD " "," " ;SPACE IS A SPECIAL CASE
XLIST
REPEAT 377,<CTGEN(\K)
K==K+1>
LIST
XWD "\","\" ;FOR HOLLERITH ERRORS
SUBTTL File Block Definitions
.FBFLG==0 ;FLAGS
FB.LDR==1B18 ;LOAD FILENAME.REL ON $DATA($EX)
FB.LOD==1B19 ;LOAD FILENAME.EXT ON $DATA($EX)
FB.DEL==1B20 ;DEL THIS FILE ON .DEL LINE
FB.SRH==1B22 ;LOAD IN LIBRARY SEARCH MODE
.FBFD==1 ;BEGINNING OF THE FD
SUBTTL AUXACC.SYS Table Definitions
TOPS10 <
;AUXACC.SYS ENTRIES
PHASE 0
.AUBEG:! BLOCK 1 ;FIRST WORD, ALWAYS CONTAINS -1
.AUNUM:! BLOCK 1 ;NUMBER OF WORDS FOLLOWING
;THIS 1+ IS 5* THE NUM OF STRS
.AUPPN:! BLOCK 1 ;PROJECT-PROGRAMMER NUMBER
.AUSTR:! BLOCK 1 ;STRUCTURE NAME
.AURSV:! BLOCK 1 ;RESERVED QUOTA
.AUFCF:! BLOCK 1 ;FCFS QUOTA
.AULGO:! BLOCK 1 ;LOGOUT QUOTA
.AUSTS:! BLOCK 1 ;STATUS BITS
AU.RON==1B0 ;READ-ONLY
AU.NOC==1B1 ;NO-CREATE
DEPHASE
SUBTTL Argument Blocks for QUEUE. UUOs
;
; Argument block to obtain user profile
;
OUPBLK: QF.RSP!.QUMAE ; Want response,,talk to ACTDAE
0 ; Reserved
20,,PROFIL ; Length,,Addr of response block
QA.IMM!1B17!.QBAFN ; Accounting sub-function here
UGOUP$ ; Function = Obtain User Profile
1,,.UGPPN ; PPN for which to get profile
.EQOID(Q) ; Find it over there
OUPLEN==.-OUPBLK ; Length of the argument block
;
; Argument block to validate PPN, Password, and Account String
;
ACCBLK: QF.RSP!.QUMAE ; Want response,,talk to ACTDAE
0 ; Reserved
20,,RESPON ; Length,,Addr of response block
QA.IMM!1B17!.QBAFN ; Accounting sub-function here
UGACC$ ; Function: Access Control Check
QA.IMM!1B17!.UGTYP ; Type of check requested
UG.SPV ; SPRINT verify
10,,.UGACT ; Here comes an account string
.EQACT(Q) ; Find it over there
1,,.UGPPN ; PPN to check
.EQOID(Q) ; Find it over there
QA.IMM!1B17!.UGPSW ; Password the user specified
ACCPSW: 0 ; gets filled in here
ACCLEN==.-ACCBLK ; Length of the argument block
;
; Argument block to Validate Account String
;
VALBLK: QF.RSP!.QUVAL ; Want resp,,validate account
0 ; Reserved
20,,RESPON ; Length,,Addr of response block
1,,.QBOID ; PPN to check
.EQOID(Q) ; Find it over there
10,,.QBACT ; Here comes an account string
.EQACT(Q) ; Find it over there
VALLEN==.-VALBLK ; Length of the argument block
ACTVAL: 0,,0 ;Account validation switch
RESPON: BLOCK 20 ; The response block
PROFIL: BLOCK 20 ; User profile goes here
>;; END OF TOPS10 CONDITIONAL CODE
SUBTTL TBLUK Table Generation Macro
;TBLUK table generation macro
DEFINE TB(TEXT,FLAGS),<
XWD [ASCIZ/TEXT/],FLAGS
>
SUBTTL Control Card Tables
;DEFINE TABLE OF CONTROL CARD NAMES
; X CARD,DISPATCH ADR,DISPATCH BITS
;
;WHERE DISPATCH BITS ARE:
CD.BTC==1B0 ;THIS CARDS TURNS THE BATCH BIT ON
CD.CLO==1B1 ;CLEAR LOAD ORDER ON THIS CARD
CD.SBC==1B3 ;THIS IS A SPECIAL BATCH CARD
CD.PAS==1B4 ;This command is $PASSWORD
CD.EOD==1B7 ;This command is a deck terminator
CD.EOJ==1B8 ;This command is a job terminator
CD.BOJ==1B9 ;This command indicates beginning of job
CD.COM==1B10 ;This command is a $comment
CD.DDS==1B11 ;This command begins with double $
; (Set only in CHEKCC)
CD.DOL==1B12 ;This command begins with $
; (Set only in CHEKCC)
CD.STG==1B13 ;[SITGO] This card is legal in a $SITGO deck
CD.LAN==CD.BTC!CD.CLO ;DISPATCH BITS FOR ALL $LANG CARDS
;
; CD.BTC indicates that this command will require a batch
; control file to be generated.
;
; CD.SBC indicates that this SPRINT command can be converted
; into an equivalent batch command. Every command with
; CD.SBC set will also have CD.BTC set.
;
DEFINE CNAMES,<
X ALGOL,$ALGOL,CD.LAN
X BACKTO,$$BATCH,CD.BTC!CD.SBC
X BLISS,$BLISS,CD.LAN
X CHKPNT,$$BATCH,CD.BTC!CD.SBC
X COBOL,$COBOL,CD.LAN
X CREATE,$CREAT,0
X DATA,$DATA.,CD.BTC!CD.STG ;;[SITGO]
TOPS10 <X DECK,$DECK>
TOPS10 <X DUMP,$DUMP,CD.BTC!CD.SBC>
X EOD,$EOD,CD.EOD!CD.STG ;;[SITGO]
X EOJ,$EOJ,CD.EOD!CD.EOJ
X ERROR,$$BATCH,CD.BTC!CD.SBC
X EXECUTE,$EXECUTE,CD.BTC
X FORTRAN,$FORTRAN,CD.LAN
X GOTO,$$BATCH,CD.BTC!CD.SBC
X IF,$$IF,CD.BTC
X INCLUDE,$INCLU,CD.CLO
X JOB,JOBLIN,CD.EOD!CD.EOJ!CD.BOJ
X LABEL,$LABEL,CD.SBC
X MACRO,$MACRO,CD.LAN
X MESSAGE,$MESS,CD.SBC
X NOERROR,$$BATCH,CD.BTC!CD.SBC
X NOOPERATOR,$$BATCH,CD.BTC!CD.SBC
X OPERATOR,$$BATCH,CD.BTC!CD.SBC
X PASSWORD,$PASSW,CD.PAS!CD.STG ;;[SITGO]
TOPS10 <X RELOCATABLE,$RELOC,CD.CLO>
X REQUEUE,$$BATCH,CD.BTC!CD.SBC
X REVIVE,$$BATCH,CD.BTC!CD.SBC
X SEQUENCE,$SEQUE
X SILENCE,$$BATCH,CD.BTC!CD.SBC
X SIMULA,$SIMULA,CD.LAN
X SITGO,SITLIN,CD.EOD!CD.EOJ!CD.BOJ
X SNOBOL,$SNOBOL,CD.LAN
X TOPS,$TOPNTV,CD.BTC
TOPS10 <X TOPS10,$TOPNTV,CD.BTC>
TOPS10 <X TOPS20,$TOPFGN,CD.BTC>
TOPS20 <X TOPS10,$TOPFGN,CD.BTC>
TOPS20 <X TOPS20,$TOPNTV,CD.BTC>
> ;END DEF CNAMES
DEFINE X(A,B,C),<
TB(A,0)>
TBCARD: XWD TB.SIZ,TB.SIZ
CNAMES
TB.SIZ==.-TBCARD-1
DEFINE X(CARD,DISP,BITS<0>),<XALL
EXP DISP+BITS ; CARD
SALL>
CADRS: CNAMES
SUBTTL Switch Tables
;SWITCH TABLES
;VALID SWITCHES FOR ALL CARDS
; Y SWITCH NAME,DISPATCH ADR,VALID CARD FLAGS
;
;WHERE VALID CARD FLAGS ARE:
SW.LAN==1B18 ;LANGUAGE CARDS
SW.DEC==1B20 ;$DECK CARD and $CREATE
SW.DAT==1B22 ;$DATA CARD
SW.EXE==1B24 ;$EXECUTE CARD
SW.INC==1B25 ;$INCLUDE CARD
SW.JOB==1B26 ;$JOB CARD
SW.TOP==1B27 ;$TOPS10 CARD
SW.MOD==1B28 ;NON-ASCII MODE SPECIFIER
SW.ALL==SW.LAN!SW.DEC!SW.DAT!SW.TOP
DEFINE SNAMES,<
Y 026,SW.ALL!SW.MOD
Y ACCOUNT,SW.JOB
Y AFTER,SW.JOB
Y ASCII,SW.ALL!SW.MOD
Y ASSISTANCE,SW.JOB
TOPS20 <Y <BATCH-LOG>,SW.JOB,BATCH>
TOPS10 <Y BATLOG,SW.JOB,BATCH>
Y BCD,SW.ALL!SW.MOD
TOPS10 <Y BINARY,SW.DEC!SW.DAT!SW.MOD>
Y CARDS,SW.JOB
TOPS10 <IFN INPCOR,<Y CORE,SW.JOB>>
Y CPUNCH,SW.DEC
Y CREF,SW.LAN
Y DEPEND,SW.JOB
Y DOLLARS,SW.ALL
Y ERRORS,SW.JOB!SW.MOD
Y FEET,SW.JOB
Y HOLLERITH,SW.JOB!SW.MOD
Y IMAGE,SW.DEC!SW.DAT!SW.MOD
Y JOBNAME,SW.JOB
Y LIST,SW.LAN
Y LOCATE,SW.JOB
Y LOGDISPOSITION,SW.JOB
Y MAP,SW.DAT!SW.EXE
TOPS10 <Y NAME,SW.JOB>
Y NODOLLARS,SW.ALL
Y NOLIST,SW.LAN
Y NOMAP,SW.DAT!SW.EXE
Y NORESTARTABLE,SW.JOB
Y NOSUPPRESS,SW.ALL
Y OUTPUT,SW.JOB
Y PAGES,SW.JOB
Y PLOT,SW.DEC
Y PPN,SW.JOB
Y PRINT,SW.DEC
Y PRIORITY,SW.JOB
Y PROTECTION,SW.DEC
Y RESTARTABLE,SW.JOB
Y SEARCH,SW.INC
Y SEQUENCE,SW.JOB
Y SUPPRESS,SW.ALL
Y TIME,SW.JOB
Y TPLOT,SW.JOB
Y TPUNCH,SW.DEC
Y UNIQUE,SW.JOB
Y USER,SW.JOB
Y WIDTH,SW.ALL
> ;END DEF SNAMES
DEFINE Y(A,B,C),<
TB(A,0)
>
TBSWIT: XWD SW.SIZ,SW.SIZ
SNAMES
SW.SIZ==.-TBSWIT-1
DEFINE Y(A,B,C),<
XALL
IFB <C>,<XWD B,W$'A>
IFNB <C>,<XWD B,W$'C>
SALL>
;TABLE OF FORM: XWD <VALID CARD FLAGS>,<DISPATCH ADDRESS>
SADRS: SNAMES
SUBTTL Lowsegment Storage Cells
L.PDL: BLOCK A%PDSZ ;PUSHDOWN LIST
L.JOB: BLOCK 1 ;SPRINT job number
L.TTY: BLOCK 1 ;SPRINT node,,line
L.LIN: BLOCK 1 ;SPRINT line number
L.NODE: BLOCK 1 ;SPRINT node
L.CON: BLOCK 1 ;SPRINT conntect time in seconds
L.CTI: BLOCK 1 ;SPRINT kilo-core-centi-seconds
L.DSR: BLOCK 1 ;SPRINT disk reads
L.DSW: BLOCK 1 ;SPRINT disk writes
L.PRIO: BLOCK 1 ;Priority
; The following locations are not zeroed or reset with each
; new job.
LOWBEG:
IFE A%DFMD,<L.DMOD:>
IFN A%DFMD,<L.NMOD:>
L.CASC: BLOCK IWPC ;CURRENT CARD IN ASCII
IFE A%DFMD,<L.NMOD:>
IFN A%DFMD,<L.DMOD:>
L.C026: BLOCK IWPC ;CURRENT CARD IN 026
L.CLEN: BLOCK 1 ;CARD LENGTH IN BYTES
L.CSUP: BLOCK 1 ;SUPPRESSED CARD LENGTH
L.BP: BLOCK 1 ;STORED BYTE POINTER FOR $TEXT
L.FUN: BLOCK 1 ;RANDOM (?) NUMBER FOR FUNNY NAMES
L.SLEN==40 ;SYSNAM LENGTH
L.SYSN: BLOCK L.SLEN ;SYSNAM
FAB.SZ==5 ; File Attribute Block size
; (Count word + 2 arguments)
L.FAB: BLOCK FAB.SZ ;"File Attribute Block"
L.FOB: BLOCK FOB.SZ ;"FILE OPEN BLOCK"
L.SAB: BLOCK SAB.SZ ;"SEND ARGUMENT BLOCK"
L.IFN: BLOCK 1 ;IFN FOR INPUT FILE
FNDJOB: BLOCK 1 ;SET UPON FINDING A $JOB CARD
CDRDEV: BLOCK 1 ;PHYSICAL READER FLAG
CDRAIM: BLOCK 1 ; Recording mode flag
; Set when augmented image (card image)
NXTRDY: BLOCK 1 ; Next card ready flag
; Words remembered from the NEXTJOB Message.
L.EQCP: BLOCK EQXSIZ ;COPY OF WHOLE NEXTJOB EQ
ACTSIZ==10 ;DEFAULT SIZE ....MAY BE CHANGED
L.RDR: BLOCK 1 ;THE READER SPECIFIER
L.INF: BLOCK 1 ;COPY OF .FPINF WORD
L.DWID: BLOCK 1 ;CURRENT JOB'S DEFAULT WIDTH
TOPS10 <
L.SL1: BLOCK SLLEN ;SAVE MY S/L ON INITIALIZATION
BLOCK PTLEN ;PATH BLOCK EXTENSION
L.SL2: BLOCK SLLEN ;CURRENT S/L (USER'S)
BLOCK PTLEN ;PATH BLOCK EXTENSION
;Extended UUO Block
ELBLOK: BLOCK .RBDED+1 ;ARGUMENT COUNT
L.DEXP: BLOCK 1 ; Directory expiration date
L.MFPP: BLOCK 1 ;MFD PPN
L.XIFN: BLOCK 1 ;IFN FOR AUXACC.SYS
L.QPPN: BLOCK 1 ;[SITGO] PPN for spooler area
L.QUST: BLOCK 1 ;[SITGO] Structure name for SITGO jobs
> ;END TOPS10
; The following locations are zeroed at the beginning of each
; job.
LOWZER:
L.SFNY: BLOCK 1 ;[SITGO] Funny name for SITGO jobs
L.BRK: BLOCK 1 ;LAST CHR FROM CARD WAS A BREAK
;Note that L.CHOL contains an appropriate byte pointer to the
; current card. Therefore the right-HALF contents is
; either L.CASC or L.C026. Note also that the initial
; default BP is stored in L.DHOL.
L.CHOL: BLOCK 1 ;CURRENT CARD CODE BP
L.DHOL: BLOCK 1 ;DEFAULT CARD CODE BP
L.DPCR: BLOCK 1 ;$DUMP,,/CREF FLAG
L.FBCT: BLOCK 1 ;LOAD NUMBER FOR FILE BLOCKS
L.FBLN: BLOCK 1 ;LIST NAME FOR CREATED FILES
L.IMGT: BLOCK 1 ;IMAGE MODE TERMINATOR
L.JLOG: BLOCK 1 ;JOB GOT LOGGED IN (SORT OF)
L.LGDS: BLOCK 1 ;LOG FILE DISPOSITION
;0=PRESERVE, ELSE DELETE
L.LOAD: BLOCK 1 ;SET TO -1 ON $DATA OR $EXEC CARD
L.LSW: BLOCK 1 ;THE LIST SWITCH
L.MODE: BLOCK 1 ;ADDRESS OF STACKING ROUTINE
L.NHOL: BLOCK 1 ;NUMBER OF HOLLERITH ERRORS
TRLCRD: BLOCK 1 ;NUMBER OF HEADER/TRAILER CARDS PASSED OVER
L.TFLG: BLOCK 1 ;[-1] IF LAST CARD READ WAS HEADER/TRAILER TYPE
L.QFN: BLOCK 1 ;USER SPECIFIED ARG TO /QUEUE:
L.SPRS: BLOCK 1 ;SUPPRESS FLAG (0=OFF)
L.SRH: BLOCK 1 ;FLAG FOR /SEARCH SWITCH
L.SWCH: BLOCK ^D8 ;NAME OF CURRENT SWITCH
L.TCHK: BLOCK 1 ;TOTAL NUMBER OF CHKSUM ERRORS
L.THOL: BLOCK 1 ;TOTAL NUMBER OF HOLLER ERRORS
L.TIBC: BLOCK 1 ;TOTAL NUMBER OF ILLEGAL BIN CARDS
L.UCHK: BLOCK 1 ;NUMBER OF CHKSUM ERRORS ALLOWED
L.UHOL: BLOCK 1 ;NUMBER HOLLERITH ERRORS ALLOWED
L.UIBC: BLOCK 1 ;NUMBER OF ILL BIN CARDS ALLOWED
L.WIDT: BLOCK 1 ;CARD WIDTH PARAMETER
L.SEQ: BLOCK 1 ;TMP STORAGE FOR SEQUENCE NUMBER
L.USER: BLOCK ^D40/5 ;STORAGE FOR /USER: SWITCH
L.PPN: BLOCK 1 ;STORAGE FOR /PPN: SWITCH
L.PROT: BLOCK 1 ;Value from /PROTECT: switch
REVDSP: BLOCK 1 ;$TOPS10/20 FLAG WORD
SYSIDP: BLOCK 1 ;SYSTEM INDEPENDENT JOB CARD FLAG
NOPSW: BLOCK 1 ;PASSWORD FLAG
LABADR: BLOCK 10 ;ROOM FOR TEMPORARY LABEL
TOPS10 <
L.CCHK: BLOCK 1 ;CHECKSUM FROM BINARY CARD
L.UFIN: BLOCK 3 ;UFD INTERLOCK BLOCK
> ;END TOPS10
TOPS20 <
L.USNO: BLOCK 1 ;USER NUMBER
L.UDIN: BLOCK 20 ;GTDIR INFORMATION
L.UDIR: BLOCK 14 ;USER DIRECTORY STRING
L.UPSW: BLOCK 10 ;USER SPECIFIED PASSWORD
L.DPSW: BLOCK 10 ;ACTUAL PASSWORD FROM DIRECTORY
L.SPDT: BLOCK 1 ; Place to keep spooled generation count
> ;END IFN FTJSYS
L.DTM: BLOCK 1 ;DAYTIME
L.RTM: BLOCK 1 ;RUNTIME
;Used by ASCIZ string scanner
L.TNAM: BLOCK ^D8 ;ROOM FOR CONTROL CARD NAME
;These locations are filled by the Date/Time scanners
L.HRS: BLOCK 1 ;HOURS
L.MIN: BLOCK 1 ;MINUTES
L.SEC: BLOCK 1 ;SECONDS
L.DAY: BLOCK 1 ;DAY
L.MON: BLOCK 1 ;MONTH
L.YRS: BLOCK 1 ;YEAR
CDRCNT: BLOCK 1 ;NUMBER OF CARDS READ - THIS JOB
DEKCRD: BLOCK 1 ;NUMBER OF CARDS READ - THIS DECK
FILFD: BLOCK FDXSIZ ;FD FOR USER FILE
FILIFN: BLOCK 1 ;IFN FOR OUTPUT FILE
FILOPN: BLOCK 1 ;-1 IF A FILE IS OPEN
FILSPC: BLOCK 1 ;-1 IF USER TYPED A FILESPEC
FILRFD: BLOCK FDXSIZ ;BLOCK FOR REL FILE FD
CLFFD: BLOCK FDXSIZ ;BLOCK TO BUILD FD FOR LOG AND CTL
CTLIFN: BLOCK 1 ;IFN FOR CTL FILE
;0=NOT OPEN, #0=OPEN
LOGIFN: BLOCK 1 ;IFN FOR LOG FILE
;0=NOT OPEN, #0=OPEN
LOGPAG: BLOCK 1 ;LOG BUFFER PAGE ADDRESS
LOGCNT: BLOCK 1 ;COUNT OF BYTES LEFT IN BUFFER
LOGPTR: BLOCK 1 ;BYTE POINTER TO LOG BUFFER
JOBCRD: BLOCK SMA/5+1 ;ROOM FOR JOB CARD
; Storage for job text and status update message
;
TXTSIZ==^D100 ;LENGTH OF A LINE
L.JPTR: BLOCK 1 ;BYTE POINTER
L.JCNT: BLOCK 1 ;CHARACTER COUNT
L.JTXT: BLOCK <TXTSIZ/5>+1 ;JOB TEXT
L.STSM: BLOCK CHE.SZ ;STATUS UPDATE BLOCK
LOWZSZ==.-LOWZER ;SIZE OF AREA TO ZERO ON EACH JOB
LOWSIZ==.-LOWBEG ;SIZE OF LOWSEG AREA
SUBTTL Non-zero storage
;THE HELLO MESSAGE FOR QUASAR
HELLO: $BUILD HEL.SZ
$SET(.MSTYP,MS.TYP,.QOHEL) ;FUNCTION
$SET(.MSTYP,MS.CNT,HEL.SZ) ;MESSAGE LENGTH
$SET(HEL.NM,,<SIXBIT /SPRINT/>)
$SET(HEL.FL,HEFVER,%%.QSR) ;QUASAR VERSION
$SET(HEL.NO,HENNOT,1) ;NUMBER OF OBJECT TYPES
$SET(HEL.NO,HENMAX,1) ;NUMBER OF STREAMS
$SET(HEL.OB,,.OTBIN) ;BATCH INPUT OBJECT
$EOB
TOPS10 <INTVEC==VECTOR>
TOPS20 <INTVEC==LEVTAB,,CHNTAB>
SPTIB: $BUILD IB.SZ
$SET (IB.PRG,,%%.MOD)
$SET (IB.OUT,,T%TTY)
$SET (IB.PIB,,SPTPIB)
$SET (IB.INT,,INTVEC)
$SET (IB.FLG,IP.STP,1) ;STOPCODES TO ORION
$EOB
; SPRINT PID BLOCK DEFINITION
SPTPIB: $BUILD (PB.MNS)
$SET (PB.HDR,PB.LEN,PB.MNS)
$SET (PB.FLG,IP.SPB,1) ;CHECK FOR IP.CFP
$EOB
;THE RESPONSE-TO-SETUP MESSAGE FOR QUASAR
RSETUP: $BUILD RSU.SZ
$SET(.MSTYP,MS.TYP,.QORSU) ;RESPONSE TO SETUP
$SET(.MSTYP,MS.CNT,RSU.SZ) ;MESSAGE SIZE
$SET(RSU.TY,,.OTBIN) ;OBJECT TYPE
$SET(RSU.CO,,%RSUOK) ;DUMMY SETUP CAN'T FAIL
$EOB
DEFNOD: BLOCK 1 ;SETUP DEFAULT NODE
WTOOBJ: $BUILD OBJ.SZ
$SET(OBJ.TY,,.OTBIN) ; Say I'm a reader interpreter
$EOB
TOPS10 <
MONPRT: EXP "."
RELX: SIXBIT/REL/
> ;END TOPS10
TOPS20 <
MONPRT: EXP "@"
RELX: XWD -1,[ASCIZ /REL/]
> ;END OF TOPS20 CONDITIONAL ASSEMBLY
SUBTTL Entry and Initialization
SPRINT: RESET ;RESET THE WORLD
MOVE P,[IOWD A%PDSZ,L.PDL]
TOPS20 <
HRRZI S1,.MSIIC ;BYPASS MOUNT COUNTS
MSTR ;DO THE FUNCTION
ERJMP .+1 ;IGNORE FOR NOW (INSUFFICIENT PRIVILEGES)
>;END TOPS20 CONDITIONAL ASSEMBLY
MOVEI S1,IB.SZ ;GET IB SIZE
MOVEI S2,SPTIB ;GET ADDRESS
$CALL I%INIT ;AND INITIALIZE THE WORLD
$CALL I%ION ;ENABLE FOR INTERRUPTS
MOVEI S1,LOWSIZ ;SIZE OF DATA AREA
MOVEI S2,LOWBEG ;BEGINNING ADR
$CALL .ZCHNK ;ZERO IT
PUSHJ P,ACTINI ;SET UP USAGE ACCOUNTING DATA
TOPS10 <
PJOB T1,0 ;GET JOB NUMBER
LSH T1,12 ;*1024
MSTIME T2, ;SO RESTART DOESN'T RESET US
ADD T1,T2 ;MAKE A FUNNY NUMBER
HRRM T1,L.FUN ;AND STORE IT
MOVEI T3,4 ;WORDS -1 IN SYSNAM
MOVSI T1,.GTCNF ;CNFTBL
SPT1: MOVS T2,T1 ;TABLE #,,INDEX
GETTAB T2,0 ;GET NAME
SETZ T2,0 ;THIS REALLY SHOULDN'T HAPPEN
MOVEM T2,L.SYSN(T1) ;STORE IT AWAY
CAILE T3,(T1) ;GOT ALL FIVE?
AOJA T1,SPT1 ;NO, LOOP AROUND
MOVX S1,%LDMFD ;GETTAB TO MFD PPN
GETTAB S1,0 ;GET IT
MOVX S1,<XWD 1,1> ;DEFAULT
MOVEM S1,L.MFPP ;SAVE IT
MOVX S1,%LDQUE ;[SITGO] Get the PPN for spooled files
GETTAB S1, ;[SITGO] . . .
MOVX S1,<XWD 3,3> ;[SITGO] Should be [3,3]
MOVEM S1,L.QPPN ;[SITGO] Save it for later use
MOVX S1,%LDQUS ;[SITGO] Get the structure for spooled files
GETTAB S1, ;[SITGO] . . .
MOVX S1,<SIXBIT |SSL|> ;[SITGO] If fails, use system search list
MOVEM S1,L.QUST ;[SITGO] Save the structure
SETOM L.XIFN ;SAY ACCOUNTING FILES NOT OPEN
MOVEI T1,L.SL1 ;BLOCK TO HOLD S/L
PUSHJ P,GETSRC ;GO GET THE SEARCH LIST
MOVX S1,%CNST2 ;GET SECOND MONITOR STATES WORD
GETTAB S1, ;READ IT IN
SETZM S1 ;FAILED...
TXNE S1,ST%ACV ;ACCOUNT VALIDATION ENABLED ???
SETOM ACTVAL ;YES,,LITE ACCOUNTING FLAG
> ;END TOPS10
TOPS20 <
MOVNI S1,5 ;GET RUNTIME FOR ENTIRE JOB
RUNTM ;GET IT
MOVE S2,S1 ;SAVE IT
GTAD ;GET TIME AND DATE
ADD S2,S1 ;ADD THEM TOGETHER
HRRM S2,L.FUN ;AND SAVE THE SEED
MOVX S1,'SYSVER' ;GET TABLE # AND LENGTH FOR SYSTEM NAME
SYSGT ;GET IT
HLRE T1,S2 ;GET -VE LENGTH IN T1
MOVN T1,T1 ;AND MAKE IT POSITIVE
CAILE T1,L.SLEN-1 ;BE A LITTLE DEFENSIVE
MOVEI T1,L.SLEN-1 ;..
HRLZ S2,S2 ;GET TABLE#,,0
SPT1: MOVS S1,S2 ;GET INDEX,,TABLE
GETAB ;DO THE GETTAB
SETZ S1, ;STORE A NULL ON FAILURE
MOVEM S1,L.SYSN(S2) ;STORE THE WORD
CAILE T1,(S2) ;DONE?
AOJA S2,SPT1 ;NO, LOOP
> ;END IFN FTJSYS
MOVX S1,HEL.SZ ;LOAD THE SIZE
MOVEI S2,HELLO ;LOAD THE ADR OF THE MSG
PUSHJ P,SNDQSR ;SEND THE MESSAGE
JRST IDLE ;AND GO INTO THE IDLE LOOP
SUBTTL Receive a Message -- IDLE - Idle Loop
;
; Here to loop and wait for messages
;
IDLE: $CALL C%BRCV ;RECEIVE A MESSAGE
JUMPF IDLE ;NOTHING THERE, LOOP
MOVE T3,S1 ;SAVE MDB ADR AWAY
LOAD T1,MDB.SI(T3),SI.FLG ;GET SPECIAL INDEX FLAG
JUMPE T1,IDLE.2 ;NONE THERE, NOT FROM QUASAR
LOAD T1,MDB.SI(T3),SI.IDX ;YES, GET THE INDEX
CAXE T1,SP.QSR ;FROM QUASAR?
JRST IDLE.2 ;NO, IGNORE IT
LOAD T1,MDB.MS(T3),MD.ADR ;GET ADDRESS OF THE MESSAGE
LOAD T2,.MSTYP(T1),MS.TYP ;GET MESSAGE TYPE
MOVSI T3,-MSGNUM ;MAKE AOBJN POINTER
IDLE.1: HLRZ S1,MSGDSP(T3) ;GET MESSAGE CODE
HRRZ S2,MSGDSP(T3) ;GET DISPATCH ADDRESS
CAMN S1,T2 ;A MATCH?
JRST [PUSHJ P,(S2) ;YUP, SURE IS
JRST IDLE.2]
AOBJN T3,IDLE.1 ;LOOP THRU
$WTOJ(^I/ABTSPR/,<Unknown Message Received^M^JMessage Type-Code is ^O/T2/ -- Message ignored>,WTOOBJ)
IDLE.2: $CALL C%REL ; Release the message
JRST IDLE ;GET BACK INTO MAIN STREAM
;
; Table to dispatch on message type
;
MSGDSP: XWD .QOSUP,IDLSUP ;SETUP
XWD .QONEX,IDLNEX ;NEXTJOB
XWD MT.TXT,IDLTXT ;TEXT
MSGNUM==.-MSGDSP ;COUNT
SUBTTL Receive a Message -- IDLNEX - Process NEXTJOB Message
;
; Here to process the NEXTJOB message
;
IDLNEX: PUSHJ P,CLRFOB ;CLEAR THE FOB
LOAD S1,.EQLEN(T1),EQ.LOH ;GET LENGTH OF HEADER
ADD S1,T1 ;POINT TO THE FP
LOAD S2,.FPINF(S1) ;TAKE COPY OF FPINF WORD
MOVEM S2,L.INF ;..
TXNE S2,FP.PCR ;IS IT A REAL READER
JRST IDLN.1 ; Yes..
GETLIM T2,.EQLIM(T1),ONOD ; Get output node field
SETZM CDRDEV ; Set not real reader ../READER
JRST IDLN.2 ;CONTINUE ON
IDLN.1: GETLIM T2,.EQLIM(T1),CNOD ; Get the reader station name
SETOM CDRDEV ; Set real reader flag
IDLN.2: SKIPN T2 ; If node is zero
MOVE T2,DEFNOD ; Use default from SETUP msg
STORE T2,WTOOBJ+OBJ.ND ; Store node name
MOVX T2,.OTBIN ; Set same object type for both
STORE T2,WTOOBJ+OBJ.TY ; real reader and /READER files
LOAD S2,L.INF,FP.RCF ;GET SPECIFIED RECORDING MODE
SETZM CDRAIM ; Assume ASCII mode
SETZ T2,0 ; Start with zero
CAXE S2,.FPFAI ;AUGMENTED IMAGE?
JRST IDLN.3 ; No.
MOVE T2,[XWD CPC,^D18] ;WIDTH,,BYTE SIZE
SETOM CDRAIM ; Set flag. This is card image.
IDLN.3: CAXE S2,.FPFAS ;FIXED OR STREAM ASCII?
CAXN S2,.FPFSA
MOVE T2,[XWD SMA,^D7] ;WIDTH,,BYTE SIZE
SKIPG T2 ;ONE OF THE ABOVE?
PJRST [$WTOJ(^I/ABTSPR/,<Unknown Recording Mode specified (^D/S2/)>,WTOOBJ)
PJRST RELREQ]
HLRZM T2,L.DWID ;STORE DEFAULT WIDTH
STORE T2,L.FOB+FOB.CW,FB.BSZ ;AND SAVE IT
HRRZS T2,T2 ;Get only the byte size
CAIE T2,7 ;ASCII?
JRST IDLN.4 ;No, don't set to strip off sequence
MOVX T2,FB.LSN ;STRIP LINE SEQUENCE NUMBERS
IORM T2,L.FOB+FOB.CW ;SET THE BIT
IDLN.4: LOAD S2,.FPLEN(S1),FP.LEN ;GET FP SIZE
ADD S1,S2 ;AND POINT TO THE FD
MOVEM S1,L.FOB+FOB.FD ;AND STORE AWAY
MOVX S1,MF.ACK ;Get the ACK flag
ANDCAM S1,.MSFLG(T1) ;Make sure it's turned off
MOVSI S1,(T1) ;TAKE COPY OF EQ
HRRI S1,L.EQCP ;..
BLT S1,L.EQCP+EQXSIZ-1
MOVEI S1,FOB.MZ ;LENGTH OF THE BLOCK
MOVEI S2,L.FOB ;AND THE ADDRESS
$CALL F%IOPN ;OPEN THE FILE
JUMPF [MOVE T1,L.FOB+FOB.FD
$WTOJ(^I/ABTSPR/,<Cannot Open Input File ^F/(T1)/ (^E/S1/)>,WTOOBJ)
PJRST RELREQ]
MOVEM S1,L.IFN ;SAVE THE IFN
PJRST PROCJS ; Start up the job stream
SUBTTL Receive a Message -- IDLSUP - Process SETUP Message
;
; Here to respond to a SETUP message
;
IDLSUP: LOAD S1,SUP.UN(T1) ;GET THE OBJECT
STORE S1,RSETUP+RSU.UN ;AND STORE IT
STORE S1,WTOOBJ+OBJ.UN
LOAD S1,SUP.NO(T1) ;GET THE NODE NUMBER
STORE S1,RSETUP+RSU.NO ;AND STORE IT
STORE S1,WTOOBJ+OBJ.ND
MOVEM S1,DEFNOD ;SAVE THE DEFAULT NODE
MOVEI S1,RSU.SZ ;LOAD THE SIZE
MOVEI S2,RSETUP ;AND THE ADDRESS
PUSHJ P,SNDQSR ;SEND IT OFF TO QUASAR
$RET ; Reenter idle loop
SUBTTL Receive a Message -- IDLTXT - Process TEXT Message
;
; Here on receipt of some TEXT message
;
IDLTXT: SKIPE .OARGC(T1) ;NULL ACK ?
$WTOJ(^I/ABTSPR/,<Unexpected text message - ^T/.OHDRS+ARG.DA(T1)/>,WTOOBJ)
$RET ; Reenter idle loop
SUBTTL PROCJS - Process A Job Stream
; ====== --------------------
;
; This in the main loop to process the input file specified
; in the "next job" message. This file can consist of a
; single job or a stream of multiple jobs. Each job must
; begin with a $JOB or $SITGO command.
;
PROCJS: SETZM FNDJOB ; Clear $JOB card flag
SETZM NXTRDY ; Clear next card ready flag
MLTJOB: MOVEI S1,LOWZSZ ; Clear out impure job data
MOVEI S2,LOWZER ; ...
$CALL .ZCHNK
SETZ F,0 ; Clear out flags
SETZM CTLIFN ; No CTL file yet!
SETZM LOGIFN ; No LOG file either!
MOVE T1,[POINT 7,L.DMOD] ;GET THE DEFAULT MODE
MOVEM T1,L.DHOL ;SAVE AS DEFAULT POINTER
MOVEM T1,L.CHOL ;AND AS CURRENT POINTER
MOVE T1,L.DWID ;LOAD DEFAULT WIDTH
MOVEM T1,L.WIDT ;STORE
PUSHJ P,STRTJB ; Set up for new job
JUMPF MLTJ.1 ; Branch if no job found
PUSHJ P,MAIN ; Process this job
SKIPF ; Successful termination?
PUSHJ P,TRMJOB ; Yes, finish up.
MLTJ.1:
TOPS10 <
PUSHJ P,DELSRL ; Remove structures from S/L
MOVX T1,L.SL1 ; Point to our original S/L
PUSHJ P,SETSRC ; Set Search List
> ; End of TOPS10
TXNN F,F.EOF!F.IFE ; At EOF or input file error?
JRST MLTJOB ; No, look for more jobs
; Here when end-of-file is encountered on the input file.
TXNE F,F.FATE ; Did we ABORT the job?
JRST EOF.1 ; Yes, release input file
SKIPE FNDJOB ; Did we find any $JOB cards?
JRST EOF.1 ; Yes, release input file
; No, give error
$TEXT(LOGTXT,<^I/FATAL/?SPTJNF ^I/EM.JNF/>)
MOVEI B,EM.JNF
PUSHJ P,PROCER ; Do ABORT processing
EOF.1: PUSHJ P,RELREQ ; Send "release" to QUASAR
MOVE S1,L.IFN ; Release the input file
MOVE T1,L.INF ;GET THE .FPINF WORD
MOVEI S2,F%REL ;PREPARE FOR SIMPLE RELEASE
TXNE T1,FP.DEL!FP.SPL ;DELETE IF EITHER SET
MOVEI S2,F%DREL ;DO THE DELETE AND RELEASE
PJRST (S2) ; and return to IDLE Loop
EM.JNF: ITEXT(<$JOB card not found>)
SUBTTL MAIN - Main Program Loop
; ==== -----------------
;
; This loop is reached after successfully processing $JOB,
; and $PASSWORD cards. The remainder of the job will be
; processed by this loop.
;
; Returns TRUE on EOF or end of job
; Returns FALSE on fatal error
;
MAIN: PUSHJ P,CRD$CC ; Read a control card
TXNE F,F.FATE ; A fatal error
$RETF ; Yes, return failure
TXNE F,F.EOF ; End of file seen
$RETT ; Yes, finish up
TXNE S1,CD.BOJ ; Beginning of next job seen
SETOM NXTRDY ; Yes, we will catch it later
TXNE S1,CD.EOJ ; End of job seen
$RETT ; Yes, finish up
TXNE F,F.SITG ;[SITGO] Is this a SITGO deck?
TXNE S1,CD.STG ;[SITGO] Yes, this card allowed?
JRST .+2 ;[SITGO] Card is ok
JRST MAIN.1 ;[SITGO] Card is not allowed
JUMPF MAIN.1 ; Not a valid control card
PUSHJ P,CONTRL ; Else, process control card
JUMPF .RETF ; Return failure if error
JRST MAIN ; Otherwise, read the next card
MAIN.1: TXNN S1,CD.COM ; A comment?
JRST MAIN.2 ; No, it's an error
PUSHJ P,LOGCRD ; Yes, log the comment
MOVEI T1,"!" ; Get comment character
MOVE T2,L.DHOL ; Get default pointer to line
IDPB T1,T2 ; Replace "$" in col 1
$TEXTC(<^Q/L.DHOL/^A>) ; Put comment in CTL file
JRST MAIN ; And loop around
MAIN.2: TXNN S1,CD.DOL ; An illegal command?
JRST MAIN.3 ; No
$TEXTL(<^I/FATAL/?SPTICC ^I/EM.ICC/^I/EM.ERR/^A>)
JSP B,CTLCER ;ABORT
ITEXT(<^I/EM.ICC/^I/EM.CFW/>)
MAIN.3: $TEXTL(<^I/FATAL/?SPTCNF ^I/EM.CNF/^I/EM.ERR/^A>)
JSP B,CTLCER ;ABORT
ITEXT(<^I/EM.CNF/^I/EM.CFW/^A>)
EM.ICC: ITEXT(<Illegal Control Card ^I/EM.CNI/>)
EM.CNF: ITEXT(<Control Card not found when expected ^I/EM.CNI/>)
EM.CNI: ITEXT(<- Card #^D/CDRCNT/^M^J>)
EM.CFW: ITEXT(<Card found was: ^Q/L.DHOL/>)
EM.ERR: ITEXT(<^I/STERR/^I/EM.CFW/>)
SUBTTL STRTJB - Start up the job
; ====== ----------------
;
; STRTJB is called to start up the job. The "EQ" page is
; acquired and initialized and the logfile gets its
; introductory messages. The input file is scanned for a
; "beginning of job" card , and control dispatches to the
; appropriate processing routine.
;
STRTJB: PUSHJ P,I%NOW ;GET TIME OF DAY
MOVEM S1,L.CON ;SAVE IT AWAY
TOPS10 < ;TOPS-10 ONLY
HRROI S1,.GTKCT ;GET KILO-CORE-TICKS
GETTAB S1,
SETZ S1,
IMULI S1,^D100 ;GET CTI IN <KCT>*100
IDIVI S1,JIFFIE ;CONVERT TO SECONDS
MOVNM S1,L.CTI ;STORE IT
HRROI S1,.GTRCT ;GET DISK READS
GETTAB S1,
SETZ S1,
ANDX S1,RC.TTL ;STRIP OFF INCREMENTAL READS
MOVNM S1,L.DSR ;STORE DISK READS
HRROI S1,.GTWCT ;GET DISK WRITES
GETTAB S1,
SETZ S1,
ANDX S1,WC.TTL ;STRIP OFF INCREMENTAL WRITES
MOVNM S1,L.DSW ;STORE NEGATIVE DISK WRITES
> ;END OF TOPS-10 CONDITIONAL
$CALL M%GPAG ; Get a page
MOVE Q,S1 ; Save address in AC Q
HRLI S1,L.EQCP ;COPY SAVED EQ TO CREATE MESSAGE
BLT S1,EQXSIZ-1(Q) ;..
MOVX S1,.QOCRE ;LOAD "CREATE" CODE
STORE S1,.MSTYP(Q),MS.TYP ;STORE IT
MOVX S1,EQXSIZ ;LENGTH OF HEADER
STORE S1,.EQLEN(Q),EQ.LOH ;AND STORE IT
MOVX S1,.OTBAT ;BATCH OBJECT TYPE
STORE S1,.EQROB+.ROBTY(Q) ;STORE IT IN THE EQ
MOVX S1,%%.QSR ;REQUEST VERSION NUMBER
STORE S1,.EQLEN(Q),EQ.VRS ;STORE IT
MOVEI S1,2 ;NUMBER OF FILES IN REQUEST
STORE S1,.EQSPC(Q),EQ.NUM ;AND STORE IT
PUSHJ P,FUNNY ;GET A FUNNY< 4 CHARS
TLO S1,'JB ' ;MAKE A JOB NAME
STORE S1,.EQJBB+JIB.JN(Q) ;YES, USE FUNNY NAME
SKIPN CDRDEV ;PHYSICAL READER?
JRST STRT.1 ; No, all set now
MOVX S1,EQLMSZ ; Yes, ...
MOVEI S2,.EQLIM(Q) ;GET THE LIMIT WORD ADDRESS
PUSHJ P,.ZCHNK ;ZERO THE LIMIT WORD BLOCK
HRLZI S1,.EQACT(Q) ; Address of acct string
HRRI S1,.EQACT+1(Q) ;MAKE A BLT POINTER
SETZM .EQACT(Q) ;CLEAR FIRST WORD
BLT S1,.EQACT+7(Q) ;CELAR THE ENTIRE BLOCK
STRT.1: $CALL M%GPAG ;GET A PAGE
MOVEM S1,LOGPAG ;SAVE PAGE ADDRESS
HRLI S1,(POINT 7) ;MAKE A BYTE POINTER
MOVEM S1,LOGPTR ;SAVE IT
MOVX S1,PAGSIZ*5 ;GET NUMBER OF BYTES ALLOWED
MOVEM S1,LOGCNT ;STORE IT
$TEXTL(<^M^L^I/STDAT/SPRINT version ^V/[EXP %SPT]/ ^T/L.SYSN/>)
MOVE S1,L.IFN ;GET THE IFN
SETO S2,0
$CALL F%FD ;BUILD AN FD
SKIPE CDRDEV ;PHYSICAL READER
$TEXTL(<^I/STMSG/[Job Input from card reader ^O/WTOOBJ+OBJ.UN/ at node ^N/WTOOBJ+OBJ.ND/]>)
SKIPN CDRDEV ;PHYSICAL READER?
$TEXTL(<^I/STMSG/[Job Input from file ^F/(S1)/]>)
$CALL L%CLST ;CREATE A LINKED LIST
MOVEM S1,L.FBLN ;AND SAVE THE LIST NAME
STRT.2: PUSHJ P,CRD$CC ;READ THE JOB CARD
TXNE F,F.EOF!F.IFE!F.FATE ; EOF or error?
$RETF ; Yes, return failure
TXNE S1,CD.BOJ ; Is this beginning of job
JRST STRT.3 ; Yes, go do it
JUMPT STRT.2 ; Card was logged; Keep looking
TXNE S1,CD.DOL ; If card "resembles" control
PUSHJ P,LOGCRD ; card, log it.
JRST STRT.2 ; Keep looking
STRT.3: MOVEI T1,1 ; Initialize card count
MOVEM T1,CDRCNT ; Save it
PJRST (S2) ; Dispatch and return
SUBTTL Control Cards -- CONTRL - Setup and Dispatch
; ====== ------------------
;
; Here to initialize and dispatch to process a control card.
;
;
; Call:
;
; PUSHJ P,CONTRL
; S1 contains dispatch flags
; S2 contains dispatch address
;
; Returns TRUE
;
; Returns FALSE on EOF or error
;
CONTRL: $CALL .SAVE2 ; Need P1 and P2
DMOVE P1,S1 ; Save arguments
PUSHJ P,$EOD ;SETUP DEFAULT HOLLERITH MODE
PUSHJ P,W$NODOLLAR ;RESET /NODOLLARS
PUSHJ P,W$LIST ;RESET /LIST
$SUPPRESS <SETOM L.SPRS>
$NOSUPPRESS <SETZM L.SPRS>
MOVE T1,L.DWID ;DEFAULT WIDTH
STORE T1,L.WIDT ;STORE IT
TXO F,F.RSCN ;RESCAN THE BREAK LATER ON
TXNE P1,CD.BTC ;THIS CARD NEED THE BATCH BIT?
TXO F,F.BTCH ;YES, TURN IT ON!
TXNE P1,CD.CLO ;CLEAR THE LOAD ORDER?
PUSHJ P,FBCLOD ;YUP!!
PJRST (P2) ; Dispatch to correct routine
; and return to caller.
SUBTTL Control Cards -- $JOB and $SITGO Cards
; Here on $JOB cards
;
JOBLIN: TXZA F,F.SITG ;INDICATE BATCON
; Here on $SITGO cards
;
SITLIN: TXO F,F.SITG ;INDICATE SITGO
SETOM FNDJOB ;WE FOUND A CARD TO BEGIN JOB
HRL S1,L.DHOL ;SAVE THE $JOB
HRRI S1,JOBCRD ;CARD AWAY
BLT S1,JOBCRD+SMA/5 ;FOR LATER
PUSHJ P,S$FSPC ;SCAN OFF BLANKS
JUMPF ILLJOB ;EOL MEANS BAD CARD
CAIN C,"/" ;FIRST ITEM A SWITCH?
SETOM SYSIDP ;YUP, SET SYS INDEPENDENT FLAG
$CALL I%NOW ;GET CURRENT DATE/TIME
MOVEM S1,L.DTM ;REMEMBER FOR ACCOUNTING
MOVX S1,-1 ;OUR JOB
MOVX S2,JI.RTM ;RUNTIME FUNCTION
$CALL I%JINF ;READ OUR RUNTIME
MOVEM S2,L.RTM ;REMEMBER FOR ACCOUNTING
PUSHJ P,JOBOS ;GET OPERATING SYSTEM DEP PART
JUMPF NOPPN ; Return failure
MOVEI S1,A%LGDS ; Default for /LOGDISP:DELETE
MOVEM S1,L.LGDS ; Store it
MOVEI S1,A%HLER ;DEFAULT FOR /ERR:HOL
MOVEM S1,L.UHOL ;STORE IT
MOVEI S1,A%CSER ;DEFAULT FOR /ERR:CHKSUM
MOVEM S1,L.UCHK
MOVEI S1,A%ICER ;DEFAULT FOR /ERRO:IBC
MOVEM S1,L.UIBC ;AND STORE IT
MOVEI S1,SW.JOB ;LOAD $JOB SWITCHES
PUSHJ P,DOSWCH ;DO THE SWITCHES
JUMPF .RETF ; Return failure
PUSHJ P,JOBVER ;VERIFY JOB DATA
JUMPF NOPPN ; Return failure
PUSHJ P,DOACCT ;CHECK ACCOUNTING
JUMPF .RETF ; Return failure
TXNE F,F.SITG ;[SITGO] SITGO job
JRST SITL.1 ;[SITGO] Yes, go handle it
PUSHJ P,MAKCTL ;MAKE THE CTL FILE
JUMPF .RETF ; Return failure if unsuccessful
PUSHJ P,MAKLOG ;MAKE A LOG FILE
JUMPF .RETF ; Return failure if unsuccessful
SETOM L.JLOG ;JOB IS LOGGED IN
PUSHJ P,JOBSTA ;SET UP STATUS UPDATE MESSAGE
PUSHJ P,UPDQSR ;UPDATE QUASAR
$WTOJ (< Starting >,<^T/L.JTXT/>,WTOOBJ)
$RETT
;
; Here to issue errors for bad job cards
;
ILLJOB: $TEXTL(<^I/FATAL/?SPTIFJ ^I/ILLJ.1/>)
JSP B,JOBCER
ILLJ.1: ITEXT(<Improperly formatted $JOB Card>)
NOPPN:
TOPS10 <
$TEXTL(<^I/FATAL/?SPTMPP ^I/EM.MPP/>)
JSP B,JOBCER ;AND ABORT THE JOB
EM.MPP: ITEXT(<Missing or badly formatted Project-Programmer Number on $JOB card>)
> ; End of TOPS-10 conditional
TOPS20 <
$TEXTL(<^I/FATAL/?SPTMUN ^I/EM.MUN/>)
JSP B,JOBCER ;AND ABORT THE JOB
EM.MUN: ITEXT(<Missing or badly formatted User Name on $JOB card>)
> ; End of TOPS-20 conditional
;
;[SITGO] This routine will enter the correct files and stack the first
;[SITGO] part of the SITGO deck
;
SITL.1: PUSHJ P,FUNNY ;[SITGO] Make a funny name for all the files
TLO S1,'ST ' ;[SITGO] Make it STxxxx
MOVEM S1,L.SFNY ;[SITGO] Save for data file
PUSHJ P,MAKLOG ;[SITGO] Make the .LOG file
JUMPF .RETF ;[SITGO] Return failure on error
PUSHJ P,MAKCTL ;[SITGO] Make the 'CTL' file (really .CDR)
JUMPF .RETF ;[SITGO] Return failure on error
MOVE S1,CTLIFN ;[SITGO] Get the IFN for the 'CTL' file
MOVEM S1,FILIFN ;[SITGO] Save it for stacking routine
PUSHJ P,W$DFMD ;[SITGO] Default mode
PUSHJ P,W$NODOLLAR ;[SITGO] And dollar switch
SETOM L.JLOG ;[SITGO] Claim the job is 'logged in'
PUSHJ P,JOBSTA ;[SITGO] Set up status for message
PUSHJ P,UPDQSR ;[SITGO] Send it to QUASAR
$WTOJ (< Starting >,<^T/L.JTXT/>,WTOOBJ)
PUSHJ P,STASC ;[SITGO] Stack the SITGO program
SETZM FILIFN ;[SITGO] Clear the file IFN to avoid closing it
$RETT ;[SITGO] And return
;
; Get operating system dependent job information
;
; On the -10 this will be jobname [PPN]
; On the -20 this will be directory_name
;
; This routine will initially attempt to parse a TOPS-10 PPN
; spec using the default mode. If the PPN cannot be
; successfully parsed in this mode, an attempt is made to
; parse it in the alternate mode. If this parsing is
; successful, the alternate mode will be used as the default
; mode for the job.
;
; For system independent jobs, just return TRUE
;
JOBOS: SKIPE SYSIDP ;SYSTEM INDEPENDENT JOB CARD?
$RETT ;YES - RETURN
TOPS10 < ;TOPS-10 ONLY
$CALL .SAVE1 ; Need a scratch register
MOVE P1,B ; Save current byte pointer
JOBO.1: PUSHJ P,W$JNAM ; Get jobname (if any)
PUSHJ P,S$PPN ; Try reading in the PPN
JUMPT JOBO.2 ; Go process if OK
JUMPE P1,.RETF ;IF 2ND TIME, PUNT
MOVE B,P1 ;RESET THE BYTE POINTER
SETZ P1,0 ;AND CLEAR A FLAG
IFG L.NMOD-L.DMOD,<ADDI B,<L.NMOD-L.DMOD>> ;POINT TO THE OTHER MODE
IFL L.NMOD-L.DMOD,<SUBI B,<L.DMOD-L.NMOD>> ;POINT TO THE OTHER MODE
LDB C,B ; Try this character
MOVE T1,[POINT 7,L.NMOD] ;MAKE THIS THE DEFAULT
MOVEM T1,L.DHOL ;FOR THE REST OF THE JOB
JRST JOBO.1 ; And try again
JOBO.2: MOVEM S1,L.PPN ; Save the PPN
MOVEM S1,.EQOID(Q) ; and here, too.
JUMPN P1,.RETT ; All done if no mode change
HRL T1,L.DHOL ; Otherwise, if mode change
HRRI T1,JOBCRD ; Update saved jobcard image
BLT T1,JOBCRD+SMA/5 ; for later
$TEXTL(<^I/STMSG/[Default mode for job changed to /HOLLERITH:^T/S.NMOD/]>)
PUSHJ P,LOGCRD ; LOG the card in new mode
> ;END OF TOPS-10 CONDITIONAL
TOPS20 < ;TOPS-20 ONLY
PUSHJ P,W$USR ; Get user name
JUMPF .RETF ; Fail if no user name
MOVSI S1,L.USER ; Move User Name
HRRI S1,.EQOWN(Q) ; to owner block
BLT S1,.EQOWN+7(Q) ; of EQ page
> ;END OF TOPS-20 CONDITIONAL
$RETT ; Return
;
; Verify that a system independent job has a valid PPN or user name
;
JOBVER: SKIPN SYSIDP ;SYS INDEPENENCE?
$RETT ;NO, NORMAL
TOPS10 < ;TOPS-10 ONLY
SKIPN S1,L.PPN ;GET SPECIFIED PPN
$RETF ;GOTTA HAVE IT
MOVEM S1,.EQOID(Q) ;STORE IT
> ;END OF TOPS-10 CONDITIONAL
TOPS20 < ;TOPS-20 ONLY
SKIPN L.USER ;USER NAME SPECIFIED?
$RETF ;GOTTA HAVE IT
MOVSI S1,L.USER ;PREPARE TO MOVE /USER
HRRI S1,.EQOWN(Q) ;NAME SPECIFIED
BLT S1,.EQOWN+7(Q) ;TO THE OWNER BLOCK
> ;END OF TOPS-20 CONDITIONAL
$RETT ;RETURN
;
; Set up job status update message
;
JOBSTA: MOVE S1,['BATCON'] ;ASSUME BATCH
TXNE F,F.SITG ;IS IT SITGO ?
MOVE S1,['SITGO '] ;YES
TOPS10 <MOVEI S2,[ITEXT (<^W6/.EQOWN(Q)/^W/.EQOWN+1(Q)/ ^P/.EQOID(Q)/>)]>
TOPS20 <MOVEI S2,[ITEXT (<^T/.EQOWN(Q)/>)]>
$TEXT (<-1,,L.JTXT>,<^W/S1/ job ^W/.EQJBB+JIB.JN(Q)/ for ^I/(S2)/^0>)
$RETT ;RETURN
SUBTTL Control Cards -- $LANGUAGE
;The LANGS macro is used to define all the $LANGUAGE cards which
; will be accepted by SPRINT. The format for each language
; definition is as follows:
; L <entry-point>,<default-extension>,<COMPIL switch>,<code>
;
;where <code> is one of:
;
; I Interpreter -- No REL file
; R Compiler -- Generates a REL file
DEFINE LANGS,<
L SIMULA,SIM,SIM,R
L SNOBOL,SNO,SNO,I
L BLISS,BLI,BLI,R
L ALGOL,ALG,ALG,R
L COBOL,CBL,COB,R
L MACRO,MAC,MAC,R
TOPS10 <
L F40,F4 ,F40,R
>
L FORTRAN,FOR,FOR,R
>;END DEFINE LANGS
; Generate Entry Points
DEFINE L(A,B,C,D),<XALL
IFIDN <D> <R> ,<
$'A: HRRZI T1,K
JRST $LANG
K=K+1>
IFIDN <D> <I> ,<
$'A: HRROI T1,K
JRST $LANG
K=K+1>
SALL>
K=0
LANCRD: LANGS
;Now generate table of Extension,,Compile switch
DEFINE L(A,B,C,D),<
TOPS10 <
XWD [SIXBIT /B/],<<SIXBIT /C/>_-^D18>
> ;END TOPS10
TOPS20 <
XWD [XWD -1,[ASCII/B/]],<<SIXBIT /C/>_-^D18>
>;END OF TOPS20 CONDITIONAL ASSEMBLY
>;END DEFINE L
EXTTBL: LANGS
$LANG: MOVEM T1,LANG.A ;SAVE THE INDEX
MOVEI S1,'LN' ;LOAD A PREFIX
PUSHJ P,MAKFUN ;AND MAKE A FUNNY NAME
MOVE T1,LANG.A ;GET THE INDEX BACK
HLRZ S2,EXTTBL(T1) ;GET ADR OF DEFAULT EXTENSION
MOVE S2,(S2) ;GET DEFAULT EXTENSION
PUSHJ P,S$FILE ;GET A FILESPEC
JUMPF .RETF ; Fail if bad file specification
MOVX S1,FB.LDR!FB.DEL ;LOAD THE REL AND DELETE BOTH
SKIPGE LANG.A ;IS IT AN INTERPRETER?
MOVX S1,FB.DEL ;YES, JUST DELETE THE SOURCE
SKIPE FILSPC ;DID THE USER NAME IT?
JRST $LAN.1 ;YES, HE SPECIFIED ONE
PUSHJ P,FILENT ;ENTER THE FILE
JUMPF .RETF ; Fail on error
JRST $LAN.2 ;MEET AT THE PASS
$LAN.1: TXZ S1,FB.DEL ;TURN OFF DELETE IF IT IS HIS
PUSHJ P,FBENT ;ENTER IT IN THE FILE-BLOCKS
$LAN.2: HRRZ T1,LANG.A ;GET LANGUAGE INDEX
$TEXTC(<^7/MONPRT/COMPILE /COMPILE/^W/EXTTBL(T1),RHMASK/ ^F/FILFD/^A>)
CAIN C," " ;NEED TO FLUSH LEADING SPACES ?
PUSHJ P,S$FSPC ;AND FLUSH LEADING SPACES
JUMPF $LAN.4 ;EOL, GO SEND LISTING SWITCH
TOPS10 <
CAIE C,"(" ;BEGINNING OF PROCESSOR SWITCH?
JRST $LAN.3 ;NO, CHECK FOR SPRINT SWITCHES
MOVEI S1,"(" ;LOAD AN OPEN PAREN
PUSHJ P,CTLTXT ;AND PRINT IT
JUMPF .RETF ; Return failure on error
MOVEI S1,")" ;LOAD THE BREAK CHARACTER
PUSHJ P,CTLCRD ;GO TRANSFER FROM CARD TO CTL
JUMPF .RETF ; Return failure on error
MOVEI S1,")" ;LOAD A CLOSE PAREN
PUSHJ P,CTLTXT ;AND PRINT IT
JUMPF .RETF ; Return failure on error
> ;END OF TOPS10 CONDITIONAL ASSEMBLY
$LAN.3: MOVX S1,SW.LAN ;VALID SWITCHES FOR LANG CARD
PUSHJ P,DOSWCH ;DO THE SWITCHES
JUMPF .RETF ; Return failure
$LAN.4: $TEXTC(<^W/L.LSW/>) ;PRINT THE /LIST SWITCH
SKIPN FILSPC ;EXPLICIT FILENAME GIVEN?
PJRST @L.MODE ;NO, GO STACK THE DECK
$RETT ;RETURN TO MAIN STREAM
LANG.A: BLOCK 1 ;SAVE LANGUAGE INDEX
SUBTTL Control Cards -- $DECK - $CREATE
$CREAT: MOVEI S1,'CR' ;GET THE PREFIX
PUSHJ P,MAKFUN ;MAKE A NAME
JRST $DEC.1 ;AND SKIP ALTERNATE ENTRY
$DECK: MOVEI S1,'DK' ;GET THE PREFIX
PUSHJ P,MAKFUN ;MAKE A NAME
$DEC.1: SETZ S2,0 ;NO EXTENSION
PUSHJ P,S$FILE ;GET A FILESPEC
JUMPF .RETF ; Fail if bad file specification
MOVX S1,SW.DEC ;LEGAL SWITCHES
PUSHJ P,DOSWCH ;DO THE SWITCHES
JUMPF .RETF ; Return failure
SETZ S1,0 ;NOTHING TO REMEMBER
PUSHJ P,FILENT ;ENTER THE FILE
JUMPF .RETF ; Return failure on error
PJRST @L.MODE ;AND GO STACK THE DECK
SUBTTL Control Cards -- $RELOC
TOPS10 <
$RELOC: SKIPN CDRAIM ; Is file augmented image mode?
JRST $REL.1 ; No, then $RELOC is illegal
MOVEI S1,'RL' ;LOAD A PREFIX
PUSHJ P,MAKFUN ;MAKE A FUNNY NAME
MOVE S2,RELX ;GET DEFAULT EXTENSION
PUSHJ P,S$FILE ;AND GET A FILESPEC
JUMPF .RETF ; Fail if bad file specification
PUSHJ P,W$BINA ;FORCE A /BINARY
MOVX S1,FB.LOD ;LOAD ON NEXT $DATA OR $EXEC
SKIPN FILSPC ;IS IT USER-NAMED?
TXO S1,FB.DEL ;NO, DELETE AT THE END
PUSHJ P,FILENT ;ENTER THE FILE
JUMPF .RETF ; Return failure on error
PJRST @L.MODE ;AND DO STACK THE DECK
COMMENT \
Here to complain about the improper use of the $RELOC card.
This card is allowed only when the job was submitted via
cards, and the file written for SPRINT is augmented image mode.
\
$REL.1: $TEXTL(<^I/FATAL/?SPTRCI ^I/$REL.2/>)
JSP B,CTLCER ;FULLY ABORT
$REL.2: ITEXT (<Improper use of $RELOC>)
>;END OF TOPS10 CONDITIONAL ASSEMBLY
SUBTTL Control Cards -- $INCLUDE
;
; The $INCLUDE card allows for an optional filespec. The
; logic imposed is similar to the $language card in that if a
; filespec is supplied the routine assumes the file already
; exists on disk and simply enters the file into the file
; blocks. If no filespec is supplied, the routine generates
; its own, enters it into the file blocks, and then goes off
; to stack the deck which presumably follows.
;
; If no file spec is supplied, the job must have been
; submitted via cards. To allow it from disk based jobs, eg.
; via /READER, implies the need for mixed mode files.
;
; For TOPS-20, a file spec must always be supplied.
;
$INCLU: MOVEI S1,'BL' ;DEFAULT PREFIX
PUSHJ P,MAKFUN ;FORM 'BL????'
MOVE S2,RELX ;DEFAULT EXTENSION
PUSHJ P,S$FILE ;READ OUT THE FILESPEC
JUMPF .RETF ; Fail if bad file specification
SETZM L.SRH ;CLEAR SEARCH FLAG
MOVX S1,SW.INC ;VALID SWITCHES FOR $INCLUDE
PUSHJ P,DOSWCH ;SCAN OFF ANY SWITCHES
JUMPF .RETF ; Return failure
SETOM L.FBCT ;SET LOAD FLAG
MOVX S1,FB.LOD!FB.DEL ;SET LOAD AND DELETE BITS
SKIPE L.SRH ;DID HE SPECIFY /SEARCH?
TXO S1,FB.SRH ;SURE DID..
SKIPE FILSPC ;DID HE SPECIFY ANY FILESPEC?
JRST $INC.1 ; Yes
TOPS10 < ; No, on TOPS-10 stack the deck
SKIPN CDRAIM ; This file augmented image?
JRST $INC.E ; No, then $INCLUDE are illegal
PUSHJ P,FILENT ;GO ENTER WITH FORMED FILESPEC
JUMPF .RETF ; Return failure on error
PUSHJ P,W$BINA ;FORCE A /BINARY
PJRST @L.MODE ;GO STACK THE DECK
>;END OF TOPS10 CONDITIONAL ASSEMBLY
; On TOPS-20, give error if
; no file specified
$INC.E: $TEXTL(<^I/FATAL/?SPTIUI ^I/$INC.F/>)
JSP B,CTLCER
$INC.F: ITEXT (<Improper use of $INCLUDE>)
$INC.1: TXZ S1,FB.DEL ;CLEAR THE DELETE BIT
PUSHJ P,FBENT ;AND ENTER INTO THE FILE BLOCKS
$RETT ;RETURN
SUBTTL Control Cards -- $DATA
TOPS10 <
$DATA.: MOVE S1,[XWD FILFD,FILFD+1] ;SETUP A BLT POINTER
SETZM FILFD ;ZERO THE FIRST WORD
BLT S1,FILFD+FDXSIZ-1 ;AND ZERO THE REST
MOVSI S1,'DSK' ;LOAD DEFAULT DEVICE
STORE S1,FILFD+.FDSTR ;STORE IT
PUSHJ P,FUNNY ;GET A FUNNY NAME
MOVSI S1,(S1) ;[SITGO] Put in left half
TXNE F,F.SITG ;[SITGO] SITGO deck?
MOVE S1,L.SFNY ;[SITGO] Yes, get correct funny name
STORE S1,FILFD+.FDNAM ;[SITGO] Save it
MOVSI S1,'CDR' ;DEFAULT EXTENSION IS CDR
TXNE F,F.SITG ;[SITGO] SITGO deck?
MOVX S1,<SIXBIT |DAT|> ;[SITGO] Yes, make it a .DAT
MOVEM S1,FILFD+.FDEXT ;SAVE IT
LOAD S1,.EQOID(Q) ;GET OUR PPN
TXNE F,F.SITG ;[SITGO] SITGO?
MOVE S1,L.QPPN ;[SITGO] Yes, make the file on [3,3]
STORE S1,FILFD+.FDPPN ;AND STORE IT
MOVX S1,FDMSIZ ;GET MINIMUM SIZE
STORE S1,FILFD+.FDLEN,FD.LEN ;AND STORE IT
TXNN F,F.SITG ;[SITGO] SITGO job?
$TEXTC(<.SET CDR ^W/FILFD+.FDNAM,LHMASK/>)
> ;END TOPS10
TOPS20 <
$DATA.: SKIPE .EQSIS(Q) ;GENERATE A NAME ALREADY?
JRST $DAT.1 ;YES, CONTINUE ON
PUSHJ P,FUNNY ;NO, GET 4 FUNNY CHARS
TLO S1,'CD ' ;MAKE IT CD????
MOVEM S1,.EQSIS(Q) ;SAVE IN CORRECT PLACE
$DAT.1: MOVE S1,[POINT 7,FILFD+.FDFIL]
MOVEM S1,L.BP ;SETUP BYTE POINTER
AOS L.SPDT ; Increment the generation file
TXNN F,F.SITG ;[SITGO] SITGO job?
$TEXT(DEPBP,<PS:^7/[OCT 74]/SPOOL^7/[OCT 76]/CDR-^O/L.USNO,RHMASK/.^W/.EQSIS(Q)/^0>)
TXNE F,F.SITG ;[SITGO] SITGO?
$TEXT(DEPBP,<PS:^7/[OCT 74]/SPOOL^7/[OCT 76]/^W/L.SFNY/.DAT^0>)
MOVX S1,FDXSIZ ;USE MAXIMUM SIZE
STORE S1,FILFD+.FDLEN,FD.LEN ;AND STORE IT
TXNN F,F.SITG ;[SITGO] SITGO deck?
$TEXTC(<@SET CARD-READER-INPUT-SET (TO) ^W/.EQSIS(Q)/ ^D/L.SPDT/>)
>;END IFN FTJSYS
MOVX S1,SW.DAT ;LEGAL SWITCHES
PUSHJ P,DOSWCH ;DO THE SWITCHES
JUMPF .RETF ; Return failure
TOPS20 <
SETZB S1,FILSPC ;CLEAR FLAGS
TXNE F,F.SITG ;[SITGO] SITGO job?
TXO S1,FB.DEL ;[SITGO] Yes, remember to delete the file if we abort
PUSHJ P,FRCENT ;ENTER THE FILE INVOKING OUR PRIVILEGES
JUMPF .RETF ; Return failure on error
TXNE F,F.SITG ;[SITGO] SITGO job?
PJRST @L.MODE ;[SITGO] Yes, just go stack it
>;END TOPS20 CONDITIONAL ASSEMBLY
TOPS10 <
SETZM FILSPC ;CLEAR FLAGS
MOVX S1,FB.DEL ;GET DELETE BIT
TXNE F,F.SITG ;[SITGO] SITGO job?
JRST [PUSHJ P,FRCENT ;[SITGO] Yes, force the enter
JUMPF .RETF ; Return failure on error
PJRST @L.MODE] ;[SITGO] And go stack the deck
PUSHJ P,FILENT ;ENTER IT
JUMPF .RETF ; Return failure on error
>
PUSHJ P,EXECUT ;PUT IN THE EXECUTE LINE
PJRST @L.MODE ;AND DO THE STACKING
SUBTTL Control Cards -- $EXECUTE
$EXECUTE:
MOVX S1,SW.EXE ;LEGAL SWITCHES
PUSHJ P,DOSWCH ;GET ANY SWITCHES
JUMPF .RETF ; Return failure
PJRST EXECUT ;AND GO PUT IN EXECUTE LINE
;
;Here the $DATA and $EXECUTE cards merge to generate the EXECUTE
; command in the control file.
EXECUT: SKIPE L.FBCT ;ANYTHING TO LOAD?
JRST EXEC.1 ;YES, CONTINUE ON
$TEXTL(<^I/STERR/%SPTNFT No files to load>)
$RETT ;AND RETURN
EXEC.1: SETOM L.LOAD ;FLAG THAT WE ARE DOING A LOAD
MOVEI T1,[ASCIZ / /] ;POINT TO A BLANK
TXZE F,F.MAP ;DOES HE WANT A MAP?
MOVEI T1,[ASCIZ %/MAP:LPT:MAP %]
$TEXTC(<^7/MONPRT/EXECUTE^T/0(T1)/^A>)
MOVE S1,L.FBLN ;GET THE LIST NAME
$CALL L%FIRST ;POSITION TO THE BEGINNING
SKIPT ;SKIP IF OK
$STOP(CFF,CAN'T FIND FILES TO LOAD)
SETZ T2,0 ;FLAG NO FILESPECS TYPED
JRST EXEC.3 ;ENTER LOOP WITH FIRST FILESPEC
EXEC.2: MOVE S1,L.FBLN ;GET LIST NAME
$CALL L%NEXT ;GET NEXT FILESPEC
JUMPF CTLEOL
EXEC.3: LOAD T1,.FBFLG(S2) ;GET THE FILE FLAGS
TXNN T1,FB.LOD ;LOADABLE?
JRST EXEC.2 ;NO, TRY THE NEXT
SKIPE T2 ;TYPED SPEC YET?
$TEXTC(<,^A>) ;YUP, SO TYPE A COMMA
$TEXTC(<^F/.FBFD(S2)/^A>) ;NO, JUST LOAD THE FILE
TXNE T1,FB.SRH ;LOAD IN LIBRARY SEARCH MODE?
$TEXTC(</SEARCH^A>) ;YES
SETO T2,0 ;SET FILE TYPED FLAG
JRST EXEC.2 ;LOOP
SUBTTL Control Cards -- $DUMP
$DUMP: HRROS L.DPCR ;AND FLAG DUMP LINE NEEDED
$RETT ;AND RETURN
SUBTTL Control Cards -- $PASSWORD
;
; Password card processing is done during the DOACCT routine.
; Control will transfer here if there are multiple $PASSWORD
; cards in the job or the job did not require a $PASSWORD
; card and one was included.
;
$PASSW: $RETT ;IGNORE EXTRA $PASSWORD CARDS
SUBTTL Control Cards -- $MESSAGE
$MESS: $CALL .SAVE1 ; Need a P register
SETZ P1,0 ;CLEAR WAIT-NOWAIT FLAG
PUSHJ P,S$FSPC ;IGNORE BLANKS
TXO F,F.RSCN ; To pick up first char of msg
CAIE C,"/" ;IS THERE A COMMAND SWITCH?
JRST $MES.1 ;NO, NOWAIT IS DEFAULT
TXZ F,F.RSCN ; Don't want to look at / again
MOVEI S1,SWNAME ;POINT TO STRING BLOCK
PUSHJ P,S$ASCZ ;READ THE KEYWORD IN
MOVEI S1,$MES.3-1 ;POINT TO THE TABLE
HRROI S2,SWNAME ;AND THE SPECIFIED KEYWORD
$CALL S%TBLK ;SEE IF IT'S THERE
TXNE S2,TL%NOM!TL%AMB ;MATCH?
JRST $MES.2 ;NOPE, LOOP
HRRZ P1,(S1) ;GET ARGUMENT
$MES.1: $TEXTC(<^7/MONPRT/PLEASE ^A>)
SETZ S1,0 ;BREAK ON EOL
PUSHJ P,CTLCRD ;COPY THE REST OF THE CARD
JUMPF .RETF ; Return failure on error
MOVEI S1,.CHESC ;LOAD AN ESCAPE
SKIPN P1 ;IS IT NOWAIT?
PUSHJ P,CTLTXT ;YES, PUT IN THE ESCAPE
JUMPF .RETF ; Return failure on error
PJRST CTLEOL ;PUT ON CRLF AND RETURN
$MES.2: $TEXTL(<%SPTIMS Illegal $MESSAGE switch, /NOWAIT assumed>)
JRST $MES.1 ;AND CONTINUE ON
XWD 2,2
$MES.3: TB(NOWAIT,0)
TB(WAIT,1)
SWNAME: BLOCK ^D8 ;ROOM FOR THE SWITCH
SUBTTL Control Cards -- BATCH Commands
; $ERROR - $NOERROR
; $BACKTO - $CHKPNT - $GOTO
; $NOOPERATOR - $OPERATOR - $REQUEUE
; $REVIVE - $SILENCE
;
;These commands are BATCH commands. They are copied directly
; into the control file with the "$" changed to the
; appropriate monitor prompt character.
$$BATCH:MOVE S1,MONPRT ;GET THE MONITOR PROMPT
MOVE S2,L.DHOL ; Get default pointer to line
IDPB S1,S2 ; Replace "$" in col 1
$TEXTC(<^Q/L.DHOL/^A>)
$RETT
SUBTTL Control Cards -- $IF Command
$$IF: PUSHJ P,S$FSPC ;IGNORE BLANKS
SKIPF
CAIE C,"(" ;PROPER DELIMITER?
JRST $$IF.1 ;NO, FAIL
PUSHJ P,S$INCH ; Eat the (
PUSHJ P,S$FSPC ;IGNORE BLANKS
TXO F,F.RSCN ; To pick up first char
MOVEI S1,AR.NAM ;POINT TO ARGUMENT BLOCK
PUSHJ P,S$ASCZ ;GATHER THE ARGUMENT
PUSHJ P,S$FSPC ; Ignore trailing blanks
MOVEI S1,$IF.A-1 ;POINT TO ARG TABLE
HRROI S2,AR.NAM ;POINT TO STRING AGAIN
$CALL S%TBLK ;TRY FOR A MATCH
CAIN C,")" ;PROPER TERMINATOR?
TXNE S2,TL%NOM!TL%AMB ;VALID ARGUMENT?
JRST $$IF.3 ;NO
PUSHJ P,S$INCH ; Eat the )
PUSHJ P,S$FSPC ;SKIP OVER BLANKS
JUMPF $$IF.1 ;??
CAIE C,"$" ;IS IT A BUCK?
JRST $$BATCH ;NO, NO HELP HERE
MOVE C,MONPRT ;YES, CONVERT TO SYSTEM PROMPT
DPB C,B ;PLANT IN PLACE
MOVEI S1,L.TNAM ;POINT TO STRING BLOCK
PUSHJ P,S$ASCZ ;SEE IF WE KNOW ABOUT THIS GUY
MOVEI S1,TBCARD ;POINT TO TABLE
HRROI S2,L.TNAM ;POINT TO THIS KEYWORD
$CALL S%TBLK ;SEE IF WE KNOW ABOUT IT
TXNE S2,TL%NOM!TL%AMB ;DO WE?
JRST $$IF.1 ;NO
SUBI S1,TBCARD+1 ;COMPUTE OFFSET
MOVE T1,S1 ;RELOCATE
MOVE T2,CADRS(T1) ;GET DISPATCH ADDRESS
TXNN T2,CD.SBC ;SPECIAL BATCH CONTROL CARD?
JRST $$IF.1 ;NO, LOSE
JRST $$BATCH ;GOOD, GO WRITE IT OUT
$$IF.1: $TEXTL(<^I/FATAL/?SPTIMF ^I/$$IF.2/>)
JSP B,CTLCER
$$IF.2: ITEXT (<Improper format for $IF control card>)
$$IF.3: $TEXTL(<^I/FATAL/?SPTIIC ^I/$$IF.4/>)
JSP B,CTLCER
$$IF.4: ITEXT(<Improper conditional in IF statement>)
XWD 2,2
$IF.A: TB (ERROR,0)
TB (NOERROR,1)
SUBTTL Control Cards -- LABEL Command
$LABEL: PUSHJ P,S$FSPC ;STRIP BLANKS
JUMPF $LAB.1 ;IF EOL, LOSE
TXO F,F.RSCN ;REREAD LAST CHARACTER
MOVEI S1,LABADR ;WHERE TO STORE ASCII LABEL
PUSHJ P,S$ASCZ ;READ IT
JUMPE S1,$LAB.1 ; Fail if null
$TEXTC(<^T/LABADR/::>) ;WRITE LABEL INTO CTL FILE
$RETT ;AND RETURN
$LAB.1: $TEXTL(<^I/FATAL/?SPTNLS ^I/$LAB.2/>)
JSP B,CTLCER
$LAB.2: ITEXT (<No label specified on $LABEL Control Card>)
SUBTTL Control Cards -- $EOD
$EOD: MOVE T1,L.DHOL ; Load the default BP
MOVEM T1,L.CHOL ; and save for the next card
MOVEI T1,STASC ; Load default stacking routine
MOVEM T1,L.MODE ; and store for next dispatch
SKIPN FILOPN ; Is there a deck open?
$RETT ; No, skip back
; Yes
MOVE S1,FILIFN ; Get the IFN
SETO S2,0
$CALL F%FD ; Build an exact FD
$TEXTL(<^I/STMSG/[File ^F/(S1)/ created - ^D/DEKCRD/ cards read]>)
SETZM FILOPN ; And zero it
SKIPE L.QFN ; Need to queue the file?
PUSHJ P,QUEFIL ; Yes, do it
MOVE S1,FILIFN ; Get the IFN
$CALL F%REL ; And release the file
$RETT ; Return success
SUBTTL Control Cards -- $EOJ
$EOJ: ;FINISH UP WITH THIS JOB
$RETT
SUBTTL Control Cards -- $SEQUENCE
$SEQUE: PUSHJ P,S$DEC ; Pick up argument
JUMPF $SEQ.1 ; Fail if not a number
MOVE S2,[XWD 1,7777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF $SEQ.1 ; Fail if not in range
STORE S1,.EQSEQ(Q),EQ.SEQ ; Store it
$RETT
$SEQ.1: $TEXTL(<^I/STERR/%SPTISN Illegal sequence number on $SEQUENCE card ignored>)
$RETT ;RETURN
SUBTTL Control Cards -- $TOPS10 - $TOPS20
$TOPNTV: TDZA T1,T1 ;CLEAR FLAG FOR NATIVE MODE
$TOPFGN: SETO T1,0 ;SET FOR "FOREIGN" MODE
MOVEM T1,REVDSP ;STORE
MOVX S1,SW.TOP ;VALID SWITCH BITS
PUSHJ P,DOSWCH ;DO THE SWITCHES
JUMPF .RETF ; Return failure
$TOP.1: PUSHJ P,CDRASC ;GET A CARD
JUMPF $TOP.4 ; Branch if EOF or error
PUSHJ P,CHEKCC ; See if this card
TXNE S1,CD.EOD ; terminates the deck
JRST $TOP.4 ; Yes, finish up.
$TOP.2: SKIPE REVDSP ;NATIVE MODE?
JRST $TOP.1 ;NO, IGNORE THIS
MOVE S1,CTLIFN ;GET THE IFN
MOVE S2,L.CSUP ;GET SUPPRESSED LENGTH
SKIPN S2 ; Is it null?
MOVX S2,1 ; Yes, ensure one blank!
CAML S2,L.WIDT ; Less than desired length?
MOVE S2,L.WIDT ; No, use only specified /WIDTH
HRL S2,S2
HRR S2,L.CHOL ;POINT TO THE CORRECT CARD
$CALL F%OBUF ;OUTPUT IT
JUMPF CTLERR ; Fail on output error
PUSHJ P,CTLEOL ;AND PUT OUT AN EOL
JRST $TOP.1 ;AND LOOP AROUND
$TOP.4: TXNE F,F.FATE ; A fatal error?
$RETF ; Yes, return failure
TXNN F,F.EOF ; If not at EOF
SETOM NXTRDY ; set "next card ready"
$RETT ; Finish up
SUBTTL Routines To Finish A Job -- TRMJOB - Normal Job Termination
;TRMJOB -- Routine to finish off a job normally. Puts CREF,
; DUMP, DELETE lines into CTL file, and goes off to queue
; up the job.
;
; This routine will be called at the end of a job when a job
; termination card (i.e., $EOJ or $JOB) is found, or when an
; end of file is encountered in the input file.
;
TRMJOB: $CALL .SAVE1 ; Need a register
PUSHJ P,$EOD ;END DECK IN PROGRESS IF ANY
$TEXTL(<^I/STSUM/End of job encountered>)
PUSHJ P,SUMARY ;GIVE SUMMARY
TXNE F,F.SITG ;[SITGO] SITGO deck?
JRST TRMJ.S ;[SITGO] Yes, skip the control file items
$TEXTC(<%FIN::>)
MOVE T1,L.DPCR ;GET DUMP AND CREF FLAGS
SKIPGE T1 ;IS DUMP SIDE (LH) SET?
$TEXTC(<^7/MONPRT/DUMP>) ;YES, SO ENTER DUMP COMMAND
TRNE T1,-1 ;CREF?
$TEXTC(<^7/MONPRT/CREF>)
MOVEI P1,FIL.LN ;NUMBER OF FILES PER LINE
MOVE S1,L.FBLN ;GET LIST NAME
$CALL L%FIRST ;POSITION TO THE BEGINNING
JUMPF TRMJ.3 ;NOTHING THERE, DONE
TRMJ.1: LOAD T1,.FBFLG(S2),FB.DEL ;GET DELETE BIT
JUMPE T1,TRMJ.2 ;JUMP IF NOT TO BE DELETED
CAIN P1,FIL.LN ;FIRST FILESPEC ON THIS LINE?
$TEXTC(<^7/MONPRT/DELETE ^A>) ;YES, TYPE DELETE COMMAND
CAIE P1,FIL.LN ;INDICATE CONTINUATION IF
$TEXTC(<,^A>) ;NOT THE FIRST
$TEXTC(<^F/.FBFD(S2)/^A>) ;TYPE THE FILESPEC
SOJG P1,TRMJ.2 ;JUMP IF ROOM FOR MORE
PUSHJ P,CTLEOL ;ELSE PUT IN A CRLF
MOVEI P1,FIL.LN ;RESET THE COUNT
TRMJ.2: MOVE S1,L.FBLN ;GET THE LIST NAME
$CALL L%NEXT ;GET THE NEXT FILE
JUMPT TRMJ.1 ;LOOP BACK IF SUCCESSFUL
TRMJ.3: CAIE P1,FIL.LN ;ANYTHING ON THE LINE?
PUSHJ P,CTLEOL ;YES, TYPE A CRLF
TRMJ.S: MOVE S1,L.FBLN ;[SITGO]GET NAME OF FILE LIST
$CALL L%DLST ;AND DELETE THE LIST
PUSHJ P,DOFACT ;DO USAGE ACCOUNTING
PUSHJ P,QUEJOB ;SUBMIT THE JOB
SETZM L.JLOG ; Job no longer "logged in"
$WTOJ (< End >,<^T/L.JTXT/>,WTOOBJ)
$RETT
SUBTTL Routines To Finish A Job -- ABORT - Abort the current job
; ===== ---------------------
;
;ABORT is called upon detection of a fatal error. ABORT deletes
; all temp files created by the job and queues up the log
; file.
;
; On entry AC B contains address of ITEXT.
JOBCER: MOVEI T1,[ITEXT(<Job Card Error>)]
PJRST ABORT
PSWCER: MOVEI T1,[ITEXT(<Invalid Password Card>)]
PJRST ABORT
CTLCER: MOVEI T1,[ITEXT(<Control Card Error>)]
PJRST ABORT
ACTCER: MOVEI T1,[ITEXT(<Accounting Error>)]
PJRST ABORT
PROCER: MOVEI T1,[ITEXT(<Input Spooling Processor Error>)]
ABORT: TXZ F,F.SITG ;[SITGO] Claim not SITGO anymore
TXOE F,F.FATE ;SET FATAL ERROR BIT
$RETF ; Return if job already aborted!
SKIPE L.JLOG ; If logged in send this msg
$WTOJ (^I/(T1)/,<^R/.EQJBB(Q)/^M^J^T/JOBCRD/^I/(B)/>,WTOOBJ)
SKIPN L.JLOG ; If not logged in send this one
$WTOJ (^I/(T1)/,<^R/.EQJBB(Q)/^M^J^I/(B)/>,WTOOBJ)
$TEXT(LOGTXT,<^M^J^J^I/STSUM/Job Aborted due to fatal error>)
PUSHJ P,CRDEOJ ; Flush to end of job
PUSHJ P,SUMARY ;GIVE THE SUMARY
TXZ F,F.BTCH ;NO BATCH JOB HERE
MOVE S1,CTLIFN ;GET THE CONTROL FILE IFN
SKIPE S1 ; If we have a CTL file
$CALL F%RREL ; release and abort it
SETZM CTLIFN ; Now it is gone.
SKIPN L.JLOG ;JOB LOGGED IN?
JRST ABOR.4 ;NO, DO SPECIAL THINGS
SETZM L.JLOG ; Job no longer "logged in"
PUSHJ P,DOFACT ;DO USAGE ACCOUNTING
PUSHJ P,QUELOG ;QUEUE UP THE LOG FILE
MOVE S1,FILIFN ;PICK UP AN IFN
SKIPE FILOPN ;IS THERE A DECK OPEN?
$CALL F%RREL ;YES, GET RID OF IT
SETZM FILOPN ;AND CLEAR IFN
MOVE S1,L.FBLN ;GET THE LIST NAME
$CALL L%FIRST ;POSITION TO THE BEGINNING
JUMPF ABOR.3 ;DONE IF NONE
ABOR.1: LOAD S1,.FBFLG(S2),FB.DEL ;GET DELETE FLAG
JUMPE S1,ABOR.2 ;JUMP IF NOT TO BE DELETED
MOVEI S1,.FBFD(S2) ;YES, GET ADDRESS OF THE FD
MOVEM S1,L.FOB+FOB.FD ;STORE IN THE FOB
MOVEI S1,^D36 ;GET A RANDOM BYTE SIZE
STORE S1,L.FOB+FOB.CW,FB.BSZ ;AND STORE IT
MOVEI S1,2 ;GET THE LENGTH
MOVEI S2,L.FOB ;GET THE ADR OF THE FOB
$CALL F%DEL ;DELETE THE FILE
ABOR.2: MOVE S1,L.FBLN ;GET THE LIST NAME
$CALL L%NEXT ;GET THE NEXT
JUMPT ABOR.1 ;LOOP FOR MORE
ABOR.3: MOVE S1,L.FBLN ;GET NAME OF FILE LIST
$CALL L%DLST ;AND DELETE THE LIST
$RETF ; Return failure
ABOR.4:
;
; Try to use user name and PPN, if possible, so .LOG file with
; error messages gets routed to owner.
;
TOPS10 <
MOVX S1,<XWD 1,2> ; Use [1,2]
SKIPN .EQOID(Q) ; if no PPN
MOVEM S1,.EQOID(Q) ; is specified
MOVX T1,'SPRINT' ;MAKE AN INTERESTING NAME
MOVX T2,' ERROR' ;LIKE "SPRINT ERROR"
CAXE S1,.EQOID(Q) ; If PPN is [1,2],
SKIPN .EQOWN(Q) ; or if no name specified,
DMOVEM T1,.EQOWN(Q) ; use this name.
MOVX S1,%BSPOL ;GET SPOOLED FILE BIT
STOLIM S1,.EQLIM(Q),BLOG ;SO THE FILE GOES TO [3,3]
>;END TOPS10
MOVE S1,LOGIFN ; Get LOG file IFN
JUMPN S1,ABOR.5 ; Do we have a LOG file open?
PUSHJ P,MAKLOG ; No, create the LOG file
JUMPF .RETF ; Fail if no LOG to queue
ABOR.5: PUSHJ P,QUELOG ;QUEUE IT UP
$RETF ;AND FINISH UP
SUBTTL Switch Processing Routines -- DOSWCH - Process switches
; ====== ----------------
;
; DOSWCH is called to process switches on a control card.
; DOSWCH parses off each switch and dispatches to the
; appropriate switch handler. Switch handlers will normally
; return true. If a switch handler fails, DOSWCH will issue
; a warning diagnostic. On fatal errors, switch handlers
; will dispatch directly to ABORT processing.
;
; Call:
;
; PUSHJ P,DOSWCH
; S1 contains valid switch bits
;
; Returns TRUE when all switches are parsed
;
; Returns FALSE if fatal error occurs
; (Return is via ABORT routine)
;
DOSWCH: $CALL .SAVE1 ; Get a register to hold flags
MOVE P1,S1 ; Valid switch bits
TXZ F,F.RSCN ; Clear rescan last char bit
DOSW.1: CAIN C,"/" ;DO WE HAVE A SLASH?
JRST DOSW.2 ;YUP, CONTINUE
PUSHJ P,S$INCH ;NO, GET NEXT CHARACTER
JUMPF .RETT ;END OF CARD, RETURN
JRST DOSW.1 ;AND LOOP
DOSW.2: MOVEI S1,L.SWCH ;PLACE TO STORE THE STRING
PUSHJ P,S$ASCZ ;GO GET IT
MOVEI S1,TBSWIT ;POINT TO TABLE
HRROI S2,L.SWCH ;POINT TO THE STRING
$CALL S%TBLK
TXNE S2,TL%NOM!TL%AMB ;VALID SWITCH?
JRST DOSW.5 ;NO, COMPLAIN
SUBI S1,TBSWIT+1 ;CALCULATE OFFSET
MOVEI T2,SADRS ;LOAD ADR OF DISPATCH TABLE
ADD T2,S1 ;ADD IN THE OFFSET
HRRZ T1,(T2) ;LOAD ADR OF SWITCH HANDLER
HLRZ T2,(T2) ;LOAD VALID BITS FOR THIS SWITCH
TRNN T2,(P1) ;TEST THE BITS FOR LEGALITY
JRST DOSW.6 ;HE LOSES
SKIPE CDRAIM ; Is input file augmented image?
JRST DOSW.3 ; Yes, all is fine
TRNE T2,SW.MOD ; No, is this a mode change?
JRST DOSW.7 ; Yes, so it's illegal!
DOSW.3: PUSHJ P,(T1) ; WIN, DISPATCH!!!
JUMPT DOSW.1 ;AND LOOP FOR NEXT SWITCH
$TEXTL(<^I/STERR/%SPTUSA Unrecognized switch argument to /^T/L.SWCH/, switch ignored>)
JRST DOSW.1 ;RECOVER
DOSW.5: $TEXTL(<^I/STERR/%SPTURS Unrecognized switch /^T/L.SWCH/, ignored>)
JRST DOSW.1 ;AND LOOP AROUND
DOSW.6: $TEXTL(<^I/STERR/%SPTISW The /^T/L.SWCH/ switch ^A>)
$TEXTL(<is illegal on the $^T/L.TNAM/ card, ignored>)
JRST DOSW.1 ;AND LOOP AROUND
DOSW.7: $TEXTL(<^I/STERR/%SPTISW The /^T/L.SWCH/ switch ^A>)
$TEXTL(<on the $^T/L.TNAM/ card is ignored ^A>)
$TEXTL(<when the job is submitted as an ASCII file>)
JRST DOSW.1 ;AND LOOP AROUND
SUBTTL Switch Processing Routines -- $JOB Card Switch Subroutines
; ----------------------------
;/CARDS
W$CARD: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$DEC ; Pick up value
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 0,777777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STOLIM S1,.EQLIM(Q),SCDP ; Store value
$RETT ; And return
;/DEPEND
W$DEPE: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$DEC ; Pick up value
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 0,177777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STOLIM S1,.EQLIM(Q),DEPN ; Store value
$RETT ; And return
;/FEET
W$FEET: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$DEC ; Pick up value
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 0,777777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STOLIM S1,.EQLIM(Q),SPTP ; Store value
$RETT ; And return
;/LOCATE
W$LOCA: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
JUMPE S1,.RETF ; Fail if null
HRROI S1,AR.NAM ; Byte pointer to ASCIZ string
$CALL S%SIXB ; SIXBITize it
STOLIM S2,.EQLIM(Q),ONOD ; Store value
$RETT ; And return
;/PAGES
W$PAGE: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$DEC ; Pick up value
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 0,777777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STOLIM S1,.EQLIM(Q),SLPT ; Store value
$RETT ; And return
;/JOBNAME
W$JOBN: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
W$JNAM: ; Look for a jobname
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ; Point to storage
PUSHJ P,S$ASCZ ; Read it in
JUMPE S1,.RETF ; Return failure if no string
HRROI S1,AR.NAM ; Byte pointer to ASCIZ string
PUSHJ P,S$SIXB ; Convert to sixbit
STORE S2,.EQJBB+JIB.JN(Q) ; Yes, store the jobname
$RETT ; And return
;/USER:USERNAME
;
; For TOPS-10 just ignore this name (/NAME is used for user name)
; /USER is legal for TOPS-10; could be system independent job
;
W$USER:
TOPS20 <
PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
W$USR:
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,L.USER ; Point to storage
PUSHJ P,S$ASCZ ; Read it in
JUMPE S1,.RETF ; Return failure if no string
>
$RETT ; RETURN
;/PPN:[PRJ,PRG]
W$PPN: PUSHJ P,S$FCOL ; Flush beyond colon
JUMPF .RETF ; Return failure
PUSHJ P,S$PPN ; Go get the PPN
JUMPF .RETF ; Return failure
MOVEM S1,L.PPN ; Save it
$RETT
;/TIME
W$TIME: PUSHJ P,S$TIM ;GET A TIME-SPEC
JUMPF BADTAR ;SOMETHING ILLEGAL
MOVEI T1,^D3600 ;START CONVERTING TO SECS
IMULM T1,L.HRS ;SEC/HRS
MOVEI T1,^D60 ;SEC/MIN
IMUL T1,L.MIN
ADD T1,L.HRS ;AND ADD THEM UP
ADD T1,L.SEC ;ADD IN SECONDS
STOLIM T1,.EQLIM(Q),TIME ;STORE AWAY
$RETT
;/ERROR:CHK:IBC:HOL
W$ERRO: PUSHJ P,S$TIM ;GET WHAT LOOKS LIKE A TIME SPEC
JUMPF BADTAR ;GIVE ERROR MESSAGE
MOVE T1,L.HRS ;GET HRS
MOVEM T1,L.UCHK ;AND MAKE IT CHKSUM ERRORS
MOVE T1,L.MIN ;GET MINUTES
MOVEM T1,L.UIBC ;AND MAKE IT ILL BIN CARDS
MOVE T1,L.SEC ;AND GET SECONDS
MOVEM T1,L.UHOL ;AND MAKE THEM HOLLERITH ERRORS
$RETT
BADTAR: $TEXTL(<^I/STERR/%SPTIAF Illegal argument format on /^T/L.SWCH/ switch, ignored>)
$RETT
;/HOLLERITH
W$HOLL: PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
JUMPE S1,.RETF ; Fail if null
MOVEI S1,W$HO.A-1 ;POINT TO TABLE
HRROI S2,AR.NAM ;AND THE STRING
$CALL S%TBLK ;DO THE SEARCH
TXNE S2,TL%NOM!TL%AMB
$RETF
HRRZ S1,(S1) ;GET THE ARGUMENT
HRLI S1,(POINT 7) ;MAKE IT COMPLETE BP
STORE S1,L.DHOL ;SAVE AS DEFAULT
$RETT
XWD 3,3
W$HO.A: TB (026,L.C026)
TB (ASCII,L.CASC)
TB (BCD,L.C026)
;/AFTER
W$AFTE:
PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETF ; None there, return failure
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ; Where to copy the string
PUSHJ P,S$DTIM ; Get the date/time string
JUMPE S1,.RETF ; Fail if null
HRRI S1,AR.NAM ; Address of date/time string
HRLI S1,(POINT 7) ; Make a byte pointer
MOVX S2,<CM%IDA!CM%ITM!CM%FUT> ; Set date/time flags (Future only)
PUSHJ P,S%DATI ; Get a date time spec
JUMPF W$AF.1 ; Lose
MOVEM S2,.EQAFT(Q) ; Store the UDT value
$RETT ;AND RETURN
W$AF.1: $TEXTL(<^I/STERR/%SPTIAF /^T/L.SWCH/ switch ignored (^E/S1/)>)
$RETT ;AND RETURN TRUE (error given)
TOPS10 <
;/NAME
W$NAME:
PUSHJ P,S$FCOL ; Flush beyond colon
JUMPF .RETF ; Fail if no :
SETZM .EQOWN(Q) ; Clear the first half
SETZM .EQOWN+1(Q) ; and second half of user name
TXO F,F.NAME ; Flag that we have a name
MOVEI S1,AR.NAM ; Where to put string
PUSHJ P,S$QUOT ; Pick up string
JUMPE S1,.RETF ; Null string
HRROI S1,AR.NAM ; Point to string
PUSHJ P,S$SIXB ;Convert it to sixbit
MOVEM S2,.EQOWN(Q) ; Save
JUMPF .RETT ;No more,,return
PUSHJ P,S$SIXB ;Convert the rest
MOVEM S2,.EQOWN+1(Q) ; Save second half
$RETT ; Return
IFN INPCOR,<
;/CORE
W$CORE: PUSHJ P,S$FCOL ; Flush beyond colon
JUMPF .RETF ; Fail if no :
PUSHJ P,S$DEC ;GET DECIMAL ARGUMENT
JUMPF .RETF ;GARBAGE!!
JUMPE S1,.RETT ;USE DEFAULT IF ZERO
CAIE C,"P" ;DID HE SPECIFY PAGES?
ASH S1,1 ;NO, MULTIPLY BY 2
W$COR1: STOLIM S1,.EQLIM(Q),CORE ;STORE VALUE AWAY
$RETT ;AND RETURN
>;END IFN INPCOR
>;END TOPS10
;/PRIO
W$PRIO: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$DEC ; Pick up argument
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 1,MXUPRI] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STORE S1,.EQSEQ(Q),EQ.PRI ; Store it
$RETT
;/RESTART
W$REST: MOVX T1,%EQRYE ;GET /REST:YES
STOLIM T1,.EQLIM(Q),REST ;AND STORE IT
$RETT ;AND RETURN
;/NORESTART
W$NORE: MOVX T1,%EQRNO ;GET NOT-RESTART
STOLIM T1,.EQLIM(Q),REST ;STORE /RESTART VALUE
$RETT ;AND RETURN
;/SEQUENCE
W$SEQU: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$DEC ; Pick up argument
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 1,7777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STORE S1,.EQSEQ(Q),EQ.SEQ ; Store it
$RETT
;/TPLOT
W$TPLO: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$DEC ; Pick up argument
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 0,777777] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
STOLIM S1,.EQLIM(Q),SPLT ; Store it
$RETT
;/UNIQUE
W$UNIQ: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
MOVEI S1,W$UN.A-1 ;POINT TO TABLE
HRROI S2,AR.NAM ;AND THE STRING
$CALL S%TBLK ;DO THE SEARCH
TXNE S2,TL%NOM!TL%AMB
$RETF
HRRZ S1,(S1) ;GET THE ARGUMENT
SKIPN S1 ;/UNIQUE:2 ?
JRST [TXO F,F.USFD ;YES - REMEMBER IT
MOVX S1,%EQUNO ;QUASAR DOESN'T KNOW ABOUT /UNIQUE:2
JRST .+1] ;CONTINUE
STOLIM S1,.EQLIM(Q),UNIQ ;STORE UNIQUE VALUE
$RETT ;RETURN
XWD 5,5
W$UN.A: TB (0,%EQUNO)
TB (1,%EQUYE)
TB (2,0)
TB (NO,%EQUNO)
TB (YES,%EQUYE)
;/OUTPUT
W$OUTP: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
MOVEI S1,W$OU.A-1 ;POINT TO TABLE
HRROI S2,AR.NAM ;AND THE STRING
$CALL S%TBLK ;DO THE SEARCH
TXNE S2,TL%NOM!TL%AMB
$RETF
HRRZ S1,(S1) ;GET THE ARGUMENT
STOLIM S1,.EQLIM(Q),OUTP
$RETT
XWD 4,4
W$OU.A: TB (ALWAYS,%EQOLG)
TB (ERRORS,%EQOLE)
TB (LOG,%EQOLG)
TB (NOLOG,%EQONL)
; DELETE
;/LOGDISP:KEEP
; PRESERVE
;Note that this switch(value) is not passed in the NEXTJOB message
;from QUASAR. The switch is only available on the JOB card and sets
;FP.DEL for the log file disposition.
W$LOGD: PUSHJ P,S$FCOL ; Position beyond colon
JUMPF .RETF ; Return failure if none
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
MOVEI S1,W$LO.A-1 ;POINT TO TABLE
HRROI S2,AR.NAM ;AND THE STRING
$CALL S%TBLK ;DO THE SEARCH
TXNE S2,TL%NOM!TL%AMB
$RETF
HRRZ S1,(S1) ;GET THE ARGUMENT
STORE S1,L.LGDS ;STORE AS LOG DISPOSITION
$RETT
XWD 3,3
W$LO.A: TB (DELETE,1)
TB (KEEP,0)
TB (PRESERVE,0)
AR.NAM: BLOCK ^D8 ;ARGUMENT NAME
; /ACCOUNT:
W$ACCO: PUSHJ P,S$FCOL ; Position beyond colon
JUMPF .RETF ; Return failure if none
HRLZI S1,.EQACT(Q) ; Address of acct string
HRRI S1,.EQACT+1(Q) ;MAKE A BLT POINTER
SETZM .EQACT(Q) ;CLEAR FIRST WORD
BLT S1,.EQACT+7(Q) ;CELAR THE ENTIRE BLOCK
TXO F,F.ACCT ; Flag that we have a string
MOVEI S1,.EQACT(Q) ; Where to put string
PUSHJ P,S$QUOT ; Pick up string
$RETT ;ALWAYS RETURN TRUE
; YES
; /ASSIST:
; NO
;
W$ASSI: PUSHJ P,S$FCOL ; Position beyond colon
JUMPF .RETF ; Return failure if none
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
MOVEI S1,W$AS.A-1 ;POINT TO TABLE
HRROI S2,AR.NAM ;AND THE STRING
$CALL S%TBLK ;DO THE SEARCH
TXNE S2,TL%NOM!TL%AMB
$RETF
HRRZ S1,(S1) ;GET THE ARGUMENT
STOLIM S1,.EQLIM(Q),OINT
$RETT
XWD 2,2
W$AS.A: TB (NO,.OPINN)
TB (YES,.OPINY)
; SUPERSEDE
; /BATLOG:APPEND
; SPOOL
W$BATC: PUSHJ P,S$FCOL ; Position beyond colon
JUMPF .RETF ; Return failure if none
PUSHJ P,S$FSPC ; Flush any spaces
TXO F,F.RSCN ; Set to rescan first character
MOVEI S1,AR.NAM ;WHERE TO COPY THE STRING
PUSHJ P,S$ASCZ
MOVEI S1,W$BA.A-1 ;POINT TO TABLE
HRROI S2,AR.NAM ;AND THE STRING
$CALL S%TBLK ;DO THE SEARCH
TXNE S2,TL%NOM!TL%AMB
$RETF
HRRZ S1,(S1) ;GET THE ARGUMENT
STOLIM S1,.EQLIM(Q),BLOG
$RETT
XWD 3,3
W$BA.A: TB (APPEND,%BAPND)
TB (SPOOL,%BSPOL)
TB (SUPERSEDE,%BSCDE)
SUBTTL Switch Processing Routines -- Non-$JOB Card Switch Routines
; -----------------------------
;/ASCII
IFE A%DFMD,<W$DFMD:>
W$ASCI: SKIPA T1,[POINT 7,L.CASC] ;LOAD ASCII MODE POINTER AND SKIP
;/026
IFN A%DFMD,<W$DFMD:>
W$BCD:
W$026: MOVE T1,[POINT 7,L.C026] ;LOAD 026 POINTER
MOVEM T1,L.CHOL ;AND SAVE FOR READ ROUTINE
MOVEI T1,STASC ;LOAD STACKING ROUTINE
MOVEM T1,L.MODE ;AND STORE FOR DISPATCH
$RETT ;AND RETURN
;/BINARY
W$BINA: MOVEI T1,STBIN ;LOAD ROUTINE NAME
MOVEM T1,L.MODE ;AND STORE IT
$RETT ;AND RETURN
;/IMAGE
W$IMAG: MOVEI T1,2 ; Pick up default arg val
MOVEM T1,L.IMGT ; and store it
MOVEI T1,STIMG ; Load routine name
MOVEM T1,L.MODE ; Store for dispatch
PUSHJ P,S$FCOL ; Look for a colon
JUMPF .RETT ; None there, take default
PUSHJ P,S$DEC ; Pick up value
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 1,^D80] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
MOVEM S1,L.IMGT ; Store value
$RETT ; And return
;/SUPPRESS - /NOSUPPRESS
W$NOSU: SETZM L.SPRS ;CLEAR THE SUPPRESS FLAG
$RETT ;AND RETURN
W$SUPP: SETOM L.SPRS ;SET THE SUPPRESS FLAG
$RETT ;AND RETURN
;/LIST - /NOLIST
W$LIST: SKIPA T1,[SIXBIT "/LIST"]
W$NOLI: SETZ T1,0 ;CLEAR THE LISTING SWITCH
MOVEM T1,L.LSW ;STORE IT
$RETT ;AND RETURN
;/SEARCH
W$SEAR: SETOM L.SRH ;SET THE SEARCH FLAG
$RETT ;AND RETURN
;/PROTECT
W$PROT: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$OCT ; Pick up argument
JUMPF .RETF ; Fail if not a number
TOPS10 <MOVE S2,[XWD 1,777]> ; Min,Max
TOPS20 <MOVE S2,[XWD 1,777777]> ; Min,Max
PUSHJ P,RCKOCT ; See if in range
JUMPF .RETT ; No, return true (error given)
MOVEM S1,L.PROT ; Yes, save value
$RETT ; Return
;/CREF
W$CREF: MOVE T1,[SIXBIT "/CREF"]
MOVEM T1,L.LSW ;STORE /CREF SWITCH
HLLOS L.DPCR ;FLAG IT FOR LATER
$RETT ;AND RETURN
;/WIDTH
W$WIDT: PUSHJ P,S$FCOL ; Position to switch arg
JUMPF .RETF ; Fail if no argument
PUSHJ P,S$DEC ; Pick up argument
JUMPF .RETF ; Fail if not a number
MOVE S2,[XWD 1,^D80] ; Min,Max
PUSHJ P,RCKDEC ; See if in range
JUMPF .RETT ; No, return true (error given)
MOVEM S1,L.WIDT ; Yes, save value
$RETT
;/MAP - /NOMAP
W$NOMA: TXZA F,F.MAP ;TURN OFF MAP BIT
W$MAP: TXO F,F.MAP ;TURN ON A BIT
$RETT ;AND RETURN
;/DOLLAR - /NODOLLAR
W$NODO: TXZA F,F.DOLR ;TURN OFF DOLLAR BIT
W$DOLL: TXO F,F.DOLR ;TURN ON DOLLAR BIT
$RETT ;AND RETURN
;/PRINT
W$PRIN: MOVX T1,.OTLPT
PJRST QSWRET
;/TPUNCH
W$TPUN: MOVX T1,.OTPTP
PJRST QSWRET
;/CPUNCH
W$CPUN: MOVX T1,.OTCDP
PJRST QSWRET
;/PLOT
W$PLOT: MOVX T1,.OTPLT
QSWRET: MOVEM T1,L.QFN ;STORE DEVICE
$RETT ;AND RETURN
SUBTTL Switch Processing Routines -- RCKOCT - Range ck octal value
; ====== --------------------
;
; Here to range check an octal or decimal value. If value is
; not in range, error message is generated.
;
; Call:
;
; S1 contains value to be range checked
; S2 contains minimum,,maximum
;
; PUSHJ P,RCKOCT (RCKDEC)
;
; Returns TRUE if in range
; S1 contains original value
;
; Returns FALSE if not in range
;
RCKOCT: MOVEI T1,[ITEXT(<^O/T1/ and ^O/T2/>)]
JRST RCKNUM ;AND CONTINUE ON
SUBTTL Switch Processing Routines -- RCKDEC - Range ck decimal value
; ====== -------------------
RCKDEC: MOVEI T1,[ITEXT(<^D/T1/ and ^D/T2/>)]
;AND FALL INTO RCKNUM
RCKNUM: MOVEM T1,RCKN.A ; Save for error processing
HLRZ T1,S2 ;GET MINIMUM VALUE
HRRZ T2,S2 ;GET MAXIMUM VALUE
CAML S1,T1 ;CHECK RANGE
CAMLE S1,T2
JRST RCKN.1 ; Out of range
$RETT ; In range, return success
RCKN.1: $TEXTL(<^I/STERR/%SPTVMB The value on the /^T/L.SWCH/ switch ^A>)
$TEXTL(<must be between ^I/@RCKN.A/, switch ignored>)
$RETF ;AND RETURN
RCKN.A: BLOCK 1 ;TEMPORARY STORAGE
SUBTTL LOG File I/O Utilities -- MAKLOG - Create the LOG File
; ====== -------------------
MAKLOG:
TOPS10 <
MOVEI S1,FDXSIZ ;GET LENGTH
MOVEI S2,CLFFD ;GET ADDRESS
$CALL .ZCHNK ;ZERO THE BLOCK
MOVSI S1,'DSK' ; Use default search list
TXNE F,F.FATE ; If during abort processing,
MOVSI S1,'SSL' ; try to put a log somewhere.
STORE S1,CLFFD+.FDSTR ; Store in FD
LOAD S1,.EQJBB+JIB.JN(Q) ;GET JOB NAME
TXNE F,F.SITG ;[SITGO] SITGO job?
MOVE S1,L.SFNY ;[SITGO] Yes, get the funny name
STORE S1,CLFFD+.FDNAM ;AND STORE IT
MOVSI S1,'LOG' ;GET EXTENSION
STORE S1,CLFFD+.FDEXT ;AND STORE IT
MOVEI S1,FDMSIZ ;GET MINIMUM FD SIZE
STORE S1,CLFFD+.FDLEN,FD.LEN ;AND STORE IT
GETLIM S1,.EQLIM(Q),BLOG ;GET /BATLOG ARGUMENT
TXNN F,F.SITG ;[SITGO] All SITGO jobs are already spooled
CAXE S1,%BSPOL ;SPOOLING SPECIFIED?
JRST MAKL.4 ;NO, SO WE'RE ALL SET
PUSHJ P,FUNNY ;GENERATE 4-CHAR FUNNY NAME
TLO S1,'BL ' ;MAKE IT BL????
MOVEM S1,CLFFD+.FDNAM ;STORE AS UNIQUE FILENAME
MOVE S1,L.QPPN ;[SITGO] SPECIFY SPOOLING AREA
MOVEM S1,CLFFD+.FDPPN ;STORE AS OUTPUT PPN
> ;END TOPS10
TOPS20 <
PUSHJ P,FUNNY ;CREATE A RANDOM FILENAME
TLO S1,'BL ' ;MAKE IT 'BLXXXX'
MOVE T1,S1 ;RELOCATE
MOVE S1,[POINT 7,CLFFD+.FDSTG]
MOVEM S1,L.BP ;STORE THE POINTER
GETLIM S1,.EQLIM(Q),BLOG ;GET /BATCH-LOG ARGUMENT
CAXN S1,%BSPOL ;SPOOLED?
$TEXT(DEPBP,<PS:^7/[OCT 74]/SPOOL^7/[OCT 76]/SPR-^O/L.USNO,RHMASK/-^W/T1/.LOG^0>)
CAXE S1,%BSPOL
$TEXT(DEPBP,<^T/L.UDIR/^W/.EQJBB+JIB.JN(Q)/.LOG^0>)
HRRZ S1,L.BP ;GET BP ADDRESS
SUBI S1,CLFFD-1 ;AND COMPUTE LENGTH
STORE S1,CLFFD+.FDLEN,FD.LEN ;AND STORE IT
> ;END IFN FTJSYS
MAKL.4: PUSHJ P,CLRFOB ;CLEAR OUT THE FOB
PUSHJ P,SETFAB ; Set the file attributes
MOVEI S1,CLFFD ;GET ADDRESS OF THE FD
MOVEM S1,L.FOB+FOB.FD ;AND STORE IT
MOVEI S1,7 ;GET THE BYTE SIZE
STORE S1,L.FOB+FOB.CW,FB.BSZ ;AND STORE IT
MOVEI S1,L.FAB ; Address of the Attribute List
MOVEM S1,L.FOB+FOB.AB ;AND STORE IT
MOVEI S1,FOB.SZ ;GET THE LENGTH OF THE FOB
MOVEI S2,L.FOB ;AND ITS ADDRESS
MOVEI T2,F%AOPN ;ASSUME APPEND MODE
GETLIM T1,.EQLIM(Q),BLOG ;GET /BATCH-LOG ARGUMENT
CAXN T1,%BSCDE ;SPECIFY SUPERSEDE?
MOVEI T2,F%OOPN ;YUP, SO DOIT!
PUSHJ P,(T2) ;CALL APPROPRIATE OPEN ROUTINE
JUMPF MAKL.1 ;JUMP IF IT FAILED
MOVEM S1,LOGIFN ;SAVE THE IFN
MOVE S1,LOGIFN ;GET THE IFN
MOVX S2,PAGSIZ*5 ;GET MAXIMUM BYTE COUNT
SKIPLE LOGCNT ; Did characters overflow buffer?
SUB S2,LOGCNT ; If no, get number to print
HRLZ S2,S2 ;GET COUNT,,0
HRR S2,LOGPAG ;GET COUNT,,ADDRESS OF LOG PAGE
$CALL F%OBUF ;OUTPUT THE BUFFER
JUMPF LOGERR ; Fail on output error
MOVE S1,LOGPAG ;GET THE PAGE ADDRESS
$CALL M%RPAG ;RELEASE IT
SETZM LOGPAG ;CLEAR THE PAGE NUMBER
$RETT ;AND RETURN
MAKL.1: $TEXTL(<^I/FATAL/?SPTECL ^I/EM.ECL/>)
JSP B,PROCER
EM.ECL: ITEXT (<Error creating log file ^F/CLFFD/, ^E/S1/>)
SUBTTL LOG File I/O Utilities -- LOGTXT - Output text to LOG File
; ====== -----------------------
LOGTXT: TXNE F,F.LOGF ; Already have log output error?
$RETF ; Yes, quit now!
SKIPG LOGIFN ;IS THE LOG OPEN?
JRST LOGT.1 ;NO, DEPOSIT CHAR IN BUFFER
MOVE S2,S1 ;PUT CHARACTER IN S2
MOVE S1,LOGIFN ;GET THE IFN IN S1
$CALL F%OBYT ;OUTPUT THE CHARACTER
JUMPT .RETT ;RETURN IF ALL IS OK
LOGERR: TXO F,F.LOGF ; Set "LOG output error" flag
PUSH P,S1 ;SAVE ERROR CODE
MOVE S1,LOGIFN ;GET LOGs HANDLE
SETO S2,0 ;BUILD AN FD
$CALL F%FD
POP P,S2 ; Get back status bits
JSP B,PROCER
ITEXT(<Error writing user LOG file ^F/(S1)/, ^E/S2/>)
LOGT.1: SKIPN LOGPAG ;HAS A PAGE BEEN SETUP?
$STOP(LNI,LOG not initialized)
JUMPE S1,.RETT ;RETURN IF NULL
SOSLE LOGCNT ;ANY ROOM LEFT?
IDPB S1,LOGPTR ;YES, DEPOSIT A CHARACTER
$RETT ;AND RETURN
SUBTTL LOG File I/O Utilities -- LOGCRD - Output a card to LOG File
; ====== -------------------------
LOGCRD: TXNE S1,CD.PAS ; A password card
PJRST [$TEXTL(<^I/STCRD/$PASSWORD>)
$RETT]
$TEXTL(<^I/STCRD/^Q/L.DHOL/^A>) ; Type the card out
$RETT ; And return
SUBTTL LOG File I/O Utilities -- LOGCLS - Close the LOG File
; ====== ------------------
LOGCLS: MOVE S1,LOGIFN ;GET THE IFN
SETZM LOGIFN ;LOG IS NOT OPEN!
PJRST F%REL ;AND RELEASE IT
SUBTTL LOG File I/O Utilities -- SUMARY - Place summary lines in LOG
; ====== --------------------------
SUMARY: SETZ T1,0 ;CLEAR A COUNTER
SUMA.1: SKIPE @SUMTB1(T1) ;IS IT A ZERO?
$TEXTL(<^I/STSUM/^D/@SUMTB1(T1)/ ^T/@SUMTB2(T1)/>)
CAIGE T1,.NMSMM-1 ;GOT ALL THE SUMMARY MESSAGES?
AOJA T1,SUMA.1 ;NO, LOOP AROUND FOR THE NEXT ONE
POPJ P, ;YES, RETURN!
SUMTB1: EXP CDRCNT ;NUMBER OF CARDS READ
EXP L.THOL ;NUMBER OF HOLLERITH ERRORS
EXP L.TIBC ;NUMBER OF ILLEGAL BINARY CARDS
EXP L.TCHK ;NUMBER OF CHECKSUM ERRORS
.NMSMM==.-SUMTB1
SUMTB2: [ASCIZ /Cards Read/]
[ASCIZ /Hollerith Errors/]
[ASCIZ /Illegal Binary Cards/]
[ASCIZ /Binary Checksum Errors/]
SUBTTL CTL File I/O Utilities -- MAKCTL - Create the CTL File
; ====== -------------------
MAKCTL:
TOPS10 <
MOVEI S1,FDXSIZ ;GET LENGTH
MOVEI S2,CLFFD ;GET ADDRESS
$CALL .ZCHNK ;ZERO THE BLOCK
LOAD S1,.EQJBB+JIB.JN(Q) ;GET JOB NAME
TXNE F,F.SITG ;[SITGO] SITGO job?
MOVE S1,L.SFNY ;[SITGO] Yes, get the correct funny name
STORE S1,CLFFD+.FDNAM ;AND STORE IT
MOVSI S1,'CTL' ;GET EXTENSION
TXNE F,F.SITG ;[SITGO] Is this a SITGO job?
MOVSI S1,'CDR' ;[SITGO] Yes, make it .CDR instead
STORE S1,CLFFD+.FDEXT ;AND STORE IT
MOVEI S1,FDMSIZ ;GET MINIMUM FD SIZE
STORE S1,CLFFD+.FDLEN,FD.LEN ;AND STORE IT
> ;END TOPS10
TOPS20 <
MOVE S1,[POINT 7,CLFFD+.FDSTG]
MOVEM S1,L.BP ;STORE IT AWAY
$TEXT (DEPBP,<^T/L.UDIR/^W/.EQJBB+JIB.JN(Q)/.CTL^0>)
HRRZ S1,L.BP ;GET BP ADDRESS
SUBI S1,CLFFD-1 ;COMPUTE SIZE
STORE S1,CLFFD+.FDLEN,FD.LEN ;AND STORE IT
> ;END IFN FTJSYS
PUSHJ P,CLRFOB ;CLEAR THE FOB OUT
PUSHJ P,SETFAB ; Set the file attributes
MOVEI S1,CLFFD ;GET ADDRESS OF THE FD
MOVEM S1,L.FOB+FOB.FD ;AND STORE IT
MOVEI S1,7 ;GET THE BYTE SIZE
STORE S1,L.FOB+FOB.CW,FB.BSZ ;AND STORE IT
MOVEI S1,L.FAB ; Address of the Attribute List
MOVEM S1,L.FOB+FOB.AB ;AND STORE IT
MOVX S1,FOB.SZ ;GET THE LENGTH OF THE FOB
MOVEI S2,L.FOB ;AND ITS ADDRESS
$CALL F%OOPN ;AND OPEN THE FILE
JUMPF MAKC.1 ;JUMP IF IT FAILED
MOVEM S1,CTLIFN ;SAVE THE IFN
$RETT ;AND RETURN
MAKC.1: $TEXTL(<^I/FATAL/?SPTECC ^I/EM.ECC/>)
JSP B,PROCER
EM.ECC: ITEXT(<Error creating BATCH control file ^F/CLFFD/, ^E/S1/>)
SUBTTL CTL File I/O Utilities -- CTLCRD - Output card to CTL file
; ====== -----------------------
COMMENT %
CTLCRD -- Routine to copy the remainder of the current card
(up to a specified break character) into the control file.
Call with S1 containing the desired break character (zero if
break on eol is desired). Returns with break character in
accumulator C. Break character is NOT written in control
file.
%
CTLCRD: $CALL .SAVE1 ; Get a P register
MOVE P1,S1 ; Save break character
PUSHJ P,S$INCH ;GET A CHARACTER
JUMPF .RETT ;EOL, RETURN
CAIN C,(P1) ;CHECK FOR BREAK
$RETT ;GOT IT!! RETURN
PUSHJ P,CTLTXT ;AND TYPE IT INTO CTL
JUMPF .RETF ; Return failure on error
JRST CTLCRD ; Otherwise, loop
SUBTTL CTL File I/O Utilities -- CTLTXT - Output text to CTL file
; ====== -----------------------
CTLTXT: MOVE S2,S1 ;RELOCATE CHARACTER
MOVE S1,CTLIFN
$CALL F%OBYT
JUMPT .RETT ; Return if successful
; On error,
CTLERR: PUSH P,S1 ; Save status bits
MOVE S1,CTLIFN ; Get CTL file IFN
SETO S2,0 ; Get a real FD
$CALL F%FD
POP P,S2 ; Get back status bits
$TEXTL(<^I/FATAL/?SPTEWC ^I/CTLS.1/>)
JSP B,PROCER
CTLS.1: ITEXT (<Error writing BATCH control file ^F/(S1)/, ^E/S2/>)
SUBTTL CTL File I/O Utilities -- CTLEOL - Output EOL to CTL file
; ====== -----------------------
CTLEOL: $TEXTC(<>) ; <CR><LF>
$RETT
SUBTTL General File I/O Utilities -- CLRFOB - Clear File Open Block
; ====== ---------------------
CLRFOB: MOVX S1,FOB.SZ ;FOB SIZE
MOVEI S2,L.FOB ;FOB ADDRESS
$CALL .ZCHNK ;ZERO IT
MOVX S1,FAB.SZ ;FAB SIZE
MOVEI S2,L.FAB ;FAB ADDRESS
$CALL .ZCHNK ;ZERO IT
$RETT ;AND RETURN
SUBTTL General File I/O Utilities -- SETFAB - Set File Attributes
; ====== -------------------
;
; Builds a File Attribute Block with user's account string
; and protection code.
;
SETFAB: MOVX T1,FAB.SZ ; Get the lenght of the FAB block
SKIPN T2,L.PROT ; Get the protection file will have
SUBI T1,2 ; If zero, give him the default
MOVEM T1,L.FAB ; Set length of block
JUMPE T2,SETF.1 ; No need to set protection
MOVX T1,<FI.IMM+1B17+.FIPRO> ; Arg header for protection
MOVE T2,L.PROT ; Pick up protection (if any)
DMOVEM T1,L.FAB+3 ; Set protection argument in FAB
SETZM L.PROT ; Clear protection
SETF.1: MOVE T2,Q ; Pick up address of EQ page
ADDI T2,.EQACT ; Where account string is
MOVX T1,<10B17+.FIACT> ; Arg header for account string
DMOVEM T1,L.FAB+1 ; Set account argument in FAB
$RETT
SUBTTL General File I/O Utilities -- FILENT - Open a User File
; ====== ----------------
;
;FILENT is called with S1 containing the file-block bits. FRCENT
; is called with the same arguments as FILENT except we
; invoke our privileges to write the file into <SPOOL>.
FRCENT: TDZA T1,T1 ;LOAD ZERO FOR FLAG
FILENT: SETO T1, ;SET FLAG FOR STANDARD ENTRY
$CALL .SAVE2 ; Need a couple of P registers
MOVE P1,S1 ; Save argument flags
MOVE P2,T1 ; Save entry flag
PUSHJ P,CLRFOB ;CLEAR THE FOB
PUSHJ P,SETFAB ; Set the file attributes
SETZM DEKCRD ;CLEAR THE CARD COUNT
MOVEI S1,FILFD ;LOAD ADDRESS OF THE FD
MOVEM S1,L.FOB+FOB.FD ;STORE IN OPEN BLOCK
MOVEI S1,7 ;GET DEFAULT BYTE SIZE
MOVE S2,L.MODE ;GET THE MODE
CAIE S2,STBIN ;IS IT /BINARY
CAIN S2,STIMG ; OR /IMAGE?
MOVEI S1,^D36 ;YES, USE 36 BIT BYTES
STORE S1,L.FOB+FOB.CW,FB.BSZ ;STORE IT
MOVEI S1,L.FAB ; Address of the Attribute List
MOVEM S1,L.FOB+FOB.AB ;AND STORE IT
JUMPE P2,FILE.1 ; Branch if not access checking
TOPS10 <
MOVE S1,.EQOID(Q) ;GET THE PPN
MOVEM S1,L.FOB+FOB.US ;AND SAVE FOR ACCESS CHECK
> ;END TOPS10
TOPS20 <
HRROI S1,.EQOWN(Q) ;POINT TO USER NAME
MOVEM S1,L.FOB+FOB.US ;STORE IT
HRROI S1,L.UDIR ;POINT TO CONNECTED DIRECTORY
MOVEM S1,L.FOB+FOB.CD ;AND STORE IT
> ;END IFN FTJSYS
FILE.1: MOVEI S1,FOB.SZ ;GET ARGBLOCK LENGTH
MOVEI S2,L.FOB ;AND ARGBLOCK ADDRESS
$CALL F%OOPN ;OPEN THE FILE
JUMPF FILE.2 ;JUMP IF WE LOSE
MOVEM S1,FILIFN ;ELSE, STORE THE IFN
SETOM FILOPN ;AND SET "FILE OPEN"
MOVE S1,P1 ; Pick up argument flags
PJRST FBENT ;AND ENTER IN THE FILE BLOCKS
FILE.2: MOVE P1,S1 ;RELOCATE ERROR CODE
$TEXTL(<^I/FATAL/?SPTCCF ^I/FILE.3/>)
JSP B,PROCER
FILE.3: ITEXT(<Error creating file ^F/FILFD/, ^E/P1/>)
SUBTTL General File I/O Utilities -- MAKFUN - Create a filename
; ====== -----------------
;MAKFUN is called to create a default (Funny) filename for user
; files. MAKFUN is called with S1 containing a 2-character
; prefix for the filename (right-justified in SIXBIT). It
; returns with S1 containing:
; On TOPS10, the default filename in SIXBIT.
; On TOPS20, [POINT 7,FILENAME]
MAKFUN: PUSH P,S1 ;SAVE S1
PUSHJ P,FUNNY ;MAKE FOUR RANDOM CHARACTERS
POP P,S2 ;GET PREFIX BACK
LSH S2,^D24 ;MOVE IT OVER
TOPS10 <
IOR S1,S2 ;OR IN THE FUNNY PART
>;END OF TOPS10 CONDITIONAL ASSEMBLY
TOPS20 <
IOR S2,S1 ;OR IN THE FUNNY PART
MOVE S1,[POINT 7,MAKF.A] ;POINT TO THE BLOCK
MOVEM S1,L.BP ;STORE IT AWAY
$TEXT(DEPBP,<^W/S2/^0>)
MOVE S1,[POINT 7,MAKF.A] ;RETURN THE ANSWER
>;END OF TOPS20 CONDITIONAL ASSEMBLY
$RETT ;RETURN
MAKF.A: BLOCK 2 ;BLOCK TO BUILD THE NAME
;FUNNY is a routine to make up a 4-character Funny Name. Returns the
; four characters in SIXBIT, right justified in S1. The
; names consist of the letters A-Z and the digits 0-9.
;The algorithm used is to first AOS location L.FUN and use this
; as a pseudo-random number. Dividing this by 36^4 and
; using the remainder as a 4-digit number base 36. (See
; FILUUO in the TOPS10 Monitor.)
FUNNY: AOS S1,L.FUN ;GET NEXT FUNNY NUMBER
IDIV S1,[DEC 1679616] ;DIVIDE BY 36^4
MOVM S1,S2 ;AND LOAD THE REMAINDER
PUSHJ P,FUNLUP ;MAKE A NAME
JFCL ;IGNORE THE SKIP
TLZ S1,777700 ;MAKE SURE ITS ONLY 4 CHARS
$RETT ;AND RETURN
FUNLUP: IDIVI S1,^D36 ;DIVIDE BY 36
HRLM S2,(P) ;STORE DIGIT ON STACK
SKIPE S1 ;FINISHED?
PUSHJ P,FUNLUP ;NO, RECURSE
MOVEI S1,'000' ;PRE-LOAD S1
HLRZ S2,(P) ;LOAD A DIGIT
ADDI S2,20 ;MAKE IT 6BIT
CAILE S2,31 ;NUMERIC?
ADDI S2,7 ;NO, ALPHABETIC, ADD OFFSET
LSH S1,6 ;SHIFT OVER ACCUMULATED NAME
IOR S1,S2 ;OR IN NEXT CHARACTER
AOS 0(P) ;INCREMENT THE PC
POPJ P, ;AND SKIP BACK
SUBTTL File Block Utilities -- FBENT - Make a File Block entry
; ====== -----------------------
;
; Routine to enter a file in the linked list of File Blocks.
; FBENT will set the load order for the file if necessary.
;
; Call:
;
; S1 contains File Block Flags
; PUSHJ P,FBENT
; Always returns TRUE
;
FBENT: JUMPE S1,.RETT ; If bits are zero, just return
$CALL .SAVE2 ; Save P1 and P2
MOVE P1,S1 ; Flags to P1
MOVE S1,L.FBLN ;GET THE LIST NAME
$CALL L%LAST ;POSITION TO THE END
MOVEI P2,FILFD ;LOAD ADDRESS OF THE FD
PUSHJ P,FBEN.2 ;DO THAT ONE
TXNN P1,FB.LDR ;LOAD THE REL FILE?
$RETT ;NO, RETURN
SETOM L.FBCT ;FLAG SOMETHING TO LOAD
TXO P1,FB.LOD ;AND SET THE LOAD FLAG
; These .REL files will be created in the default directory
; when the batch job runs.
TOPS10 <
MOVSI T1,'DSK' ; Use default search list
STORE T1,FILRFD+.FDSTR ; Store it
MOVE T1,FILFD+.FDNAM ; Use same file name
STORE T1,FILRFD+.FDNAM ; Store it
MOVSI T1,'REL' ; Load an extension
STORE T1,FILRFD+.FDEXT ; Store it
MOVE T1,.EQOID(Q) ; PPN of default directory
STORE T1,FILRFD+.FDPPN ; Store it
MOVE T1,.EQPAT+1(Q) ; In case /UNIQUE specified
STORE T1,FILRFD+.FDPAT ; Store it
MOVEI T2,FDMSIZ ; Start with minimum size FD
SKIPE T1 ; If SFD name has been specified
ADDI T2,1 ; FD length must include it
STORE T2,FILRFD+.FDLEN,FD.LEN ; Store correct length
MOVEI P2,FILRFD ; Load address of FD
PJRST FBEN.2 ; Copy it and return
> ;END TOPS10
TOPS20 <
MOVEI P2,FILRFD ;LOAD THE REL FD
PUSHJ P,FBEN.2 ;SETUP THE FD
$RETT ;AND RETURN
>;END IFN FTJSYS
FBEN.2: MOVE S1,L.FBLN ;GET THE LIST NAME
LOAD S2,.FDLEN(P2),FD.LEN ;GET THE LENGTH
ADDI S2,.FBFD ;ADD IN THE OVERHEAD
$CALL L%CENT ;CREATE AN ENTRY
SKIPT
$STOP (CCE,<Cannot create an entry>)
MOVE S1,S2 ;GET THE ADDRESS IN S1
ADDI S2,.FBFD ; S2 points to dest for FD
HRL S2,P2 ;MAKE A BLT POINTER
LOAD T2,.FDLEN(P2),FD.LEN ;GET THE LENGTH
ADD T2,S1 ;ADD IN THE DESTINATION
BLT S2,.FBFD-1(T2) ;AND BLT THE ENTRY
MOVEI S2,1 ;LOAD A FLAG
TXNE P1,FB.DEL ;IS DELETE ON?
STORE S2,.FBFLG(S1),FB.DEL ;YES, SET DELETE
TXNE P1,FB.LOD ;IS LOAD ON?
STORE S2,.FBFLG(S1),FB.LOD ;YES, SET IT
TXNE P1,FB.SRH ;IS SEARCH ON?
STORE S2,.FBFLG(S1),FB.SRH ;YUP!
$RETT ;RETURN OK
SUBTTL File Block Utilities -- FBCLOD - Clear File Block LOaD bits
; ====== --------------------------
;
; FBCLOD is called on each $LANGUAGE, $INCLUDE, and $RELOC
; card. If the current remembered files have been loaded
; (L.LOAD) then all files are scanned and their "LOAD" bits
; are cleared.
;
FBCLOD: SKIPN L.LOAD ;IS LOAD SET?
$RETT ;NO, JUST RETURN
SETZM L.LOAD ;CLEAR THE LOAD WORD
SETZM L.FBCT ;CLEAR THE COUNTER
MOVE S1,L.FBLN ;GET THE LIST NAME
$CALL L%FIRST ;POSITION TO BEGINNING
JUMPF .RETT ;Quit if done
FBCL.1: ZERO .FBFLG(S2),FB.LOD ;CLEAR THE LOAD FLAG
$CALL L%NEXT ;GET THE NEXT
JUMPT FBCL.1 ;LOOP IF MORE
$RETT ;ELSE, RETURN
SUBTTL String scanning routines -- CHEKCC - Check for a control card
; ====== ------------------------
;
; This routine checks to see if the current card is a control
; card, $!comment, $;comment, $<alpha>, or $$.
;
; Call:
;
; PUSHJ P,CHEKCC
; L.DHOL points to the ASCIZ string of the current card
;
; Returns TRUE on valid control cards
; S1 contains flags
; S2 contains dispatch address
; parsed command stored as ASCIZ string beginning at L.TNAM
;
; Returns FALSE if not a valid control card
; S1 contains flags
;
; Flags are:
;
; CD.BTC==1B0 ;This cards turns the batch bit on
; CD.CLO==1B1 ;Clear load order on this card
; CD.SBC==1B3 ;This is a special batch card
; CD.PAS==1B4 ;This command is $PASSWORD
; CD.EOD==1B7 ;This command is a deck terminator
; CD.EOJ==1B8 ;This command is a job terminator
; CD.BOJ==1B9 ;This command indicates beginning of job
; CD.COM==1B10 ;This command is a $comment
; CD.DDS==1B11 ;This command begins with double $
; CD.DOL==1B12 ;This command begins with $
;
;
; Card scanning routines -- CHEKCC - Check for a control card
;
CHEKCC:
$CALL .SAVE1 ; Need P1 for flags
SETZ P1, ; Zero flags
PUSHJ P,S$INIT ; Reinitialize for scanning
PUSHJ P,S$INCH ; Get the first character
CAIE C,"$" ; Is it a dollar sign?
JRST CHEK.3 ; No, not a command
TXO P1,CD.DOL ; Yes, set flag
PUSHJ P,S$INCH ; Get the second character
CAIL C,"A" ; Is it alpha?
CAILE C,"Z" ; Only have to deal with UC
JRST CHEK.1 ; No, not a command
TXNN F,F.DOLR ; Is /DOLLARS on?
TXO P1,CD.EOD ; No, this is deck terminator
TXO F,F.RSCN ; Set to rescan last char
MOVEI S1,L.TNAM ; Point to string block
PUSHJ P,S$ASCZ ; Read the keyword
JUMPE S1,CHEK.1 ; No chars for keyword
MOVEI S1,TBCARD ; Point to table of commands
HRROI S2,L.TNAM ; Point to string
$CALL S%TBLK ; Look it up
TXNE S2,TL%NOM!TL%AMB ; Match?
JRST CHEK.3 ; No, not a command.
SUBI S1,TBCARD+1 ; Get offset to matching entry
HRRZ S2,CADRS(S1) ; Get dispatch address
HLLZ S1,CADRS(S1) ; Get flag bits from table entry
IORM P1,S1 ; Pick up flags
$RETT ; Return success
CHEK.1: ; $<non-alpha>
CAIE C,"!" ; Is it a comment?
CAIN C,";" ; Check for 2 types of comments
TXO P1,CD.COM ; Flag as a comment
CAIN C,"$" ; Is it a $ sign
TXO P1,CD.DDS ; Yes, set flag
CHEK.3: ; Not a valid command
MOVE S1,P1 ; Pick up current flags
$RETF ; and return failure
SUBTTL String scanning routines -- S$OCT / S$DEC - Number scanners
; ============= ---------------
;
; Scans string for octal or decimal number.
;
; Call:
;
; PUSHJ P,S$OCT (S$DEC)
; B contains byte pointer pointing to first digit of number
; or span of blanks preceding number
;
; Returns TRUE
; B points to the terminating character
; C contains the terminating character
; S1 contains the number
;
; Returns FALSE if not a number
;
S$OCT: SKIPA T1,[EXP 8] ;LOAD AN 8
S$DEC: MOVEI T1,12 ;LOAD A 10
S$NUM: $CALL .SAVE2 ; Need two registers
SETZ P1,0 ;CLEAR THE ACCUMULATOR
MOVE P2,T1 ; Get radix
PUSHJ P,S$FSPC ; Flush leading spaces
JUMPF .RETF ; EOL
CAIL C,"0" ;CHECK RANGE
CAILE C,"0"-1(P2)
$RETF ;FAIL RETURN
JRST S$NU.2 ;OK, SKIP INTO LOOP
S$NU.1: PUSHJ P,S$INCH ;GET A CHARACTER
JUMPF S$NU.3 ; EOL, Return OK
CAIL C,"0" ;CHECK THE RANGE
CAILE C,"0"-1(P2)
JRST S$NU.3 ;NOT A NUMBER, JUST RETURN OK
S$NU.2: IMULI P1,(P2) ;SHIFT RADIX POINT OVER ONE
ADDI P1,-"0"(C) ;ADD IN THE NEXT DIGIT
JRST S$NU.1 ; LOOP AROUND FOR THE NEXT DIGIT
S$NU.3: MOVE S1,P1 ; Pick up value
$RETT
SUBTTL String scanning routines -- S$ASCZ - Scan an ASCIZ string
; ====== ----------------------
COMMENT \
Routine continues scanning and loading characters into the
specified block pointed to by S1 until either a terminating
character is found or more than 38 characters have been scanned.
A terminating character is any character other than one of the
following: 1) Alphabetic (upper or lower case)
2) Numeric (0-9)
3) Hyphen/Minus sign (Code=45 decimal) (TOPS-20 only)
4) Dot/Period (Code 46 Decimal) (TOPS-20 only)
Call:
B contains byte pointer to string to be scanned
(Usually points to character preceding string
If rescan flag set, can be pointing to first character)
S1 contains destination address for characters scanned
PUSHJ P,S$ASCZ
Always returns TRUE
B points to the terminating character
C contains the terminating character
S1 contains count of characters scanned
ASCIZ string loaded in block
\
S$ASCZ: $CALL .SAVE2 ; Need two scratch registers
HRR P1,S1 ; Relocate calling argument
HRLI P1,(POINT 7) ; Make a byte pointer
SETZB P2,(P1) ; And clear a counter
S$AS.1: CAIL P2,^D38 ; Got enough characters?
JRST S$AS.3 ; Yes, finish up.
PUSHJ P,S$INCH ; No, get a character
JUMPF S$AS.3 ; EOL or something like that
CAIL C,"A" ; Alphabetic?
CAILE C,"Z"
SKIPA ; No
JRST S$AS.2 ; Yes
CAIL C,"0" ; Numeric?
CAILE C,"9"
TOPS20< ; So S$FILE works on -10
SKIPA ; No
JRST S$AS.2 ; Yes
CAIE C,"-" ; Hyphen ???
CAIN C,"." ; Dot/period ???
SKIPA ; Yes, continue
> ; End of TOPS20
JRST S$AS.3 ; A break character, finish up
S$AS.2: IDPB C,P1 ; Deposit the char
AOJA P2,S$AS.1 ; Get next character
S$AS.3: SETZ T1,0 ; Load null
IDPB T1,P1 ; Deposit it
MOVE S1,P2 ; Count of characters scanned
$RETT ; And return
SUBTTL String scanning routines -- S$SIXB - ASCIZ to SIXBIT
;
COMMENT \
This routine will convert an ascii string to sixbit and allow special
characters to be returned. This is required because GLXLIB's S%SIXB
stops scanning on the first special character encountered. Illegal
or unconvertable characters are converted to blanks. Conversion
stops with the first null encountered within the source string.
Call: S1/ Pointer to Ascii(z) string
Ret: S1/ Updated byte pointer (points to last char processed)
S2/ SIXBIT string (0 to 6 characters)
Returns false if a null is encountered in the conversion
\
S$SIXB: PUSHJ P,.SAVET ;Save 'T' acs
TLCE S1,-1 ;Left half of ptr = 0?
TLCN S1,-1 ;... or -1 ?
HRLI S1,(POINT 7,) ;Yes, Make up pointer for caller
HRRI S1,@S1 ;Compute effective addr
TLZ S1,(@(17)) ;Remove indirection and index
SETZM S2 ;Reset the return string
MOVEI T1,6 ;Setup character counter
MOVE T2,[POINT 6,S2] ;Setup output byte pointer
SIXB.1: ILDB T3,S1 ;Get a source byte
JUMPE T3,.RETF ;Done,,return
CAIL T3,"A"+40 ;Is it a
CAILE T3,"Z"+40 ; Lower case character ???
SKIPA ;No,,continue
SUBI T3,40 ;Yes,,convert to upper case
CAIL T3," " ;Is it a
CAILE T3,"]" ; Convertable character ???
MOVEI T3," " ;No,,make it a blank
SUBI T3,40 ;Convert it to sixbit
IDPB T3,T2 ;Stash it away
SOJG T1,SIXB.1 ;Get another character
$RETT ;Done,,return
SUBTTL String scanning routines -- S$DTIM - Scan a date/time string
; ====== -----------------------
COMMENT \
Routine continues scanning and loading characters into the
specified block pointed to by S1 until either a terminating
character is found or more than 38 characters have been scanned.
A terminating character is any character not legal in a date/time
string. That is, a character other than one of the following:
1) Alphabetic (upper or lower case)
2) Numeric (0-9)
3) Hyphen/Minus sign (Code=45 decimal)
4) Colon
Call:
B contains byte pointer to string to be scanned
(Usually points to character preceding string
If rescan flag set, can be pointing to first character)
S1 contains destination address for characters scanned
PUSHJ P,S$DTIM
Always returns TRUE
B points to the terminating character
C contains the terminating character
S1 contains count of characters scanned
ASCIZ string loaded in block
\
S$DTIM: $CALL .SAVE2 ; Need two scratch registers
HRR P1,S1 ; Relocate calling argument
HRLI P1,(POINT 7) ; Make a byte pointer
SETZB P2,(P1) ; And clear a counter
S$DT.1: CAIL P2,^D38 ; Got enough characters?
JRST S$DT.3 ; Yes, finish up.
PUSHJ P,S$INCH ; No, get a character
JUMPF S$DT.3 ; EOL or something like that
CAIL C,"A" ; Alphabetic?
CAILE C,"Z"
SKIPA ; No
JRST S$DT.2 ; Yes
CAIL C,"0" ; Numeric?
CAILE C,"9"
SKIPA ; No
JRST S$DT.2 ; Yes
CAIE C,"-" ; Hyphen ???
CAIN C,"+" ; Plus sign ???
JRST S$DT.2 ; Yes
CAIE C,":" ; Colon ???
JRST S$DT.3 ; A break character, finish up
S$DT.2: IDPB C,P1 ; Deposit the char
AOJA P2,S$DT.1 ; Get next character
S$DT.3: SETZ T1,0 ; Load null
IDPB T1,P1 ; Deposit it
MOVE S1,P2 ; Count of characters scanned
$RETT ; And return
SUBTTL String scanning routines -- S$QUOT - Scan a quoted string
; ====== --------------------
;
; Here to scan a quoted string and return an ASCIZ string.
; If the string begins with a ", then only a matching " or
; EOL will be recognized as a valid terminator. If the
; string does not begin with a ", then EOL or a slash (/)
; will be recognized as a valid terminator. The ASCIZ string
; returned will not be mapped. That is, lower case
; characters will not be folded into upper case and certain
; special chars will not be mapped into blanks. (See GETCHR)
;
; Call:
;
; PUSHJ P,S$QUOT
; B contains byte pointer pointing to first char of string
; or span of blanks preceding string
; S1 contains destination address for characters scanned
;
; Always returns TRUE
; B points to the terminating character
; C contains the terminating character
; S1 contains count of characters scanned
; ASCIZ string loaded in block
;
S$QUOT: $CALL .SAVE3 ; Need three scratch registers
HRR P1,S1 ; Relocate calling argument
HRLI P1,(POINT 7) ; Make a byte pointer
SETZB P2,(P1) ; And clear a counter
PUSHJ P,S$FSPC ; Flush leading spaces
JUMPF S$QU.5 ; EOL, No value specified
TXO F,F.RSCN ; Set to rescan character
PUSHJ P,S$INCH ; Get the unmapped character
SETZ P3, ; Clear quote flag
CAIE S1,"""" ; Is first char a quote?
JRST S$QU.2 ; No,
SETO P3, ; Yes, set a flag
S$QU.1: CAIL P2,^D38 ; Got enough characters?
JRST S$QU.5 ; Yes, finish up.
PUSHJ P,S$INCH ; No, get a character
JUMPF S$QU.5 ; EOL or something like that
JUMPE P3,S$QU.2 ; Branch if not looking for "
CAIN S1,"""" ; Is it a quote?
JRST S$QU.4 ; Yes, all done
JRST S$QU.3 ; No, go deposit char
S$QU.2: CAIN C,"/" ; A slash?
JRST S$QU.5 ; Yes, finish up
S$QU.3: IDPB S1,P1 ; Deposit the char
AOJA P2,S$QU.1 ; Get next character
S$QU.4: PUSHJ P,S$INCH ; Eat the terminating "
S$QU.5: SETZ T1,0 ; Load null
IDPB T1,P1 ; Deposit it
MOVE S1,P2 ; Count of characters scanned
$RETT ; And return
SUBTTL String scanning routines -- S$PPN - Scan a PPN string
; ===== -----------------
;
; Scans a string for PPN [proj,prog]
;
; Call:
;
; PUSHJ P,S$PPN
; B contains byte pointer pointing to first char of PPN (e.g. [)
; or span of blanks preceding PPN
;
; Returns TRUE
; B points to the terminating character
; (character following closing "]")
; C contains the terminating character
; S1 contains the PPN
;
; Returns FALSE if not a valid PPN
;
S$PPN:
TOPS10<
$CALL .SAVE1 ; Get a register to store PPN
PUSHJ P,S$FSPC ; Flush leading spaces
JUMPF .RETF ; EOL, No PPN specified
PUSHJ P,OPNBKT ; See if we have the makings of a PPN
SKIPT ; Yes,
$RETF ;No
PUSHJ P,S$INCH ; Bump pointer over bracket
PUSHJ P,S$OCT ;GET PROJECT NUMBER
JUMPF .RETF ;???
HRLZM S1,P1 ;SAVE PROJECT NUMBER
CAIE C,"," ;BREAK ON COMMA?
$RETF ;NO, BAD FORMAT
PUSHJ P,S$INCH ; Bump pointer over comma
PUSHJ P,S$OCT ;GET PROGRAMMER NUMBER
JUMPT S$PP.1 ;GOT A NUMBER!
CAIE C,"#" ;IS IT A WILDCARD?
$RETF ;NO, BAD FORMAT
PUSHJ P,S$INCH ;SKIP TO NEXT CHARACTER
MSTIME S1, ;GET RANDOM NUMBER (RANDOM?)
TXO S1,1B18 ;MAKE IT GT 400000
TXZ S1,1B19!1B20 ;FOLLOW CONVENTION
S$PP.1: HRRM S1,P1 ;SAVE PROGRAMMER NUMBER
PUSHJ P,S$FSPC ; Flush spaces
JUMPF .RETF ;BAD FORMAT FOR PPN
PUSHJ P,CLSBKT ; Have a closing delimiter
SKIPT ; Yes,
$RETF ;NO!!!!
PUSHJ P,S$INCH ; Position to next character
MOVE S1,P1 ; Pick up valid PPN
> ;END OF TOPS-10 CONDITIONAL
$RETT ; Return success
SUBTTL String scanning routines -- S$TIM -- Scan a time specification
; ===== -------------------------
;
; S$TIM scans a string of the form hh:mm:ss and returns L.HRS,
; L.MIN, L.SEC updated. No range checking is done so 120 may
; be used instead of 2:0.
;
; Call:
;
; PUSHJ P,S$TIM
; RETURN HERE
;
S$TIM: $CALL .SAVE2 ; Need 2 P regs
SETZM L.HRS ;SETZM ANSWERS
SETZM L.MIN ;BEFORE WE ASK THE QUESTIONS
SETZM L.SEC
MOVEI P1,L.SEC ;ADDRESS FOR LAST ARGUMENT
MOVNI P2,3 ; - NUMBER OF LEGAL ARGS
PJRST S$TML ;GO SCAN SOME
S$TML: PUSHJ P,S$FCOL ; Eat up colon
JUMPF .RETF ; Pass on failure
PUSHJ P,S$DEC ;GET A DECIMAL NUMBER
SKIPT ;SKIP ON VALID NUMBER READ
SETZ S1,0 ;MAKE IT ZERO
HRLM S1,(P) ;SAVE IT ON THE STACK
AOJG P2,.RETF ; Fail if too many args
CAIE C,":" ;BREAK ON COLON?
JRST S$TM1 ; No, finish up
PUSHJ P,S$TML ;YES, RECURSE
JUMPF .RETF ; Pass on failure
S$TM1: HLRZ T1,(P) ;GET AN ARGUMENT
MOVEM T1,(P1) ;SAVE IT
SOS P1 ;POINTER FOR NEXT ARG
$RETT ; And unwind
SUBTTL String scanning routines -- S$FILE - Scan off a filespec
; ====== -------------------
; Call with S1 containing the default file name (in SIXBIT on
; the -10, ASCII byte pointer on the -20)
; Call with S2 containing the default extension (same format
; as name)
; Returns TRUE
; FILSPC non zero if valid file spec found
; FILSPC zero no file spec found
;
; Returns FALSE if invalid file spec found
;
; Filespec flags kept in P1
;
SC.DIR==1B0 ;DIRECTORY WAS FOUND
SC.DEV==1B1 ;DEVICE WAS FOUND
SC.NAM==1B2 ;NAME WAS FOUND
SC.EXT==1B3 ;EXTENSION WAS FOUND
TOPS10 <
S$FILE: $CALL .SAVE2 ; Need 2 P registers
SETZB P1,FILSPC ;CLEAR SPEC FLAGS AND WORD
SETZM FILFD ;CLEAR THE FIRST WORD OF FD
MOVE T1,[FILFD,,FILFD+1]
BLT T1,FILFD+FDXSIZ-1 ;CLEAR OUT THE FD
MOVSI T1,'DSK' ;GET DEFAULT DEVICE
STORE T1,FILFD+.FDSTR ;STORE IT
LOAD T1,.EQOID(Q) ;GET USERS PPN
STORE T1,FILFD+.FDPPN ;AND STORE IT
STORE S1,FILFD+.FDNAM ;STORE THE DEFAULT NAME
STORE S2,FILFD+.FDEXT ;STORE THE DEFAULT EXTENSION
MOVEI S1,FDMSIZ ;ASSUME NO SFDS
STORE S1,FILFD+.FDLEN,FD.LEN;STORE THE INITIAL LENGTH
S$FIL1: PUSHJ P,S$FSPC ;SCAN OFF SPACES
TXO F,F.RSCN ;SET APPROPRIATE FLAG
MOVEI S1,AR.NAM ;POINT TO ARGUMENT BLOCK
PUSHJ P,S$ASCZ ;GO GET IT
JUMPE S1,S$FIL4 ; Not a text string, return
HRROI S1,AR.NAM ;POINT TO THE BLOCK AGAIN
$CALL S%SIXB ;SIXBITIZE
MOVE S1,S2 ;RELOCATE
;NOT ALPHANUMERIC
S$FIL2: CAIN C,":" ;DEVICE SPECIFIED?
JRST S$DEV ;YUP, GO DO IT
JUMPE S1,S$FIL3 ;NULL CANT BE FILENAME
TXOE P1,SC.NAM ;SET NAME FLAG
JRST S$FIL5 ;TWO NAMES ARE ILLEGAL
MOVEM S1,FILFD+.FDNAM ;STORE THE FILENAME
S$FIL3: PUSHJ P,S$FSPC ;SCAN OFF SPACES
CAIN C,"." ;EXTENSION COMING?
JRST S$EXT ;YES, DO IT!
PUSHJ P,OPNBKT ; See if opening directory
JUMPT S$DIR ; Yes, go parse it
CAIN C," " ;A BLANK?
JRST S$FIL1 ;YES, TRY SOME MORE
S$FIL4: TXNE P1,SC.NAM ;DID WE FIND A NAME?
SETOM FILSPC ;YES, SET THE FLAG
$RETT ;AND RETURN TRUE
S$DEV: JUMPE S1,S$FIL5 ;NULL DEVICE?
TXOE P1,SC.DEV ;SET DEV FLAG
JRST S$FIL5 ; Error if duplicate device
MOVEM S1,FILFD+.FDSTR ;STORE DEVICE NAME
PUSHJ P,S$INCH ; Bump pointer over colon
JRST S$FIL1 ;AND LOOP FOR MORE STUFF
S$EXT: TXOE P1,SC.EXT ;SET EXT FLAG
JRST S$FIL5 ; Error if duplicate extension
PUSHJ P,S$INCH ; Bump pointer over dot
PUSHJ P,S$FSPC ;SCAN OFF SPACES
TXO F,F.RSCN ;SET APPROPRIATE FLAG
MOVEI S1,AR.NAM ;POINT TO ARGUMENT BLOCK
PUSHJ P,S$ASCZ ;GO GET IT
HRROI S1,AR.NAM ;POINT TO THE BLOCK AGAIN
$CALL S%SIXB ;SIXBITIZE
HLLZM S2,FILFD+.FDEXT ;STORE THE EXTENSION
JRST S$FIL3 ;AND LOOP FOR MORE
S$DIR: TXOE P1,SC.DIR ;DO WE HAVE A DIRECTORY ALREADY?
JRST S$FIL5 ;YES, LOSE
PUSHJ P,S$INCH ; Bump pointer over bracket
PUSHJ P,S$OCT ;GET AN OCTAL NUMBER
JUMPT S$DIR1 ;WE'VE GOT PROJ, GET PROG
CAIN C,"," ;SEE IF NULL PROJ NUMBER
JRST S$DIR2 ;IT IS, GET PROG NUMBER
CAIE C,"-" ;SEE IF DEFAULT DIRECTORY
JRST S$FIL5 ;IT ISN'T, ITS GARBAGE
PUSHJ P,S$INCH ;Bump pointer over dash
JUMPF S$FIL1 ; Only [- specified. OK
PUSHJ P,S$FSPC ; Eat any blanks
PUSHJ P,CLSBKT ; See if we have close brackets
JUMPT S$FIL1 ; Yes, Finish up.
JRST S$FIL5 ; Must be an error
S$DIR1:
HRLM S1,FILFD+.FDPPN ;SAVE PROJECT NUMBER
PUSHJ P,S$FSPC ; Eat any blanks
S$DIR2:
CAIE C,"," ; It should be a comma
JRST S$FIL5 ; It isn't
PUSHJ P,S$INCH ; Eat the comma
JUMPF S$FIL1 ; Only [nn, specified. OK
PUSHJ P,S$OCT ;GET PROG
SKIPF ; If valid,
HRRM S1,FILFD+.FDPPN ; save programmer number
PUSHJ P,S$FSPC ; Eat any blanks
PUSHJ P,CLSBKT ; See if we have close brackets
JUMPT S$DIR5 ; Yes, Finish up.
CAIE C,"," ;MORE TO COME?
JRST S$FIL5 ;NO, MORE GARBAGE
MOVEI P2,FILFD+.FDPAT ;POINT TO FIRST SFD
S$DIR3:
PUSHJ P,S$INCH ; Bump pointer over comma
PUSHJ P,S$FSPC ;SCAN OFF SPACES
TXO F,F.RSCN ;SET APPROPRIATE FLAG
MOVEI S1,AR.NAM ;POINT TO ARGUMENT BLOCK
PUSHJ P,S$ASCZ ;GO GET IT
JUMPE S1,S$FIL5 ; Null SFD name is illegal
HRROI S1,AR.NAM ;POINT TO THE BLOCK AGAIN
$CALL S%SIXB ;SIXBITIZE
MOVEM S2,(P2) ;STORE SFD IN PATH BLOCK
INCR FILFD+.FDLEN,FD.LEN ;INCREMENT THE COUNT FIELD
PUSHJ P,S$FSPC ;SCAN OFF SPACES
PUSHJ P,CLSBKT ; See if we have close brackets
JUMPT S$DIR5 ; Finish up
CAIE C,"," ;TERMINATED BY ","
JRST S$FIL5 ;NO, LOSE
LOAD T1,FILFD+.FDLEN,FD.LEN ;GET THE LENGTH
CAIGE T1,FDXSIZ ;GREATER THAN MAX?
AOJA P2,S$DIR3 ;NO, WIN
JRST S$FIL5 ;YES, NESTING TO DEEP
S$DIR5: PUSHJ P,S$INCH ; Position beyond terminator
JRST S$FIL1 ; Return
S$FIL5: $TEXTL(<^I/FATAL/?SPTFSE ^I/S$ERR5/>)
JSP B,CTLCER ;ABORT
S$ERR5: ITEXT (<File specification error on $^T/L.TNAM/ card>)
; Convenient routine to check if directory delimiter is being seen.
OPNBKT: CAIE C,"[" ; Check for all types of brackets
CAIN C,74 ;ACCEPT EITHER DELIMETER
$RETT ; Affirmative
CAIN C,"(" ; Get this other delimiter?
$RETT ; Affirmative
$RETF
; This, of course, does the opposite.
CLSBKT: CAIE C,"]" ; Check for all types of brackets
CAIN C,76 ;ACCEPT EITHER DELIMETER
$RETT ; Affirmative
CAIN C,")" ; Get this other delimiter?
$RETT ; Affirmative
$RETF
>;END TOPS10
TOPS20 <
S$FILE: $CALL .SAVE2 ; Need 2 P registers
SETZM FILSPC ;CLEAR SPEC FOUND FILE
DMOVE P1,S1 ;SAVE THE ARGUMENTS
MOVEI S1,.GJCPC+1 ;BLOC SIZE
MOVEI S2,SFIL.A ;BLOCK ADDRESS
$CALL .ZCHNK ;ZERO OUT THE GTJFN BLOCK
MOVEM P1,SFIL.A+.GJNAM ;SAVE DEFAULT NAME
MOVEM P2,SFIL.A+.GJEXT ;SAVE DEFAULT EXTENSION
MOVX S1,GJ%OFG!GJ%XTN ;"JUST PARSE" FLAG
MOVEM S1,SFIL.A+.GJGEN ;SAVE IT
MOVX S1,<XWD .NULIO,.NULIO> ;GET NUL IO DEVICE
MOVEM S1,SFIL.A+.GJSRC ;FOR ADDITIONAL SOURCE
HRROI S1,[ASCIZ /PS/] ;GET DEFAULT DEVICE
MOVEM S1,SFIL.A+.GJDEV ;STORE IT
HRROI S1,.EQOWN(Q) ;POINT TO DIRECTORY
MOVEM S1,SFIL.A+.GJDIR ;STORE
MOVX S1,2 ;LONG FILENAMES AND 2 WRDS FOLLOWING
MOVEM S1,SFIL.A+.GJF2 ;AND STORE IT
HRROI S1,FILRFD ;BYTE POINTER FOR USER TYPED
MOVEM S1,SFIL.A+.GJCPP ;AND STORE IT
MOVEI S1,<FDXSIZ*5> ;AND A BYTE COUNT
MOVEM S1,SFIL.A+.GJCPC ;AND STORE IT
SETZM FILRFD ;CLEAR THE WORD
PUSHJ P,S$FSPC ;SKIP OVER BLANKS
MOVEI S1,SFIL.A ;LOAD ADDRESS OF BLOCK
SETO S2,0 ;INDICATE TASK
ADJBP S2,B ;READJUST BP
GTJFN ;GET THE FILE SPEC
JRST S$FIL2 ;LOSE??
SETO B,0 ;SETUP TO DECREMENT
ADJBP B,S2 ;THE RETURNED BP
MOVE S2,S1 ;PUT JFN IN S2
MOVX S1,177B6 ;PREPARE TO CLEAR TERMINATING CHARACTER
ANDCAM S1,FILRFD ;CLEAR IT OUT
SKIPE S1,FILRFD ;TEST FOR NULL
CAMN S1,[BYTE (7) 0,.CHLFD] ;AND ALSO CRLF
SKIPA
SETOM FILSPC ;HE TYPED A FILENAME
SETZM FILRFD ;CLEAR THE FIRST WORD
HRROI S1,FILFD+.FDSTG ;POINT TO STRING BLOCK
MOVX T1,<XWD 221100,JS%PAF> ;GET THE FIELDS WE WANT
JFNS ;GET THE FILESPEC BACK
TLZ S1,-1 ;ZAP LEFT HALF OF BP
SUBI S1,FILFD+.FDSTG-3 ;GET LENGTH (WITH SOME SLOP)
STORE S1,FILFD+.FDLEN,FD.LEN ;STORE IN PRIME FD
STORE S1,FILRFD+.FDLEN,FD.LEN ;AND REL FILE FD
MOVE S1,S2 ;GET THE JFN BACK
RLJFN ;RELEASE IT
JFCL ;IGNORE THE ERROR RETURN
MOVE S1,[XWD FILFD,FILRFD] ;PREPARE TO TAKE
BLT S1,FILRFD+FDXSIZ-1 ;COPY OF FD
MOVE S1,[POINT 7,FILRFD+.FDSTG];AND START SEARCH
S$FIL4: ILDB T1,S1 ;FOR THE DOT or widget
CAIE T1,"<" ; Is it a widget?
CAIN T1,"[" ; or the -10 die-hard version
TRNA ; . . .
JRST S$FIL3 ; No, try the dot then
S$FIL5: ILDB T1,S1 ; Look for a closing widget now
JUMPE T1,S$FIL2 ; In case of problems
CAIE T1,">" ; Found?
CAIN T1,"]" ; . . .
JRST S$FIL4 ; Yes, now look for dots
JRST S$FIL5 ; No, try to find it then
S$FIL3: CAIE T1,"." ;FOUND?
JRST S$FIL4 ;NO, KEEP GOING
MOVEM S1,L.BP ;SAVE POINTER FOR $TEXT
$TEXT (DEPBP,<REL^0>) ;AND REPLACE THE EXTENSION
$RETT ;AND RETURN
S$FIL1: RLJFN ;RELEASE THE FILE
JFCL ;IGNORE ANY ERROR
S$FIL2: $TEXTL(<^I/FATAL/?SPTFSE ^I/S$ERR2/>)
JSP B,CTLCER ;ABORT
S$ERR2: ITEXT (<File specification error on $^T/L.TNAM/ card>)
SFIL.A: BLOCK .GJCPC+1 ;DEFAULT JFN BLOCK
>;END IFN FTJSYS
SUBTTL String scanning routines -- S$FSPC - Flush leading spaces
; ====== --------------------
;
; This routine skips over a span of blanks.
;
; Call:
;
; PUSHJ P,S$FSPC
; B contains byte pointer to string
;
; Returns TRUE
; B points the non-blank character
; C contains non-blank character
; Rescan flag will be cleared
;
; Returns FALSE if remainder of line is blank
;
S$FSPC: TXO F,F.RSCN ; Set rescan flag
S$FS.1: PUSHJ P,S$INCH ;GET A CHARACTER
JUMPF .RETF ;FAIL, EOL
CAIN C," " ;A SPACE?
JRST S$FS.1 ;YES, LOOP
$RETT ;NO, RETURN SUCCESS
SUBTTL String scanning routines -- S$FCOL - Flush over colon
; ====== ----------------
;
; Here to skip over a span of blanks followed by colon.
;
; Call:
;
; B contains byte pointer to string
;
; PUSHJ P,S$FCOL
;
; Returns TRUE
; B points to character following colon
; C contains character
;
; Returns FALSE if break char is not a colon
; B points to break character
; C contains break character
;
S$FCOL: PUSHJ P,S$FSPC ; Flush out any blanks
JUMPF .RETF ; Fail, EOL
CAIE C,":" ; A colon?
$RETF ; No, return failure
PUSHJ P,S$INCH ; Yes, Eat the colon
$RETT ; Always return true
SUBTTL String scanning routines -- S$INIT - Init Scanner
; ====== ------------
;
S$INIT: MOVE B,L.DHOL ; Initialize pointer to string
TXZ F,F.RSCN ; Clear rescan flag
SETZM L.BRK ; Clear EOL
$RETT ; Return true
SUBTTL String scanning routines -- S$INCH - Get a character
; ====== ---------------
;
; This routine obtains the next character in the string being
; scanned. It processes continuation characters and
; reads the next line if necessary.
;
; Call:
;
; PUSHJ P,S$INCH
; B contains pointer to current position in string
;
; Returns TRUE
; B points to character returned
; C contains character
; S1 contains original, unmapped character
;
; Returns FALSE on EOL
;
S$INCH: MOVE S1,C ; Set up S1 if just rescanning
SKIPE L.BRK ; If at EOL
$RETF ; just return
TXZE F,F.RSCN ; Clear rescan flag
$RETT ; Return now if this is a rescan
PUSHJ P,GETCHR ; Get next character and map it
JUMPF .RETF ; Fail on EOL
CAIE C,"-" ; Continuation character?
$RETT ; No, return with a character
PUSH P,B ;SAVE BYTE POINTER
S$IN.1: PUSHJ P,GETCHR ;GET ANOTHER CHARACTER
JUMPF S$IN.2 ;EOL MEANS IT WAS A CONTINUATION
CAIE C,"!" ;SO DOES A COMMENT
CAIN C,";" ; EITHER TYPE OF COMMENT
JRST S$IN.2 ;SO GO GET IT
CAIN C," " ;IS IT A BLANK?
JRST S$IN.1 ;YES, LOOP FOR NON-BLANK
POP P,B ;ITS NOT A CONTINUATION
MOVEI C,"-" ;SO RESTORE THE HYPHEN
MOVE S1,C ; And here, too
$RETT ;RETURN SUCCESS
S$IN.2: POP P,B ;BRING STACK INTO PHASE
PUSHJ P,CDRASC ;GET NEXT RECORD
JUMPF .RETF ; Fail if read fails
PUSHJ P,S$INIT ; Reinitialize for scanning
SETZ S1,0 ; Clear flags
PUSHJ P,LOGCRD ; Log this card
JRST S$INCH ; TRY AGAIN
SUBTTL String scanning routines -- GETCHR - Get and map a character
; ====== -----------------------
;
; This routine is called by the character input routine
; S$INCH to get the next character from the string. This
; routine converts tabs and CR to spaces, and maps lower into
; upper case.
;
; Call:
;
; PUSHJ P,GETCHR
; B contains pointer to current position in string
;
; Returns TRUE
; B points to character obtained
; C contains mapped character
; S1 contains original, unmapped character
;
; Returns FALSE if EOL
;
GETCHR: SKIPE L.BRK ;WAS LAST CHARACTER A BREAK?
$RETF ;YES, FAIL RETURN
GETC.1: ILDB S1,B ;GET A CHARACTER
MOVE C,S1 ; Prepare to map it
CAIN C,.CHCRT ;IGNORE CR'S
JRST GETC.1 ; Get next character
CAIN C,.CHTAB ;DO FIXUP ON TABS
MOVEI C," " ;YES, MAKE A SPACE
CAIN C,.CHLFD ;LINEFEED?
JRST GETC.2 ;YES, SET BREAK FLAG
CAIL C,"a" ;CHECK FOR LOWER CASE
CAILE C,"z" ; I.E. "A"-"Z"
$RETT ;NO, RETURN
SUBI C,40 ;MAKE IT UPPER CASE
$RETT ;AND RETURN
GETC.2: SETOM L.BRK ;SET BREAK FLAG
MOVEI C," " ;MAKE BREAK CHAR A SPACE
$RETF ;AND FAIL
SUBTTL Card reading routines -- CRD$CC - Read a $ Control Card
; ====== ---------------------
;
; Here to read a card from the input file and see if it is a
; $ control card. If a card has already been read into the
; buffer, this routine will process that card and not read a
; new one. If the card is blank, it is discarded. If the
; card is a valid control card, it is written to the log
; file.
;
; Call:
;
; PUSHJ P,CRD$CC
;
; Returns TRUE on valid control card
; S1 contains flags
; S2 contains dispatch address for flagword
;
; Returns FALSE if not a valid control card
; S1 contains flags
;
; See routine CHEKCC for flags.
;
CRD$CC: SKIPE NXTRDY ; Next card already been read?
JRST CRD$.1 ; Yes, don't read another yet.
MOVE S1,L.DWID ; Load default width
MOVEM S1,L.WIDT ; Save it
PUSHJ P,CDRASC ; Get a card
JUMPF [SETZ S1, ; Clear flags and
$RETF] ; Return if failed
CRD$.1: SETZM NXTRDY ; Clear flag indicating next
; card read ahead
SKIPN L.CSUP ; If null card,
JRST CRD$CC ; try the next one.
; Truncate to L.CSUP chars.
MOVE T1,L.DHOL ; Initialize pointer
SETZ T3, ; Clear a counter
CRD$.2: CAML T3,L.CSUP ; Skipped all chars
JRST CRD$.3 ; Yes, go put on terminator
IBP T1 ; No, bump pointer
AOJA T3,CRD$.2 ; Keep looping
CRD$.3: MOVEI T2,.CHCRT ; Now
IDPB T2,T1 ; Put on line terminator of
MOVEI T2,.CHLFD ; <cr><lf><0>
IDPB T2,T1 ; on trimmed line
SETZ T2,0
IDPB T2,T1
PUSHJ P,CHEKCC ; See if a control card
JUMPF .RETF ; Fail if not
PUSHJ P,LOGCRD ; LOG valid control card
$RETT ; and return
SUBTTL Card reading routines -- CRDEOJ - Flush to end of job
; ====== -------------------
;
; Here to read cards until a job terminator is found. It
; then tries to read the next card to see if the job
; terminator was the last card in the file.
;
; Call:
;
; PUSHJ P,CRDEOJ
;
; Returns TRUE if more cards follow this job
;
; Returns FALSE if EOF terminates job or input error occurs
;
CRDEOJ: SKIPE NXTRDY ; Next card already been read?
JRST CRDE.1 ; Yes, don't read another yet.
MOVE S1,L.DWID ; Load default width
MOVEM S1,L.WIDT ; Save it
PUSHJ P,CDRASC ; Get a card
TXNE F,F.EOF!F.IFE ; EOF or input error?
$RETF ; Yes, return failure.
CRDE.1: SETZM NXTRDY ; Clear flag indicating next
; card read ahead
PUSHJ P,CHEKCC ; See if a control card
JUMPF CRDEOJ ; Loop if not
TXNE S1,CD.BOJ ; Beginning of next job seen
SETOM NXTRDY ; Yes, we will catch it later
TXNN S1,CD.EOJ ; End of job seen
JRST CRDEOJ ; No, keep looking
PUSHJ P,CDRASC ; Yes, try to get next card
TXNE F,F.EOF!F.IFE ; EOF or input error?
$RETF ; Yes, return failure.
SETOM NXTRDY ; Say we have a card ready.
$RETT ; and return
SUBTTL Card reading routines -- CDRASC - Read ASCII text
; ====== ---------------
;
; Here to read either an ASCII line or Hollerith (026 or 029)
; card image from the input file. Depending on the recording
; mode of the input file, this routine dispatches to the
; appropriate input routine.
;
; Call:
;
; PUSHJ P,CDRASC
;
; Returns TRUE
; L.CHOL contains a byte pointer to the ASCIZ string
; interpreted in the current mode
; L.DHOL contains a byte pointer to the ASCIZ string
; interpreted in the default mode for the job
; (If the job was not initiated at a physical reader,
; L.DHOL = L.CHOL and the buffer begins at L.DMOD.
; For card reader initiated jobs, the 026 buffer
; begins at L.C026 and the 029 buffer begins at L.CASC.
; L.CHOL points to one of these buffers depending on the
; current mode of interpretation and L.DHOL also
; points to one of these depending on the default
; interpretation mode for the job.)
; L.CLEN contains the actual length of the line
; L.CSUP contains the suppressed length of the line
; CDRCNT is incremented
;
; Returns FALSE on EOF or error
;
CDRASC:
TXNE F,F.EOF ; Already at EOF?
$RETF ; Yes, simply return failure.
SETZM L.CSUP ;CLEAR SUPPRESSED LENGTH
SETZM L.CLEN ;CLEAR ACTUAL LENGTH
SETZM L.NHOL ;CLEAR # OF HOL ERRORS
SETZM L.TFLG ;CLEAR HEADER/TRAILER FLAG
SETZM TRLCRD ;CLEAR HEADER/TRAILER CARD COUNT
LOAD S1,L.INF,FP.RCF ; Get file format code
MOVSI T1,-MODCNT ; Make AOBJN pointer
CDRA.1: HLRZ T2,MODTBL(T1) ; Get code from table
CAMN S1,T2 ; Match?
JRST CDRA.2 ; Yes, go dispatch
AOBJN T1,CDRA.1 ; No, try other codes
$STOP (URM,<Unknown Recording Mode(^O/S1/) Error in NEXTJOB Message>)
CDRA.2: HRRZ T2,MODTBL(T1) ; Get dispatch address
PJRST (T2) ; and read line from file
MODTBL: XWD .FPFAI,CDR.AI ;AUGMENTED IMAGE
XWD .FPFSA,CDR.SA ;STREAM ASCII
XWD .FPFAS,CDR.FA ;FIXED ASCII
MODCNT==.-MODTBL ;COUNT FOR AOBJN
SUBTTL Card reading routines -- CDR.SA - Read in Stream ASCII mode
; ====== -------------------------
;
; This routine reads a Stream ASCII line from a file and
; stores it as an ASCIZ string in the line buffer beginning
; at L.DMOD.
;
; A Stream ASCII file is a 7-bit ASCII file having each line
; terminated by a linefeed.
;
; This routine will discard any carriage-returns within the
; line and replace the line-feed terminator with a
; <cr><lf><0> sequence.
;
; Call:
;
; PUSHJ P,CDR.SA
;
; Returns TRUE
; L.DMOD is starting address of ASCIZ string
; L.CLEN contains the actual length of the line
; L.CSUP contains the suppressed length of the line
;
; Returns FALSE on EOF or error
;
CDR.SA:
$CALL .SAVE2 ; Need P1 and P2 for scratch
MOVE P1,[POINT 7,L.DMOD] ; P1 points to buffer area
SETZ P2,0 ; P2 contains character count
CDR.S1: PUSHJ P,CHR.SA ; Get a character
JUMPF CDR.S3 ; Break out on EOL
CAXN S2,.CHCRT ; Is it carriage-return?
JRST CDR.S1 ; Yes, ignore it.
IDPB S2,P1 ; No, store character
AOS P2 ; Count it.
CAXE S2," " ; Is it a blank?
MOVEM P2,L.CSUP ; No, update suppressed length
MOVEM P2,L.CLEN ; Update length of current line
CAMGE P2,L.DWID ; Do we have all we want?
JRST CDR.S1 ; No, get more.
; Yes, flush remainder of line
CDR.S2: PUSHJ P,CHR.SA ; Get a character
JUMPT CDR.S2 ; Loop until EOL
CDR.S3: TXNE F,F.FATE!F.EOF ; Fail if EOF or error
JUMPF .RETF
MOVEI S2,.CHCRT ; Here on EOL
IDPB S2,P1 ; Put on line terminator of
MOVEI S2,.CHLFD ; <cr><lf><0>
IDPB S2,P1
SETZ S2,0
IDPB S2,P1
AOS CDRCNT ; Bump count
$RETT ; Return
;
; Routine to read the next character from a Stream ASCII file.
; Any nulls will be discarded.
;
; Call:
;
; PUSHJ P,CHR.SA
;
; Returns TRUE
; Character in S2
;
; Returns FALSE if character is a linefeed or if EOF or error
;
CHR.SA:
MOVE S1,L.IFN ; Get handle of input file
$CALL F%IBYT ; Get a byte
JUMPF INFAIL ; Branch on error!
JUMPE S2,CHR.SA ; Ignore nulls
CAXE S2,.CHLFD ; Is it a linefeed?
$RETT ; No, return TRUE
$RETF ; Yes, return FALSE for EOL
SUBTTL Card reading routines -- CDR.AI - Read in Augmented Image mode
; ====== ---------------------------
;
;
CDRA.A: SETZM L.TFLG ;CLEAR HEADER/TRAILER FLAG
CDR.AI:
$CALL .SAVE3 ; Need 3 registers
MOVE S1,L.IFN ;GET THE IFN
$CALL F%CHKP ;GET CURRENT POSITION
ADDI S1,CPC ;POINT TO NEXT CARD
MOVEM S1,CDRA.F ;STORE TO POSITION LATER
MOVEI P1,1 ;START THE COUNTER
MOVE P2,[POINT 7,L.CASC]
MOVE P3,[POINT 7,L.C026]
CDRA.B: MOVE S1,L.IFN ;GET THE IFN
$CALL F%IBYT ;GET A BYTE
JUMPF INFAIL ; Branch on error
TXNE S2,1B20 ;WAS IT A HOLLERITH ERROR?
JRST CDRA.G ; Yes, go process it
CDRA.C: MOVE S1,S2
LSHC S1,-2
LSH S1,-7
LSHC S1,2
LOAD S2,CODTBL(S1),CODASC
IDPB S2,P2
LOAD S2,CODTBL(S1),COD026
CAIN S2,173 ;ALTERNATE "?"?
MOVEI S2,77 ;YES, MAKE IT REAL "?"
CAIN S2,175 ;ALTERNATE ":"?
MOVEI S2,72 ;YES, MAKE IT REAL ":"
IDPB S2,P3 ;DEPOSIT CHARACTER IN BUFFER
CAIE S2,40 ;IS IT A SPACE?
MOVEM P1,L.CSUP ;NO, COUNT IT
MOVEM P1,L.CLEN ;SAVE CURRENT LENGTH
CAMGE P1,L.DWID ;GOT THEM ALL?
AOJA P1,CDRA.B ;NO, LOOP
MOVEI S1,.CHCRT ;LOAD A CR
IDPB S1,P2 ;STORE IN ONE
IDPB S1,P3 ;STORE IN THE OTHER
MOVEI S1,.CHLFD ;LOAD A LF
IDPB S1,P2 ;STORE IN ONE
IDPB S1,P3 ;STORE IN THE OTHER
SETZ S1, ; Load a null
IDPB S1,P2 ;STORE IN ONE
IDPB S1,P3 ;STORE IN THE OTHER
CDRA.D: MOVE S1,L.IFN ;GET THE IFN
MOVE S2,CDRA.F ;GET POSITION OF NEXT CARD
$CALL F%POS ;AND POSITION IT
JUMPT CDRA.E ;JUMP IF OK
MOVE S1,L.IFN ;ELSE, GET THE IFN
SETO S2, ;SET EOF
$CALL F%POS ;AND SET EOF FOR NEXT TIME
CDRA.E: AOS CDRCNT ;ONE MORE!
SKIPN L.NHOL ;ANY HOLLERITH ERRORS?
JRST CDRA.I ;NO, PREPARE TO RETURN
$TEXTL(<^I/STERR/%SPTHOL ^D/L.NHOL/ Hollerith errors in card #^D/CDRCNT/>)
SKIPE FILIFN ;ARE WE IN A DECK?
PUSHJ P,CARDID ;YES, GIVE CARD INFO
$TEXTL(<^I/STMSG/[Card: ^Q/L.CHOL/]^A>)
MOVE P1,L.NHOL ;GET NUMBER OF ERRORS
ADDB P1,L.THOL ;ADD TO TOTAL
CAMG P1,L.UHOL ;GREATER THAN ALLOWABLE?
$RETT ;NO, ALL IS WELL
$TEXTL(<^I/FATAL/?SPTTMH ^I/CDR.E1/>)
JSP B,PROCER
CDR.E1: ITEXT (<Too many Hollerith errors>)
CDRA.F: BLOCK 1 ;STORAGE FOR THE POSITION
;
; Here to process Hollerith error
;
CDRA.G: ANDI S2,7777 ;CHECK FIRST COLUMN OF CARD
CAXE S2,3776 ;LOOK LIKE A HEADER CARD?
JRST CDRA.H ;NO
MOVE S1,L.IFN ;YES, BUT MAKE SURE
$CALL F%IBYT
JUMPF INFAIL
ANDI S2,7777
CAXE S2,7777 ;NOW, IS IT REALLY?
JRST [AOS L.NHOL
JRST CDRA.H]
AOS TRLCRD ;BY GEORGE IT IS!
SETOM L.TFLG ;SET FLAG
JRST CDRA.D ;AND FINISH UP THIS CARD
CDRA.H: AOS L.NHOL ;COUNT HOLLERITH ERROR
MOVEI S2,CODHER ;LOAD UP STANDARD ERROR CODE
JRST CDRA.C ;AND CONTINUE PROCESSING
CDRA.I: SKIPE L.TFLG ;FLAG SET?
JRST CDRA.A
SKIPN TRLCRD ;ANY TRAILER CARDS PASSED OVER?
$RETT ;RETURN
SKIPE FILIFN
$TEXTL(<^I/STSUM/^D/TRLCRD/ Header/Trailer cards ignored in file ^F/FILFD/>)
SKIPN FILIFN
$TEXTL(<^I/STSUM/^D/TRLCRD/ Header/Trailer cards ignored>)
$RETT
SUBTTL Card reading routines -- CDR.FA - Read in Fixed ASCII mode
; ====== ------------------------
CDR.FA:
$STOP (UMS,<Unsupported Recording Mode Specified(^O/S1/)>)
SUBTTL Card reading routines -- CDRBIN - Read a Chksummed Binary Card
; ====== ----------------------------
;
; CDRBIN -- Routine to read a Binary mode card. Reads each
; card and checks for a 7-9 punch, stores the word count and
; checksum from card. Computes checksum and checks against
; punched checksum. If no 7-9 punch is found, checks for a
; control card. Returns false on error, EOF, and control card.
;
; Call:
;
; PUSHJ P,CDRBIN
;
; Returns TRUE
; L.DMOD is starting address of binary data packed in
; 12-bit bytes, 3 bytes per word
; L.CLEN contains the word count
; CDRCNT is incremented
;
; Returns FALSE on EOF, error, or control card
; Input file is repositioned to beginning of record
;
TOPS10 <
CDRBIN:
$CALL .SAVE2 ; Need 2 scratch registers
MOVE B,[POINT ^D12,L.DMOD] ; Set up byte pointer
MOVE S1,L.IFN ;GET THE IFN
$CALL F%IBYT ;GET COLUMN 1
JUMPF INFAIL ; Branch on error
ANDI S2,7777 ;GET RID OF AUGMENTATION
TRC S2,.IM79 ;REVERSE ROWS 7 AND 9
TRCE S2,.IM79 ;WERE THEY BOTH ON?
JRST CDRB.5 ;NOPE!!
LSH S2,-6 ;RIGHT JUSTIFY WORD COUNT
MOVEM S2,L.CLEN ;AND STORE IT
MOVE S1,L.IFN ;GET THE IFN
$CALL F%IBYT ;GET COLUMN 2
JUMPF INFAIL ; Branch on error
ANDI S2,7777 ;GET RID OF EXTRA STUFF
MOVEM S2,L.CCHK ;AND STORE THE CHECK SUM
MOVEI P1,^D78 ;NUMBER OF COLUMNS LEFT TO READ
MOVE P2,L.CLEN ;NUMBER OF SIGNIFICANT WORDS
IMULI P2,3 ;CONVERT TO COLUMNS
CDRB.1: MOVE S1,L.IFN ;GET THE IFN
$CALL F%IBYT ;GET A COLUMN
JUMPF INFAIL ; Branch on error
IDPB S2,B ;DEPOSIT IT
SOJ P1, ;DECREMENT COUNT OF COLUMNS
SOJG P2,CDRB.1 ;AND LOOP FOR SIGNIFICANT ONES
PUSHJ P,CDRB.F ; Flush remaining columns
JUMPF .RETF ; Return failure on error
AOS CDRCNT ;COUNT ANOTHER CARD
; Here to check checksum and return
MOVN T1,L.CLEN ;GET NEG WORD COUNT
HRLZ T1,T1 ;PUT IN LEFT HALF
ADDI T1,L.DMOD ;MAKE AOBJN POINTER
SETZ T2,0 ;ACCUMULATE CHECKSUM HERE
CDRB.4: ADD T2,(T1) ;ADD A WORD
AOBJN T1,CDRB.4 ;GET ALL WORDS
LSHC T2,-30 ;THIS ALGORITHM USED BY UUOCON
LSH T1,-14 ; ROUTINE CKS12 TO COMPUTE A
ADD T2,T1 ; 12 BIT FOLDED CHECKSUM
LSHC T2,-14 ;
LSH T1,-30
ADD T2,T1
TXZE T2,77B23 ;
AOS T2
CAMN T2,L.CCHK ;DOES IT MATCH CHECKSUM ON CARD
$RETT ; Yes, return true.
$TEXTL(<^I/STERR/%SPTBCK Binary checksum error in card #^D/CDRCNT/>)
PUSHJ P,CARDID ;AND CARD INFO
AOS T2,L.TCHK ;INCREMENT ERROR COUNT AND LOAD
CAMG T2,L.UCHK ;COMPARE AGAINST MAX
$RETT ;STILL LEGAL
$TEXTL(<^I/FATAL/?SPTTMC ^I/EM.TMC/>)
JSP B,PROCER ;AND ABORT THE JOB
EM.TMC: ITEXT (<Too many binary checksum errors>)
; Here on non-binary card
CDRB.5: CAIE S2,.IMDOL ; Is column 1 a dollar sign?
JRST CDRB.6 ; No, an error
MOVE S1,L.IFN ; Yes, get file handle
$CALL F%CHKP ;AND DETERMINE WHERE WE ARE
JUMPF INFAIL ; Branch on error
MOVEI S2,-1(S1) ;BACK OFF BY ONE
MOVE S1,L.IFN ;DO'IT AGAIN
$CALL F%POS ;POSITION TO REREAD LAST BYTE
JUMPF INFAIL ; Branch on error
$RETF
CDRB.6:
$TEXTL(<^I/STERR/%SPTIBC Illegal binary card, card #^D/CDRCNT/>)
PUSHJ P,CARDID ;WHERE THE CARD IS
AOS T2,L.TIBC ;INCREMENT COUNT AND LOAD
CAMG T2,L.UIBC ;GREATER THAN ALLOWABLE?
JRST [MOVEI P1,^D79
PUSHJ P,CDRB.F ;NO, JUST IGNORE CARD
JRST CDRBIN]
$TEXTL(<^I/FATAL/?SPTTMB ^I/EM.TMB/>)
JSP B,PROCER ;AND DIE
EM.TMB: ITEXT (<Too many illegal binary cards>)
;
; Here to flush remainder of card
; P1 is count of columns to flush
CDRB.F: SOJL P1,.RETT ;DID WE GET ALL 80?
MOVE S1,L.IFN ;GET THE IFN
$CALL F%IBYT ;GET A COLUMN
JUMPF INFAIL ; Branch on error
JRST CDRB.F ;AND LOOP FOR THEM ALL
>;END TOPS10
SUBTTL Card reading routines -- CDRIMG - Read an Image Card
; ====== ------------------
;
; CDRIMG -- Routine to read one card in Image mode.
;
; Call:
;
; PUSHJ P,CDRIMG
;
; Returns TRUE
; L.DMOD is starting address of image data packed in
; 12-bit bytes, 3 bytes per word
; L.CLEN contains number of image words per card (IWPC)
; CDRCNT is incremented
;
; Returns FALSE on EOF, or error
;
CDRIMG: $CALL .SAVE2 ; Need 2 registers
MOVEI P1,CPC ;GET COLUMNS/CARD
MOVE P2,[POINT ^D12,L.DMOD] ;SETUP BYTE POINTER
CDRIM1: MOVE S1,L.IFN ;GET THE IFN
$CALL F%IBYT ;GET A BYTE
JUMPF INFAIL ;IO ERROR
IDPB S2,P2 ;DEPOSIT THE BYTE
SOJG P1,CDRIM1 ;AND LOOP
SETZ T1, ; Zero out byte 81
IDPB T1,P2
MOVEI T1,IWPC ;LOAD # IMAGE WORD/CARD
MOVEM T1,L.CLEN ;STORE IN COUNT WORD
AOS CDRCNT ;ONE MORE!!
$RETT ;AND RETURN
SUBTTL Card reading routines -- INFAIL - Input failure from source file
INFAIL: CAIN S1,EREOF$ ;IS IT END OF FILE?
JRST [TXO F,F.EOF ; Yes, set flag
$RETF] ; Return FALSE
TXO F,F.IFE ; Set flag to abort job stream
PUSH P,S1 ; Save status bits
MOVE S1,L.IFN ; Get input file IFN
SETO S2,0 ; Get a real FD
$CALL F%FD
POP P,S2 ; Get back status bits
$TEXTL(<^I/FATAL/?SPTERI ^I/INFA.1/>)
JSP B,PROCER
INFA.1: ITEXT (<Error reading input file ^F/(S1)/, ^E/S2/>)
SUBTTL Deck Stacking Routines -- STASC - Stack ASCII Deck
; ===== ----------------
; Routine to stack a user's Hollerith (029 or 026) or ASCII file.
; Stacks until a control card or an input EOF is found.
STASC: $CALL .SAVE2 ; Need 2 registers
STAS.1: PUSHJ P,CDRASC ; Get ASCII card image
JUMPF STAS.4 ; Branch if EOF or error
MOVE P1,L.CHOL ; Pointer to beginning of card
PUSHJ P,CHEKCC ; See if this card
TXNE S1,CD.EOD ; terminates the deck
JRST STAS.4 ; Yes, finish up.
TXNN S1,CD.DDS ; No, does it begin with $$
JRST STAS.2 ; No, go stack it
IBP P1 ; Yes, convert $$ to $
SOS L.CLEN ; And adjust counts
SOS L.CSUP
STAS.2: MOVE P2,L.CLEN ; Get number of bytes
SKIPE L.SPRS ; Suppress flag on?
MOVE P2,L.CSUP ; Yes, so use suppressed length
CAML P2,L.WIDT ; Less than desired length
MOVE P2,L.WIDT ; No, use only desired number
STAS.3: MOVE S1,FILIFN ; Get the IFN
ILDB S2,P1 ; Get a byte
$CALL F%OBYT ; Write out the byte
JUMPF FILERR ; Branch on error
SOJG P2,STAS.3 ; Decrement count
MOVE S1,FILIFN ;GET THE IFN
MOVE S2,[2,,[BYTE (7) .CHCRT,.CHLFD]]
$CALL F%OBUF ;PUT IN A CRLF
JUMPF FILERR ;AND LOSE
AOS DEKCRD ;COUNT THE CARD
JRST STAS.1 ;AND GO AROUND FOR ANOTHER
STAS.4: TXNE F,F.FATE ; A fatal error?
$RETF ; Yes, return failure
TXNN F,F.EOF ; If not at EOF
SETOM NXTRDY ; set "next card ready"
PJRST $EOD ; Finish up
SUBTTL Deck Stacking Routines -- STIMG - Stack Image Deck
; ===== ----------------
;STIMG -- Routine to transfer User's IMAGE mode deck to disk.
; Deck ends on CDR-EOF or Image Terminator.
STIMG: $CALL .SAVE2 ; Need 2 scratch registers
MOVE P1,L.IMGT ;GET IMAGE MODE TERM COLUMN
IDIVI P1,3 ;GET WORD IN P1, BYTE # IN P2
ADD P1,P.ICOL(P2) ;MAKE POINTER TO CORRECT COLUMN
STIM.1: PUSHJ P,CDRIMG ;GET IMAGE MODE CARD
JUMPF STIM.3 ; Branch on error or EOF
LDB T1,P.CL1I ;GET IMAGE COLUMN 1
CAIE T1,7777 ;FULLY LACED?
JRST STIM.5 ;NO, NOT END OF DECK
LDB T1,P1 ;YES, GET SPECIFIED TERM COLUMN
CAIE T1,7777 ;FULLY LACED?
JRST STIM.5 ; No, not end of deck
; Yes, ck other cols for zeros
MOVE T1,L.DMOD ;SAVE FIRST WORD
MOVE T2,(P1) ;AND WORD WITH TERMINATOR
SETZ T3,0 ;CLEAR A COUNTER
DPB T3,P.CL1I ;ZERO OUT FIRST COLUMN
DPB T3,P1 ;AND TERMINATOR COLUMN
STIM.2: SKIPE L.DMOD(T3) ;WORD ZERO?
JRST STIM.4 ; No, not a terminator
CAIGE T3,IWPC-1 ;LOOP FOR 27 WORDS
AOJA T3,STIM.2 ;AND AROUND WE GO
; Remainder of card was blank
STIM.3: TXNE F,F.FATE ; A fatal error?
$RETF ; Yes, return failure
PJRST $EOD ; Else end the deck and return
STIM.4: MOVEM T2,(P1) ;RESTORE TERMINATOR COLUMN
MOVEM T1,L.DMOD ;AND FIRST COLUMN
STIM.5: AOS DEKCRD ;INCREMENT CARD COUNT
MOVE S1,FILIFN ;GET THE IFN
HRL S2,L.CLEN ;GET COUNT,,0
HRRI S2,L.DMOD ;GET COUNT,,ADR
$CALL F%OBUF ;WRITE OUT THE CARD
JUMPF FILERR ; Branch on error
JRST STIM.1 ; LOOP IF OK
;BYTE POINTERS FOR STIMG
P.ICOL: POINT 12,L.DMOD,35 ;THIRD BYTE OF WORD
P.CL1I: POINT 12,L.DMOD,11 ;FIRST BYTE OF WORD
POINT 12,L.DMOD,23 ;SECOND BYTE OF WORD
POINT 12,L.DMOD,35 ;THIRD BYTE OF WORD
SUBTTL Deck Stacking Routines -- STBIN - Stack Binary Deck
; ===== -----------------
COMMENT \
STBIN -- Routine to transfer user's BINARY mode deck. Deck ends
on CDR-EOF or a control card. Special check is made to
insure that a null file is not created. The CDR input
routine CDRBIN is called. CDRBIN does all the
checksumming and 7-9 checking and will decide whether it
is a control card (which will trap as an illegal binary
card).
\
TOPS10 <
STBIN: PUSHJ P,CDRBIN ; Get a card
JUMPF STBI.1 ; Either error, EOF, or command
AOS DEKCRD ;INCREMENT CARD COUNT
MOVE S1,FILIFN ;GET THE IFN
HRL S2,L.CLEN ;GET COUNT,,0
HRRI S2,L.DMOD ;GET COUNT,,ADR
$CALL F%OBUF ;WRITE OUT THE CARD
JUMPF FILERR ; Branch if error
JRST STBIN ; Else loop
STBI.1: TXNE F,F.FATE ; A fatal error?
$RETF ; Yes, return failure
PJRST $EOD ; No, finish up
>;END TOPS10
TOPS20 <
STBIN: $STOP(TSB,Tried stacking binary cards)
>;END IFN FTJSYS
SUBTTL Deck Stacking Routines -- FILERR - Error writing user file
; ====== -----------------------
FILERR: $TEXTL(<^I/FATAL/?SPTEWF ^I/FLER.1/>)
JSP B,PROCER ;
FLER.1: ITEXT (<Error writing file ^F/FILFD/, ^E/S1/>)
SUBTTL Deck Stacking Routines -- CARDID - Identify card with error
; ====== ------------------------
;
; HERE TO TYPE OUT "CARD 3 IN FILE FOO.BAR"
;
CARDID: MOVE T1,DEKCRD ; Get current count
AOS T1 ; Get number of this card
$TEXTL(<^I/STMSG/[Card #^D/T1/ in file ^F/FILFD/]>)
$RETT ;AND RETURN
SUBTTL Usage Accounting Routines -- DOFACT - Fact Accounting
; ====== ---------------
;
DOFACT: SKIPE DEBUGW ;DEBUGGING ???
$RETT ;YES,,RETURN
LOAD S1,.EQSEQ(Q),EQ.IAS ;GET THE INVALID ACCT STRING BIT
JUMPN S1,.RETT ;IF LIT,,THEN JUST RETURN
LOAD S1,.EQSEQ(Q),EQ.SEQ ;GET JOB SEQUENCE NUMBER
MOVEM S1,L.SEQ ;STORE IT
LOAD T1,.EQSEQ(Q),EQ.PRI ;GET /PRIORITY VALUE
MOVEM T1,L.PRIO ;SAVE FOR ACCOUNTING
TOPS20< MOVX S1,.FHSLF ;GET FORK HANDLE
RUNTM ;GET RUNTIME
ADDM S1,L.RTM ;GET RUNTIME FOR THE JOB
MOVEI S1,.USENT ;WRITE AN ENTRY
MOVEI S2,ACTLST ;GET ADDRESS OF BLOCK
USAGE ;ACCOUNT FOR THE WORLD
ERCAL DOFA.1 ;FAILED
$RET ;AND RETURN
DOFA.1: MOVX S1,.FHSLF ;PREPARE TO GET THE ERROR
JSYS 12 ;GETER JSYS
HRROI S1,DOFA.3 ;POINT TO BLOCK
MOVEI T1,^D60-1 ;59 CHARS + NULL
ERSTR ;GET THE ERROR STRING
ERJMP DOFA.2
DOFA.2: $WTOJ(^I/ABTSPR/,<Accounting System Failure, ^E/[EXP -2]/>,WTOOBJ)
$RET
DOFA.3: BLOCK ^D60/5 ;RESERVE nUFF ROOM FOR ERROR
>;END OF TOPS20 CONDITIONAL
TOPS10< SETZM S1 ;GET THE RUNTIME FOR THIS JOB
RUNTIM S1, ;ASK MONITOR
ADDM S1,L.RTM ;CALC RUN TIME TO PROCESS THE REQUEST
PUSHJ P,I%NOW ;GET THE CURRENT TIME
SUB S1,L.CON ;GET JIFFIES OF CONNECT TIME
IDIVI S1,3 ;GET NUMBER OF SECONDS
MOVEM S1,L.CON ;SAVE THE CONNECT TIME
GETLIM T1,.EQLIM(Q),ONOD ;GET THE NODE NUMBER
FACT< HRLZM T1,FACTBL+3 > ;STORE NODE NUMBER NOW
HRROI S1,.GTKCT ;GET KILO-CORE-TICKS
GETTAB S1,
SETZ S1,
IMULI S1,^D100 ;GET CTI IN <KCT>*100
IDIVI S1,JIFFIE ;CONVERT TO SECONDS
ADDM S1,L.CTI ;STORE IT
;CONTINUED ON THE NEXT PAGE
;CONTINUED FROM THE PREVIOUS PAGE
HRROI S1,.GTRCT ;GET DISK READS
GETTAB S1,
SETZ S1,
ANDX S1,RC.TTL ;STRIP OFF INCREMENTAL READS
ADDM S1,L.DSR ;STORE DISK READS
HRROI S1,.GTWCT ;GET DISK WRITES
GETTAB S1,
SETZ S1,
ANDX S1,WC.TTL ;STRIP OFF INCREMENTAL WRITES
ADDM S1,L.DSW ;STORE NEGATIVE DISK WRITES
MOVE S1,[ACTLEN,,ACTLST] ;GET THE PARM BLOCK LENGTH,,ADDRESS
QUEUE. S1, ;REQUEST ACCOUNTING BE DONE
JRST DOFA.1 ;FAILED,,TELL OPR
FACT< MOVE S1,L.LIN ;GET LINE NUMBER
LDB S2,[POINT 7,L.TTY,6] ;GET TERMINAL DESIGNATOR
CAIN S2,"C" ;ON THE CTY
MOVEI S1,7777 ;YES, CTY DESIGNATOR
CAIN S2,"D" ;DETACHED
MOVEI S1,7776 ;YES, FLAG THAT INSTEAD OF LINE NUMBER
LSH S1,6 ;PUT IN BITS 18-29
HRL S1,L.JOB ;INSERT JOB NUMBER
IOR S1,[231000,,13] ;ADD FACT TYPE AND NUMBER OF WORDS
MOVEM S1,FACTBL+0 ;STORE IN BLOCK
MOVE S1,.EQOID(Q) ;GET PPN
MOVEM S1,FACTBL+1 ;STORE
SETZM FACTBL+2 ;DAEMON FILLS IN THE DATE/TIME
MOVE S1,[%CNSER] ;CPU SERIAL NUMBER
GETTAB S1, ;ASK FOR IT
SETZ S1, ;USE 0 IF CAN'T FIND IT
TLO S1,'IN ' ;QUEUE NAME = INPUT
IORM S1,FACTBL+3 ;NODE NUMBER ALREADY STORED FROM ABOVE
MOVE S1,L.RTM ;RUN TIME IN MILLISECONDS
MOVEM S1,FACTBL+4 ;STORE
MOVE S1,L.CTI ;CORE/TIME INTERGRAL
MOVEM S1,FACTBL+5 ;STORE
MOVE S1,L.DSR ;DISK READS
MOVEM S1,FACTBL+6 ;STORE
MOVE S1,L.DSW ;DISK WRITES
MOVEM S1,FACTBL+7 ;STORE
MOVSI S1,'CDR' ;DEFAULT TO CARD READER
SKIPN CDRDEV ;WAS IT /READER ???
MOVSI S1,'DSK' ;YES,,SET TO DISK
MOVEM S1,FACTBL+10 ;SET INPUT DEVICE TYPE
MOVE S1,L.SEQ ;SEQUENCE NUMBER
MOVEM S1,FACTBL+11 ;STORE
MOVE S1,CDRCNT ;CARDS READ (PROCESSED)
TLO S1,(1B0) ;ALWAYS SUBMITTED THE JOB
MOVEM S1,FACTBL+12 ;STORE
MOVE S1,[14,,FACTBL-1] ;DAEMON ARGUMENT
DAEMON S1, ;MAKE THE FACT ENTRY
JRST DOFA.1 ;FAILED !!!
> ;END FACT ACCOUNTING
$RETT ;RETURN
DOFA.1: $WTOJ(^I/ABTSPR/,<System accounting failure^M^J^R/.EQJBB(Q)/>,WTOOBJ)
$RETT ;RETURN
> ;END TOPS10 ACCOUNTING
SUBTTL Usage Accounting Routines -- ACTLST - Usage Accounting Data
; ====== ---------------------
;
ACTLST: USENT. (.UTINP,1,1,0)
USJNO. (L.JOB) ;JOB NUMBER
USTAD. (-1) ;CURRENT DATE/TIME
USTRM. (L.TTY) ;TERMINAL DESIGNATOR
USLNO. (L.LIN) ;TTY LINE NUMBER
USPNM. (<'SPRINT'>,US%IMM) ;PROGRAM NAME
USPVR. (%SPT,US%IMM) ;PROGRAM VERSION
USAMV. (-1) ;ACCOUNTING MODULE VERSION
USNOD. (L.NODE) ;NODE NAME
TOPS10< USIAC. (<POINT 7,.EQACT(Q)>) ;ACCOUNT STRING POINTER
USIRN. (L.RTM) ;RUN TIME
USICT. (L.CTI) ;CORE-TIME INTERGRAL
USIDR. (L.DSR) ;DISK READS
USIDW. (L.DSW) ;DISK WRITES
USIJN. (.EQJOB(Q)) ;JOB NAME
USIQN. (<'INP '>,US%IMM) ;QUEUE NAME
USIPD. (0,US%IMM) ;DEVICE NAME
USISN. (L.SEQ) ;JOB SEQUENCE NUMBER
USICR. (CDRCNT) ;TOTAL CARDS READ
USICD. (.EQAFT(Q)) ;CREATION DATE/TIME OF REQUEST
USIDS. (<'BATCH '>,US%IMM) ;DISPOSITION
; USITX. (0) ;OPERATOR TEXT (NOT USED)
USIPR. (L.PRIO) ;JOB PRIORITY
USIRI. (.EQRID(Q)) ;USER REQUEST ID
USICN. (L.CON) ;CONNECT TIME
USPPN. (.EQOID(Q)) ;USER PPN
USNM1. (.EQOWN(Q)) ;USER NAME WORD 1 (TOPS10)
USNM3. (.EQOWN+1(Q)) ;USER NAME WORD 2 (TOPS10)
ACTLEN==.-ACTLST ;ACCOUNTING BLOCK LENGTH
> ;END OF TOPS-10 CONDITIONAL
TOPS20< USACT. (<POINT 7,.EQACT(Q)>) ;ACCOUNT STRING POINTER
USSRT. (L.RTM) ;RUN TIME
USSDR. (L.DSR) ;DISK READS
USSDW. (L.DSW) ;DISK WRITES
USJNM. (.EQJOB(Q)) ;JOB NAME
USQNM. (<'INP '>,US%IMM) ;QUEUE NAME
USSDV. (0,US%IMM) ;DEVICE NAME
USSSN. (L.SEQ) ;JOB SEQUENCE NUMBER
USSUN. (CDRCNT) ;TOTAL CARDS READ
USCRT. (.EQAFT(Q)) ;CREATION DATE/TIME OF REQUEST
USDSP. (<'BATCH '>,US%IMM) ;DISPOSITION
USTXT. (<-1,,[ASCIZ / /]>) ;SYSTEM TEXT
USPRI. (L.PRIO) ;JOB PRIORITY
USCCT. (L.CON) ;CONNECT TIME
USNM2. (<POINT 7,.EQOWN(Q)>) ;USER NAME (TOPS20)
0 ;END OF LIST
> ;END OT TOPS-20 CONDITIONAL
FACT< EXP .FACT ;DAEMON WRITE FACT FILE FUNCTION
FACTBL: BLOCK 13 > ;FACT BLOCK FILLED IN
SUBTTL Usage Accounting Routines -- ACTINI - Set Up Usage Accounting
; ====== -----------------------
;
ACTINI: MOVX S1,-1 ;-1 For us
MOVX S2,JI.JNO ;Function code
$CALL I%JINF ;Get our job number
MOVEM S2,L.JOB ;Store it
SETZM L.NODE ;Default to detached
MOVE S1,[ASCII/D/] ;DEFAULT TO DETACHED
MOVEM S1,L.TTY ;SAVE THE DESIGNATOR
MOVE S1,L.JOB ;Get job number
TOPS10 < ;TOPS-10 ONLY
GETLIN S1, ;GET OUR TTY NUMBER
TLNN S1,-1 ;ARE WE DEATCHED ???
$RETT ;YES,,SKIP THIS
GTNTN. S1, ;GET OUR LINE NUMBER
$RETT ;YES,,SKIP THIS
HLRZM S1,L.NODE ;SAVE OUR NODE NUMBER
SETOM S2 ;GET A -1
TRMNO. S2, ;GET OUR TTY NUMBER
$RETT ;YES,,SKIP THIS
GETLCH S2 ;GET OUR LINE CHARACTERISTICS
MOVE TF,[ASCII/T/] ;DEFAULT TO A TTY
TXNE S2,GL.ITY ;ARE WE A PTY ???
MOVE TF,[ASCII/P/] ;YES,,MAKE US 'PTY'
TXNE S2,GL.CTY ;ARE WE THE CTY ???
MOVE TF,[ASCII/C/] ;YES,,MAKE US 'CTY'
MOVEM TF,L.TTY ;SAVE THE TERMINAL DESIGNATOR
HRRZM S1,L.LIN ;SAVE THE LINE NUMBER
$RETT ;RETURN
> ;END OF TOPS-10 CONDITIONAL
TOPS20 < ;TOPS-20 ONLY
$RETT ;RETURN
> ;END OF TOPS-20 CONDITIONAL
SUBTTL TOPS-10 Accounting Routines --
TOPS10 <
;***THIS CONDITIONAL CONTINUES FOR APPROXIMATELY 18 PAGES**
; IT TERMINATES AFTER INPAUX ROUTINE
COMMENT /
TOPS-10 Accounting Routines
The Accounting File Handlers are a set of routines which
manipulate the ACCT.SYS and AUXACC.SYS files.
The routines are:
SRHAUX Search AUXACC.SYS
MAKSL Generate Search List
MAKPTH Make UFD and SFD's
SETUFL Routine to Set UFD Interlock
DOACCT Setup all accounting for a specific job
/
.AFMT2==2 ;OUR ACCT.SYS FORMAT
.AFMT3==3 ;NEW VM ACCT.SYS FORMAT
.AFMT4==4 ;[1056] SCHED AND ENQ/DEQ ACCT.SYS
.UFMT==0 ;OUR AUXACC.SYS FORMAT
.UBKS==5 ;WORDS/STR IN AUXACC
;FD FOR SYS:AUXACC.SYS
AUXFD: $BUILD FDMSIZ
$SET (.FDLEN,FD.LEN,FDMSIZ)
$SET (.FDSTR,,<SIXBIT/SYS/>)
$SET (.FDNAM,,<SIXBIT/AUXACC/>) ;FILENAME
$SET (.FDEXT,,<SIXBIT/SYS/>) ;EXTENSION
$SET (.FDPPN,,0) ;PPN
$EOB
SUBTTL TOPS-10 Accounting Routines -- ACTOPN - Open accounting file
COMMENT \
Routine to open either of the accounting files for input.
The data mode is binary.
\
ACTOPN: PUSH P,S1 ;SAVE ADDRESS OF THE FD
PUSHJ P,CLRFOB ;ZERO THE FOB BLOCK
POP P,S1 ;RESTORE ADR OF FD
STORE S1,L.FOB+FOB.FD ;SAVE IT IN THE FOB
MOVEI S1,^D36 ;LOAD THE BYTE SIZE
STORE S1,L.FOB+FOB.CW,FB.BSZ ;STORE IT
MOVX S1,FOB.MZ ;SIZE OF THE FOB
MOVEI S2,L.FOB ;STORE IT
$CALL F%IOPN ;OPEN THE FILE
JUMPF AUXERR ; Abort on failure
$RETT ;RETURN ON SUCCESSFUL OPEN
SUBTTL TOPS-10 Accounting Routines -- AUXSCN - Scan for next AUXACC entry
COMMENT \
AUXSCN - Routine to scan for the beginning of an entry. First word of
each entry contains a -1. On return P1 = count of STR words
following. The PPN is returned in S2. P2 contains the relative file
byte position of this AUXACC entry. Note, it always points to the
[-1] word.
\
AUXSCN: MOVE S1,L.XIFN ;GET OUR IFN
$CALL F%IBYT ;GET THE NEXT WORD
JUMPF AUXERR ;ERROR
CAME S2,[-1] ;BEGINNING OF NEXT ENTRY?
JRST AUXSCN ;NO, KEEP GOIN'
MOVE S1,L.XIFN ;GET THE IFN
$CALL F%CHKP ;DETERMINE OUR POSITION
MOVEI P2,-1(S1) ;POINT TO THE [-1]
MOVE S1,L.XIFN ;GET OUR IFN AGAIN
$CALL F%IBYT ;GET THE SIZE
MOVE P1,S2 ;RELOCATE IT
MOVE S1,L.XIFN ;THE IFN
$CALL F%IBYT ;GET THE PPN
JUMPF AUXERR ;FALSE RETURN ALWAYS AN ERROR
$RETT
SUBTTL TOPS-10 Accounting Routines -- SRHAUX - Search AUXACC for entry
COMMENT \
SRHAUX -- Routine to search AUXACC.SYS. Starts searching at
word specified by in-core index. Returns "TRUE" if entry
found, with the second word .AUNUM in P1 and next call to
RDAUX will get first STR name.
Enter with S1=Replacement register index.
Caution: The loops in this routine are strangely nested, read
it slowly.
\
SRHAUX:
MOVX S1,AUXFD ; Get FD for AUXACC.SYS
PUSHJ P,ACTOPN ; Open the file
MOVEM S1,L.XIFN ; Save the IFN
MOVE T2,.EQOID(Q) ;GET USER'S PPN
TRNE T2,1B18 ;FUNNY NUMBER?
HRRI T2,777776 ;YES, GET STANDARD FLAG FOR IT
JRST SRHU.3 ;AND JUMP INTO THE LOOP
SRHU.2: HLRZ T3,S2 ;GET ENTRIES PROJ # IN T3
HLRZ T1,T2 ;GET USER'S PROJ # IN T1
CAMN T1,T3 ;ARE THEY THE SAME PROJECT?
JRST SRHU.4 ;YES, CHECK IT OUT
CAMG T1,T3 ;NO, IT USER'S BIGGER?
$RETF ;NO, USER'S IS SMALLER, ENTRY IS
; NOT THERE.
SRHU.3: PUSHJ P,AUXSCN ;GET THE NEXT ENTRY
JUMPF .RETF ;EOF, NO ENTRY!!
CAMN S2,T2 ;EXACT MATCH?
PJRST SRHU.6 ;YES, HOW LUCKY
JRST SRHU.2 ;NO, LOOP TILL WE GET THERE
SRHU.4: TRC S2,-1 ;TRICK THE PROG NUMBER
TRCN S2,-1 ;TRICK BACK AGAIN
PJRST SRHU.6 ;ALL 1'S IS WILDCARD, RETURN
JRST SRHU.3 ;AND LOOP
SRHU.6: MOVE S1,.EQOID(Q) ;GET REAL PPN
TRNE S1,1B18 ;FUNNY NUMBER?
HRRI S1,-2 ;YES
$RETT ;
SUBTTL TOPS-10 Accounting Routines -- MAKSL - Make a search list
COMMENT %
MAKSL -- Routine To Generate a Search List Call with RDAUX
ready to read user's first structure name and P1 containing
number of words from .AUNUM. Calls MAKPTH to setup UFD and
SFD and if MAKPTH says it's OK, put the structure in my
Search List.
%
MAKSL: $CALL .SAVE3 ;SAVE P1 - P3
MOVEI P3,L.SL2+1 ;WHERE TO START STORING ARGS
TXNE F,F.SITG ;[SITGO] SITGO deck?
JRST MAKS.S ;[SITGO] Yes, set up correct search list
MOVE S2,P1 ;COPY WORD COUNT INTO S2
IDIVI S2,.UBKS ;CONVERT TO # STRS
MOVE P2,S2 ;A COUNTER
MOVE P1,S2 ;LATER ARGUMENT TO STRUUO
MAKS.1: MOVE S1,L.XIFN ;GET THE IFN
$CALL F%IBYT ;GET THE STRUCTURE NAME
JUMPF AUXERR
MOVEM S2,(P3) ;STORE STRUCTURE NAME
SETZM 1(P3) ;2ND WORD OF TRIPLET IS 0
PUSHJ P,MAKPTH ;MAKE UFD AND SFD
JUMPF MAKS.3 ;MAKPTH SAYS DON'T USE THIS ONE
MOVE S1,L.XIFN ;GET THE IFN
$CALL F%IBYT ;GET THE STATUS BITS
JUMPF AUXERR
MOVEM S2,2(P3) ;STORE THEM
MAKS.2: ADDI P3,3 ;POINT TO NEXT ENTRY
SKIPA
MAKS.3: SOS P1 ;ONE LESS FOR STRUUO
SOJG P2,MAKS.1 ;AND LOOP FOR THEM ALL
MOVEM P1,L.SL2 ;SAVE NUM OF STRS
MOVEI T1,L.SL2 ;LOAD ADDRESS OF BLOCK
MOVEI T2,SLLEN+.PTPPN(T1) ;POINT TO PATH BLOCK
HRLI T2,.EQPAT(Q) ;SETUP TO BLT THE PATH
BLT T2,SLLEN+.PTPPN+5(T1) ;BLT THE FULL PATH
MOVX T2,.PTSCN ;/NOSCAN
MOVEM T2,L.SL2+SLLEN+.PTSWT ;STORE SWITCH
PJRST SETSRC ;SET THE S/L, PATH AND RETURN
MAKS.S: MOVEI S1,1 ;[SITGO] Only one structure
MOVEM S1,L.SL2 ;[SITGO] Save it
MOVE S1,L.QUST ;[SITGO] Get the structure name
MOVEM S1,(P3) ;[SITGO] Save it
SETZM 1(P3) ;[SITGO] Clear the other words
SETZM 2(P3) ;[SITGO] . . .
MOVX S1,.PTMAX ;[SITGO] Get the size of the path block
MOVEI S1,L.SL2+SLLEN ;[SITGO] Get the address
$CALL .ZCHNK ;[SITGO] Clear it out
MOVE S1,L.QPPN ;[SITGO] Get the place to put this
MOVEM S1,L.SL2+SLLEN+.PTPPN ;[SITGO] Save the PPN
MOVEI T1,L.SL2 ;[SITGO] Get the block address
PJRST SETSRC ;[SITGO] And set up the search list
SUBTTL TOPS-10 Accounting Routines -- MAKPTH - Create UFD and SFD on a STR.
COMMENT \
MAKPTH -- Routine to create UFD and SFD on a STR. Call with S2
containing structure name.
Call:
PUSHJ P,MAKPTH
Return here if can't do it (AUXACC is scanned till next entry)
Return here normally
Non-skip return implies that STR should not be put in S/L
\
MAKPTH: $CALL .SAVE3 ; Save 3 P registers
MOVE P1,[ELBLOK,,ELBLOK+1]
SETZM ELBLOK ;CLEAR THE FIRST WORD
BLT P1,ELBLOK+.RBDED ;CLEAR THE WHOLE UUO BLOCK
MOVX P1,.IODMP ;USE DUMP MODE
MOVE P2,S2 ;GET STR NAME
MOVEM P2,L.UFIN+1 ;SAVE FOR STRUUO TO LOCK UFD
SETZ P3,0 ;NO BUFFERS
OPEN UFD,P1 ;OPEN THE CHANNEL
JRST MAKP.5 ;CAN'T DO IT
MOVEI P1,.RBDED ;START SETTING UP UUOBLK
MOVEM P1,ELBLOK ;FIRST WORD
MOVE P1,.EQOID(Q) ;HIS PPN IS FILENAME
MOVEM P1,ELBLOK+.RBNAM ;STORE IT
MOVEM P1,L.UFIN+2 ;SAVE FOR STRUUO TO LOCK UFD
MOVSI P1,'UFD'
MOVEM P1,ELBLOK+.RBEXT ;STORE EXTENSION
MOVE P1,L.MFPP ;PUT IT IN MFDPPN
MOVEM P1,ELBLOK+.RBPPN
MOVE S1,L.XIFN ;GET THE IFN
$CALL F%IBYT ;READ AND IGNORE RSVD QUOTA
JUMPF AUXERR ;ERROR
MOVE S1,L.XIFN ;GET THE IFN
$CALL F%IBYT ;READ THE FCFS QUOTA
JUMPF AUXERR ;ERROR
MOVEM S2,ELBLOK+.RBQTF ;AND STORE IT
MOVE S1,L.XIFN ;IFN
$CALL F%IBYT ;READ THE LOG-OUT QUOTA
JUMPF AUXERR ;ERROR
MOVEM S2,ELBLOK+.RBQTO ;STORE THAT
MOVX S2,RP.DIR ;GET DIRECTORY BIT
MOVEM S2,ELBLOK+.RBSTS ;SAVE AS FILE STATUS
MOVE S1,L.DEXP ; Get expiration date
PUSHJ P,FIXXPD ; Convert it to UDT format
MOVEM S1,ELBLOK+.RBDED ; Save it
SKIPN ELBLOK+.RBQTF ;NO LOGGED IN QUOTA?
JRST MAKP.4 ;YES, THEN DON'T MAKE A UFD
SKIPN P1,.EQPAT+1(Q) ;GET SFD NAME FOR LATER
JRST MAKP.1 ;NO PATH
MOVSI P2,'SFD' ;THE EXTENSION
SETZ P3,0
MOVE P4,.EQOID(Q) ;AND USER'S PPN
MAKP.1: PUSHJ P,SETUFL ;SET THE UFD INTERLOCK
LOOKUP UFD,ELBLOK ;LOOKUP THE UFD
JRST MAKP.2 ;IT'S NOT THERE! GO ENTER IT
JRST MAKP.3 ;ITS THERE, GO MAKE AN SFD
MAKP.2: ENTER UFD,ELBLOK ;ENTER THE UFD
JRST MAKP.3 ;MAYBE ITS THERE!, GO TRY FOR SFD
USETO UFD,2 ;MAKE 1 BLOCK
MAKP.3: CLOSE UFD, ;CLOSE UFD OFF
JUMPE P1,MAKP.4 ;[1052] RETURN IF NO SFD
ENTER UFD,P1 ;ENTER THE SFD
JFCL ;DON'T WORRY NOW
MAKP.4: RELEASE UFD, ;[1052] RELEASE CHANNEL
$RETT ;AND RETURN
MAKP.5: MOVEI P1,.UBKS-1 ;SETUP TO READ THE REST OF THE ENTRY
MAKP.6: MOVE S1,L.XIFN ;IFN
$CALL F%IBYT ;READ THE WORD
JUMPF AUXERR ;ERROR
SOJG P1,MAKP.6 ;AND LOOP
$RETF ;AND RETURN
SUBTTL TOPS-10 Accounting Routines -- FIXXPD - Expiration date conversion
;Call:
; MOVE S1,React-expiration date
; PUSHJ P,FIXXPD
;Returns with S1=Universal date/time (0=none, .INFIN=never)
FIXXPD: JUMPE S1,.RETT ;Leave zero alone
CAIL S1,77777 ;See if large (from REACT)
JRST FIXX.1 ;Yes--Make .INFIN
MOVEI T1,0 ;No time (we'll fix later)
MOVE T2,S1 ; Date to T2
PUSHJ P,.CNVDT ;Convert to universal format
MOVE S1,T1 ; Get UDT to S1
ADD S1,[1,,0] ;Bump to next day as PPN really expires
; one millisecond before midnite
$RETT ;And return
FIXX.1: MOVX S1,.INFIN ;Get largest date
$RETT ;And return
SUBTTL TOPS-10 Accounting Routines -- .CNVDT - Convert to UDT
;.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
RADIX 10 ;**** NOTE WELL ****
.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
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
;UNDER RADIX 10 **** NOTE WELL ****
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
;BACK TO OUR FAVORITE RADIX
RADIX 8
SUBTTL TOPS-10 Accounting Routines -- SETUFL - Set UFD interlock
COMMENT \
SETUFL WORKS AS A CO-ROUTINE WITH ITS CALLER. IF IT IS
CALLED, IT SETS THE INTERLOCK AND CALLS THE CALLER, SO WHEN
THE CALLER RETURNS THE INTERLOCK IS CLEARED FIRST.
THIS IS USED SO THAT THE INTERLOCK IS CLEARED BEFORE
RETURNING AND JOBINT IS RESTORED.
\
SETUFL: MOVX T1,.FSULK ;LOCK CODE
MOVEM T1,L.UFIN ;STORE IN STRUUO BLOCK
MOVEI T1,^D100 ;NO. TIMES TO TRY INTERLOCK
SETUF1: MOVE T2,[3,,L.UFIN] ;LOAD ARG TO STRUUO
STRUUO T2, ;DO THE UUO
SKIPA ;IT FAILED
JRST SETUF2 ;WIN, RETURN (SORT OF)
MOVEI T2,1 ;SLEEP FOR 1 SEC
SLEEP T2, ;ZZZ
SOJG T1,SETUF1 ;AND TRY AGAIN
;FORGET IT!!
SETUF2: POP P,T1 ;LOAD RETURN ADDRESS
PUSHJ P,(T1) ;CALL HIM BACK
JRST CLRUFL ;HERE IF HE POPJ'ED
AOS -1(P) ;HERE IF HE .POPJ1'ED
;AND FALL INTO CLRUFL
SUBTTL TOPS-10 Accounting Routines -- CLRUFL - Clear UFD interlock
;CLRUFL -- ROUTINE TO CLEAR UFD INTERLOCK
CLRUFL: MOVX T1,.FSUCL ;UNLOCK CODE
MOVEM T1,L.UFIN ;STORE IT
MOVE T2,[3,,L.UFIN]
STRUUO T2, ;DO THE UUO
$STOP(CCI,Cant clear UFD Interlock)
POPJ P,0 ;OK, RETURN
SUBTTL TOPS-10 Accounting Routines -- GETSRC/SETSRC - GET/SET Search-List
COMMENT \
GETSRC and SETSRC are used to get and set SPRINT's search
list. Both are called with T1 containing the address of a
block as described below. GETSRC reads the current search
list and returns it in the specified block. SETSRC sets the
search-list from the contents of the block.
Following the searchlist block is a block for the PATH. GETSRC
reads SPRINT's current PATH into this block, and SETSRC sets
the PATH from the block.
Calls:
MOVEI T1,ADR OF BLOCK
PUSHJ P,GETSRC (or SETSRC)
Always return here
\
;The format of the block is as follows:
; !-------------------------------------!
; ! NUMBER OF STRUCTURES !
; !=====================================!
; ! FILE STRUCTURE #1 !
; !-------------------------------------!
; ! 0 !
; !-------------------------------------!
; !RO!NC! !
; !=====================================!
; ! FILE STRUCTURE #2 !
; !-------------------------------------!
; ! 0 !
; !-------------------------------------!
; !RO!NC! !
; !=====================================!
; ! !
; / . /
; / . /
; / . /
; ! !
; !=====================================!
; ! FILE STRUCTURE #N !
; !-------------------------------------!
; ! 0 !
; !-------------------------------------!
; !RO!NC! !
; !=====================================!
;--
;GETSRC -- Routine to return current search list
GETSRC: PUSH P,T1 ;SAVE ADDRESS OF BLOCK
AOS T1 ;SKIP OVER FIRST WORD FOR COUNT
SETZ T3,0 ;CLEAR TO COUNT STRS
SETOM (T1) ;CLEAR TO GET FIRST STR
JRST GETS.2 ;AND JUMP INTO LOOP
GETS.1: MOVE T2,(T1) ;GET RESULT OF LAST JOBSTR
ADDI T1,3 ;POINT TO NEXT 3 WORDS
MOVEM T2,(T1) ;AND USE AS ARGUMENT TO NEXT JOBSTR
GETS.2: MOVSI T2,3 ;3 WORD ARGUMENT
HRRI T2,(T1) ;STARTING THERE
JOBSTR T2, ;DO IT,
JRST GETS.4 ;LOSE BIG!!
SKIPN T2,(T1) ;GET THE ANSWER
JRST GETS.3 ;ZERO MEANS WE'RE DONE
AOJE T2,GETS.3 ;SO DOES -1
AOJA T3,GETS.1 ;ELSE LOOP AROUND
GETS.3: POP P,T1 ;RESTORE T1
MOVEM T3,(T1) ;SAVE STR COUNT
MOVEI T1,SLLEN(T1) ;POINT TO PATH BLOCK
MOVX T2,.PTFRD ;FUNC TO READ MY PATH
MOVEM T2,.PTFCN(T1) ;STORE IT
SETZM .PTSWT(T1) ;CLEAR FLAGS
HRLI T1,PTLEN ;LOAD THE LENGTH
PATH. T1, ;READ THE PATH
GETS.4: $STOP(CRS,Cant read searchlist)
POPJ P, ;AND RETURN
;SETSRC -- Routine to set search list
SETSRC: SKIPN (T1) ;ARGUMENT BLOCK CLEAR?
POPJ P, ;YES, RETURN
PUSH P,(T1) ;SAVE FIRST WORD OF BLOCK
MOVX T2,.FSSRC ;SET S/L FUNCTION
EXCH T2,(T1) ;SWAP THEM
IMULI T2,3 ;3 WORDS/STR
AOS T2 ;PLUS FUNCTION WORD
MOVSS T2 ;PUT IN LH
HRRI T2,(T1) ;ADR OF BLOCK
STRUUO T2, ;DO IT
JRST SETSR1 ;LOSE BIG!!
POP P,(T1) ;RESTORE FIRST WORD OF BLOCK
MOVEI T1,SLLEN(T1) ;GET POINTER TO PATH BLOCK
MOVX T2,.PTFSD ;FUNC TO SET PATH
MOVEM T2,.PTFCN(T1) ;STORE IT
HRLI T1,PTLEN ;PUT THE LENGTH IN
PATH. T1, ;SET THE PATH
SETSR1: $STOP(CSS,Cant set searchlist)
POPJ P, ;AND RETURN
SUBTTL TOPS-10 Accounting Routines -- DELSRL - Delete Search-List
;
; Routine to delete current search list
;
DELSRL: MOVX T1,.FSDSL ;STRUUO CODE
SETOB T2,T3 ;MY JOB, MY PPN
MOVX T4,DF.SRM ;DELETE ALL STRUCTURES
MOVE S1,[4,,T1] ;ARG TO STRUUO
STRUUO S1,0 ;ZAP THE S/L
$RETF ;CAN'T SAY WE DIDN'T TRY!
$RETT
>;END TOPS10 (FROM WAY-WAY BACK)
SUBTTL TOPS-10 Accounting Routines -- DOACCT - Do all job accounting
TOPS10 <
COMMENT \
DOACCT -- Routine to setup and do all the accounting for a
job. Call with the PPN in .EQOID. Does all the ACCT.SYS and
AUXACC stuff, checks the Password, and sets the Search-List.
\
DOACCT: $CALL .SAVE3 ; Get 3 P regs
MOVEI S1,.EQPSZ-.EQPAT ; Length of path block
MOVEI S2,.EQPAT(Q) ; Beginning of the path block
$CALL .ZCHNK ; Zero out the path block
MOVE T1,.EQOID(Q) ;GET THE PPN
MOVEM T1,.EQPAT(Q) ;STORE IN PATH BLOCK
PUSHJ P,FUNNY ;MAKE A FUNNY NAME
TLO S1,'SF ' ;AND MAKE AN OBVIOUS NAME
TXNE F,F.USFD ;UNIQUE SFD ?
MOVEM S1,.EQPAT+1(Q) ; Yes, STORE IN THE PATH BLOCK
MOVE S1,[OUPLEN,,OUPBLK] ; Point to QUEUE. arguments
QUEUE. S1, ; Ask ACTDAE for user profile
PJRST DO10E1 ; It's not there!!
MOVEI P1,PROFIL ; Point to profile block
LOAD S1,.ACWRD(P1),AC.VRS ; Get version #
CAIL S1,.AFMT2 ; Make sure we know how to
CAILE S1,.AFMT4 ; process this entry
JRST BAFERR ; Can't do this kind
AOS P1 ; Point to profile entry
DATE S1, ;GET DATE
LOAD S2,.ACESE(P1),AC.EXP ; Get directory expiration date
MOVEM S2,L.DEXP ; Save expiration date
CAML S1,S2 ; PPN expire ?
PJRST DO10E6 ; Yes
MOVE T1,.ACPRO(P1) ; Get the profile word
TXNN T1,AC.BAT ; Can it LOGIN as batch job?
PJRST DO10E3 ; No!!
TXNN T1,AC.NRB ;NAME REQURED FOR BATCH?
JRST DO10.G ;NO, CONTINUE
SKIPN .ACNM1(P1) ;YES, SEE IF ACCT ENTRY IS ZERO
SKIPE .ACNM2(P1) ;CHECK SECOND WORD
SKIPA ;NON-ZERO
JRST DO10.H ;ZERO!!, DON'T CHECK
MOVE S1,.EQOWN(Q) ;GET FIRST HALF GIVEN
CAME S1,.ACNM1(P1) ;MATCH?
PJRST DO10E5 ;NO, ERROR
MOVE S1,.EQOWN+1(Q) ;GET SECOND HALF
CAME S1,.ACNM2(P1) ;MATCH??
PJRST DO10E5 ;NO!
JRST DO10.H ;ITS OK!!
DO10.G: TXNE F,F.NAME ;DID HE SPECIFY NAME SWITCH?
JRST DO10.H ;YES, DON'T PUT IN OFFICIAL NAME
MOVE S1,.ACNM1(P1) ;GET FIRST HALF
MOVEM S1,.EQOWN(Q) ;STORE IT
MOVE S1,.ACNM2(P1) ;GET SECOND HALF
MOVEM S1,.EQOWN+1(Q) ;AND STORE IT
DO10.H: TXNN T1,AC.ACT ; Account string required?
JRST DO10.I ; No, continue
TXNN F,F.ACCT ; Did he specify /ACCOUNT
PJRST DO10E4 ; No, error
DO10.I: SETZM ACCPSW ; Zero password field
MOVE T2,L.PPN ;GET SPECIFIED PPN
CAME T2,L.EQCP+.EQOID ;SAME AS SUBMITTER?
TXNN T1,AC.PRB ;DOES IT NEED A PASSWORD?
JRST DO10.J ; No, validate account string
HLRZ T2,T2 ;[SIT] Get the project number
CAIN T2,1 ;[SIT] project 1?
JRST DO10E2 ;[SIT] Yes, punt it
PUSHJ P,CRD$CC ; Yes, get a card
TXNN S1,CD.PAS ; Is it a $PASSWORD?
PJRST MSGIMP ; No, lose
MOVEI S1,AR.NAM ; Where to put string
PUSHJ P,S$QUOT ; Pick up string
HRROI S1,AR.NAM ; Point to string
PUSHJ P,S$SIXB ;Convert to sixbit
MOVEM S2,ACCPSW ; Save it in arg block
MOVE S1,[ACCLEN,,ACCBLK] ; Point to QUEUE. arguments
QUEUE. S1, ; Ask ACTDAE to validate this
PJRST DO10E2 ; Invalid
JRST DO10.K ; Finsih up
DO10.J: SKIPN ACTVAL ;Validation enabled ???
JRST DO10.K ;No,,he wins
MOVE S1,[VALLEN,,VALBLK] ; Point to QUEUE. arguments
QUEUE. S1, ; Validate account string
PJRST DOAC.5 ; No good!!
DO10.K: $TEXTL(<^I/STMSG/[SPTBJD Batch job's directory is [^A>)
$TEXTL(<^O/.EQPAT(Q),LHMASK/,^O/.EQPAT(Q),RHMASK/^A>)
SKIPE .EQPAT+1(Q) ;ARE THERE ANY?
$TEXTL(<,^W/.EQPAT+1(Q)/^A>)
$TEXTL(<]>)
PUSHJ P,SRHAUX ; Search AUXACC
JUMPF DO10.L ; No AUXACC entry
PUSHJ P,MAKSL ;MAKE SEARCH LIST AND UFD'S
SKIPA
DO10.L: $TEXTL(<^I/STERR/%SPTNAU No AUXACC entry>)
MOVE S1,L.XIFN ; Get IFN of AUXACC
PJRST F%REL ; Close it off and return
$RETT ;AND RETURN
DO10E1: $TEXTL(<^I/FATAL/?SPTIPN ^I/EM.IPN/>)
JSP B,ACTCER ;AND DIE
EM.IPN: ITEXT (<Invalid PPN "^U/.EQOID(Q)/">)
DO10E2: $TEXTL(<^I/FATAL/?SPTIPA ^I/EM.IPA/>)
JSP B,ACTCER ;AND DIE
EM.IPA: ITEXT (<Password and/or account string is invalid for PPN "^U/.EQOID(Q)/">)
DO10E3: $TEXTL(<^I/FATAL/?SPTPNB ^I/EM.PNB/>)
JSP B,ACTCER ;
EM.PNB: ITEXT (<PPN may not run batch jobs>)
DO10E4: $TEXTL(<^I/FATAL/?SPTNAS ^I/EM.NAS/>)
JSP B,JOBCER ;
EM.NAS: ITEXT (<No account string supplied>)
DO10E5: $TEXTL(<^I/FATAL/?SPTIUN ^I/EM.IUN/>)
JSP B,JOBCER ;
EM.IUN: ITEXT (<Illegal or missing user name>)
DO10E6: $TEXTL(<^I/FATAL/?SPTPHE ^I/EM.PHE/>)
JSP B,ACTCER
EM.PHE: ITEXT (<PPN has expired>)
SUBTTL TOPS-10 Accounting Routines -- Error traps
AUXERR: $TEXT(LOGTXT,<^I/FATAL/?SPTERA ^I/EM.ERA/>)
JSP B,PROCER
EM.ERA: ITEXT(<Error reading System Accounting File ^F/AUXFD/^M^J(^E/S1/)>)
BAFERR: $TEXT(LOGTXT,<^I/FATAL/?SPTBAF ^I/EM.BAF/>)
JSP B,PROCER
EM.BAF: ITEXT(<Bad format for System Accounting File>)
>;END TOPS10
SUBTTL TOPS-20 Accounting Routines -- DOACCT - Do all job accounting
TOPS20 <
COMMENT \
DOACCT -- Routine to setup and do all accounting for a job.
Call with User name string in L.UNAM.
\
DOACCT: MOVX S1,RC%EMO ;EXACT MATCH ONLY
HRROI S2,.EQOWN(Q) ;POINT TO STRING
RCUSR ;CONVERT IT
TXNE S1,RC%NOM ;MATCH?
JRST DOAC.3 ;NO, TELL HIM
MOVEM T1,L.USNO ;SAVE RETURNED INFO
MOVEM T1,.EQOID(Q) ;SAVE THE OWNER ID
MOVE S1,[POINT 7,L.UDIR] ;LOAD A BYTE POINTER
MOVEM S1,L.BP ;STORE IT
$TEXT(DEPBP,<PS:^7/[74]/^T/.EQOWN(Q)/^7/[76]/^0>)
SKIPE CDRDEV ; Physical reader?
JRST DOAC.0 ; Yes, password required!
HRROI S1,L.EQCP+.EQOWN ; No, compare directories
HRROI S2,.EQOWN(Q) ;..
PUSHJ P,S%SCMP ;..
JUMPN S1,DOAC.0 ;JUMP IF DIFFERENT
SETOM NOPSW ;SET NO PASSWORD FLAG
JRST DOAC.1 ; and don't try to read one
DOAC.0: PUSHJ P,CRD$CC ; Get a card
TXNN S1,CD.PAS ; Is it a $PASSWORD?
PJRST MSGIMP ; No, lose
MOVEI S1,L.UPSW ; Where to put string
PUSHJ P,S$ASCZ ; Pick up string
DOAC.1: MOVX S1,RC%EMO ;EXACT MATCH
HRROI S2,L.UDIR ;POINT TO THE STRING
RCDIR ;GET DIRECTORY NUMBER
TXNE S1,RC%NOM ;BETTER BE A MATCH!!
JRST DOAC.3 ;NO??
MOVE S1,T1 ;COPY DIR NO INTO S1
MOVEI S2,L.UDIN ;POINT TO GTDIR BLOCK
HRROI T1,.EQACT(Q) ;
SKIPN .EQACT(Q) ;
MOVEM T1,L.UDIN+.CDDAC ;
MOVEI T1,.CDDAC+1 ;
MOVEM T1,L.UDIN+.CDLEN ;
HRROI T1,L.DPSW ;AND PLACE TO STORE PSW
GTDIR ;GET DIRECTORY INFO
ERJMP DOAC.3 ;LOSE?
MOVE S1,[XWD L.DPSW,L.UPSW] ;SET UP TO TRANSFER
SKIPE NOPSW ; Do we have user supplied pswd?
BLT S1,L.UPSW+7 ; No, so ensure a match!
HRROI S1,L.UPSW ;POINT TO USER STRING
HRROI S2,L.DPSW ;POINT TO CORRECT ONE
$CALL S%SCMP ;STRING COMPARE ROUTINE
JUMPN S1,DOAC.6 ;JUMP IF NO MATCH
MOVE S1,L.USNO
HRROI S2,.EQACT(Q) ;
SKIPE .EQACT(Q) ;
VACCT ;
ERJMP DOAC.5 ;
$RETT ;RETURN
DOAC.3: $TEXTL(<^I/FATAL/?SPTUUN ^I/DOA.3A/>)
JSP B,JOBCER
DOA.3A: ITEXT (<Unrecognized User Name "^T/.EQOWN(Q)/" on the $JOB card>)
>;END TO TOPS20 CONDITIONAL ASSEMBLY
MSGIMP: $TEXTL(<^I/FATAL/?SPTIMP ^I/EM.IMP/>)
JSP B,PSWCER ;
EM.IMP: ITEXT (<Incorrect or missing $PASSWORD card>)
DOAC.5: $TEXTL(<^I/FATAL/?SPTIAS ^I/DOA.5A/>)
JSP B,ACTCER ;
DOA.5A: ITEXT (<Illegal Account String "^T/.EQACT(Q)/">)
DOAC.6: $TEXTL(<^I/FATAL/?SPTIMP ^I/EM.IMP/>)
JSP B,PSWCER ;
DOA.6A: ITEXT (<Specified password incorrect for user>)
SUBTTL QUASAR Message Routines -- QUEJOB - Create batch entry
QUEJOB: TXNN F,F.SITG ;[SITGO] SITGO job?
TXZE F,F.BTCH ;[SITGO] IS THE BATCH BIT SET?
JRST .+2 ;[SITGO] Either real batch job or SITGO job
JRST QUEJ.1 ;[SITGO] NO, JUST PRINT THE LOG FILE
MOVX S1,%SITGO ;GET SITGO BATCH PROCESSOR FLAG
TXNE F,F.SITG ;BATCON OR SITGO ?
STORE S1,.EQROB+.ROBAT(Q),RO.ATR ;STORE SITGO FLAG
TOPS20<
MOVE S1,[POINT 7,.EQCON(Q)] ;FILL OUT CONNECTED DIRECTORY
MOVEM S1,L.BP ;..
$TEXT (DEPBP,<PS:^7/[74]/^T/.EQOWN(Q)/^7/[76]/^0>)
>
$TEXTL(<^I/STSUM/Batch job submitted>)
MOVE S1,CTLIFN ;GET THE CONTROL FILE IFN
MOVEI S2,EQXSIZ(Q) ;AND WHERE TO PUT IT
PUSHJ P,INCFIL ;INCLUDE IN THE MESSAGE
MOVX T1,FP.DEL ;GET DELETE BIT
IORM T1,.FPINF(S1) ;AND SET IT
MOVE S1,LOGIFN ;GET THE LOG IFN
PUSHJ P,INCFIL ;AND INCLUDE IT
SUB S2,Q ;SUB START TO GET LENGTH
STORE S2,.MSTYP(Q),MS.CNT ;STORE TOTAL MESSAGE LENGTH
MOVX T1,FP.FLG ;GET LOG FILE BIT
SKIPE L.LGDS ;/DISP:DEL?
TXO T1,FP.DEL ;YES, SET THE BIT
GETLIM S2,.EQLIM(Q),BLOG ;GET BATCH-LOG ARG
CAXN S2,%BSPOL ;SPOOLED?
TXO T1,FP.SPL!FP.DEL ;YUP
IORM T1,.FPINF(S1) ;AND STORE IT
MOVX T1,%BAPND ;LOAD APPEND CODE
STOLIM T1,.EQLIM(Q),BLOG ;Always, make it append
GETLIM S1,.EQLIM(Q),ONOD ; Pick up the output field
SKIPE CDRDEV ; Real reader ?
GETLIM S1,L.EQCP+.EQLIM,CNOD ; Yes, get the originating node
STOLIM S1,.EQLIM(Q),ONOD ; Store as the output field
PUSHJ P,LOGCLS ;CLOSE THE LOG FILE
MOVE S1,CTLIFN ;GET THE CTL IFN
$CALL F%REL ;RELEASE IT
SETZM CTLIFN ; CTL file is closed!
MOVX S1,PAGSIZ ;LOAD THE MESSAGE SIZE
MOVE S2,Q ;AND THE ADDRESS
PJRST SNDQSR ;SEND THE MESSAGE
QUEJ.1: MOVE S1,CTLIFN ;GET CTL FILE IFN
$CALL F%RREL ;ABORT THE FILE
SETZM CTLIFN ; CTL file is gone!
$TEXTL(<^I/STSUM/No Batch job submitted>)
JRST QUELOG ;AND QUEUE UP THE LOG FILE
SUBTTL QUASAR Message Routines -- QUELOG - LOG file PRINT request
QUELOG: GETLIM S1,.EQLIM(Q),OUTP ;GET THE /OUTPUT SWITCH
TXNN F,F.FATE ;WAS THERE A FATAL ERROR?
CAXE S1,%EQOLE ;NO, DID HE WANT LOG ON ERROR ONLY?
SKIPA ;FATAL ERROR, ALWAYS GIVE LOG
JRST QUEL.3 ;OUTPUT:ERROR, BUT NO ERROR
$TEXT(LOGTXT,<^I/STSUM/LOG file submitted for printing>)
MOVE S1,LOGIFN ;GET THE LOG FILE IFN
MOVEI S2,EQXSIZ(Q) ;AND WHERE TO PUT IT
PUSHJ P,INCFIL ;INCLUDE THE LOG FILE
SUB S2,Q ;SUBT START ADR FOR LENGTH
STORE S2,.MSTYP(Q),MS.CNT ;AND STORE MESSAGE LENGTH
MOVX S2,FP.FLG ;GET LOG FILE BIT
GETLIM T1,.EQLIM(Q),BLOG ;GET BATCH-LOG ARG
CAXN T1,%BSPOL ;SPOOLED?
TXO S2,FP.SPL!FP.DEL ;YUP, TRANSFER THAT INFO
SKIPE L.LGDS ;CHECK DISPOSITION
TXO S2,FP.DEL ;DELETE IT
IORM S2,.FPINF(S1) ;AND SET THE BITS
PUSHJ P,LOGCLS ;CLOSE THE LOG FILE
MOVX S1,.OTLPT ;LOAD THE PRINTER OBJECT
STORE S1,.EQROB+.ROBTY(Q) ;STORE AS DESIRED DESTINATION
SKIPN CDRDEV ;REAL READER ?
JRST QUEL.1 ;NO..
GETLIM S1,L.EQCP+.EQLIM,CNOD ;GET THE ORIGINATING NODE
JRST QUEL.2 ;GO ON
QUEL.1: GETLIM S1,.EQLIM(Q),ONOD ;GET THE OUTPUT FIELD
SKIPN S1 ;NON-ZERO
MOVE S1,DEFNOD ;NO..GET DEFAULT NODE
QUEL.2: STORE S1,.EQROB+.ROBND(Q) ;YES, STORE AS DESTINATION NODE
MOVX S1,EQLMSZ ;LOAD A COUNT
MOVEI S2,.EQLIM(Q) ;AND AN ADDRESS
$CALL .ZCHNK ;ZERO THE LIMIT WORDS
MOVX S1,'SPRINT' ;MIGHT AS WELL PUT IN A NOTE
STOLIM S1,.EQLIM(Q),NOT1 ;STORE 1ST HALF
MOVX S1,' LOG ' ; TO MAKE IT EASIER FOR HIM
STOLIM S1,.EQLIM(Q),NOT2 ;STORE 2ND HALF
MOVEI S1,^D15 ;LOAD A SMALL PAGE LIMIT
STOLIM S1,.EQLIM(Q),OLIM ;STORE OUTPUT LIMIT
ZERO .EQAFT(Q) ; DITTO DITTO
MOVEI T1,1 ;LOAD NUMBER OF FILES
STORE T1,.EQSPC(Q),EQ.NUM ;AND STORE IT
MOVX S1,PAGSIZ ;SEND A PAGE
MOVE S2,Q ;STARTING THERE
PJRST SNDQSR ;AND SEND THE MESSAGE
QUEL.3: GETLIM S2,.EQLIM(Q),BLOG ;GET BATCH-LOG ARG
MOVEI T1,F%REL ;ASSUME STANDARD CLOSE
CAXE S2,%BSPOL ;IF ITs SPOOLED
SKIPE L.LGDS ;OR DISP:DELETE
MOVEI T1,F%RREL ;THEN DELETE IT
MOVE S1,LOGIFN ;GET THE IFN IN ANY CASE
PUSHJ P,(T1) ;CALL APPROPRIATE ROUTINE
SETZM LOGIFN ;CLEAR OUT THE IFN
MOVE S1,Q ;GET PAGE ADDRESS
PJRST M%RPAG ;RELEASE PAGE AND RETURN
SUBTTL QUASAR Message Routines -- QUEFIL - User file request
QUEFIL: $SAVE <P1> ;Save a reg.
$CALL M%ACQP ;GET A FREE PAGE
MOVE P1,S1 ;SAVE THE PAGE NUMBER
PG2ADR P1 ;AND MAKE AN ADDRESS
MOVS T2,Q ;GET ADR OF JOB PAGE
HRR T2,P1 ;AND THE NEW PAGE
BLT T2,EQHSIZ-1(P1) ;AND BLT THE HEADER
MOVE S1,L.QFN ;GET THE DEVICE
STORE S1,.EQROB+.ROBTY(P1) ;AND STORE IT
SKIPN CDRDEV ;REAL READER ?
JRST QUEF.1 ;NO..
GETLIM S1,L.EQCP+.EQLIM,CNOD ;GET THE ORIGINATING NODE
JRST QUEF.2 ;GO ON
QUEF.1: GETLIM S1,.EQLIM(P1),ONOD ;GET THE OUTPUT FIELD
SKIPN S1 ;NON-ZERO
MOVE S1,DEFNOD ;NO..GET DEFAULT NODE
QUEF.2: STORE S1,.EQROB+.ROBND(P1) ;YES, STORE AS DESTINATION NODE
$TEXTL(<^I/STMSG/[File queued for ^1/L.QFN/ at node ^N/S1/]>)
MOVX S1,EQLMSZ ;LOAD BLOCK LENGTH
MOVEI S2,.EQLIM(P1) ;AND BLOCK ADDRESS
$CALL .ZCHNK ;AND ZERO THE BLOCK
MOVE S1,FILIFN ;GET THE IFN
MOVEI S2,EQHSIZ(P1) ;AND WHERE TO PUT IT
PUSHJ P,INCFIL ;INCLUDE THE FILE
SUB S2,P1 ;SUBTRACT START ADDRESS
STORE S2,.MSTYP(P1),MS.CNT ;STORE MESSAGE SIZE
MOVEI S1,1 ;LOAD NUMBER OF FILES
STORE S1,.EQSPC(P1),EQ.NUM ;AND STORE IT
MOVEI S1,EQHSIZ ;LOAD CREATE HEADER SIZE
STORE S1,.EQLEN(P1),EQ.LOH ;AND STORE IT
MOVX S1,PAGSIZ ;SEND A PAGE
MOVE S2,P1 ;GET THE ADDRESS
PJRST SNDQSR ;AND SEND IT
SUBTTL QUASAR Message Routines -- UPDQSR - Send Update Message
; Update job status
;
UPDQSR: MOVEI S1,[L.STSM,,L.STSM+1] ;SET UP BLT
SETZM L.STSM ;CLEAR THE FIRST WORD
BLT S1,L.STSM+CHE.SZ-1 ;CLEAR THE BLOCK
MOVX S1,.QOCHE ;MESSAGE TYPE
STORE S1,L.STSM+.MSTYP,MS.TYP ;SAVE TYPE IN MESSAGE
MOVX S1,CHE.SZ ;GET MESSAGE SIZE
STORE S1,L.STSM+.MSTYP,MS.CNT ;STORE IT
MOVE S1,L.EQCP+.EQITN ;GET THE ITN
MOVEM S1,L.STSM+CHE.IT ;STORE IT
MOVX S1,CH.FST ;GET UPDATE STATUS FLAG
MOVEM S1,L.STSM+CHE.FL ;STORE IT
$TEXT (<-1,,L.STSM+CHE.ST>,<^T/L.JTXT/^0>)
MOVEI S1,CHE.SZ ;GET MESSAGE LENGTH
MOVEI S2,L.STSM ;GET MESSAGE ADDRESS
PJRST SNDQSR ; Send to QUASAR and return
SUBTTL QUASAR Message Routines -- RELREQ - Release a Request
; ====== -----------------
;
; Here to send a "release" message to QUASAR to indicate the
; termination of a request.
;
RELREQ: MOVX S1,<XWD REL.SZ,.QOREL> ;FIRST WORD OF THE RELEASE
STORE S1,RELMSG+.MSTYP ;AND STORE IT
LOAD S1,L.EQCP+.EQITN ;GET THE ITN
STORE S1,RELMSG+REL.IT ;AND STORE IT
MOVX S1,REL.SZ ;LENGTH OF MESSAGE
MOVEI S2,RELMSG ;AND LOCATION
PJRST SNDQSR ; Send it and return
RELMSG: BLOCK REL.SZ ;BUILD THE RELEASE MESSAGE
SUBTTL QUASAR Message Routines -- Utility subroutines
;SNDQSR -- Routine to send a message to QUASAR
; Call with S1/ length
; S2/ address
SNDQSR: STORE S1,L.SAB+SAB.LN ;STORE THE LENGTH
STORE S2,L.SAB+SAB.MS ;AND THE ADDRESS
MOVEI S1,SP.QSR ;GET SPECIAL INDEX
TXO S1,SI.FLG ;FLAG IT
MOVEM S1,L.SAB+SAB.SI ;STORE IT
MOVEI S1,SAB.SZ ;GET SAB SIZE
MOVEI S2,L.SAB ;GET SAB ADDRESS
$CALL C%SEND ;SEND THE MESSAGE
JUMPT .RETT ;RETURN IF OK
;ELSE GIVE A SEND FAILURE
;Here when a send to QUASAR fails
SNDFAI: $STOP(QSF,QUASAR send failed)
; INCFIL -- Include a file into a CREATE message
;Call with S1 containing the IFN
; S2 containing the adr of the 1st FD WORD
; Creates FP and FD and returns S1 containing the address of
; the FP and S2 containing the address of the first free word.
INCFIL: $CALL .SAVE1 ; Need a P reg
MOVE P1,S2 ;SAVE FP ADDRESS
MOVEI S2,FPMSIZ ;GET FP SIZE
STORE S2,.FPLEN(P1),FP.LEN ;STORE IT
MOVEI S2,1 ;GET A STARTING POINT
STORE S2,.FPFST(P1) ;STORE IT
STORE S2,.FPINF(P1),FP.FCY ;AND A COPIES FIELD
SETO S2, ;GET FULL FILESPEC
$CALL F%FD ;GET FROM GLXFIL
LOAD S2,.FDLEN(S1),FD.LEN ;GET THE LENGTH OF THE FD
HRL S1,S1 ;START MAKING A BLT POINTER
HRRI S1,FPMSIZ(P1) ;POINT TO WHERE TO PUT IT
ADDI S2,FPMSIZ(P1) ;POINT TO THE NEXT FP
BLT S1,-1(S2) ;BLT THE FD
MOVE S1,P1 ;GET RETURN AC
$RETT ;AND RETURN
SUBTTL $TEXT Utilities
; Routine to deposit the character in S1 (as called from
; $TEXT) according to the Byte-Pointer in L.BP
DEPBP: IDPB S1,L.BP ;DEPOSIT THE BYTE
$RETT ;AND RETURN TRUE
FATAL: ITEXT(<^M^J^J^C/[-1]/ STERR >)
STDAT: ITEXT(<^C/[-1]/ STDAT >)
STMSG: ITEXT(<^C/[-1]/ STMSG >)
STERR: ITEXT(<^C/[-1]/ STERR >)
STCRD: ITEXT(<^C/[-1]/ STCRD >)
STSUM: ITEXT(<^C/[-1]/ STSUM >)
ABTSPR: ITEXT (<Input Spooling Processor Error>)
SUBTTL Interrupt System Database
TOPS10 <
VECTOR: BLOCK 4 ;START OF VECTOR BLOCK
> ;END TOPS10 CONDITIONAL
TOPS20 <
LEVTAB: EXP LEV1PC ;WHERE TO STORE LEVEL 1 INT PC
EXP LEV2PC ;WHERE TO STORE LEVEL 2 INT PC
EXP LEV3PC ;WHERE TO STORE LEVEL 3 INT PC
LEV1PC: BLOCK 1 ;LVL 1 INTERRUPT PC STORED HERE
LEV2PC: BLOCK 1 ;LVL 2 INTERRUPT PC STORED HERE
LEV3PC: BLOCK 1 ;LVL 3 INTERRUPT PC STORED HERE
CHNTAB: BLOCK ^D36 ;A NULL INTERRUPT DISPATCH TABLE
> ;END TOPS20 CONDITIONAL assembly
END SPRINT