Trailing-Edge
-
PDP-10 Archives
-
decuslib10-12
-
43,50551/dumper.mac
There are 42 other files named dumper.mac in the archive. Click here to see a list.
DUMVER==1 ;Version
DUMMIN==0 ;SOUP
DUMEDT==4 ;Edit
DUMWHO==0 ;Who
Subttl Timothe Litt 7-Oct-82
Search MACTEN,UUOSYM
Title. DUM,DUMPER,DECsystem-10 Utility for reading DUMPER-20 tapes
DUMTTL ;Generate a TITLE statement
DUMPTX ;Generate a PRINTX for PASS2
.DIRECTIVE FLBLST,.XTABM
Twoseg
Reloc 400K
.REQUEST REL:HELPER
;****************************************************
;COPYRIGHT (C) 1982
;Timothe Litt, Waltham Massachusetts
;This software may be used, copied, or modified without
;fee - Subject only to the inclusion of this notice.
;Users who modify this code are encouraged (begged, even) to
;submit their changes to either DECUS or the author.
;****************************************************
DUM137 ;Store the version in JOBDAT
Subttl Table of contents
; Table of Contents for DUMPER-10
;
;
; SECTION PAGE
; 1. Table of contents..................................... 2
; 2. Revision History...................................... 3
; 3. Definitions........................................... 4
; 4. Initialization........................................ 6
; 5. Command processor
; 5.1 Dispatch table................................ 7
; 5.2 ACCOUNT....................................... 8
; 5.3 CHECKSUM...................................... 9
; 5.4 DENSITY....................................... 10
; 5.5 HELP.......................................... 11
; 5.6 LIST.......................................... 12
; 5.7 PRINT......................................... 13
; 5.8 RESTORE....................................... 14
; 5.9 REWIND........................................ 15
; 5.10 SSNAME........................................ 16
; 5.11 TAPE.......................................... 17
; 5.12 TIMEZONE...................................... 18
; 6. Common routines
; 6.1 OPEN tape for processing...................... 19
; 6.2 Blocking factor recognition................... 20
; 6.3 Build buffers for tape IO..................... 21
; 6.4 CLOSE tape when done.......................... 22
; 7. Input processing
; 7.1 Get record and dispatch on type............... 23
; 7.2 Saveset header records........................ 25
; 7.3 File header record............................ 30
; 7.4 File data records............................. 33
; 7.5 File trailer record........................... 34
; 7.6 Deal with EOF marks........................... 35
; 7.7 Saveset trailer record........................ 37
; 8. Checksum calculation routines......................... 39
; 9. Utility routines
; 9.1 Masked table lookup........................... 40
; 9.2 Read a TOPS-10 filespec....................... 41
; 9.3 Read number................................... 43
; 9.4 Read a masked SIXBIT word..................... 44
; 9.5 Skip leading blanks........................... 45
; 9.6 Input a command character..................... 46
; 9.7 ASCII - SIXBIT conversion..................... 47
; 9.8 UDT conversion................................ 48
; 9.9 Accumulator coroutines........................ 52
; 10. Listing routines
; 10.1 Open listing file............................. 53
; 10.2 Numeric output................................ 54
; 10.3 Primitives.................................... 55
; 11. Impure storage........................................ 56
Subttl Revision History
Comment @
Edit Who What/Why
---- --- -------------------------------------------------
1 TL Initial development
2 TL Add SSNAME support. Add ^Z support. Fix RESTORE
to properly stop at each SaveSet.
3 TL Add revision history. Remove more magic numbers.
Fix various listing bugs.
4 TL Fix SSNAME so maximum length properly checks final <NUL>
5 TL Modify Copyright notice for DECUS release.
Things to improve:
o Memory management of page header; should be able to reuse,
perhaps with list of chunks, or just reset .jbff to header if #0
o Print destination filespec on restore from lookup block and path.
o Replace halts with error messages
o Error recovery. Include more info in error messages
o SSNAME should take explicitly quoted string, and skip leading blanks.
o Define and use symbols for tape record offsets, FDB words.
o List more of FDB on PRINT output
o Add SKIP command. (Read backwards for skip .le. 0)
o RESTORE should take 10-filespec=20-filespec. Including wildcards.
TSKSER has reasonable code for -20 style ASCII wildcards.
o Maybe there should be a SAVE command after all.
o Add support (or at least recognition) of labeled tapes.
@
Subttl Definitions
ND LN$REC,^D518 ;Size of a record
ND MX$BLK,^D20 ;Maximum allowed blocking factor
ND T$BUF,^D6 ;Number of tape buffers
ND DF$TZN,^D5 ;Default timezone of 20 system
ND LN$PDL,30
ND NM$LPP,^D60 ;Number of data lines/listing page
ND MX$SSN,^D200 ;Max chars in a SaveSet name
ND FDB,^O206 ;Offset of FDB data in file header
ND HLP,0
ND MTA,1
ND FIL,2
ND LST,3
;ACs
F=0
T1=1
T2=2
T3=3
T4=4
P1=5
P2=6
P3=7
P4=10
R=11
C=12
P=17
;Bits in F
F.SAVE==1 ;SAVE in progress
F.REST==2 ;RESTORE in progress
F.LIST==4 ;LIST in progress
F.EOF==10 ;EOF mark seen on last IN UUO
F.RGT==20 ;Char re-getter
F.PRNT==40 ;PRINT in progress
F.INT==100 ;Listing device is "interactive"
F.TTYL==200 ;Listing device is my TTY
F.REW==400 ;Rewind tape before command
F.NCKS==1K ;NOCHECksum on input
F.NACT==2K ;NOACCOunt from tape
F.SSNM==4K ;Working on an explicit SSNAME
F.SSOK==10K ;Current SS is specified one
;File spec block layout
$FSDEV==0
$FSNAM==1
$FSEXT==2
$FSPPN==3
$FSPTH==4
$FSLEN==$FSPTH+.PTMAX
Subttl Initialization
START: TDZA T1,T1 ;Zero offset
MOVEI T1,1 ;CCL start
MOVEM T1,OFFSET
RESET
MOVE P,[IOWD LN$PDL,PDL] ;Set up a stack
SETZM BLKFCT ;Clear old blocking factor
SETZM TAPDEN ;Default is don't touch
MOVX T1,-^D100 ;Use impossible value
MOVEM T1,TIMZON ;To say we don't know
SETZ F, ;Clear our flags
NEWCMD: HLRZ T1,.JBSA ;Get original .JBFF
HRRM T1,.JBFF ;And reset it
SETZM HDRPTR
SETZM HEADER
OUTCHR ["/"] ;Prompt
PUSHJ P,RDSIXM ;Read a masked SIXBIT word
JUMPE T2,CHKEOL ;If null, be sure at EOL
MOVE T3,CMDIOW ;Fetch an IOWD to our command table
PUSHJ P,LUKTAB ;Look up the command
JRST E$$URC ;Unrecognized or ambiguous
MOVE T1,CMDDSP(T1) ;Get dispatch
PUSHJ P,0(T1) ;Call action routine
JRST CMDFLH ;Error, flush to EOL
CHKEOL: TXZ F,F.RGT
JUMPLE C,NEWCMD ;If at EOL, done
OUTSTR [Asciz .
? Junk in command line -- ignored
.]
JRST CMDFLH
E$$URC: OUTSTR [Asciz .
? Unrecognized (or ambiguous) command
.]
CMDFLH: TXZ F,F.RGT
JUMPLE C,NEWCMD ;If at EOL, done
PUSHJ P,TYI ;Read a char
JRST CMDFLH ;And see what we got
Subttl Command processor -- Dispatch table
;Dispatch flags
CP.NO==(1B0) ;This is a NO form command
DEFINE CMDS,
<
X ACCOUNT ,$ACCOUNT
XLIST
X CHECKSU ,$CHECKSUM
X DENSITY ,$DENSITY
X HELP ,$HELP
X LIST ,$LIST
X NOACCOU ,$ACCOUNT,CP.NO
X NOCHECK ,$CHECKSUM,CP.NO
X NOLIST ,$LIST,CP.NO
X NOREWIN ,$REWIND,CP.NO
X NOSSNAME,$SSNAME,CP.NO
X PRINT ,$PRINT
X RESTORE ,$RESTO
X REWIND ,$REWIND
X SSNAME ,$SSNAME
X TAPE ,$TAPE
X TIMEZON ,$TIMZONE
LIST
>
DEFINE X(C,P,F<0>),
<
EXP <SIXBIT /C/>>
CMDTAB: CMDS
CMDNUM==.-CMDTAB
CMDIOW: IOWD CMDNUM,CMDTAB ;Iowd to command table
DEFINE X(C,P,F<0>),
<
XWD <F>,P>
CMDDSP: CMDS
Subttl Command processor -- ACCOUNT
$ACCOUNT:
TLNE T1,CP.NO ;NOACCOUNT?
TXOA F,F.NACT ;Yes
TXZ F,F.NACT ;No
JRST CPOPJ1 ;Done
Subttl Command processor -- CHECKSUM
$CHECKSUM:
TLNE T1,CP.NO ;NOCHECKsum?
TXOA F,F.NCKS ;Yes
TXZ F,F.NCKS ;No
JRST CPOPJ1 ;Done
Subttl Command processor -- DENSITY
$DENSITY:
TXO F,F.RGT ;Have a char
JUMPLE C,E$$IDN
PUSHJ P,RDDEC ;Get a number
MOVSI T4,-DENNUM ;Legal densities table
DENST0: MOVE T2,DENTAB(T4) ;Get one
CAIN T1,(T2) ;Match?
JRST DENSTF ;Yes
AOBJN T4,DENST0 ;Keep looking
E$$IDN: OUTSTR [Asciz .
?Illegal value for density
.]
POPJ P, ;Sigh
DENSTF: HLRZS T2 ;Get code
MOVEM T2,TAPDEN ;Save
JRST CPOPJ1 ;Done
DEFINE D(DN,CD),
<
XWD <CD>,^D<DN>>
DENTAB: D 200,.TFD20
D 556,.TFD55
D 800,.TFD80
D 1600,.TFD16
D 6250,.TFD62
DENNUM==.-DENTAB
Subttl Command processor -- HELP
$HELP:
MOVE T1,[SIXBIT .DUMPER.] ;Our name
PUSHJ P,.HELPR## ;Call the inefficient system routine
JRST CPOPJ1 ;Done
Subttl Command processor -- LIST
$LIST:
TLNE T1,CP.NO ;NO form?
JRST [TXZ F,F.LIST ;Yes, turn it off
JRST CPOPJ1]
TXO F,F.LIST ;Turn LISTing on
MOVEI T1,LSTSPC ;Point to listing spec
PUSHJ P,FILS10 ;Read a 10 filespec
POPJ P, ;Oops
JRST CPOPJ1 ;Done
Subttl Command processor -- PRINT
$PRINT:
TXZ F,F.SAVE ;Not SAVE
TXO F,F.PRNT ;Is PRINT
MOVEI T1,LSTSPC ;Point to listing spec
PUSHJ P,FILS10 ;Read a 10 filespec
POPJ P, ;Error
DOPRT: PUSHJ P,OPNTAP ;Open the tape
POPJ P, ;Can't
PUSHJ P,OPNLST ;Get the listing file open
JRST PRTEND ;No point in continuing
PUSHJ P,RDTAPE ;Process the tape
JFCL
PRTEND: PUSHJ P,CLSTAP ;Close the tape
JRST CPOPJ1
Subttl Command processor -- RESTORE
$RESTORE:
TXZ F,F.SAVE!F.PRNT ;Neither SAVE nor PRINT
JUMPLE C,DORST ;If no args, just do restore
JRST CPOPJ1
DORST: PUSHJ P,OPNTAP ;Open the tape
POPJ P, ;Can't
PUSHJ P,OPNLST ;Get the listing file if on
JRST RSTEND ;Sigh
PUSHJ P,RDTAPE ;Process the tape
JFCL
RSTEND: PUSHJ P,CLSTAP ;Close the tape
JRST CPOPJ1
Subttl Command processor -- REWIND
$REWIND:
TLNE T1,CP.NO ;No form?
JRST [TXZ F,F.REW ;Yes, don't to that
JRST CPOPJ1]
JUMPLE C,REWND1 ;If no arg, use present device
TXO F,F.RGT ;Already have a char
PUSHJ P,RDSIXM ;Read a tape name
CAIN C,":" ;Trash extra colon
PUSHJ P,TYI
JUMPE T2,E$$ILD ;Bitch if illegal
MOVEM T1,DEVICE ;Save as new device
REWND1: TXO F,F.REW ;Remember to rewind it
JRST CPOPJ1 ;Done
Subttl Command processor -- SSNAME
$SSNAME:
TLNE T1,CP.NO ;NOSSNAME?
JRST [TXZ F,F.SSNM ;Yes, forget it
JRST CPOPJ1] ;Done
MOVE T4,[POINT 7,SSNBUF] ;Point to buffer
MOVEI T3,MX$SSN ;Maximum size allowed
SSNLUP: PUSHJ P,TYI ;Get a character
JUMPLE C,SSNEND ;End of line, stop
CAIL C,"a" ;If lowercase,
CAILE C,"z" ;...
CAIA
TRZ C,40 ;Make upper
IDPB C,T4 ;Store now
SOJG T3,SSNLUP ;Loop for next char
OUTSTR [Asciz /
? SSNAME exceeds maximum length
/]
POPJ P,
SSNEND: SETZ T1, ;Get a null
IDPB T1,T4 ;Terminate the string
TXO F,F.SSNM ;Remember we want a specific SS
JRST CPOPJ1 ;Done
Subttl Command processor -- TAPE
$TAPE: TXO F,F.RGT ;Already have a char
PUSHJ P,RDSIXM ;Read a tape name
CAIN C,":" ;If trailing colon,
PUSHJ P,TYI ;Eat it here
JUMPE T2,E$$ILD ;Illegal device
MOVEM T1,DEVICE ;Save requested device
JRST CPOPJ1 ;Done
E$$ILD: OUTSTR [ASCIZ .
? Illegal device name
.]
POPJ P,
Subttl Command processor -- TIMEZONE
$TIMZONE:
TXO F,F.RGT ;Already may have a char
JUMPLE C,E$$ITZ ;Required
PUSHJ P,RDDEC ;Get one
CAML T1,[^D-24]
CAILE T1,^D24 ;See that it's reasonable
JRST E$$ITZ
MOVEM T1,TIMZON ;Save it
JRST CPOPJ1 ;Seems OK
E$$ITZ: OUTSTR [Asciz .
?Illegal value for timezone
.]
POPJ P,
Subttl Common routines -- OPEN tape for processing
OPNTAP: MOVX T1,UU.SOE!.IODMP ;Set up DUMP mode to read first record
SKIPN T2,DEVICE ;See if a device was specified
MOVE T2,[SIXBIT/DUMPER/] ;Use logical device name
MOVEI T3,MTAHDR ;Point to input header
TXNE F,F.SAVE ;If doing a SAVE,
MOVSS T3 ;Need an OUTPUT header
OPEN MTA,T1 ;Get the device
JRST [OUTSTR [Asciz .
? Can't OPEN tape device
.]
POPJ P,]
MOVE T1,[XWD 3,T2] ;UUO pointer
MOVEI T2,.TFDEN+.TOSET ;To set density
MOVEI T3,MTA ;For our tape
SKIPE T4,TAPDEN ;If specified
TAPOP. T1, ;Set it
JFCL
MOVE T1,[XWD 3,T2] ;Once more
MOVEI T2,.TFRDB+.TOSET ;To clear any read backwards
SETZ T4, ;Left behind
TAPOP. T1, ;Do it
JFCL ;Probably wrong kind of drive
TXZE F,F.REW ;Were we supposed to rewind first?
MTREW. MTA, ;Yes
MTWAT. MTA, ;Wait in any case, for old monitors
SETOM OURSEQ ;We've lost position
MOVEI T1,MTA ;Get channel number
DEVNAM T1, ;Turn into physical device
HALT . ;It must exist(!)
MOVEM T1,PHYMTA ;Save physical device name
Subttl Common routines -- Blocking factor recognition
TXNE F,F.SAVE ;Doing a SAVE?
JRST BLDBUF ;Yes, use specified blocking factor
PUSH P,[EXP 0] ;Save a small buffer
MOVSI T1,-1 ;Build an
HRRI T1,-1(P) ;Iowd
SETZ T2, ;List
INPUT MTA,T1 ;Read the first record
POP P,(P) ;Throw it out
MOVE T1,[XWD 2,T2] ;Point to TAPOP. block
MOVEI T2,.TFCNT ;Read frame count of last record
MOVEI T3,MTA ;Read on channel MTA
TAPOP. T1, ;Ask for it
MOVEI T1,LN$REC*5 ;Assume blocked 1
JUMPE T1,[TXON F,F.EOF ;Must have hit an EOF mark
JRST OPNTAP ;Stray one, try again
MOVX T1,UU.PHS!UU.SOE!.IODMP ;Clear the status bits
MOVE T2,PHYMTA ;The hard way
SETZ T3,
OPEN MTA,T1
HALT .
JRST FNDEOT] ;Found logical EOT. Stop
IDIVI T1,^D5 ;Turn frames into 10 words
JUMPN T2,NOTDPF ;If not even, can't be DUMPER format
IDIVI T1,LN$REC ;Divide into records
JUMPN T2,NOTDPF ;If not even, not DUMPER
CAILE T1,MX$BLK ;Legal blocking?
JRST NOTDPF ;No, not DUMPER format
MOVEM T1,BLKFCT ;Save blocking factor
MTBSR. MTA, ;Put tape back where it belongs
MTWAT. MTA, ;Wait for completion
Subttl Common routines -- Build buffers for tape IO
BLDBUF: SETSTS MTA,.IOIMG ;Use buffered image mode
SKIPLE T1,BLKFCT ;Get blocking factor
CAILE T1,MX$BLK ;Be sure it's legal
MOVEI T1,1 ;Default blocking factor
MOVEM T1,BLKFCT ;Save result
IMULI T1,LN$REC ;Now size of buffer's data
ADDI T1,3 ;Add buffer header size
MOVE T4,T1 ;Size of a buffer
IMULI T1,T$BUF ;Times number of buffers
EXCH T1,.JBFF ;Get address of first
MOVE T2,T1 ;Save address
ADDB T2,.JBFF ;Allocate the core
CAMG T2,.JBREL ;Is it in core?
JRST GOTCOR ;Yes, all set
CORE T2, ;No, make room
CAIA
JRST GOTCOR ;Got it
OUTSTR [Asciz .
?Core expansion failed for IO buffers.]
EXIT
GOTCOR: MOVEI T3,T$BUF-1 ;Get number of buffers - 1
AOJ T1, ;Point to second word of buffer
TLO T1,(BF.VBR) ;Set virgin ring bit
MOVEM T1,MTAHDR+.BFADR ;Point ring header to first
BUFLUP: HRRZ T2,T1 ;Get address of current buffer
ADDI T2,0(T4) ;Point to next buffer
HRLI T2,-2(T4) ;Size of buffer +1
MOVEM T2,0(T1) ;Point this to next
MOVE T1,T2 ;Step to next
SOJG T3,BUFLUP ;Loop over all but last buffer
HRRZ T3,MTAHDR+.BFADR ;Get address of first
HRLI T3,-2(T4) ;Size of last buffer
MOVEM T3,0(T2) ;Point last to first
JRST CPOPJ1 ;Tape is now ready for IO
Subttl Common routines -- CLOSE tape when done
CLSTAP: TXNE F,F.SAVE ;SAVE?
JRST CLSTPZ ;Yes, don't mess around
WAIT MTA, ;Make sure we have stopped
SETZ T1, ;Clear count of preread buffers
HRRZ T2,MTAHDR+.BFADR ;Get address of current buffer
SKIPN T2 ;Be sure buffers are present
HALT . ;Debug this
HRRZ T3,0(T2) ;Start with the next one
CLSTP1: CAMN T3,T2 ;Returned to current buffer yet?
JRST CLSTP2 ;Yes, see what we have
SKIPGE 0(T3) ;Is the "USE" bit set?
AOJ T1, ;Yes, it's full
HRRZ T3,0(T3) ;Get next buffer in ring
JRST CLSTP1 ;And look at it
CLSTP2: JUMPLE T1,CLSTPZ ;Exit if no extra records read
MOVE T2,[XWD 2,T3] ;Set up TAPOP.
MOVEI T3,.TFBSB ;Backspace a record
MOVEI T4,MTA ;For this device
CLSTP3: TAPOP. T2, ;For each extra record read
MTBSR. MTA, ;Old way
SOJGE T1,CLSTP3 ;So we don't miss any
CLSTPZ: RELEAS MTA, ;Get rid of the tape
POPJ P, ;Done
Subttl Input processing -- Get record and dispatch on type
RDTAPE: MOVEI T1,NM$LPP ;Start a fresh page
MOVEM T1,LINLFT ;In case we are listing/printing
TXZ F,F.SSOK ;Clear process this SS flag
RECLUP: SKIPLE MTAHDR+.BFCTR ;Records left?
JRST GOTREC ;Yes
RECLP1: IN MTA,
JRST RECLUP ;Got a new one, process
STATZ MTA,IO.EOF
JRST INEOF
OUTSTR [ASCIZ .
?Input error, continuing
.]
JRST RECLP1 ;Read next record
NOTDPF: MTBSR. MTA, ;Un-move the tape
MTWAT. MTA, ;Wait for it to finish
OUTSTR [Asciz .
?Not DUMPER format.]
POPJ P,
GOTREC: TXZ F,F.EOF ;Last record not EOF
MOVNI R,LN$REC ;Get size of a record
ADDM R,MTAHDR+.BFCTR ;Count it off
SKIPGE MTAHDR+.BFCTR ;Did it go negative?
JRST [OUTSTR [Asciz . Record length error, continuing.]
JRST RECLUP]
MOVNS R ;Get positive length
EXCH R,MTAHDR+.BFPTR ;Get new address
ADDM R,MTAHDR+.BFPTR ;Update for next record
AOJ R, ;Point to real first word
MOVE T1,5(R) ;Get record sequence
AOSG OURSEQ ;Figure what comes next
MOVEM T1,OURSEQ ;First one, take what we get
CAME T1,OURSEQ ;Do they match?
JRST [OUTSTR [Asciz . Sequence error, continuing.]
MOVEM T1,OURSEQ ;Save what last we got
JRST .+1]
TXNE F,F.NCKS ;Suppress checksumming?
JRST GOTRC1 ;Yes, not recommended, but fast
PUSHJ P,CHKCKS ;Check the checksum
OUTSTR [Asciz . Checksum error.]
GOTRC1: MOVN T1,4(R) ;Get record type
CAIL T1,0 ;If illegal
CAILE T1,7 ;...
JRST RECLUP ;Flush it
JRST @DSPTAB(T1) ;Dispatch on record type
DSPTAB: Z DATA
Z SSNAME
Z FILEST
Z FILEND
Z EOTREC
Z RECLUP ;User directory info
Z SSNAM2
Z RECLUP ;Fill record
Subttl Input processing -- Saveset header records
;Here at the beginning of a save set...
SSNAME: MOVE T1,F
ANDX T1,F.SSOK
MOVEM T1,LSSOK ;Remember if last ss was processed
PUSHJ P,SETHDR ;Set up for writing header
MOVEI T1,[Asciz .
DUMPER tape #.]
PUSHJ P,HDRSTR ;Output it
HRRZ T1,2(R) ;Get tape #
PUSHJ P,HDRDEC ;That too
MOVEI T1,[Asciz ., ".]
PUSHJ P,HDRSTR
TXNN F,F.SSNM ;SS specified?
JRST SSNAM1 ;No, don't bother checking
MOVE T4,[POINT 7,11(R)] ;Get a pointer to Tape
MOVE T3,[POINT 7,SSNBUF] ;And one to desired SS
TXZ F,F.SSOK ;Assume bad
PUSH P,P1 ;Save an AC
MOVEI P1,MX$SSN ;Maximum chars to check
SSNAM0: ILDB T1,T4 ;Get a char from tape
CAIL T1,"a" ;Upcase the tape
CAILE T1,"z" ; (The user's was fixed earlier)
CAIA
TRZ T1,40 ;LC, do the UPcase
ILDB T2,T3 ;And one from user
CAIE T1,(T2) ;Do they match?
JRST SSNM1 ;No
JUMPE T1,SSNAMO ;If hit end of string, OK
SOJGE P1,SSNAM0 ;Not yet, keep trying
JRST SSNM1 ;Strange, but no match
SSNAMO: TXO F,F.SSOK ;Remember that this is good
SSNM1: POP P,P1
SSNAM1: MOVEI T1,11(R) ;Point to SSNAME
PUSHJ P,HDRSTR ;List it
MOVEI T1,[Asciz .", .]
PUSHJ P,HDRSTR
PUSHJ P,UDTFUD ;Get fudge factor for GMT
MOVE T2,10(R) ;Get UDT of save -GMT
SUBM T2,T1 ;Make a local time
HLRZS T1 ;Get days since only
IDIVI T1,^D7 ;Find weekday of save
MOVE T1,[[ASCIZ .Wednesday.]
[ASCIZ .Thursday.]
[ASCIZ .Friday.]
[ASCIZ .Saturday.]
[ASCIZ .Sunday.]
[ASCIZ .Monday.]
[ASCIZ .Tuesday.]](T2)
PUSHJ P,HDRSTR ;Add that
MOVEI T1,[ASCIZ ., .] ;And that
PUSHJ P,HDRSTR
MOVE T1,10(R) ;Get save time again
PUSHJ P,UDTSDT ;Turn into a system date
PUSH P,T1 ;Save time
MOVE T1,T2 ;Get date
IDIVI T1,^D31 ;Find days
PUSH P,T1 ;Save rest
AOS T1,T2 ;Get day
PUSHJ P,HDRDEC ;Output it
MOVE T1,(P) ;Get fraction
IDIVI T1,^D12 ;Split years, months
MOVEM T1,(P) ;Save years
PUSH P,[ASCII .-Jan--Feb--Mar--Apr--May--Jun--Jul--Aug--Sep--Oct--Nov--Dec-.](T2)
PUSH P,[EXP 0] ;Make ASCIZ
MOVEI T1,-1(P) ;Point to value
PUSHJ P,HDRSTR ;Send it along
POP P,(P)
POP P,(P)
POP P,T1 ;Years
ADDI T1,^D64 ;Relocate to reality
PUSHJ P,HDRDEC ;Now, output it
MOVEI T2," "
PUSHJ P,HDRCHR
POP P,T1 ;Get time back
ADDI T1,^D30K ;Round to minutes
IDIVI T1,^D60K ;From MS
IDIVI T1,^D60 ;Now, split hours from minutes
IMULI T1,^D100 ;Time in split radix
ADDI T1,(T2) ;with the minutes, of course
PUSHJ P,HDRDEC ;Send it out
MOVEI T1,[CRLF: BYTE(7).CHCRT,.CHLFD,.CHNUL]
PUSHJ P,HDRSTR
PUSHJ P,HDREND ;Done with header
MOVE T1,HEADER ;Get pointer to result
TXNN F,F.TTYL
OUTSTR (T1)
MOVEI T1,[Asciz .
File
Eof(bytsz) Pgs
.]
PUSHJ P,HDRSTR
PUSHJ P,HDREND
MOVE T1,HEADER ;Point to result
PUSHJ P,LSTSTR
TXNE F,F.SSNM ;If generic SS
SKIPN LSSOK ; or last one not processed
JRST RECLUP ;keep going
TXNE F,F.PRNT ;If printing,
JRST RECLUP ;Continue
JRST CPOPJ1 ;Restore, stop at end of SS
;Here with a continuation save set...
SSNAM2:; MOVEI T1,[Asciz .
;Continuation saveset ".]
; PUSHJ P,LSTMSG
; JRST SSNAM1
jrst ssname
SETHDR: HRRZ T1,.JBFF ;Get a place to find core
MOVEM T1,HEADER ;Save the place
AOS .JBFF ;Allocate the core
HRLI T1,(POINT 7,0) ;Get a pointer to it
MOVEM T1,HDRPTR ;Save for later
SETHWD: HRRZS T1
CAMG T1,.JBREL ;In core?
JRST SETHW1 ;Yes
PUSH P,T1
CORE T1,
JRST [OUTSTR [Asciz .
?Core expansion failed for SSNAME
.]
EXIT]
POP P,T1
SETHW1: SETZM (T1) ;Clear the core
POPJ P,
HDRSTR: HRLI T1,(POINT 7,0)
HDRST1: ILDB T2,T1
JUMPE T2,CPOPJ
PUSHJ P,HDRCHR
JRST HDRST1
HDRDEC: IDIVI T1,12
HRLM T2,(P)
SKIPE T1
PUSHJ P,HDRDEC
HLRZ T2,(P)
ADDI T2,"0"
HDRCHR: MOVE T3,HDRPTR ;Get the output pointer
TLNE T3,(76B5) ;Word full?
JRST HDRCH1 ;No
PUSH P,T1
AOS T1,.JBFF
SOJ T1,
PUSHJ P,SETHWD
POP P,T1
HDRCH1: IDPB T2,HDRPTR
POPJ P,
HDREND: SETZ T2,
PUSH P,HDRPTR
PUSHJ P,HDRCHR
POP P,HDRPTR
POPJ P,
Subttl Input processing -- File header record
;Here with the beginning of a new file...
FILEST: TXNE F,F.SSNM
TXNE F,F.SSOK
CAIA
JRST RECLUP
TXNN F,F.TTYL!F.PRNT
OUTSTR [ASCIZ .
Restoring file .]
MOVEI T1,6(R)
TXNN F,F.PRNT
OUTSTR (T1)
PUSHJ P,LSTSTR
MOVEI T1,CRLF
PUSHJ P,LSTSTR
MOVEI T1,[Asciz . .]
PUSHJ P,LSTSTR
SETZM LKPBLK
MOVE T1,[XWD LKPBLK,LKPBLK+1]
BLT T1,CLREND
MOVE T1,FDB+12(R) ;(.FBSIZ)Bytes in file
PUSHJ P,LSTDEC
MOVEI T1,[Asciz .(.]
PUSHJ P,LSTSTR
LDB T1,[POINT 6,FDB+11(R),11] ;(.FBBYZ)Byte size
PUSHJ P,LSTDEC
MOVEI T1,[Asciz .).]
PUSHJ P,LSTSTR
HRRZ T1,FDB+11(R) ;(.FBBYZ)Page count
MOVE T2,T1 ;Make a copy
LSH T2,2 ;Turn into blocks
MOVEM T2,LKPBLK+.RBEST ;Help FILSER
PUSHJ P,LSTDEC
HRLZ T2,FDB+4(R) ;(.FBPRT)Protection
MOVE T3,[POINT 3,LKPBLK+.RBPRV]
MOVEI T4,3
PRTCVT: SETZ T1, ;Clear 10 protection
LSHC T1,6 ;Get 20 protection
TLO T1,7 ;Assume no access
TRNE T1,10 ;Execute ok?
HRLI T1,6
TRNE T1,40 ;Read?
HRLI T1,5
TRNE T1,4 ;Append?
HRLI T1,4
TRNE T1,20 ;Write?
HRLI T1,2
TRC T1,77 ;77 usually means "anything"
TRCN T1,77 ;On TOPS-20, so allow rename
HRLI T1,0 ;In this case (20 has no equiv)
LSH T1,-22 ;Position new protection
IDPB T1,T3 ;Store in RIB
SOJG T4,PRTCVT ;Loop for group, world access
HLRZ T1,FDB+7(R) ;(.FBGEN)Generation of file
MOVEM T1,LKPBLK+.RBVER ;Store for directory cmd
MOVEI T1,CRLF
PUSHJ P,LSTSTR
TXNE F,F.PRNT ;PRINTing?
JRST RECLUP ;Yes, don't restore
MOVE T4,[POINT 7,6(R)]
FILST1: ILDB T1,T4
CAIE T1,">"
JRST FILST1
MOVE T3,[POINT 6,FILNAM]
FILST2: ILDB T1,T4
CAIN T1,"."
JRST FILST3
PUSHJ P,SIXFIX
TLNE T3,(77B5)
IDPB T1,T3
JRST FILST2
FILST3: MOVE T3,[POINT 6,FILEXT,17]
FILST4: ILDB T1,T4
CAIN T1,"."
JRST FILST5
PUSHJ P,SIXFIX
TLNE T3,(77B5)
IDPB T1,T3
JRST FILST4
FILST5: MOVSS FILEXT
CAIA
FILST6: JUMPE T1,FILST8
ILDB T1,T4
CAIE T1,";"
JRST FILST6
ILDB T1,T4
CAIE T1,"A"
JRST FILST6
MOVE T2,[POINT 7,LKPBLK+.RBACT]
MOVEI T3,^D40
FILST7: ILDB T1,T4
CAIE T1,";"
SKIPN T1
JRST FILST8
TXNN F,F.NACT
IDPB T1,T2
SOJG T3,FILST7
FILST8: MOVE T1,FDB+13(R) ;(.FBCRV)File creation
PUSHJ P,UDTSDT ;Turn into 15 bit format
DPB T2,[POINTR(LKPBLK+.RBPRV,RB.CRD)] ;Store 12
LSH T2,-^D12
DPB T2,[POINTR(LKPBLK+.RBEXT,RB.CRX)] ;and high 3
IDIVI T1,^D<60*1K> ;Turn MS into minutes
DPB T1,[POINTR(LKPBLK+.RBPRV,RB.CRT)] ;Save creation time
MOVE T1,FDB+5(R) ;(.FBCRE)Last write close
MOVE T2,FDB+15(R) ;(.FBREF)Last non-write close)
CAMGE T1,T2 ;Which is later
MOVE T1,T2
PUSHJ P,UDTSDT ;Use result as access date
DPB T2,[POINTR(LKPBLK+.RBEXT,RB.ACD)] ;For RIB
MOVEI T1,.RBAC8
MOVEM T1,LKPBLK
TXNN F,F.TTYL!F.PRNT
OUTSTR [Asciz / .../]
MOVEI T1,.IODMP
MOVSI T2,(SIXBIT /DSK/)
MOVSI T3,0
OPEN FIL,T1
HALT .
ENTER FIL,LKPBLK
HALT .
MOVEI T1,FIL ;Get the file channel
MOVEM T1,FILPTH+.PTFCN ;We want it's path
MOVE T1,[XWD .PTMAX,FILPTH] ;Arg pointer
PATH. T1, ;Do it
HALT . ;Huh?
JRST RECLUP
Subttl Input processing -- File data records
;Here with a data record. Presumably the file is open...
DATA: TXNE F,F.SSNM
TXNE F,F.SSOK
CAIA
JRST RECLUP
TXNE F,F.PRNT ;PRINTing?
JRST RECLUP ;Yes, ignore data
HRRZ T3,3(R) ;Get file page number
LSH T3,2 ;Make block number
CAMN T3,CURBLK ;Don't bother if already there
JRST DATA1 ;Contiguous page, continue
MOVE T1,[XWD 2,T2] ;Point to FILOP.
MOVE T2,[XWD FIL,.FOUSO] ;What to do
AOJ T3, ;Turn offset into block number
FILOP. T1, ;Put it there
USETO FIL,(T3) ;Try the old way
SOJ T3, ;Restore block offset (usually faster)
DATA1: ADDI T3,4 ;We are doing this much more...
MOVEM T3,CURBLK ;So save for next time
MOVSI T1,-1000 ;Count
HRRI T1,6-1(R) ;Address-1 of data
SETZ T2,
OUT FIL,T1
JRST RECLUP
OUTSTR [ASCIZ .
?Output error.]
EXIT
Subttl Input processing -- File trailer record
;Here with the End of File record...
FILEND: TXNE F,F.SSNM
TXNE F,F.SSOK
CAIA
JRST RECLUP
TXNE F,F.PRNT ;PRINTing?
JRST RECLUP ;Yes, ignore
TXNN F,F.TTYL
OUTSTR [ASCIZ .[EOF].]
CLOSE FIL,CL.ACS
STATZ FIL,IO.ERR
JRST [OUTSTR [ASCIZ .
?Error on close.]
EXIT]
RELEAS FIL,
JRST RECLUP
Subttl Input processing -- Deal with EOF marks
;Here at EOF mark
INEOF: CLOSE MTA, ;Flush buffer ring
; PUSH P,MTAHDR+.BFADR ;Save pointer to ring
; MOVX T1,UU.PHS!UU.SOE!.IOIMG ;Image mode
; MOVE T2,PHYMTA ;The physical device
; MOVEI T3,MTAHDR ;Point to the control block
; TXNE F,F.SAVE ;Doing output?
; MOVSS T3 ;Yes
; OPEN MTA,T1 ;Get the device again
; HALT . ;Who stole it (and how?)
; POP P,MTAHDR+.BFADR ;Restore our buffer ring
TXON F,F.EOF ;Was last record an EOF?
JRST RECLUP ;No, continue
FNDEOT: MOVEI T1,[Asciz |
End of tape.
|]
PUSHJ P,LSTMSG ;Tell folks
MTBSR. MTA, ;Back over the last mark
MTWAT. MTA, ;And wait
SETOM OURSEQ ;We've lost position
TXNE F,F.PRNT!F.LIST ;PRINTing or LISTing?
RELEAS LST, ;Yes, close file
JRST CPOPJ1 ;Done with command
Subttl Input processing -- Saveset trailer record
;Here on EOF record
EOTREC: MOVEI T1,[Asciz |
End of saveset.
|]
PUSHJ P,LSTMSG
TXNE F,F.PRNT ;If PRINTing
JRST RECLUP ;Loop for next record
TXNE F,F.LIST ;Listing?
RELEAS LST, ;Yes, close file
JRST CPOPJ1 ;Done with command
Subttl Checksum calculation routines
CHKCKS: PUSHJ P,CKSREC ;Checksum this record
CAMN T1,[EXP -1] ;Is it right?
CPOPJ1: AOS (P) ;Yes
CPOPJ: POPJ P,
SETCKS: SETZM 0(R) ;Clear checksum
PUSHJ P,CKSREC ;Compute a checksum
SETCAM T1,0(R) ;Store result
POPJ P,
CKSREC: SETZ T1, ;Clear answer
JCRY0 .+1 ;Clear carry
MOVSI T2,-LN$REC ;Record size
HRRI T2,0(R) ;Point to record
CKSRC1: ADD T1,0(T2) ;Add this word into sum
JCRY0 [AOJA T1,.+1] ;If went to zero, make 1
AOBJN T2,CKSRC1 ;Loop over whole record
POPJ P,
Subttl Utility routines -- Masked table lookup
LUKTAB: PUSH P,P1 ;Save an AC
PUSH P,P2
SETZ P1, ;Location of match
MOVE P2,T3 ;Original table pointer
LUKTBL: MOVE T4,1(T3) ;Get the next entry
XOR T4,T1 ;See if matches input
JUMPE T4,LKTBM1 ;Yes, match (exact)
AND T4,T2 ;No, see if partial
JUMPN T4,LUKTBE ;No, advance to next
JUMPN P1,LUKTBF ;If second match, fail
MOVE P1,T3 ;Yes, save this match
LUKTBE: AOBJN T3,LUKTBL ;Loop for next word
JUMPN P1,LUKTBM ;If we had a match, use it
LUKTBF: POP P,P2 ;Restore P1
POP P,P1
POPJ P,
LUKTBM: MOVE T3,P1 ;Get offset of success
LKTBM1: SUB T3,P2 ;Compute offset
HRRZS T1,T3
AOS -2(P) ;Success
JRST LUKTBF ;Return
Subttl Utility routines -- Read a TOPS-10 filespec
FILS10: PUSHJ P,SAVE1 ;Save an AC
MOVE P1,T1 ;Now, keep a pointer to the FS block
SETZM 0(P1) ;Clear it out
HRLI T1,(T1) ;Make BLT pointer
HRRI T1,1(T1) ;Finish it
BLT T1,$FSLEN-1(P1) ;Clear to end
JUMPLE C,CPOPJ1 ;Return if none
FILS1A: PUSHJ P,RDSIXM ;Get the next word
CAIE C,":" ;Was that a device?
JRST FILS1B ;No
JUMPE T2,E$$ETF ;Error in 10 filespec
SKIPE $FSDEV(P1) ;Already specified?
JRST E$$ETF ;Yes
MOVEM T1,$FSDEV(P1) ;No
JRST FILS1A ;Get next token
FILS1B: JUMPE T2,FILS1C ;If null, not file name
SKIPE $FSNAM(P1) ;Previously specified?
JRST [TXO F,F.RGT
JRST E$$ETF]
MOVEM T1,$FSNAM(P1) ;Save
FILS1C: CAIE C,"." ;Ext next?
JRST FILS1D ;No
PUSHJ P,RDSIXM ;Yes, read it
TXO F,F.RGT ;Stash delimiter
SKIPE $FSEXT(P1) ;Dup?
JRST E$$ETF ;Yes
HRRI T1,2K ;Set extension seen bit
MOVEM T1,$FSEXT(P1) ;Save extension
JRST FILS1A ;Next token
FILS1D: CAIE C,"[" ;Start of PPN?
JRST [TXO F,F.RGT ;No, stuff delimiter
JRST CPOPJ1] ;And assume success
SKIPE $FSPPN(P1) ;Prev PPN?
JRST E$$ETF ;Sigh
PUSHJ P,RDOCT ;Get project
TRNE T1,377777 ;be sure something is there
TDNE T1,[-1,,400K] ; ...But not too much
JRST E$$ETF ;Not good
HRLZM T1,$FSPPN(P1) ;Save
CAIE C,"," ;Project next
JRST [TXO F,F.RGT
JRST E$$ETF]
PUSHJ P,RDOCT ;Get programmer
TRNE T1,-1 ;Must be present
TLNE T1,-1
JRST E$$ETF
HRRM T1,$FSPPN(P1) ;Stuff that
PUSH P,P2 ;Save another AC
CAIE C,"," ;SFD coming?
JRST FILS1F ;No
MOVE T1,$FSPPN(P1) ;Get PPN
MOVEM T1,$FSPTH+.PTPPN(P1) ;Put it in PATH. block
MOVEI T1,$FSPTH(P1) ;Get address of path block
MOVEM T1,$FSPPN(P1) ;Set up PPN word to point to it
MOVEI P2,$FSPTH+.PTSFD(P1) ;Get pointer to next SFD
FILS1E: PUSHJ P,RDSIXM ;Get next SFD
JUMPE T2,[TXO F,F.RGT
JRST E$$ET2]
MOVEM T1,0(P2) ;Store this one
CAIE P2,$FSPTH+.PTSFD+4(P1) ;Last?
JRST [CAIN C,"," ;More?
AOJA P2,FILS1E ;Yes
JRST .+1]
FILS1F: JUMPLE C,FILS1G ;If <EOL>, stop
CAIE C,"]" ;End of PPN?
JRST E$$ET2
POP P,P2
JRST FILS1A ;Yes see what's next
FILS1G: POP P,P2
JRST CPOPJ1
E$$ET2: POP P,P2
E$$ETF: OUTSTR [ASCIZ .
?Error in TOPS-10 file specification
.]
POPJ P,
Subttl Utility routines -- Read number
RDDEC: SKIPA T2,[^D10]
RDOCT: MOVEI T2,^O10 ;Set radix
PUSHJ P,SKIPB ;Skip leading blanks
PUSH P,[0] ;Assume positive
CAIN C,"-" ;True?
SETOM (P) ;No
SKIPL (P) ;If had a "-"
TXO F,F.RGT ;(we didn't, get the real char)
SETZ T1, ;Clear result
RDOCT1: PUSHJ P,TYI ;Get a char
CAIL C,"0" ;If not a
CAILE C,"0"-1(T2) ; digit
JRST [SKIPGE (P) ;Negate?
MOVNS T1 ;Yes
POP P,(P)
POPJ P,]
CAIN T2,^D8
LSH T1,3 ;Radix shift
CAIE T2,^D8
IMULI T1,(T2) ;For non binary radix
ADDI T1,-"0"(C) ;Add in new digit
JRST RDOCT1 ;Continue
Subttl Utility routines -- Read a masked SIXBIT word
RDSIXM: PUSHJ P,SKIPB ;Skip blanks
SETZB T1,T2 ;Clear results
MOVE T3,[POINT 6,T1] ;Point to word
MOVE T4,[POINT 6,T2] ;Point to mask
CAIA
RDSXM1: PUSHJ P,TYI ;Read next char
JUMPLE C,CPOPJ ;If eol, stop
CAIL C,"a" ;Worry about lower case
CAILE C,"z"
CAIA
TRZ C,40
CAIL C,"A"
CAILE C,"Z"
CAIA
JRST RDSXM2
CAIL C,"0"
CAILE C,"9"
POPJ P, ;Return break
RDSXM2: SUBI C," "-' ' ;Convert to sixbit
TLNN T3,(77B5) ;Space left?
JRST RDSXM1 ;No, keep parsing
IDPB C,T3 ;Store char
MOVEI C,77 ;Mask
IDPB C,T4 ;Add to it
JRST RDSXM1 ;Continue
Subttl Utility routines -- Skip leading blanks
SKIPB: PUSHJ P,TYI ;Get a char
CAIE C," " ;Space?
CAIN C,.CHTAB ;or TAB
JRST SKIPB ;Yes, skip it
POPJ P, ;Done
Subttl Utility routines -- Input a command character
TYI: TXZE F,F.RGT ;Want last one again?
POPJ P, ;Yes
INCHWL C ;Read one
JUMPE C,TYI ;Flush nulls
CAIN C,.CHCRT ;and <CR>
JRST TYI
CAIE C,.CHLFD
CAIN C,.CHFFD
SETO C, ;flag eol
CAIN C,.CHESC
SETZ C, ;Flag escape
CAIN C,.CHCNZ ;[2] If ^Z
EXIT 1, ;[2] Stop
POPJ P, ;DONE
Subttl Utility routines -- ASCII - SIXBIT conversion
SIXFIX: CAIL T1,"a"
CAILE T1,"z"
CAIA
TRZ T1,40
SUBI T1,40
SKIPL T1
CAILE T1,'_'
MOVEI T1,'_'
POPJ P,
Subttl Utility routines -- UDT conversion
UDTSDT: PUSH P,T1 ;SAVE TIME FOR LATER
PUSHJ P,UDTFUD ;Compute the offset from GMT
EXCH T1,(P) ;GMT - offset = local
SUBB T1,(P) ;Make GMT be local
JUMPL T1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ T1,T1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI T1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
;T1=DAYS SINCE JAN 1, 1501
IDIVI T1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY
LSH T2,2 ;CONVERT TO NUMBER OF QUARTER DAYS
IDIVI T2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY
IORI T3,3 ;DISCARD FRACTIONS OF DAY
IDIVI T3,4*365+1 ;SEPARATE INTO YEARS
LSH T4,-2 ;T4=NO DAYS THIS YEAR
LSH T1,2 ;T1=4*NO QUADRACENTURIES
ADD T1,T2 ;T1=NO CENTURIES
IMULI T1,100 ;T1=100*NO CENTURIES
ADDI T1,1501(T3) ;T1 HAS YEAR, T4 HAS DAY IN YEAR
MOVE T2,T1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE T2,3 ;IS THE YEAR A MULT OF 4?
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR
IDIVI T2,100 ;SEE IF YEAR IS MULT OF 100
SKIPN T3 ;IF NOT, THEN LEAP
TRNN T2,3 ;IS YEAR MULT OF 400?
TDZA T3,T3 ;YES--LEAP YEAR AFTER ALL
CNTDT0: MOVEI T3,1 ;SET LEAP YEAR FLAG
;T3 IS 0 IF LEAP YEAR
;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI T1,1964 ;SET TO SYSTEM ORIGIN
IMULI T1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T3,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T4,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T4 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI T2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T4,MONTAB+1(T2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI T1,31 ;NO--COUNT SYSTEM MONTH
AOBJN T2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T4,MONTAB(T2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD T1,T4 ;INCLUDE IN FINAL RESULT
CNTDT6: EXCH T1,(P) ;SAVE ANSWER, GET TIME
TLZ T1,-1 ;CLEAR DATE
MUL T1,[24*60*60*1000] ;CONVERT TO MILLI-SEC.
ASHC T1,17 ;POSITION RESULT
POP P,T2 ;RECOVER DATE
POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
SDTUDT: 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
HRL T1,T4 ;INCLUDE DATE
GETNWX: MOVE T4,T1 ;Save local UDT
PUSHJ P,UDTFUD ;Compute GMT offset
ADDM T4,T1 ;Turn local into GMT
POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
UDTFUD: MOVE T1,TIMZON ;Get alleged timezone
CAML T1,[-24] ;If too small
CAILE T1,24 ;or too big
MOVEI T1,DF$TZN ;Use something reasonable
IMULX T1,60*60*1000 ;Make hours into MS
SETZ T2, ;Clear other half
ASHC T1,-17 ;Slip the binary point
DIV T1,[24*60*60*1000] ;Make fractional days
POPJ P, ;Return offset from GMT
RADIX 8
Subttl Utility routines -- Accumulator coroutines
SAVE1: EXCH P1,(P) ;Save
HRLI P1,(P)
PUSHJ P,SAVJMP
SOS -1(P)
JRST RET1
SAVE2: EXCH P1,(P)
HRLI P1,(P)
PUSH P,P2
PUSHJ P,SAVJMP
SOS -2(P)
JRST RET2
SAVE3: EXCH P1,(P)
HRLI P1,(P)
PUSH P,P2
PUSH P,P3
PUSHJ P,SAVJMP
SOS -3(P)
JRST RET3
SAVE4: EXCH P1,(P)
HRLI P1,(P)
PUSH P,P2
PUSH P,P3
PUSH P,P4
PUSHJ P,SAVJMP
SOS -4(P)
RET4: POP P,P4
RET3: POP P,P3
RET2: POP P,P2
RET1: POP P,P1
JRST CPOPJ1
SAVJMP: JRA P1,(P1)
Subttl Listing routines -- Open listing file
OPNLST: TXZ F,F.TTYL ;Listing device isn't TTY ...yet
TXNN F,F.LIST!F.PRNT ;If not LISTing or PRINTing
JRST CPOPJ1 ; ...Don't waste our time
PUSHJ P,SAVE1
MOVE T1,[XWD LST,.FOAPP] ;FILOP. append
MOVEM T1,FOPBLK+.FOFNC ;Set function
MOVEI T1,.IOASL ;ASCII line mode for listing
SKIPN T2,LSTSPC+$FSDEV ;Get device
MOVX T2,SIXBIT .DSK. ;Default to DSK
MOVSI T3,LSTHDR ;Point to header
MOVE T4,[XWD T1,FOPBLK+.FOIOS] ;Move to FILOP. block
BLT T4,FOPBLK+.FOBRH ;(Instead of OPEN
MOVSI T1,-1 ;Output buffer count
MOVEM T1,FOPBLK+.FONBF ;Default number of buffers
MOVEI T1,T1 ;Address of LOOKUP block
MOVEM T1,FOPBLK+.FOLEB ;Put in FILOP.
SKIPN T1,LSTSPC+$FSNAM ;Get file name
MOVE T1,[SIXBIT .DUMPER.] ;Default
SKIPN T2,LSTSPC+$FSEXT ;Extension
MOVSI T2,(SIXBIT .LST.) ;Default
TRZ T2,-1 ;Clear forced ext flag
SETZ T3, ;Default protection
MOVE T4,LSTSPC+$FSPPN ;PPN or PATH
MOVE P1,[XWD .FOLEB+1,FOPBLK] ;Point to arg block
FILOP. P1, ;Open the file
JRST E$$COL ;Sigh
MOVEI T1,LST ;Point to listing device
DEVTYP T1, ;Find out about it
HALT .
TXNE T1,TY.INT ;Interactive device?
TXOA F,F.INT ;Yes, remember that
TXZ F,F.INT ;No, don't waste OUTPUTs
MOVX T1,SIXBIT .TTY. ;Get our TTY
IONDX. T1,UU.PHY ; UDX
HALT .
MOVEI T2,LST ;Now the listing device
IONDX. T2,UU.PHY ;Same way
HALT .
CAMN T1,T2 ;Same device?
TXO F,F.TTYL ;Yes, don't duplicate output
JRST CPOPJ1 ;Success
E$$COL: OUTSTR [ASCIZ .
? Can't OPEN listing file
.]
POPJ P,
Subttl Listing routines -- Numeric output
LSTDEC: MOVEI T3,^D10 ;Radix
LSTRDX: IDIV T1,T3 ;Split a digit
HRLM T2,(P) ;Save
SKIPE T1 ;Done?
PUSHJ P,LSTRDX ;No
HLRZ T1,(P) ;Yes, retrieve digit
ADDI T1,"0" ;Make ASCII
PJRST LSTCHR ;Output it
Subttl Listing routines -- Primitives
LSTMSG: TXNN F,F.TTYL ;Is list device TTY?
OUTSTR (T1) ;No, tell user
LSTSTR: TXNN F,F.LIST!F.PRNT ;Should we?
POPJ P, ;No
HRLI T1,(POINT 7,0) ;Make a byte pointer
MOVE T2,T1 ;Copy pointer
LSTST1: ILDB T1,T2 ;Get next byte
JUMPE T1,CPOPJ ;Done when null
PUSHJ P,LSTCHC ;Output it
JRST LSTST1 ;Loop forever
LSTCHR: TXNN F,F.LIST!F.PRNT ;Should we?
POPJ P,
LSTCHC: SOSL LSTHDR+.BFCTR ;Room for it?
JRST LSTCH1 ;Yes
OUT LST, ;No, make room
JRST LSTCHC ;Try again
OUTSTR [Asciz .
?Listing output error
.]
EXIT
LSTCH1: IDPB T1,LSTHDR+.BFPTR ;Store it
CAIE T1,.CHTAB ;Tab
CAIL T1,40 ;No, control?
POPJ P, ;No, nothing special
CAIN T1,.CHCRT ;<CR> is ignored (till LF)
POPJ P,
CAIN T1,.CHFFD ;If a FF,
JRST [PUSH P,[EXP NM$LPP] ;Reset line counter
POP P,LINLFT ;For later processing
JRST LSTCH2] ;But don't output header (contains ^L)
SOSLE LINLFT ;Yes, end of page?
JRST LSTCH2 ;No
PUSH P,T2 ;Save our place (in case in string)
MOVEI T2,NM$LPP ;Yes, reset counter
MOVEM T2,LINLFT ;To page size
MOVE T1,HEADER ;Get address of header
PUSHJ P,LSTSTR ;Go output it
POP P,T2 ;Restore place
POPJ P,
LSTCH2: TXNE F,F.INT ;Interactive device?
OUTPUT LST, ;Yes, flush buffer now
POPJ P, ;Done
Subttl Impure storage
XLIST ;LIT
LIT
LIST
RELOC
MTAHDR: BLOCK 3
LSTHDR: BLOCK 3
PDL: BLOCK LN$PDL
OFFSET: BLOCK 1
BLKFCT: BLOCK 1
TAPDEN: BLOCK 1
DEVICE: BLOCK 1
PHYMTA: BLOCK 1
TIMZON: BLOCK 1
SSNBUF: BLOCK ^D<<MX$SSN+1+4>/5>
LSSOK: BLOCK 1
LSTSPC: BLOCK $FSLEN
FILPTH: BLOCK .PTMAX
LINLFT: BLOCK 1
OURSEQ: BLOCK 1
HEADER: BLOCK 1
HDRPTR: BLOCK 1
FOPBLK: BLOCK .FOLEB+1
LKPBLK: BLOCK .RBAC8+1
FILNAM=LKPBLK+.RBNAM
FILEXT=LKPBLK+.RBEXT
CURBLK: BLOCK 1
CLREND==.-1
END START