Google
 

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