Trailing-Edge
-
PDP-10 Archives
-
bb-lw55a-bm
-
galaxy-sources/lptdqs.mac
There are 7 other files named lptdqs.mac in the archive. Click here to see a list.
TITLE LPTDQS - LPTSPL Support for Distributed Queueing System
SUBTTL Gregory A. Scott
SUBTTL Preliminaries
.DIRECTIVE FLBLST
; COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1988.
; ALL RIGHTS RESERVED.
;
; 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 THAT IS NOT SUPPLIED BY DIGITAL.
SEARCH GLXMAC ;Search GLXLIB's symbols
SEARCH LPTMAC ;Search LPTSPL's symbols
SEARCH QSRMAC ;Search QUASAR's symbols
SEARCH ORNMAC ;Search ORION's symbols
IFN FTACNT,<
SEARCH ACTSYM ;Search for accounting symbols
>
SALL ;Suppress macro expansion
RELOC ;Relocatable code follows
PROLOGUE(LPTDQS) ;Generate the necessary symbols
;All of these edit numbers don't make sense.
DQSMAN==:0 ;Maintenance edit number
DQSDEV==:15 ;Development edit number
VERSIN (DQS) ;Generate edit number
Subttl Table of Contents
; Table of Contents for LPTDQS
;
; Section Page
;
;
; 1. Revision History . . . . . . . . . . . . . . . . . . . 4
; 2. Definitions
; 2.1 External and Internal Symbols . . . . . . . . 5
; 2.2 DQS Protocol . . . . . . . . . . . . . . . . . 6
; 2.2.1 Message Types . . . . . . . . . . . . . 7
; 2.2.2 Block Types . . . . . . . . . . . . . . 8
; 2.2.3 Bytes in Message Header and Block . . . 11
; 2.2.4 Message Byte Pointers . . . . . . . . . 12
; 2.3 Assembly Parameters . . . . . . . . . . . . . 13
; 2.4 Storage . . . . . . . . . . . . . . . . . . . 14
; 3. Setup Message . . . . . . . . . . . . . . . . . . . . 15
; 3.1 Build device name . . . . . . . . . . . . . . 16
; 3.2 Open DECnet Link . . . . . . . . . . . . . . . 17
; 4. Shutdown Message . . . . . . . . . . . . . . . . . . . 18
; 5. Next Job Message . . . . . . . . . . . . . . . . . . . 19
; 6. Job Processing . . . . . . . . . . . . . . . . . . . . 20
; 6.1 Remote CREATE request . . . . . . . . . . . . 21
; 6.2 Send Create Request . . . . . . . . . . . . . 22
; 6.3 Send Files . . . . . . . . . . . . . . . . . . 25
; 6.3.1 Send Filespec Message . . . . . . . . . 27
; 6.3.2 Check /FILE and /MODE Switches . . . . . 31
; 6.3.3 Send Error Messages . . . . . . . . . . 32
; 6.3.4 Send Data Messages . . . . . . . . . . . 33
; 6.3.4.1 Ascii Mode . . . . . . . . . . . . 35
; 6.3.4.2 Eleven Format . . . . . . . . . . 36
; 6.3.4.3 Fortran Format . . . . . . . . . . 37
; 6.3.4.4 Octal Mode . . . . . . . . . . . . 39
; 6.3.4.5 Suppress/Arrow Modes . . . . . . . 41
; 6.3.5 Send End Of File Message . . . . . . . . 43
; 6.4 Send EOR . . . . . . . . . . . . . . . . . . . 44
; 6.5 Receive Summary message . . . . . . . . . . . 45
; 6.6 Send Commit Message . . . . . . . . . . . . . 46
; 6.7 Receive End Message . . . . . . . . . . . . . 47
; 6.8 Error Recovery
; 6.8.1 Restart Job . . . . . . . . . . . . . . 48
; 6.8.2 Check DJB Objections . . . . . . . . . . 49
; 6.8.3 Unpack DQS Error . . . . . . . . . . . . 50
; 7. Message Packing Routines
; 7.1 Setup/Finish Message . . . . . . . . . . . . . 53
; 7.2 Put a Byte or Word . . . . . . . . . . . . . . 54
; 7.3 Put a Word or Longword . . . . . . . . . . . . 55
; 7.4 Put a String . . . . . . . . . . . . . . . . . 56
; 7.5 Put a Counted String . . . . . . . . . . . . . 57
; 8. Message Unpacking Routines
; 8.1 Get a Word or Longword . . . . . . . . . . . . 58
; 8.2 Get Variable Length Item . . . . . . . . . . . 59
; 8.3 Get A String . . . . . . . . . . . . . . . . . 60
Subttl Table of Contents (page 2)
; Table of Contents for LPTDQS
;
; Section Page
;
;
; 9. I/O Routines
; 9.1 Load or Store a Byte . . . . . . . . . . . . . 61
; 9.2 Send Data . . . . . . . . . . . . . . . . . . 62
; 9.3 Receive Data . . . . . . . . . . . . . . . . . 63
; 9.4 Wait for Data . . . . . . . . . . . . . . . . 65
; 9.5 Check on Link Status . . . . . . . . . . . . . 66
; 10. Report Log . . . . . . . . . . . . . . . . . . . . . . 67
; 11. End of LPTDQS . . . . . . . . . . . . . . . . . . . . 68
SUBTTL Revision History
COMMENT \
***** Release 6.0 - begin development edits *****
1 6.1036 20-Oct-87
Add LPTDQS as the DQS printer handler for LPTSPL.
2 6.1054 3-Nov-87
Fix various problems. Why should the revision history make
sense if the %&!@ edit numbers don't. Fix leading space on
time queued, length of filespec seperator field.
3 6.1056 4-Nov-87
Remove reference to the checksum word CHECKS.
4 6.1069 10-Nov-87
Send protocol version number in ;BDATA field. Send checkpoints
each 100K characters transmitted instead of each minute. Only
call scheduler each 10K characters transmitted. Insert full
filespec code which is repeat 0ed out due to a DJM 1.0 bug.
Never abort a job from the queue, always requeue it.
5 6.1073 11-Nov-87
Improve logging and error recovery, fix things from last edit.
Add protocol trace facility. Fix stupid smashed AC bug in DQSSND
that kept me busy for days. Remove repeat 0ed code in last edit.
Turn on FTMJ.
6 6.1075 13-Nov-87
Use file reading routine in LPTSUB, do accounting properly.
7 6.1075 13-Nov-87
Fix typeo in last edit.
10 6.1102 24-Nov-87
Shutdown if error in transmission to DQS DJM rather than requeueing.
The /AFTER switch seems to confuse the users, we'll let QUASAR restart
us after a little wait. Also if the link was just disconnected, try
two times to get the job done.
11 6.1111 1-Dec-87
Improve job requeued message.
12 6.1116 2-Dec-87
The data type being stream causes confusion since the VMS system will
think that it is implied carriage control. Revert to undefined to
not have the VMS system put in extra blank lines for us. Also include
the account string for printing on the remote system. Use protocol
version 1.0 for now since 1.1 doesn't seem to read the separator packet
properly.
13 6.1224 7-Mar-88
Since use of recent DQS servers is not required, it seems we have to
default the use of the DECnet link to one job per opening or mixtures
of usernames if the first username queued is longer than the second
username queued are generated on the remote VMS system (and are printed
as such by the symbiont). Setting FTMJ to 0 by default prevents the
gastric distress caused by the rich meal of two DQS jobs in a row.
14 6.1225 8-Mar-88
Update copyright notice.
15 6.1246 4-May-88
Check /FILE and /MODE switches. Support /FILE:ELEVEN and /FILE:FORTRAN
(/FILE:ASCII was assumed for all files). /FILE:COBOL and /REPORT are
not currently supported. Support /MODE:ARROW and /MODE:SUPPRESS and
/MODE:OCTAL (/MODE:ASCII was assumed for all files).
\ ;End of revision history
SUBTTL Definitions -- External and Internal Symbols
;Interns for LPTDQS
INTERN DQSINI,DQSREL,DQSFIX,DQSLOG,DQSJOB
;Globular symbols in LPTSPL
EXTERN CNTSTA,DETDEL,DIRNAM,DSCHD,ENDREQ,JOBACT ;[4]
EXTERN JOBOBA,LPTVNO,NXTFIL,RSETUP,SHUTIN,SNDQSR
EXTERN ENDJOB,ENDREQ,LPCNF,JOBCHK ;[4]
;Globular symbols in LPTSUB
EXTERN ABTLNK,GETLNK,CASTIM,FNDCER,FORMS,INPOPN,INPCLS ;[5]
EXTERN INPBYT,LFINF,LSTAF,LPMSG,LPERR,LOGCHR ;[5] [15]
SUBTTL Definitions -- DQS Protocol
;Steps in request creation:
; Connect to remote DJM
; For each job,
; Send create message
; For each file,
; Send FILESPEC message
; Send FILEDATA message(s)
; Send EOF message
; Send EOR message
; Receive ERROR or SUMMARY message
; Send COMMIT message (no errors) or WITHDRAW message (errors)
; Receive END message from remote DJM
; Disconnect from remote DJM
SUBTTL Definitions -- DQS Protocol -- Message Types
RADIX 5+5 ;Decimal radix
;Message types
.MTCRE==2 ;Create
.MTPAR==3 ;Parameter
.MTFSP==4 ;File spec
.MTFDT==5 ;File data
.MTEOF==6 ;End of file
.MTEOR==7 ;End of request
.MTCOM==8 ;Commit
.MTWIT==9 ;Withdraw
.MTCAN==10 ;Cancel
.MTDIS==11 ;Display
.MTMOD==12 ;Modify
.MTSUM==13 ;Summary
.MTERR==15 ;Error
.MTEND==16 ;End
SUBTTL Definitions -- DQS Protocol -- Block Types
;Block types for the ENVIRONMENT message (not used)
; .BTPVN==1 ;Protocol version
; .BTBFS==3 ;Buffer size
; .BTSUP==4 ;Supported features
; .BTOST==5 ;Operating system type
;Block types for the CREATE, MODIFY, CANCEL, DISPLAY, and SUMMARY
;messages - note that each message does not necessarily support
;all of the block types listed
.BTJNB==1 ;Job number
.BTJNA==3 ;Job name
.BTJOW==4 ;Job owner
.BTQUE==5 ;Queue name
.BTJBS==6 ;Job state
.BTRJN==9 ;Requestor job number
.BTTXT==10 ;Text
.BTJCT==11 ;Job count
.BTPGL==12 ;Page limit
.BTPRI==13 ;Priority
.MVPRI==5 ;[2] Maximum priority allowed
.BTAFT==14 ;After time
.BTNOA==16 ;Notify action
.BTPVN==18 ;Protocol version number
.LNPVN==4 ;[2] Length of protocol version
.BTACT==19 ;Account name
.BTJID==20 ;Jobid list
.BTCAS==21 ;Case type
.BTFRM==22 ;Forms type
.BTCHR==23 ;Characteristics
.LNCHR==^D16 ;Length of characteristics byte string
.BTAJB==24 ;All jobs
.BTNON==29 ;Notify name
.BTFNT==30 ;Font name
.BTP01==31 ;Parameter 1
.BTP02==32 ;Parameter 2
.BTP03==33 ;Parameter 3
.BTP04==34 ;Parameter 4
.BTP05==35 ;Parameter 5
.BTP06==36 ;Parameter 6
.BTP07==37 ;Parameter 7
.BTP08==38 ;Parameter 8
.BTNOT==39 ;Note
.BTTMQ==40 ;Time queued
;Continued on next page
;Continued from previous page
;Block types for the file spec message
.BTFNM==6 ;File name
.BTFTY==8 ;File data type
FT.UDF==0 ;[12] Undefined data type
FT.STM==1 ;[5] Stream data type
.BTFCC==11 ;Copies
.BTFSE==12 ;Separator
SE.HDR==1 ;File headers
SE.BST==4 ;File burst pages
SE.TRL==8 ;File trailers
.BTFEP==14 ;End page
.BTFBL==15 ;Blank lines
.BTFPO==17 ;Page option
PO.PAG==1 ;Paginate
PO.LFS==2 ;Listfilespec (not supported)
.BTFOR==18 ;Fab org
.BTFAT==19 ;Fab rat
.BTFRS==20 ;Fab mrs
.BTFRN==21 ;Fab mrn
.BTFFM==22 ;Fab rfm
.BTFSZ==23 ;Fab fsz
.BTFBK==24 ;Fab bks
.BTFGB==25 ;Fab gbc
.BTFOP==26 ;Fab fop
.BTFAL==27 ;Fab alq
.BTFSP==28 ;Start page
.BTFST==29 ;File setup
;Block types for the FILE DATA message
.BTDAT==1 ;Data transfer
;Block types for the ERROR message
.BTEEL==1 ;Error level
.BTEEC==2 ;Error class
.BTECD==3 ;Error code
.BTEID==7 ;Message id
.BTETX==10 ;Text
;Continued on next page
;Continued from previous page
;Status values
.STHDJ==1 ;Hold waiting for commit
.STHUS==2 ;Hold by user
.STHOP==3 ;Hold by operator
.STHTI==4 ;Hold until designated time
.STHFT==5 ;Hold waiting for file transfer
.STHRW==6 ;Hold waiting for resources
.STSCH==7 ;Scheduled for execution
.STEXC==8 ;Execution in progress
.STSUS==9 ;Execution suspended by user
.STSOP==10 ;Execution suspended by operator
.STSRQ==11 ;Execution suspended by job request
.STSRW==12 ;Execution suspended by resource wait
.STCUS==13 ;Job cancelled by user
.STCOP==14 ;Job cancelled by operator
.STCMK==15 ;Job marked for cancellation
.STSUC==16 ;Job completed (terminated normally)
.STFAI==17 ;Job completed (terminated abnormally)
;Case types
.CTANY==1 ;Any
.CTLOW==2 ;Lower
.CTUPR==3 ;Upper
.CTLQP==4 ;LQP
;Notify action bits
NA.CMP==1 ;Notify on completion
NA.CHG==2 ;Notify on change
NA.TSK==4 ;Notify task
;Error levels
.ELFAT==4 ;Fatal
.ELWRN==3 ;Warning
.ELINF==2 ;Informational
.ELSUC==1 ;Success
;Error classes
.ECRMT==4 ;Remote
.ECDJS==3 ;Djs
.ECUNS==2 ;Unsupported
.ECPRT==1 ;Protocol error
RADIX 4+4
SUBTTL Definitions -- DQS Protocol -- Bytes in Message Header and Block
;The first "n" bytes in the DQS message are the message header.
;The contents of these bytes and their names are:
.HDTYP==0 ;Message type (.MTxxx)
.HDFLG==1 ;Flags (none defined?)
.HDCTX==2 ;Sender's context
.HDBLK==3 ;Number of blocks in body of message
.HDLNL==4 ;Low order byte of message length
.HDLNH==5 ;High order byte of message length
.HDSIZ==6 ;Size of message header
;The first "n" bytes in a DQS message block are the block header.
;The contents of these bytes and their names are:
.BKTYP==0 ;Block type (.btxxx)
.BKLNH==1 ;High order byte of block length
.BKLNL==2 ;Low order byte of block length
.BKSIZ==3 ;Size of block header
SUBTTL Definitions -- DQS Protocol -- Message Byte Pointers
;P.Ixxx are for incoming messages, P.Oxxx are for outgoing messages
;Macro to make byte pointers
;Arguments: OFS - byte offset into message
; ADR - address of message
DEFINE BYTPNT (OFS,ADR),<
$$$WRD==OFS/4 ;;Word offset
$$$POS==<<<OFS&3>+1>*8>-1 ;;Position of right-most bit
POINT 8,$$$WRD+ADR,$$$POS
>; END DEFINE BYTPNT
P.ITYP: BYTPNT (.HDTYP,IBUFF) ;Type
P.OTYP: BYTPNT (.HDTYP,OBUFF)
P.IFLG: BYTPNT (.HDFLG,IBUFF) ;Flags
P.OFLG: BYTPNT (.HDFLG,OBUFF)
P.ICTX: BYTPNT (.HDCTX,IBUFF) ;Context
P.OCTX: BYTPNT (.HDCTX,OBUFF)
P.IBLK: BYTPNT (.HDBLK,IBUFF) ;Number of blocks
P.OBLK: BYTPNT (.HDBLK,OBUFF)
P.ILNH: BYTPNT (.HDLNH,IBUFF) ;High byte of message length
P.OLNH: BYTPNT (.HDLNH,OBUFF)
P.ILNL: BYTPNT (.HDLNL,IBUFF) ;Low byte of message length
P.OLNL: BYTPNT (.HDLNL,OBUFF)
SUBTTL Definitions -- Assembly Parameters
;Some assembly parameters
ND FTMJ,0 ;[13] Zero closes link after each job
ND FTPT,0 ;[5] Zero to remote protocol trace code
ND RTYMAX,2 ;[10] Times to retry this job
ND PVMAJ,1 ;[2] Major protocol version
ND PVMIN,1 ;[2] Minor protocol version
ND PVEDT,0 ;[2] Edit 0 (must be 0)
ND PVUSR,0 ;[2] User version 0 (must be 0)
ND DQSWTM,^D60*^D1 ;Seconds to wait for DJM response
ND OCTWPL,^D4 ;[15] /MODE:OCTAL words per line
ND OCTLPB,^D16 ;[15] /MODE:OCTAL lines per block
ND OCTBPP,^D3 ;[15] /MODE:OCTAL blocks per page
;[2] Spec allows 4096 byte data transfers
ND BFSBYT,^D512 ;Buffer size in bytes
XP BFSWRD,<<BFSBYT+3>/4> ;Buffer size in words
SUBTTL Definitions -- Storage
;Here is the local storage used for LPTDQS
IFN FTPT,< ;[5] Protocol trace?
PTRACE: BLOCK 1 ;[5] If nonzero trace to log file
> ;[5] End of FTPT
PRTVER: BLOCK 4 ;[4] Protocol version
RETRYC: BLOCK 1 ;[10] Retry count for this job
BLKCNT: BLOCK 1 ;Count of bytes in this block
SAVBPP: BLOCK 2 ;[15] Saved /MODE:OCTAL bpp and lpb
SAVWPL: BLOCK 1 ;[15] Saved /MODE:OCTAL wpl
TRNRTN: BLOCK 1 ;[15] Routine to use to print file
TMPBUF: BLOCK BFSWRD ;Temporary buffer for building text
IBPTR: BLOCK 1 ;Input buffer byte pointer
IBCNT: BLOCK 1 ;Input buffer byte count
IBSLT: BLOCK 1 ;Input buffer saved last transfer count
IBUFF: BLOCK BFSWRD ;Input buffer
OBPTR: BLOCK 1 ;Output buffer byte pointer
OBCNT: BLOCK 1 ;Output buffer byte count
OBUFF: BLOCK BFSWRD ;Output buffer
ERRBEG:!
ERRCOD: BLOCK 1 ;Error code
ERRLVL: BLOCK 1 ;Error level
ERRCLS: BLOCK 1 ;Error class
ERRBUF: BLOCK 30 ;Error text buffer
ERREND==.-1 ;End of zeroed block
SUBTTL Setup Message
;INIDQS is called during LPTSPL's setup to build the decnet dcn: device name,
;to open the decnet link and to allocate the buffer for any files that may need
;to be transferred to a remote node. If accounting is enabled, then a listener
;is also started. If the decnet dcn: jfn cannot be obtained or opened, or if
;The listener cannot be started, then a setup response message is sent to
;Quasar indicating that this lptspl is shutting down. The operator is also
;informed that this LPTSPL is being shutdown.
;
;Call is: J/Job Context Pointer
; M/Address of the SETUP message
;Returns true: S1/SETUP response code
; The DECnet link is connected and the listener (if any) is
; started
;Returns false: A fatal error occurred (the DECnet DCN: JFN could not be
; obtained or opened, or the listener could not be started)
;Attempt to open and connect the DECnet link
DQSINI: $CALL DQSDCN ;Build the DCN: device name
$CALL DQSLNK ;Open the DECnet link if not open now
$RETIF ;Return bad, S1/response to setup code
;Link is open or opening, return OK code after doing a little housekeeping.
IFN FTACNT<
SETOM J$ACCT(J) ;Indicate accounting is enabled
>
IFN FTMJ,<
$CALL CASTIM ;Set the DECnet inactivity timer
>
$CALL DQSOBS ;Setup output buffer pointer/count
MOVX S1,%RSUOK ;Pick up the setup ok response code
$RETT ;Return OK
SUBTTL Setup Message -- Build device name
;DQSDCN is called from INIDQS to build the DECnet DCN: device name that we will
;use in opening our DECnet link. The format of the DCN: device name is:
; DCN:rnode-66
;
;where RNODE is the remote node name
; 66 is the corporate DECnet object for DQS
;
;Call is: J/Job Context Pointer
;Returns The DCN: device name has been built and placed in the stream's
; data base
DQSDCN: $SAVE <P1,P2,P3,P4> ;Save these ac
;Get node name, abort any old link if the node names don't match.
MOVE S2,JOBOBA ;Pick up the object block address
MOVE S2,OBJ.ND(S2) ;Pick up the listener's node name
CAMN S2,J$RNOD(J) ;Is this the same node name?
$CALL ABTLNK ;Abort link if present now
MOVEM S2,J$RNOD(J) ;Save in the data base
;[12] BDATA is the protocol version, returned by the remote for us to read only
;[12] if using object 66. Object is either 66 (new) or 170 (old), 170 only
;[12] talks protocol version 1.0. Note: Don't send BDATA if you wish to talk
;[12] protocol version 1.0.
;[12] $TEXT(<-1,,J$CDCN(J)>,<DCN:^N/J$RNOD(J)/-66.;BDATA:^O3R0/[PVMAJ]/^O3R0/[PVMIN]/000000^0>) ;[4]
$TEXT(<-1,,J$CDCN(J)>,<DCN:^N/J$RNOD(J)/-66.^0>) ;[12]
$RET ;Return to the caller
SUBTTL Setup Message -- Open DECnet Link
;DQSLNK is called by DQSINI (Setup Measage) and also if it is detected that the
;link is no longer connected while starting to process a print request (Nextjob
;Message).
;This routine opens a DECnet link to a remote DQS system. If a connection
;cannot be obtained, then a check is made to see if the error is fatal. If the
;error is fatal, then we return a code that shuts down the object. If the
;error is not fatal, then DQSLNK will return an error to QUASAR that will have
;QUASAR try again later.
;Call is: J/Job Context Pointer
;Returns true: The DECnet link is connected
;Returns false: A fatal DECnet error was detected
; S1/ setup code
; J$ERRA(J)/ Address of the error string
DQSLNK: SKIPLE J$LCHN(J) ;Still have a connection?
$CALL ABTLNK ;Yep, zap it
;Try and get the link, return fatal error if it is fatal
$CALL GETLNK ;Obtain one and OPENF
JUMPF OPNLN3 ;[4] Owie
SETZM PRTVER ;[4] Clear protocol version word
SETZM PRTVER+1 ;[5] Clear returned protocol version
;Check the status of the link. Return if it is open or opening.
$CALL DQSCHK ;Check the link status, return in T1
$RETIT ;Return if true
MOVEI S1,%RSUNA ;That device is unavailable now
$RET ;Return FALSE
;Here if fatal error, shut it down
OPNLN3: MOVEI S1,%RSUDE ;Fatal error
$RET ;Return FALSE with S1/ code
SUBTTL Shutdown Message
;DQSREL is called as part of the shutdown of a DQS LPTSPL. It just aborts the
;link and returns.
;
;Call is: J/Job Context Pointer
;Returns: The cleanup has been performed
DQSREL: SKIPLE J$LCHN(J) ;Is there a DECnet DCN: device jfn?
$CALL ABTLNK ;Yes, release it
$RET ;Return to the shutdown
SUBTTL Next Job Message
;DQSFIX is called from routine NXTJOB when NXTJOB determines that this is
;a DQS LPTSPL.
;
;Call is: $CALL from NXTJOB
; J/Job Context Pointer
;
;Returns: Selected job data words have been zeroed
DQSFIX: SETZM J$CONF(J) ;Zero out connection failure during job
$RET ;Return to finish NXTJOB stuff
SUBTTL Job Processing
;DQSJOB processes a NEXTJOB message that is to be routed to a remote node.
;
;Call is: This routine is started by the job processing dispatch scheduler
;Returns: The print request has been forwarded to the node where the files
; in the print request are to be printed.
DQSJOB: LOAD S1,.EQSEQ(J),EQ.IAS ;Get invalid account string bit
STORE S1,S,ABORT ;Save it as the abort bit
SETZM RETRYC ;[10] Clear DECnet retry counter
DQSJ1: LOAD E,.EQLEN(J),EQ.LOH ;Get length of header
ADD E,J ;Point to first file
TXO S,INJOB ;We are in a job now
SETZM J$RNFP(J) ;Back to first file for requeue
;Get proper forms number saved
$CALL FORMS ;Get proper forms number
;Insure that link is open and that it is OK
SKIPLE J$LCHN(J) ;Is there a link open?
JRST DQSJ3 ;Yes
$CALL DQSLNK ;No, get one open
JUMPF RSTMSG ;Jump if failure
DQSJ3: $CALL DQSCHK ;Is the link status OK
JUMPF RSTMSG ;Fatal error
;Send the files over to the DJM
DQSJ4: $CALL RCREAT ;Send create message
JUMPF RSTMSG ;[10] Jump if failure
;Finish up and return.
IFN FTMJ,< ;If doing multiple jobs per link
$CALL CASTIM ;Set DECnet timeout interval
> ;End of IFN FTMJ
IFE FTMJ,< ;If only one job per link
$CALL ABTLNK ;DJM wants one job at a time
> ;End of IFE FTMJ
PJRST ENDJOB ;Finish up job in LPTSPL
SUBTTL Job Processing -- Remote CREATE request
;Here with link open to the remote to do the files that have been given to us.
;Returns: TRUE if everything OK
; FALSE if not OK
;Steps in request creation:
; (Connect to remote DJM)
; Send create message
; For each file,
; Send FILESPEC message
; Send FILEDATA message(s)
; Send EOF message
; Send EOR message
; Receive ERROR or SUMMARY message
; Send COMMIT message (no errors) or WITHDRAW message (errors)
; Receive END message from remote DJM
; (Disconnect from remote DJM)
RCREAT: $CALL SCREAT ;Send Creation message
$RETIF ;[10] Return FALSE if problem
$CALL SFILES ;Send files
$RETIF ;[10] Return FALSE if problem
$CALL SEOR ;Send end of request
$RETIF ;[10] Return FALSE if problem
$CALL RSUMMA ;Recieve summary or error
$RETIF ;[10] Return FALSE if problem
$CALL SCOMMI ;Send commit or withdraw
$RETIF ;[10] Return FALSE if problem
$CALL REND ;Recieve end message
$RET ;[10] Return TRUE or FALSE
SUBTTL Job Processing -- Send Create Request
;Here to send a create request out the connection
;Returns TRUE if ok FALSE if not
SCREAT: MOVX S1,.MTCRE ;Type = create request
$CALL SETMSG ;Set up message header
;[2] Protocol version
;[5] MOVE S1,[.LNPVN,,.BTPVN] ;[2] Protocol version number
;[5] MOVE S2,[Point 8,[BYTE(8)PVMAJ,PVMIN,PVEDT,PVUSR]] ;[2]
;[5] $CALL G$PCST ;[2] Output those four bytes
;Job name
$TEXT <-1,,TMPBUF>,<^W/.EQJOB(J)/^0> ;Generate job name
MOVX S1,.BTJNA ;Type = job name
$CALL G$PTMP ;Heave it out of the buffer
;Job owner
$TEXT <-1,,TMPBUF>,<^W/CNTSTA/::^T/.EQOWN(J)/^0>
MOVX S1,.BTJOW ;Type = job owner
$CALL G$PTMP ;Cram it
;Job account
MOVEI S2,.EQACT(J) ;[12] Point to account string
HRLI S2,(Point 7) ;[12] and make a byte pointer
MOVEI S1,.BTACT ;[12] Load the account name
SKIPE .EQACT(J) ;[12] If there is an account
$CALL G$PSTG ;[12] Send it
;Job queue name
MOVX S1,.BTQUE ;Type = queue name
MOVEI S2,.EQRPN(J) ;Load queue name address
$CALL G$PSUC ;Force it to be uppercase this time
;Continued on next page
;Continued from previous page
;Requestor job number
MOVX S1,.BTRJN ;Type = requestor job number
MOVE S2,.EQRID(J) ;Use request number
$CALL G$PWRD ;Stuff it
;Job count (number of times to print this job) would go here
;Page limit would go here
;Priority
MOVX S1,.BTPRI ;Type = priority
LOAD S2,.EQSEQ(J),EQ.PRI ;Get external priority
CAILE S2,.MVPRI ;In range for DQS?
MOVEI S2,.MVPRI ;No, use the maximum for DQS
$CALL G$PWRD ;Another word of pleasure
;Notify action
;[12] MOVX S1,.BTNOA ;Type = notify action
;[12] MOVEI S2,NA.CMP!NA.CHG ;Notify on completion or change
;[12] $CALL G$PBYT ;Stuff it
;Notify name and case type (lower, upper, generic) would go here
;Forms type
MOVX S1,.BTFRM ;Type = forms code
MOVE S2,J$FNUM(J) ;Load forms number
SKIPE S2 ;Is it normal forms?
$CALL G$PBYT ;No, cram it there
;Characteristics
MOVE S1,[.LNCHR,,.BTCHR] ;Length = 16, type = characteristics
MOVEI S2,.EQCHR(J) ;Load characteristics area address
HRLI S2,(Point 8) ;Set byte pointer
$CALL G$PCST ;Probably will be LANDSCAPE a lot
;Continued on next page
;Continued from previous page
;Font name and Parameter_1 through Parameter_8 would go here
;Note string
GETLIM S1,.EQLIM(J),NOT1 ;Get the first half of /NOTE:
GETLIM S2,.EQLIM(J),NOT2 ;Get the second half
SKIPN S1 ;Skip if not null
JUMPE S2,SCRE.2 ;If null, ignore it
$TEXT <-1,,TMPBUF>,<^W6/S1/^W/S2/ ^T/.EQBOX(J)/^0> ;[2] Ascificate
MOVX S1,.BTNOT ;Type = note
$CALL G$PTMP ;Not null, stuff it
;Time queued
SCRE.2: HRROI S1,TMPBUF ;Point to the buffer
MOVE S2,.EQAFT(J) ;Load the after word
MOVX T1,OT%4YR ;Output like "21-Oct-1987 12:34:56"
ODTIM% ;Output it
ERJMP .+1 ;Ignore error
LDB S1,[POINT 7,TMPBUF,6] ;[2] get first character of time
CAIN S1," " ;[2] Is it a space?
MOVEI S1,"0" ;[2] Yes make it zero
DPB S1,[POINT 7,TMPBUF,6] ;[2] Store that character back
MOVX S1,.BTTMQ ;Type = after time
$CALL G$PTMP ;Copy that over for VMS
;Finish message up, send it, check for objections
$CALL FINMSG ;Finish message
$CALL DQSSND ;[4] Send it
$RETIF ;[4] Return if owie
JRST DJMOBJ ;[4] Check objections and return
SUBTTL Job Processing -- Send Files
;Now loop for each file, sending a FILESPEC message, one or more
;FILEDATA messages, and an EOF message.
;Returns TRUE if ok FALSE if not
SFILES: STKVAR <BPLEN,BPCNT> ;A couple of safe places
SFIL.1: SETZM JOBCHK ;Send a checkpoint message soon
$CALL SNDFSP ;Send filespec message
$RETIF ;Return if owie
;[15] Check /FILE and /MODE switches passed to us then open the file up.
$CALL FILMOD ;[15] Check /FILE and /PRINT switches
JUMPF SFIL.5 ;[15] If error, report
$CALL INPOPN ;Open the file
JUMPF SFIL.6 ;Jump if a problem
;[15] Log the start message, send the data, log the finish message
$CALL LSTAF ;[4] Log the start
$CALL SNDDAT ;Send the data
$RETIF ;Return owie
$CALL LFINF ;[4] Output to log
$CALL INPCLS ;[4] Close input file
;Continued on next page
;Continued from previous page
;Here with data or error message about file sent, count the file and send
;an end of file message.
SFIL.2: AOS J$RNFP(J) ;Count a file please
$DSCHD(0) ;See if any IPCF messages for us
TXNE S,RQB!ABORT ;Should we just abort this?
$RETF ;[10] Return owie
$CALL SNDEOF ;Send the EOF
$RETIF ;Return if that didn't work
;Here to send over the next file.
$CALL DJMOBJ ;DJM objections?
$RETIF ;Yes
$CALL NXTFIL ;Get the next filespec
JUMPT SFIL.1 ;Process that file
$RETT ;Return with all files sent
;[15] Problem with /FILE or /MODE from FILMOD routine.
SFIL.5: $CALL FILMER ;[15] Output can't print message
$RETIF ;[15] Return if hell freezing over
JRST SFIL.2 ;[15] Get the next file
;Can't find file error.
SFIL.6: $CALL CACFIL ;Output can't access text message
$RETIF ;Return now if owie
JRST SFIL.2 ;Try the next file
SUBTTL Job Processing -- Send Files -- Send Filespec Message
;Here to send the filespec message out.
SNDFSP: MOVX S1,.MTFSP ;Type = file spec
$CALL SETMSG ;Set up message header
;Filename string.
LOAD S2,.FPLEN(E),FP.LEN ;Get length of the FP
ADDI S2,.FDSTG(E) ;Point to the filespec in the FD
HRLI S2,(Point 7) ;Make a byte pointer to that please
;[4] Depending on the DQS protocol version that we are talking to we have to
;[4] send just the filename or the full filespec block.
MOVE S1,PRTVER+1 ;[4] Get the other end's protocol ver
CAML S1,[BYTE(8)1,1,0,0] ;[4] Is it OK to send long filespec?
JRST SNDF.F ;[4] Yes, send full file
;Protocol is older, send only the part after the directory as to not
;confuse the poor DJM.
SNDF.0: ILDB S1,S2 ;Get a character
CAIE S1,135 ;Is it a close square bracket?
CAIN S1,76 ; or is it a close angle bracket?
JRST SNDF.7 ;Yes, ready to check for other things
JUMPN S1,SNDF.0 ;Loop until a null seen
JRST SNDF.7 ;[4] No angle bracket seen!
;Continued on next page
;Continued from previous page
;[4] Protocol is later version, we can pass full filespec, but we have to
;[4] VAXinate the TOPS-20 filename string passed to us. This is done by
;[4] copying the file name string from the EQ into TMPBUF. We also have to
;[4] change the dot before the generation into a semicolon. We pass the rest
;[4] of the filename string as is. Therefore, "WORK:<GSCOTT.LPTSPL>A.B.33"
;[4] gets turned into "_WORK:[GSCOTT.LPTSPL]A.B;3".
SNDF.F: MOVE T1,[Point 7,TMPBUF] ;[4] Point to temp storage
MOVEI S1,"_" ;[4] Load the VMS physical character
IDPB S1,T1 ;[4] Store that in the buffer
SETZ T2, ;[4] Clear counter of dots
SNDF.1: ILDB S1,S2 ;[4] Get a character
CAIE S1,"V"-100 ;[4] Is it a control V?
JRST SNDF.2 ;[4] No
ILDB S1,S2 ;[4] Get the next character
MOVEI S1,"_" ;[4] Load an underscore for now
SNDF.2: CAIE S1,"." ;[4] Is it a dot?
JRST SNDF.4 ;[4] Nope
SOJN T2,SNDF.4 ;[4] Yep, jump if this dot is OK
MOVEI S1,";" ;[4] Make it a semicolon for VMS
SNDF.4: CAIN S1,74 ;[4] Is it an open angle bracket?
MOVEI S1,"[" ;[4] Yes, vaxinate it
CAIE S1,76 ;[4] Is it a close angle bracket?
JRST SNDF.5 ;[4] Nope
MOVEI S1,"]" ;[4] Yes, vaxinate it
MOVEI T2,2 ;[4] Remember to eat two dots
SNDF.5: IDPB S1,T1 ;[4] Store character
JUMPN S1,SNDF.1 ;[4] Loop until a null seen
MOVEI S2,TMPBUF ;[4] Point to filename storage area
;Filespec is set up in TMPBUF, check for spooled files or not (to substitute
;filenames) then store the filename message for DQS.
SNDF.7: MOVE S1,.FPINF(E) ;[2] Get flags for file
TXNE S1,FP.SPL ;Is it a spooled file?
MOVEI S2,[ASCIZ/Spooled.File;1/] ;Yes
TXNE S1,FP.FLG ;Is it also a log file?
MOVEI S2,[ASCIZ/Batch_Log.File;1/] ;Yes
MOVX S1,.BTFNM ;Type = filename
$CALL G$PSTG ;Copy from address in S2
;Continued on next page
;Continued from previous page
;Data type
MOVX S1,.BTFTY ;Type = data type
MOVEI S2,FT.UDF ;[12] Undefined data
$CALL G$PBYT ;Stuff it
;Copy count
MOVX S1,.BTFCC ;Type = copy count
LOAD S2,.FPINF(E),FP.FCY ;Get the count
CAILE S2,1 ;Don't bother if just one copy
$CALL G$PWRD ;Stuff it
;Separator
MOVX S1,.BTFSE ;Type = separator
MOVE S2,.FPINF(E) ;Get file info bits
TXNE S2,FP.NFH ;No file headers?
TDZA S2,S2 ;[12] /noheader, clear s2 and skip
MOVEI S2,SE.HDR ;[12] /header, load header flag
$CALL G$PBYT ;[12] Send the byte
;Blank lines
MOVX S1,.BTFBL ;Type = blank line count
LOAD S2,.FPINF(E),FP.FSP ;Get the spacing
SOS S2 ;[12] Get blank lines-1
$CALL G$PBYT ;[12] Blank lines is nonzero, store
;Continued on next page
;Continued from previous page
;Page options
MOVX S1,.BTFPO ;Type = page options
SETZ S2, ;None yet
$CALL G$PBYT ;Stuff it
;Start page
MOVX S1,.BTFSP ;Type = start page
MOVE S2,.FPFST(E) ;Get starting page
CAILE S2,1 ;Don't bother if starting at beginning
$CALL G$PWRD ;Stuff it
;End of blocks
$CALL FINMSG ;Finish message
$CALL DQSSND ;[4] Send the message
$RETIF ;[4] Return if owie
JRST DJMOBJ ;[4] See if DJM objections and return
SUBTTL Job Processing -- Send Files -- Check /FILE and /MODE Switches
;[15] Here to check out and /FILE and /MODE switches for this request.
; LPTSPL's switch checking order inspired the order of checking here.
; /FILE options supported are ASCII and ELEVEN.
; /MODE options supported are ARROW, ASCII, and SUPPRESS.
; /MODE:OCTAL and /FILE:(COBOL,FORTRAN) and /REPORT are not implemented.
;Returns FALSE if some problem, T1/ adr of bad switch in ASCIZ
;Returns TRUE if all is OK, sets ARROW and/or SUPFIL bits in S and TRNRTN.
FILMOD: LOAD S1,.FPINF(E),FP.FFF ;Get the /FILE switch
LOAD S2,.FPINF(E),FP.FPF ;Get the /PRINT switch
TXZ S,NEWLIN!ARROW!SUPFIL ;Assume no ARROW or SUPPRESS mode
MOVEI T2,SNDASC ;Assume ASCII
CAIE S2,%FPLOC ;/MODE:OCTAL?
JRST FILM.2 ;No
MOVEI T2,SNDOCT ;Yes, load OCTAL dump routine
SETZM OCTLPB ;First line, clear line per block
JRST FILM.7 ;Store routine and return
FILM.2: CAIE S1,.FPFFO ;/FILE:FORTRAN?
JRST FILM.3 ;No
MOVEI T2,SNDFOR ;Yes, load special transfer routine
TXO S,FCONV ; and first char is to be converted
FILM.3: MOVEI T1,[ASCIZ\/FILE:COBOL\] ;Load the switch name for error
CAIN S1,.FPFCO ;/FILE:COBOL?
$RETF ;Yes
MOVEI T1,[ASCIZ\/REPORT\] ;Load switch name
SKIPE .FPFR1(E) ;/REPORT specified?
$RETF ;Yes
CAIN S2,%FPLAR ;/MODE:ARROW?
TXO S,ARROW ;Yes, light flag for later
CAIN S2,%FPLSU ;/MODE:SUPPRESS?
TXO S,SUPFIL!ARROW ;Yes, light both arrow and it
TXNE S,ARROW!SUPFIL!SUPJOB ;/MODE:ARROW or /MODE:SUPPRESS?
MOVEI T2,SNDSLO ;Yes, use slow copy routine
CAIN S1,.FPF11 ;/FILE:ELEVEN?
MOVEI T2,SNDELE ;Yes use special routine
;Store routine to use and return good.
FILM.7: MOVEM T2,TRNRTN ;Store routine to use today
$RETT ;Nope, standard ASCII
SUBTTL Job Processing -- Send Files -- Send Error Messages
;[15] Here if switch specified for this file is not supported in DQS LPTSPL.
;Called after FILMOD returns FALSE, T1/ address of ASCIZ bad switch name.
FILMER: LOAD S2,.FPLEN(E),FP.LEN ;[15] Get length of the FP
ADDI S2,.FDSTG(E) ;[15] Point to the FD
$TEXT(LOGCHR,<^I/LPERR/Can't transmit ^T/(S2)/, switch ^T/(T1)/ not implemented for DQS spooling>) ;[15]
MOVEI S1,[ITEXT (<Switch ^T/(T1)/ is not implemented for DQS spooling>)] ;[15]
JRST ERRFIL ;[15] Output that error message as file
;[15] and then return
;Here when we can't access a file to put a little message out to the DJM that
;tells the user he lost. We send this message rather than the file's contents.
CACFIL: MOVEI S1,[ITEXT (<^E/[-1]/>)] ;[15] Make a nice easy message
;[15] and fall through to ERRFIL
;[15] Here to send error message as a file for the user to agonize over
; Call with S1/ address of ITEXT with error in it
ERRFIL: LOAD S2,.FPLEN(E),FP.LEN ;Get length of the FP
ADDI S2,.FDSTG(E) ;Point to the FD
$TEXT (<-1,,TMPBUF>,<^M^J
LPTSPL version ^V/LPTVNO/
^T/LPCNF/
^B/@JOBOBA/ at ^H/[-1]/
^R/.EQJBB(J)/
File ^T/(S2)/ cannot be transmitted
^I/(S1)/^M^J^0>) ;[15] Create error message text
MOVX S1,.MTFDT ;Type = filedata
$CALL SETMSG ;Set up message header
MOVX S1,.BTDAT ;Type = data transfer
$CALL G$PTMP ;Stuff the string from TMPBUF
$CALL FINMSG ;Finish up message
$CALL DQSSND ;[4] Send it
$RETIF ;[4] Return if owie
JRST DJMOBJ ;[4] Check objections and return
SUBTTL Job Processing -- Send Files -- Send Data Messages
;Output all of the file data here, called with file already open we just have
;to pump out the data. [4] Checkpoint every 100Kbytes so we update a little
;more often than once a job.
;[4] AC usage: P1/ <number of bytes transmitted>/^D100K
; P2/ <number of bytes transmittes>/^D10K
; P3/ Pointer to length bytes of the data subblock in buffer
; P4/ Count of free bytes in transmit buffer
; T2/ Count of possible data bytes in that transmit buffer
SNDDAT: $SAVE <P1,P2,P3,P4> ;[4] Save some acs
SETZB P1,P2 ;[4] Zero count of each 100K bytes
;[4] Top of loop to transmit the next data message. First do housekeeping.
;[4] If there has been another 100K characters transmitted send a update
;[4] message to QUASAR so that all can see how the print jobs are going.
SNDD.0: MOVE S1,J$APRT(J) ;[4] Load bytes transmitted
IDIVI S1,^D100000 ;[4] Get number of 100K bytes in S1
EXCH S1,P1 ;[4] Swap to save new count in P1
CAMLE P1,S1 ;[4] Transmitted another 100K yet?
SETZM JOBCHK ;[2] Yes send a checkpoint message
;[4] Perform a scheduling pass to catch IPCFs each 10K characters. This alows
;[4] for a reasonable response to operaor or user commands yet keeps the
;[4] overhead down when transmitting data. The call to the scheduler will also
;[4] send a checkpoint message to QUASAR.
MOVE S2,J$APRT(J) ;[4] Load the characters transmitted
IDIVI S2,^D10000 ;[4] Get number of 10K characters
EXCH S2,P2 ;[4] Swap to save new in P2 old in S1
SKIPE JOBCHK ;[4] If checkpoint force scheduling
CAMLE P2,S2 ;[4] No, transmitted another 10K yet?
$DSCHD(0) ;Scheduling pass (to update QUASAR)
;[4] See if the DJM or QUASAR has had any objections to us while all of this is
;[4] going on. (IPCF messages are only processed occasionally.)
$CALL DJMOBJ ;DJM objection?
$RETIF ;Return if so
;Continued on next page
;Continued from previous page
;Ready to transmit, set up the header first.
MOVX S1,.MTFDT ;Type = filedata
$CALL SETMSG ;Set up message header
AOS BLKCNT ;Count another block
MOVX S1,.BTDAT ;Type = filedata
$CALL PUTBYT ;Stuff the block type
MOVE P3,OBPTR ;Save pointer to hi length byte
SETZ S1, ;Get a zero
$CALL PUTBYT ;Store length of zero temporarily
$CALL PUTBYT ;...
MOVE T2,OBCNT ;[6] Get space left in buffer, the same
MOVE P4,OBCNT ;[6] as maximum number of bytes send
;[15] Call specific routine to load up a bufferfull of data. The caller is
;expected to preserve T2 and count P4 down by 1 each time PUTBYT is called.
;The formatting routine returns TRUE if more characters to send, FALSE if EOF.
$CALL @TRNRTN ;[15] Dispatch to print routine
;[15] Here with a bufferfull of characters, with P4/ free bytes in the buffer.
;Store the length of the data in the message and send it. We are at end of
;file if entered with TF FALSE.
SNDD.4: MOVE S1,T2 ;Get the free byte count back
SUB S1,P4 ;[6] Minus space left equals data count
ROT S1,-^D8 ;Shift high byte over
IDPB S1,P3 ;Store the high order length byte
ROT S1,^D8 ;Shift low byte back
IDPB S1,P3 ;Store the low order length byte
MOVE P4,TF ;[15] Remember if more to do
$CALL FINMSG ;Finish message
$CALL DQSSND ;Send it
$RETIF ;Return if owie
;Loop if more file to do (buffer full), otherwise return with all data sent.
JUMPT P4,SNDD.0 ;[15] Jump if SNDxxx returned TRUE
$RETT ;[15] Return if end of file seen here
SUBTTL Job Processing -- Send Files -- Send Data Messages -- Ascii Mode
;[15] Normal fast ASCII print loop to get a buffer full of characters.
; P4/ count of free bytes in the buffer
; Returns FALSE if end of file
; Returns TRUE if more to do
SNDASC: $CALL INPBYT ;[6] Read a byte
$RETIF ;[15] End of file
SKIPN S1,C ;[6] Copy the character
JRST SNDASC ;Null, throw it away
$CALL PUTBYT ;Stuff the byte
SOJG P4,SNDASC ;[6] Loop for the rest we can do
$RETT ;[15] Send buffer full
SUBTTL Job Processing -- Send Files -- Send Data Messages -- Eleven Format
;[15] Routine for printing /FILE:ELEVEN files.
;No special formatting of the data is done, even if a /MODE switch specified.
; P4/ count of free bytes in the buffer
; Returns FALSE if end of file
; Returns TRUE if more to do
SNDELE: CAIGE P4,4 ;Room for all four bytes?
$RETT ;Nope, send this buffer
$CALL INPBYT ;Get a word of 4 bytes of data
$RETIF ;End of file probably
LDB S1,[POINT 8,C,17] ;Get the first byte
$CALL PUTBYT ;Store first one
LDB S1,[POINT 8,C,9] ;Get second byte
$CALL PUTBYT ;Store second one
LDB S1,[POINT 8,C,35] ;Get third byte
$CALL PUTBYT ;Store third one
LDB S1,[POINT 8,C,27] ;Get fourth byte
$CALL PUTBYT ;Store fourth one
SUBI P4,4 ;Count those four bytes
JRST SNDELE ;Loop for next word
SUBTTL Job Processing -- Send Files -- Send Data Messages -- Fortran Format
;[15] Routine for printing /FILE:FORTRAN files. FCONV is set when the next
;character expected is a format control character we need to convert, set at
;beginning of the file and at each linefeed. Linefeeds from the file are not
;transmitted, this is done when the next character (format control) is read.
; P4/ count of free bytes in the buffer
; Returns FALSE if end of file
; Returns TRUE if more to do
SNDFOR: TXNE S,FCONV ;Is next character a Fortran ctl char?
JRST SNFO.2 ;Yes, ok sir, that'll be fine sir
SNFO.1: $CALL INPBYT ;There is room, read a byte from file
$RETIF ;False is end of file probably
SKIPN S1,C ;Copy the character to where we want it
JRST SNFO.1 ;Null, throw it away
CAIN S1,.CHLFD ;Line feed?
TXOA S,FCONV ;Don't send, next char is translated
$CALL SNDBYT ;Send character and count it from P4
JUMPG P4,SNDFOR ;Loop for more characters if room
$RETT ;Return to transmit this buffer
;Here when the next character is to be interpreted as a Fortran forms
;character. Check if there is room in the buffer for any possible translated
;string. Convert to a forms motion character and transmit the appropriate
;character sequence. Then return to above loop for more characters.
SNFO.2: CAIGE P4,4 ;Insure room in buffer for translation
$RETT ;No room, send this buffer along please
TXZ S,FCONV ;Looks like we will convert this one
SNFO.3: $CALL INPBYT ;Get the next byte please
$RETIF ;Return if end of file
JUMPE C,SNFO.3 ;Get another one if a null seen
MOVSI S2,-FTNTSZ ;Load size of that table
SNFO.4: LDB S1,[Point 7,FTNTAB(S2),6] ;Get character from translation table
CAIE S1,(C) ;Does it match character from file?
AOBJN S2,SNFO.4 ;Nope, loop
;No match will get the linefeed at end
TXNE S,SUPFIL!SUPJOB ;Suppressing forms motion?
SETZ S2, ;Yes, use entry for single space
MOVE T1,[Point 7,FTNTAB(S2),6] ;Load pointer to data characters
SNFO.5: ILDB S1,T1 ;Get a translated character
JUMPE S1,SNDFOR ;If at end, we can loop for next char
$CALL PUTBYT ;Store that character
SOJA P4,SNFO.5 ;Loop for more
;[15] Table of translation characters. The first character is the character to
;translate, and the rest of the characters in that word are the characters to
;translate to. Obviously you can only have up to three characters translation.
;It is also not clear what the remote DJM's symbiont will do with things like
;vertical tab, control-P, and DC1-DC4 (control-Q, control-R, control-S, and
;control-T) but we faithfully translate them like LPTSPL does. Single space
;must be first entry in table (for suppress check above and it is the most
;common translation character).
FTNTAB: BYTE(7) " ",.CHLFD ;Space means single space
BYTE(7) "0",.CHLFD,.CHLFD ;Zero means double space
BYTE(7) "1",.CHFFD ;One means go to channel 1
BYTE(7) "2",.CHCNP ;Two means skip 1/2 page (channel 2)
BYTE(7) "3",.CHVTB ;Three means skip 1/3 page (channel 3)
BYTE(7) "/",.CHCNT ;Slash means skip 1/6 page
BYTE(7) "*",.CHCNS ;Star means suppress skip over perf
BYTE(7) "+",.CHCRT ;Plus means overprint
BYTE(7) ",",.CHCNQ ;Comma means doublespace
BYTE(7) "-",.CHLFD,.CHLFD,.CHLFD ;Hyphen means triple line feed
BYTE(7) ".",.CHCNR ;Dot means skip 3 lines
BYTE(7) 000,.CHLFD ;Anything else means same as space
FTNTSZ==.-FTNTAB ;Size of this table
SUBTTL Job Processing -- Send Files -- Send Data Messages -- Octal Mode
;[15] Routine for printing /MODE:OCTAL. We will print OCTWPL octal words per
;line, OCTLPB words per block, OCTBPP blocks per page.
;
;ACs: P1/ block per page
; P2/ lines per block
; P3/ words per line
; P4/ count of free bytes in the buffer
;Returns FALSE if end of file
;Returns TRUE if more to do
SNDOCT: $SAVE <P1,P2,P3> ;Get some space to work with
DMOVE P1,SAVBPP ;Load saved blocks/page and lines/block
MOVE P3,SAVWPL ; and word per line counters
JUMPN P1,SNDO.4 ;Enter to do next line or reload cntrs
SNDO.1: MOVEI P1,OCTBPP ;Here to start a new page
SNDO.2: MOVEI P2,OCTLPB ;Here to start a new block
SNDO.3: MOVEI P3,OCTWPL ;Here to start new line
SNDO.4: CAIGE P4,3+^D12+2+2+2+1 ;Here to start new line, enough space?
JRST SNDO.7 ;Nope
MOVEI S1," " ;Here to start new word,
$CALL SNDBYT ; begin with one
$CALL SNDBYT ; two
$CALL SNDBYT ; three blanks
$CALL INPBYT ;Get a word from the file into C
$RETIF ;Done if end of file
MOVEI T4,^D12 ;Digits per word
MOVE T3,[POINT 3,C] ;Load byte pointer to the word
SNDO.5: ILDB S1,T3 ;For each digit, get next digit
MOVEI S1,"0"(S1) ;Asciify that digit
$CALL SNDBYT ;Output that digit
SOJG T4,SNDO.5 ;Loop for all 12 digits
SOJG P3,SNDO.4 ;Loop for all of words on that line
$CALL SNDCRL ;End of line, output CRLF
SOJG P2,SNDO.3 ;Loop for all lines in that block
$CALL SNDCRL ;End of block, output
$CALL SNDCRL ; two extra CRLFs to seperate block
SOJG P1,SNDO.2 ;Loop for all blocks on this page
MOVEI S1,.CHFFD ;We have output blocks per page, so we
$CALL SNDBYT ; need a form feed next
JRST SNDO.1 ;Print next page
;Here when we need to transmit a buffer, save the blocks per page and lines per
;block output so far.
SNDO.7: DMOVEM P1,SAVBPP ;Save blocks/page and lines/block
MOVEM P3,SAVWPL ; and word per line counters
$RETT ;Return now for transmission
;Local routine to send a CRLF along.
SNDCRL: MOVEI S1,.CHCRT ;Load a carriage return
$CALL SNDBYT ; output that character
MOVEI S1,.CHLFD ;Load a linefeed
;Fall thru to SNDBYT
;Local routine to count down P4 by one and send a character.
SNDBYT: SOJA P4,PUTBYT ;Output byte and return
SUBTTL Job Processing -- Send Files -- Send Data Messages -- Suppress/Arrow Modes
;[15] Slow ASCII print loop. This loop used only with /FILE:ASCII and either
;/MODE:ARROW or /MODE:SUPPRESS or operator's SUPPRESS command. If /MODE:ASCII
;we use the fast ASCII loop. Check for two character positions available since
;(almost) any control character can turn into a two character sequence.
; P4/ count of free bytes in the buffer
; Returns FALSE if end of file
; Returns TRUE if more to do
SNDSLO: CAIGE P4,2 ;Room for uparrow and character?
$RETT ;Time to send it
$CALL INPBYT ;Read a byte
$RETIF ;False is end of file probably
SKIPN S1,C ;Copy the character
JRST SNDSLO ;Null, throw it away
CAIL S1," " ;Is it a nonprintable char?
JRST SNDS.N ;Nope, no translation, go for it
JRST @CCTAB(S1) ;Dispatch based on character type
;Here for suppression of char if suppress mode, no translation if arrow mode.
;NEWLIN flag will be set to one if we have just printed forms motion char.
SNDS.S: TXNN S,SUPFIL!SUPJOB ;Suppress mode?
JRST SNDS.N ;Nope, no suppression please
TXOE S,NEWLIN ;Just has forms motion character?
JRST SNDSLO ;Yes, suppress this one
MOVEI S1,.CHCRT ;Suppressing forms motion, send return
$CALL PUTBYT ; out there followed by
MOVEI S1,.CHLFD ; line feed so all printers work ok
$CALL PUTBYT ; but no more than one CRLF in a row
SUBI P4,2 ;Count two characters loaded in buffer
JRST SNDSLO ; and continue in slow ascii loop
;Here for translation of the character into uparrow followed by 100+character.
SNDS.A: MOVEI S1,"^" ;Load uparrow character
$CALL PUTBYT ;(S1/) Output that uparrow
MOVEI S1,"@"(C) ;Make control character printable now
SOJA P4,SNDS.N ;Count uparrow, print printable version
;Here for no translation of the character.
SNDS.N: $CALL PUTBYT ;(S1/) Stuff the byte
TXZ S,NEWLIN ;Something now printed on this line
SOJA P4,SNDSLO ;Loop for the rest we can do
;[15] Table for slow ASCII print loop.
; SNDS.A - Outputs uparrow-character if arrow or suppress mode
; SNDS.N - Never translated to anything
; SNDS.S - Outputs one CRLF if suppress mode, no translation if arrow
CCTAB: EXP SNDS.A ;(00) Null (Control-@)
EXP SNDS.A ;(01) Control-A
EXP SNDS.A ;(02) Control-B
EXP SNDS.A ;(03) Control-C
EXP SNDS.A ;(04) Control-D
EXP SNDS.A ;(05) Control-E
EXP SNDS.A ;(06) Control-F
EXP SNDS.A ;(07) Control-G
EXP SNDS.A ;(10) Control-H
EXP SNDS.N ;(11) Horizontal Tab
EXP SNDS.S ;(12) Line Feed
EXP SNDS.S ;(13) Vertical Tab (skips 1/3 page)
EXP SNDS.S ;(14) Form Feed
EXP SNDS.S ;(15) Carriage Return
EXP SNDS.A ;(16) Control-N
EXP SNDS.A ;(17) Control-O
EXP SNDS.S ;(20) Control-P (skips 1/2 page)
EXP SNDS.S ;(21) DC1 (skips 2 lines)
EXP SNDS.S ;(22) DC2 (skips 3 lines)
EXP SNDS.S ;(23) DC3 (skips 1 line no matter what)
EXP SNDS.S ;(24) DC4 (skips 1/6 page)
EXP SNDS.A ;(25) Control-U
EXP SNDS.A ;(26) Control-V
EXP SNDS.A ;(27) Control-W
EXP SNDS.A ;(30) Control-X
EXP SNDS.A ;(31) Control-Y
EXP SNDS.A ;(32) Control-Z
EXP SNDS.A ;(33) Escape (Control-[)
EXP SNDS.A ;(34) Control-\
EXP SNDS.A ;(35) Control-]
EXP SNDS.A ;(36) Control-^
EXP SNDS.A ;(37) Control-_
SUBTTL Job Processing -- Send Files -- Send End Of File Message
;Here after file is copied to send end of file message
SNDEOF: $CALL DJMOBJ ;Has the DJM objected to something?
$RETIF ;Return if badness
MOVX S1,.MTEOF ;Type = end of file
$CALL SETMSG ;Set up message header
$CALL FINMSG ;Finish up message (no body)
$CALL DQSSND ;[4] Send it
$RETIF ;[4] Return if owie
JRST DJMOBJ ;[4] Check objections and return
SUBTTL Job Processing -- Send EOR
;Here after all the files have been sent, send the END (COMMIT) message
;Returns TRUE or FALSE
SEOR: MOVX S1,.MTEOR ;Type = end of record
$CALL SETMSG ;Set up message header
$CALL DQSSND ;[4] Send it
$RETIF ;[4] Return if owie
JRST DJMOBJ ;[4] Check objections and return
SUBTTL Job Processing -- Receive Summary message
;Here to try to read an expected summary message from DJM.
;Return TRUE if so.
;Return FALSE with error text stored.
RSUMMA: $CALL DQSWAT ;Wait for input from remote
$RETIF ;Return if none or timeout
;Check message coming back for summary response.
LDB S1,P.ITYP ;Get message type
CAIN S1,.MTSUM ;Summary message?
JRST RSUM.1 ;Yes, it went OK!
;Check message coming back from DJM.
$CALL UNPERR ;Unpack the error message
$RETF ;Return owie
;Might want to propagate remote request (job) number to queuer?
RSUM.1: $RETT ;Return OK
SUBTTL Job Processing -- Send Commit Message
;Here to send the commit message.
;Returns TRUE or FALSE.
SCOMMI: $DSCHD(0) ;Scheduling pass (to get any IPCF)
TXNE S,RQB!ABORT ;Withdraw or commit?
SKIPA S1,[.MTWIT] ;Withdraw
MOVX S1,.MTCOM ;Type = commit
$CALL SETMSG ;Set up message header
$CALL FINMSG ;Finish up message (no body)
$CALL DQSSND ;[4] Send it
$RETIF ;[4] Return if owie
JRST DJMOBJ ;[4] Check objections and return
SUBTTL Job Processing -- Receive End Message
;Here to read an expected END message from DJM. Return TRUE if so.
;Return FALSE with error text stored.
REND: $CALL DQSWAT ;Wait for some data
$RETIF ;Return if problem
;We have a message is it what we expect?
LDB S1,P.ITYP ;Get message type
CAIN S1,.MTEND ;End message?
$RETT ;Return OK
;Message had an error
$CALL UNPERR ;Unpack error
$RETF ;Return owie
SUBTTL Job Processing -- Error Recovery -- Restart Job
;Here to restart the job in progress, call with J$ERRA(J) setup. We know that
;if we abort the link now we will be all set in terms of (1) DQS protocol
;errors from stopping in odd places while transmitting and (2) problems around
;the time we are sending summary/commit messages. It seems the safest (read:
;reliable) thing to just abort the link now and finish cleanly. Next time we
;want to use the link we will reopen it.
RSTMSG: $CALL ABTLNK ;[10] Avoid confusion with DQS or us
TXNE S,RQB!ABORT ;Abort or requeue by operator?
JRST RSTM.3 ;Yes, get out now
;[10] Count this as a retry. See if we just dropped the ball and if so, abort
;current link and try this job again.
AOS S1,RETRYC ;[10] Count this is as a retry
HRRZ S2,J$LSTS(J) ;[10] Get the disconnect code
CAIN S2,.DCX0 ;[10] Reject or disconnect by object?
CAILE S1,RTYMAX ;[10] Should we try again now?
JRST RSTM.2 ;[10] Nope, "object not available"
JRST DQSJ1 ;[10] Yes, retry this job
;[10] Transmission errors, respose to setup message to QUASAR who will
;reschedule us in a little bit, routines in LPTSPL will close the input file.
RSTM.2: $WTO (<Transmission Error>,<^R/.EQJBB(J)/^M^J^T/@J$ERRA(J)/>,@JOBOBA) ;[11]
$TEXT (LOGCHR,<^I/LPMSG/Transmission error ^T/@J$ERRA(J)/>) ;[11]
MOVEI S1,%RSUNA ;[10] Not available right now
$CALL RSETUP ;[10] Tell QUASAR
PJRST SHUTIN ;[10] Shut us down please (abort link)
;[10] Here when operator aborted this request.
RSTM.3: SETZM J$RNFP(J) ;Back to first file for requeue
SKIPE S1,J$ERRA(J) ;What kind of error today?
MOVEI S1,[ASCIZ/DQS LPTSPL internal error - No error string set up/]
MOVEM S1,J$ERRA(J) ;Store final error address
$CALL INPCLS ;[4] Close input file if any
PJRST ENDJOB ;Requeue it
SUBTTL Job Processing -- Error Recovery -- Check DJB Objections
;Routine to see if the DJM is objecting.
;Check to see if it sent something back, probably an error message.
;Return TRUE if all is OK
;Return FALSE if not with J$ERRA(J) set up
DJMOBJ: TXNE S,RQB!ABORT ;Aborting?
JRST DJMO.3 ;[5] Yes
$CALL DQSREC ;Get something back
$RETIF ;Return if link broken
SKIPN IBCNT ;Was there anything there?
$RETT ;No, return not owie
;Unpack the DJM's error message into text and send it out for all to see.
$CALL UNPERR ;Unpack the error message
$RETF ;Return owie but requeue the job
;Here if RQB or ABORT lit
DJMO.3: MOVEI S1,[ASCIZ/Requeue by operator/] ;[5] Indicate what happened
MOVEM S1,J$ERRA(J) ;[5] Save that please
$RETF ;[5] Return owie to abort job
SUBTTL Job Processing -- Error Recovery -- Unpack DQS Error
;Call with IBUFF/ response from DJM (after reading any message that is)
;Returns with J$ERRA(J) set to address of error text
UNPERR: $SAVE <P1> ;Free up P1
SETZM ERRBEG ;Zero out the
MOVE S1,[ERRBEG,,ERRBEG+1] ; error areas as we call them
BLT S1,ERREND ; many or few its all the same
LDB S1,P.ITYP ;Get the message type
CAXN S1,.MTERR ;Error message?
JRST UNPE.0 ;No, protocol error
;Here if not error message, assume DQS protocol error
MOVEI S2,.ELINF ;[5] Get error level
MOVEM S2,ERRLVL ;[5] Protocol error is requeue
$TEXT (<-1,,ERRBUF>,<DQS protocol error, packet type ^D/S1/, length ^D/IBSLT/^0>) ;[5]
;Here to return our error buffer address in S1, text in ERRBUF
UNPE.4: SKIPN ERRBUF ;Did we write anything there?
$TEXT (<-1,,ERRBUF>,<DQS error packet without error string, packet length ^D/IBSLT/^0>) ;[5]
MOVEI S1,ERRBUF ;Point to my error buffer
UNPE.5: MOVEM S1,J$ERRA(J) ;Save it in the error address please
$RET ;Return
;It was an error message, get all of the relevent parts out of it
UNPE.0: $CALL GETBYT ;Skip type
$CALL GETBYT ;Skip flags
$CALL GETBYT ;Skip context
$CALL GETBYT ;Get block count
MOVE P1,S1 ;Save block count
$CALL GETWRD ;Get message length in S1
MOVE T2,IBSLT ;Get the saved last total byte count
SUBI T2,.HDSIZ ;See if buffer size less header size
CAMN S1,T2 ; equals the length of the packet
JRST UNPE.1 ;Yes, unpack the message
MOVEI S1,[ASCIZ/Length error in DQS error packet/]
JRST UNPE.5 ;Store that error and return
;Continued on next page
;Continued from previous page
;Remove the blocks from the message and store them.
UNPE.1: SOJL P1,UNPE.4 ;Done if no more blocks
$CALL GETBYT ;Get the block type
MOVE T1,S1 ;Save it
$CALL GETBYT ;Skip flags
$CALL GETBYT ;Get length
MOVE T2,S1 ;Save it
;See if we're interested in this block type, and store the data
;temporarily if so. Otherwise just skip this block.
MOVSI S1,-ERRTBL ;Length of table
UNPE.2: HLRZ S2,ERRTAB(S1) ;Get a block type
CAME S2,T1 ;Match the one we have?
AOBJN S1,UNPE.2 ;No, loop
JUMPGE S1,UNPE.3 ;If no match, just skip the block
HRRZ S1,ERRTAB(S1) ;Get the processing routine
$CALL (S1) ;Call it
JRST UNPE.1 ;Loop
UNPE.3: SOJL T2,UNPE.1 ;Done when all bytes processed
$CALL GETBYT ;Get a byte
JRST UNPE.3 ;Deja vu' time
;Continued on next page
;Continued from previous page
;Table of error codes and what to do with them
ERRTAB: XWD .BTEEL,LVL ;Error level
XWD .BTEEC,CLS ;Error class
XWD .BTECD,COD ;Error code
XWD .BTETX,TXT ;Error text
ERRTBL==.-ERRTAB ;Length of this table
;Here on error level, class, or code
LVL: $CALL GETITM ;Get it
MOVEM S1,ERRLVL ;Save it
$RETT ;Return
CLS: $CALL GETITM ;Get it
MOVEM S1,ERRCLS ;Save it
$RETT ;Return
COD: $CALL GETITM ;Get it
MOVEM S1,ERRCOD ;Save it
$RETT ;Return
;Here on error text
TXT: MOVEI S1,ERRBUF ;Point at where it goes
PJRST GETSTG ;Get it
SUBTTL Message Packing Routines -- Setup/Finish Message
;SETMSG - set up message header.
;Call:
; S1/ message type
;Writes message type, flags (0), context(0), blocks(0 now),
;low order length(0), high order length(0)
SETMSG: SETZM BLKCNT ;No blocks in this message yet
$CALL PUTBYT ;Insert the type
SETZ S1, ;Get a zero
$CALL PUTBYT ;No flags
; MOVE S1,.JQOBJ+OBJ.UN(J) ;Sender's context (?)
$CALL PUTBYT ;Slam dunk sender's context
$CALL PUTBYT ;No blocks yet
$CALL PUTBYT ;No low order size yet
JRST PUTBYT ;No high order size either
;FINMSG - finish a message
;Returns: always, message ready for transmission
FINMSG: MOVX S1,BFSBYT ;Get buffer size
SUB S1,OBCNT ;Subtract amount free to get length
SUBI S1,.HDSIZ ;Length doesn't include header
DPB S1,P.OLNL ;Store low byte of length
LSH S1,-^D8 ;Shift off the low byte
DPB S1,P.OLNH ;Store high byte of length
MOVE S1,BLKCNT ;Get number of blocks
DPB S1,P.OBLK ;Store in message
$RET ;Return
SUBTTL Message Packing Routines -- Put a Byte or Word
;G$PBYT - Put a byte
;Call:
; S1/ block type
; S2/ data item
; outputs block type, 0, 1, data byte
G$PBYT: AOS BLKCNT ;Count another block
$CALL PUTBYT ;Store the block type
SETZ S1, ;Get a zero
$CALL PUTBYT ;Store high order length byte
MOVEI S1,1 ;Length
$CALL PUTBYT ;Store low order length byte
MOVE S1,S2 ;Data item
PJRST PUTBYT ;Store it and return
SUBTTL Message Packing Routines -- Put a Word or Longword
;G$PWRD - Put a word (2 bytes)
;Call:
; S1/ block type
; S2/ data item
G$PWRD: AOS BLKCNT ;Count another block
$CALL PUTBYT ;Store the block type
SETZ S1, ;Get a zero
$CALL PUTBYT ;Store high order length byte
MOVEI S1,2 ;Length
$CALL PUTBYT ;Store low order length byte
MOVE S1,S2 ;Copy the word to store
$CALL PUTBYT ;Store low order byte of word
LSH S1,-^D8 ;Shift over high order byte
PJRST PUTBYT ;Store it and return
;G$PLWD - Put a longword (4 bytes)
;Call:
; S1/ block type
; S2/ data item
G$PLWD: AOS BLKCNT ;Count another block
$CALL PUTBYT ;Store the block type
SETZ S1, ;Get a zero
$CALL PUTBYT ;Store high order length byte
MOVEI S1,4 ;Length
$CALL PUTBYT ;Store low order length byte
MOVE S1,S2 ;Copy long word
$CALL PUTBYT ;Store low order byte
LSH S1,-^D8 ;Shift next byte into position
$CALL PUTBYT ;Store it
LSH S1,-^D8 ;Shift next byte into position
$CALL PUTBYT ;Store it
LSH S1,-^D8 ;Shift high order byte into position
PJRST PUTBYT ;Store it and return
SUBTTL Message Packing Routines -- Put a String
;G$PTMP - Put the string from TMPBUF
;G$PSTG - Put a string
;G$PSUC - Put a raised string
;Call:
; S1/ block type
; S2/ pointer to ASCIZ string
; Stores block type, hi length, low length, characters
G$PTMP: MOVEI S2,TMPBUF ;Point to the temp buffer
G$PSTG: TDZA TF,TF ;Skip always
G$PSUC: SETO TF, ;We want to uppercase here
$SAVE <P1,P2,P3> ;Save an AC
MOVE P3,TF ;Load the uppercasify flag
AOS BLKCNT ;Count another block
$CALL PUTBYT ;Store the block type from S1
MOVE P1,OBPTR ;Save pointer to length byte
$CALL PUTBYT ;Store length of zero temporarily
$CALL PUTBYT ; in those two bytes
MOVE P2,OBCNT ;Load the current count
TLNN S2,-1 ;Is there a pointer?
HRLI S2,(POINT 7) ;No, assume regular ascii
PSTG.1: ILDB S1,S2 ;Get a byte
JUMPE S1,PSTG.2 ;Jump if end
JUMPE P3,PSTG.3 ;Jump of not raising
CAIL S1,"a" ;Is it going
CAILE S1,"z" ; to be lowercase?
CAIA ;Nope
SUBI S1,"a"-"A" ;Yes raise the character
PSTG.3: $CALL PUTBYT ;Store it
JRST PSTG.1 ;Loop
PSTG.2: SUB P2,OBCNT ;Minus number left gives number stored
MOVE S1,P2 ;Load count back to S1
ROT S1,-^D8 ;Shift high byte over
IDPB S1,P1 ;Store the high order length byte
ROT S1,^D8 ;Shift low byte back
IDPB S1,P1 ;Store the low order length byte
$RET ;Return
SUBTTL Message Packing Routines -- Put a Counted String
;G$PCST - Put a counted string
;Call:
; S1/ count,,block type
; S2/ pointer
G$PCST: $SAVE <P1> ;Save an AC for later
AOS BLKCNT ;Count another block
$CALL PUTBYT ;Stuff the type
HLRZS S1 ;Isolate length
ROT S1,-^D8 ;Shift high byte over
$CALL PUTBYT ;Stuff it
ROT S1,^D8 ;Shift low byte back
$CALL PUTBYT ;Stuff it
MOVE P1,S1 ;Copy count to T1
G$PCS1: ILDB S1,S2 ;Get a byte
$CALL PUTBYT ;Stuff it
SOJG P1,G$PCS1 ;Loop as required
$RET ;Return
SUBTTL Message Unpacking Routines -- Get a Word or Longword
;Get a word (byte swapped) from the input message
GETWRD: STKVAR <ABYTE> ;Place for a bite
$CALL GETBYT ;Get first byte (low order)
MOVEM S1,ABYTE ;Save it there
$CALL GETBYT ;Get second byte (high order)
LSH S1,^D8 ;Position it
IOR S1,ABYTE ;Include low order
$RET ;Return, its in S1
;Get a longword (swapped) from the input message
GETLWD: STKVAR <AWORD> ;Place to save a word
$CALL GETWRD ;Get first word (low order)
MOVEM S1,AWORD ;Save it
$CALL GETWRD ;Get second word (high order)
LSH S1,^D16 ;Position it
IOR S1,AWORD ;Include low order word
$RET ;Return
SUBTTL Message Unpacking Routines -- Get Variable Length Item
;Get a byte/word/longword (based on length in T2)
GETITM: SETZ S1, ;Assume no match
CAIN T2,1 ;Single byte?
MOVEI S1,GETBYT ;Yes
CAIN T2,2 ;Word?
MOVEI S1,GETWRD ;Yes
CAIN T2,4 ;Longword?
MOVEI S1,GETLWD ;Yes
JUMPN S1,(S1) ;Do it
$RET ; Or not
SUBTTL Message Unpacking Routines -- Get A String
;Get a string (length in T2) and store it in block pointed to by S1
GETSTG: TLNN S1,-1 ;Pointer supplied?
HRLI S1,(POINT 7) ;Nope
MOVE T1,S1 ;Save pointer
GETS.1: SOJL T2,.RETT ;When done
$CALL GETBYT ;Get a byte
IDPB S1,T1 ;Store it
JRST GETS.1 ;Loop
SUBTTL I/O Routines -- Load or Store a Byte
;PUTBYT - Call to put a byte to the output buffer
;Call S1/ byte to put
;Returns FALSE with if no more room for byte
;Returns TRUE with character stored otherwise.
PUTBYT: SOSGE OBCNT ;Room for this byte?
$RETF ;Return false
IDPB S1,OBPTR ;Store it
$RETT ;Return
;GETBYT - returns a byte of data in S1 from the buffer.
;Returns FALSE with S1/-1 if no more characters
;Returns TRUE with S1/character otherwise.
GETBYT: SOSGE S1,IBCNT ;Room for this byte?
$RETF ;Nope
ILDB S1,IBPTR ;Get it
$RETT ;Return
SUBTTL I/O Routines -- Send Data
;Here to send data out to the DJM.
;Returns TRUE of ok, FALSE if not
DQSSND: MOVX T1,BFSBYT ;Buffer size (in bytes)
SUB T1,OBCNT ;Less bytes left gets bytes used
ADDM T1,J$APRT(J) ;Count bytes transmitted
;[5] Write message to log file for debugging
IFN FTPT,< ;[5]
SKIPN PTRACE ;[5] Debugging?
JRST DQSS.1 ;[5] No
$TEXT (LOGCHR,<^I/LPMSG/Sending (length ^D/T1/)^A>) ;[5]
MOVE S2,T1 ;[5] Copy count to S2
MOVE T2,[Point 8,OBUFF] ;[5] Load pointer to string
DQSS.0: ILDB S1,T2 ;[5] Load a character
$TEXT (LOGCHR,< ^D/S1/^A>) ;[5] Output character
SOJG S2,DQSS.0 ;[5] Loop for all characters
$TEXT (LOGCHR,<>) ;[5] Output crlf
> ;[5] End of FTPT
;[5] Send message, length is in T1.
DQSS.1: MOVN T1,T1 ;[5] Make -ive bytes
MOVE S1,J$LCHN(J) ;Load the JFN
MOVE S2,[Point 8,OBUFF] ;Point to the buffer
SOUTR% ;Send the message
ERJMP DQSS.2 ;[5] Owie if failure
;Fall through to DQSOBS
;Here to setup output buffers for transmission
;Returns TRUE always
DQSOBS: MOVX S1,BFSBYT ;Initialize output byte count
MOVEM S1,OBCNT ;Store it there
MOVE S1,[Point 8,OBUFF] ;Reload the output buffer pointer
MOVEM S1,OBPTR ;Store the pointer
$RETT ;Return OK
;[5] Here if error on the SOUTR, return an error for later.
DQSS.2: $CALL DQSOBS ;[5] Reset the buffer for next send
$CALL DQSCHK ;[5] Check and report on link status
$RETF ;[5] Return owie
SUBTTL I/O Routines -- Receive Data
;Here to read data from the DJM.
;Returns TRUE if ok, OBCNT is nonzero if there was a message.
;Returns FALSE if link status not OK or the SINR failed.
DQSREC: $CALL DQSCHK ;Get link status
$RETIF ;Punt if link owie
SETZM IBCNT ;Zero count of characters
TXNN T1,MO%EOM ;Message to read today?
$RETT ;Return OK
;Read whatever is available
DQSR.1: MOVE S1,J$LCHN(J) ;Load the JFN
SIBE% ;Skip input buffer empty
SKIPA T2,S2 ;Load byte count to T1
$RETT ;Return if nothing there
CAILE T2,BFSBYT ;Can we read it?
MOVEI T2,BFSBYT ;No, load max buffer size (in bytes)
MOVN T1,T2 ;Read just that many bytes
MOVE S2,[Point 8,IBUFF] ;Point to the buffer
MOVEM S2,IBPTR ;Save as pointer to buffer
SINR% ;Get the message
ERJMP DQSR.7 ;[5] Failure, indicate that please
MOVEM T2,IBCNT ;Return the number of bytes read
MOVEM T2,IBSLT ;Save last total byte count
;Continued on next page
;Continued from previous page
;[5] Here to put protocol trace in the log file
IFN FTPT,< ;[5]
SKIPN PTRACE ;[5] Debugging?
$RETT ;Return OK
$TEXT (LOGCHR,<^I/LPMSG/Received (length ^D/T2/)^A>) ;[5]
MOVE S2,[Point 8,OBUFF] ;[5] Load pointer to string
JUMPE T2,DQSR.4 ;[5] Jump if no bytes to print
DQSR.3: ILDB S1,S2 ;[5] Load a character
$TEXT (LOGCHR,< ^D/S1/^A>) ;[5] Output character
SOJG T2,DQSR.3 ;[5] Loop for all characters
DQSR.4: $TEXT (LOGCHR,<>) ;[5] Output crlf
> ;[5] End of IFN FTPT
$RETT ;[5] Return OK
;[5] Here if the SINR failed
DQSR.7: MOVEM T2,IBCNT ;[5] Return the number of bytes read
MOVEM T2,IBSLT ;[5] Save last total byte count
CALL DQSCHK ;[5] Get proper error returned
$RETF ;[5] Return bad
SUBTTL I/O Routines -- Wait for Data
;This is the routine to call if you want to wait for data
;Returns TRUE if data recieved
;FALSE if no data or timeout or bad link, J$ERRA(J) set up
DQSWAT: $SAVE <P1> ;Get an AC to loop on
MOVEI P1,DQSWTM ;Wait a maximum of this long
SETZM IBCNT ;Zero count of characters
DQSW.1: $CALL DQSCHK ;Get link status
$RETIF ;Punt if link owie
TXNE T1,MO%EOM ;Message to read today?
JRST DQSR.1 ;Yes, read it
SOJLE P1,DQSW.2 ;Loop for all of it
$DSCHD(0) ;Perform scheduling pass
MOVEI S1,1 ;Sleep for a second
$CALL I%SLP ;ZZZ...
JRST DQSW.1 ;Loop for more
;Here if timed out
DQSW.2: MOVEI S1,[ASCIZ/No message received from DJM/]
MOVEM S1,J$ERRA(J) ;Save that error
$RETF ;Return owie
SUBTTL I/O Routines -- Check on Link Status
;Here to see if the DJM is telling us something we should know.
;Returns TRUE if ok, T1/ link status
;Returns FALSE if not, S1/ error address
DQSCHK: MOVE S1,J$LCHN(J) ;Load the JFN
MOVEI S2,.MORLS ;Read link status
MTOPR% ;Get the status of the link
ERJMP DQSCH3 ;Owie if can't read link status
MOVEM T1,J$LSTS(J) ;Store link status and disconnect code
;See if anything on wire if OK status
TXNN T1,MO%CON!MO%WCC ;[4] Link is connected or waiting?
JRST DQSCH2 ;[4] Nope its owie
TXNE T1,MO%CON ;[4] Link connected?
SKIPE PRTVER ;[4] Yes, read protocol yet?
$RETT ;[4] Yes, just return OK
;[4] Link is open and we haven't read the optional DECnet data, read it
MOVE S1,J$LCHN(J) ;[4] Get JFN
MOVEI S2,.MORDA ;[4] Read data
MOVE T1,[Point 8,PRTVER] ;[4] Point to protocol version area
MTOPR% ;[4] Get the optional data
ERJMP DQSCH3 ;[4] Owie, check it and report it
MOVE T1,J$LSTS(J) ;[5] Get link status/disconnect code
$RETT ;[4] Return OK, PRTVER updated
;Here if problem, close the link and return
DQSCH2: $CALL FNDCER ;Get the DECnet error causing this
MOVEM S1,J$ERRA(J) ;Store error reason
$CALL ABTLNK ;Close and release the JFN
$RETF ;Return owie
;Here if we can't get status of link
DQSCH3: $CALL S%ERR ;Pick up error string address
SKIPT ;Unable to pick up error string adr?
MOVEI S1,[ASCIZ/Fatal error detected in checking DECnet link/]
MOVEM S1,J$ERRA(J) ;Save the error text address
$RETF ;Return error to caller
SUBTTL Report Log
;Here to report the runtime and so on and then return.
DQSLOG: MOVE T3,J$GINP(J) ;Get number of pages
MOVE T2,J ;Get offset into page storage area
DQSL.1: MOVE S1,J$GBUF(T2) ;Get the next buffer address
$LOG (DQS LPTSPL Log,<^T/@S1/>,@JOBOBA,$WTFLG(WT.NFO)) ;Log a buffer
CAME T2,J ;Skip if this is the pre-allocated page
PUSHJ P,M%RPAG ;No, release it
SOJLE T3,ENDREQ ;Decrement count, jump if done
AOJA T2,DQSL.1 ;Loop if not done
SUBTTL End of LPTDQS
END
;;;Local modes:
;;;Mode: MACRO
;;;Comment begin: ";[15] "
;;;Comment column: 40
;;;End: