File: DUMP.02 of Tape: Various/Decus/decus-2
(Source file text)
LAP
IBUF, BLOCK 200 /START OF MAIN BUFFER
BLOCK 177
IBUFE, 0 /END OF MAIN BUFFER
JBUF, BLOCK 200 /START OF AUX BUFFER
BLOCK 177
JBUFE, BLOCK 1 /END OF AUZ BUF
CPAGE 6
EAP
/THIS ROUTINE WILL COMPLETELY ZERO THE DATA BASE OF
/ AN ALREADY EXISTING FILE
/
/
/VERSION 02
/
/
/*********************************************************
/
/
/ IT MUST BE USED WITH E X T R E E M CAUTION
/ *************
/
/
/*********************************************************
/
/THERE ARE FOUR ENTRIES TO THIS SOUBROUTINE
/ FOPN WILL INITIALIZE THE DATA BASE CALLED
/ FROM THE CALLING PROGRAM WITH AN EXTENSION
/ OF '.DA' ASSUMED
/
/
/ GETF WILL GET THE NEXT SEQUENTIAL RECORD OF DATA
/
/ PUTF WILL PLACE THE DATA AFTER THE LAST RECORD
/ OF DATA ACCESSED
/
/ FCLOS WILL ALSO DO JUST THAT - CLOSE THE FILE TO
/ ALL ADDITIONAL I/O.
/
/THESE ROUTINES WILL OPERATE ONLY ON A FILE ON THE SYSTEMS
/ DEVICE SINCE IT USES THE PERMINATELY RESIDENT
/ DEVICE HANDLER WITH AN ENTRY POINT OF 7607
/
/
/ USE WITH CAUTION
/
ENTRY ZERO /ENTRY POINT OF THIS ROUTINE
/
/
/
/
OPDEF CDF1 6211 /CHANGE TO DATA FIELD 1
OPDEF CDFZ 6201 /CHANGE TO DF 0
OPDEF CIFZ 6202 /CHANGE INST FIELD ZERO
OPDEF TADI 1400 /TAD INDIRECT
OPDEF DCAI 3400 /DCA INDIRECT
/
/
ABSYM TEMP1 162 /JUST THAT - TEMPORARY STORAGE
ABSYM TEMP2 163 /DITTO
ABSYM TEMP4 164 /DITTO
/
/
ENTRY FOPN /INITIALIZE THE I/O HANDLERS ETC.
ENTRY GETF /GET A LOGICAL RECORD
ENTRY PUTF /PUT A LOGICAL RECORD
ENTRY FCLOS /CLOSE THE FILE TO ALL ADDL I/O
/
/
/
/
/
/
ABSYM GPNT 147 /POINTER TO CURRENT LOCATION
ABSYM RCNT 150 /COUNTER FOR NUMBER OF RECORDS/BLOCK
ABSYM DEST 151 /DESTINATION OF COMMON DATA
ABSYM IMRK 152 /NUMBER OF BLOCK CURRENTLY IN CORE
ABSYM IFW 153 /FORDWARD POINTER
ABSYM IBK 154 /REVERSE POINTER
ABSYM MEND 155 /ABSOLUTE END OF DATA BASE(BLK NO)
ABSYM MBASE 156 /ABSOLUTE START OF DATA BASE(BLK NO)
ABSYM FREE 157 /BLK NO OF FIRST FREE(UNUSED) BLOCK
ABSYM STRT 160 /BLK NO OF FIRST DATA BLOCK
ABSYM CNTR 161 /COUNTER FOR VARIOUS DATA MOVES
/
/
IXYZ, COMMN 1 /TO FORCE ERROR IN NO COMMON SPECIFIED
LOSTR, IBUF /ADDRESS OF START OF DATA
HISTR, JBUF /ABBRESS OF END OF DATA
DEV, TEXT 'SYS' /SYSTEMS DEVICE ONLY
DUMMY NWDS /NUMBER OF WORDS PER BLOCK
NWDS, BLOCK 2 /NUMBER OF WDS PER RECORD
MSG1, TEXT 'ZRO1' /ZRO1 MESSAGE-FILE PARAMETERS NO GOOD
ZERO, BLOCK 2 /INITIALIZE ALL GOODIES
TAD I ZERO /NOW GET THE FILE NAME
DCA NAME
INC ZERO#
TAD I ZERO
DCA NAME#
INC ZERO#
TAD I ZERO /AND GET THE NO WDS/RECORD
DCA NWDS
INC ZERO#
TAD I ZERO
DCA NWDS#
INC ZERO#
TAD I NWDS
DCA TEMP1 /SAVE THE ACTUAL NO OF WDS/RECORD
TAD TEMP1
CMA IAC
SMA
JMS ERR1 /TOO LONG A RECORD
TAD (175
SPA CLA
JMS ERR1 /STILL TOO LONG
TAD LOSTR
TAD (2
DCA TEMP2
TAD TEMP1
CMA IAC
DCA TEMP1
TAD TEMP1
DCA I TEMP2
INC TEMP2
DCA DUM1
TAD (400 /NOW COMPUTE THE NO RECS/BLOCK
CMPRC, TAD TEMP1
SPA
JMP GOTIT
INC DUM1
JMP CMPRC
ERR1, 0 /RATS!!!!!
CALL 1,ERROR /TOO LONG A RECORD
ARG MSG1
DUM1, 0 /SILLY COUNTER
S616, 616 /FIRST BLK NO
S573, 573 /LAST BLK NO
S122, 122 /HANDLER NO
OPEN, 0 /NOW OPEN IT
CALL 2,IOPEN /GET THE PARAMETERS
ARG DEV
NAME, ARG 0
CLA CLL /AND PICK UP THE GOODIES
DCA CNTR /MAKE IT RESTARTABLE
CDFZ
CLA CLL CMA
TADI S616
DCA MBASE /SAVE THE FIRST BLOCK NO
TADI S573
CMA IAC
IAC
TAD MBASE /AND ADD THE BASE BLOCK NO
DUMTG1, DCA MEND /SAVE THE LAST BLOCK NO
TADI S122
CURFD, DCA MHAND /AND ENTRY OF SYS HANDLER
TAD CURFD /AND PUT DF IN RWPAR
AND (70
TAD (0200
DCA RWPAR
JMP I OPEN /AND RETURN
GOTIT, CLA CLL
TAD DUM1
CMA IAC
DCAI TEMP2
INC TEMP2
JMS OPEN /NOW OPEN THE FILE
CLA CLL IAC
DCA IBUF /THE START OF DATA
TAD (2
DCA IBUF# /SET THE FIRST FREE BLOCK NO TO 1
TAD (7405
DCA TEMP1
MRFST, DCA I TEMP2 /ZERO OUT BLOCK NO ZERO
INC TEMP2
ISZ TEMP1
JMP MRFST
STL CLA IAC /AND WRITE THE BLOCK
JMS RWROT
INC MBASE /BUMP MBASE
DCA IBUF /SET BKPOINTER TO ZERO
DCA IBUFE /SET FWD POINTER TO ZERO
TAD LOSTR
IAC
DCA TEMP1
TAD (-200 /NOW PUT ZERO'S ALL OVER THE PLACE
DCA TEMP2
MORE, DCAI TEMP1
INC TEMP1
ISZ TEMP2
JMP MORE
TAD (-175
DCA TEMP2 /NOW PUT 999(10)'S ALL OVER THE PLACE
MORE1, TAD (1747
DCAI TEMP1
INC TEMP1
ISZ TEMP2
JMP MORE1
STL CLA IAC /AND START HALF WAY THROUGH ROUTINE
JMS RWROT /AND WRITE IT
INC MBASE
INC CNTR
DCA IBUF
JMP MRWDS
MRBLK, TAD MEND
CMA IAC
IAC
TAD MBASE
SMA CLA
JMP ALDON
INC CNTR
CLA CLL
TAD CNTR
DCA IBUF /SET REV POINTER
MRWDS, TAD CNTR
IAC
IAC
DCA IBUFE /SET FWD POINTER
TAD LOSTR
TAD (1
DCA TEMP1
DCAI TEMP1 /SET ZERO TO START OF FIRST BLOCK
TAD (7403
DCA TEMP2 /SET UP HOW MANY
INC TEMP1
MRFIL, DCAI TEMP1 /PUT ZEROS ALL OVER
INC TEMP1
ISZ TEMP2
JMP MRFIL
STL CLA IAC
JMS RWROT /AND WRITE THE BLOCK
INC MBASE
JMP MRBLK
ALDON, DCA IBUFE /SET THE FWD POINTER
CLA CLL CMA /OF THE LAST BLOCK TO ZERO
TAD MBASE
DCA MBASE /TO AVOID A LOSML ERROR
CLA STL IAC /NOW REWRITE THE BLOCK
JMS RWROT
TAD (0200 /AND RESET R/W PARAMETER
DCA RWPAR /TO MAKE IT RESTARTABLE
DCA MHAND /AND FORCE ERROR IF CALL AGAIN
RETRN ZERO /AND GO HOME
SWSTH, 0 /SWITCH TO SHOW IF JBUF SWAPPED 0=N0;1=YES
MNWDS, 7777 /SKIPS AFTER WORD COUNT OVFLO
MNREC, 7777 /SKIPS AFTER REC COUNT OVFLO
MSG9, TEXT 'ZRO9' /NO OPEN - TOO BAD
FOPN, BLOCK 2 /INITIALIZE ALL GOODIES
TAD I FOPN /GET THE NAME OF THE FILE
DCA NAME
INC FOPN#
TAD I FOPN
DCA NAME#
INC FOPN#
JMS OPEN /OPEN THE FILE
CLA CLL IAC
JMS RWROT
INC MBASE /BUMP MBASE TO FORCE ERROR IF
TAD IBUF /TRY TO ACCESS BLOCK ZERO
/GET THE START OF THE FIRST BLK
DCA STRT
TAD IBUF#
DCA FREE /AND THE START OF THE FREE BLOCKS
TAD LOSTR
TAD (2
DCA TEMP1
TAD I TEMP1
DCA MNWDS
INC TEMP1
TADI TEMP1
DCA MNREC
TAD STRT
JMS RWROT
TAD STRT
JMS FRSET /AND BK & FWD POINTERS
CALL 0,GETF /AND GET THE FIRST BLOCK
RETRN FOPN /THATS ALL FOLKS
CPAGE 6
MSG8, 3222 /ZRO8 MSG-END OF FILE WHEN NOT EXPECTED
1770
GETF, BLOCK 2 /GET THE NEXT SEQ RECORD
GETNX, CLA CLL
TAD MNWDS /GET THE NUMBER OF WORDS
DCA CNTR
DCA TEMP1 /WHEN AT END,IF TEMP1=0,A FILLER
TAD (200
DCA DEST
NCAR2, TAD I GPNT
CDF1
DCAI DEST
INC DEST
DTAG1, TAD I GPNT /TAG TO FORCE CDF CUR
SNA CLA
INC TEMP1 /THAT ONE WAS A ZERO
INC GPNT /GETTING THE DATA FROM 0 AND PUTTING IT IN 1
ISZ CNTR
JMP NCAR2
ISZ RCNT
JMP GETDN /STILL ROOM IN THIS BLOCK
CLA CLL
TAD IBUFE
SNA /END OF FILE???
JMS EOF /TOO BAD
JMS RWROT /GET IT
TAD IBUF
CMA IAC
TAD IMRK /HOPE IT MATCHES
SZA CLA
JMS ERROR /RATS!!!
TAD IFW
JMS FRSET /SET THE POINTERS
GETDN, TAD MNWDS
TAD TEMP1
SNA CLA
JMP GETNX /THAT LAST ONE WAS BLANK
RETRN GETF /THATS ALL FOLKS
RWROT, 0 /SYSTEM I/O HANDLER
TAD MBASE /SINCE RELATIVE
DCA RW3 /ENTER WITH AC=BLOCK NO AND
RAR /LINK=0-READ;=1-WRITE
TAD RWPAR
DCA RW1
TAD MBASE /CHECK THE LOW BOUNDRY
CMA
TAD RW3
SPA CLA
JMS ERROR /TOO SMALL
TAD RW3 /CHECK THE HI BOUNDRY
CMA IAC
TAD MEND
SPA CLA
JMS ERROR /TOO LARGE
TAD MHAND
SNA CLA
JMP NOPEN /NOT OPENED
CIFZ /CHANGE THE INST FIELD
JMS I MHAND /READ OR WRITE
RW1, 0 /RWPAR WITH 2 PAGES
RW2, IBUF /THATS WHERE WE STARE FROM
RW3, 0 /WITH THIS BLOCK NO
JMS ERROR /ERROR RETURN
CLA CLL
JMP I RWROT /ALL DONE
RWPAR, 0200 /ONLY TWO PAGES
NOPEN, CALL 1,ERROR /WHOOPS
ARG MSG9
MHAND, 0 /ENTRY OF SYS HANDLER
FCLOS, BLOCK 2 /CLOSE THE FILE TO I/O
CLA CLL
TAD SWSTH /WAS IT SWAPPED
SNA CLA
JMP NOSWP /NOPE
TAD CURFD /LETS FUDGE A PUTF CALL
DCA PUTF
TAD CMBACK
DCA PUTF#
JMP CURNEW /CREATE A NEW RECORD
CMBACK, CMBACK# /SORT OF A 'JMS .+1'
CRSH, TAD LOSTR /LETS MOVE THE BUFFER IN NOW
IAC
DCA TEMP1
TAD TEMP1
TAD (400
DCA TEMP2
TAD (7400
DCA CNTR
MVFST, TADI TEMP2
DCAI TEMP1
DCAI TEMP2
INC TEMP1
INC TEMP2
ISZ CNTR
JMP MVFST
TAD IMRK /AND REWRITE THE BLOCK
STL
JMS RWROT
NOSWP, CLA CLL CMA /SET AC=-1
TAD MBASE
DCA MBASE
CLA CLL IAC
JMS RWROT /GO GET THE FIRST BLOCK
TAD FREE
DCA IBUF#
TAD STRT
DCA IBUF
CLA STL IAC
JMS RWROT /SAVE THESE GOODIES
DCA MHAND /AN I/O NOW IS A NO-NO
CLA CLL CMA
DCA MNREC /RESET M NO RECORDS TO FORCE ERROR
CLA CLL CMA /IF TRY TO ACCESS I/O AGAIN
DCA MNWDS
TAD (0200
DCA RWPAR /AND RESTORE READ/WRITE PARAMETER
DCA SWSTH /MAKE IT RESTARTABLE
RETRN FCLOS
FRSET, 0 /SET ALL THE GOOD POINTERS ETC
DCA IMRK /THATS WHERE WE ARE
TAD IBUF
DCA IBK
TAD IBUFE
DCA IFW
TAD MNREC
DCA RCNT
TAD LOSTR
IAC
DCA GPNT
JMP I FRSET /AND PRESET EVERYTHING
EOF, CALL 0,FCLOS /END OF FILE WHEN NOT EXPECTED
CALL 1,ERROR
ARG MSG8
MSG6, 3222 /CAN ONLY SWAP ONCE
1766
PUTF, BLOCK 2 /PUT A RECORD AFTER THE ONE JUST READ
CLA CLL
TAD GPNT
JMS EMCHK /IS IT EMPTY?
SMA CLA
JMS SWOUT /NOPE SO SWAP OUT
TAD (200
DCA DEST
TAD MNWDS
DCA CNTR
PWRD, CDF1 /GET THE WORD
TADI DEST
DCA I GPNT /AND STORE IT AWAY
INC DEST
INC GPNT
ISZ CNTR /ALL DONE?
JMP PWRD /NOPE
ISZ RCNT /WAS THAT THE LAST ONE?
JMP ENPUT /DONT HAVE TO REWRITE THE SAME BLOCK!
CURNEW, TAD FREE /HAVE TO CREAT A NEW BLOCK
SNA
JMS ERROR
DCA IBUFE /SET MARKERS
TAD IMRK
STL
JMS RWROT /WRITE THE I BLOCK
TAD FREE
JMS RWROT /GET THE NEW BLOCK TO INSERT
TAD IBUF
SZA CLA
JMS ERROR /NONZERO ON IBUF OF FREE
TAD IBUFE
SNA CLA
JMP ERROX /RATS NO FREE BLOCKS AFTER THIS ONE
TAD IMRK
DCA IBUF /SET THE BACK POINTER
TAD FREE
DCA TEMP4 /SAVE 'FREE'
TAD IBUFE
DCA FREE
TAD IFW
DCA IBUFE /SET FWD POINTER
TAD IFW
SZA /IS IT AN END OF FILE?
JMS ERROR /NOPE - - TILT!!!
TAD TEMP4 /NOW WRITE THE BLOCK
STL
JMS RWROT
TAD FREE /NOW SET THE IBUF OF THE FREE(NEW)
JMS RWROT /LIST TO ZERO
TAD IBUF
CMA IAC
TAD TEMP4 /AND CHECK THE LINKAGES
SZA CLA /THE FREE LIST HAS BAD LINKAGES
JMS ERROR
DCA IBUF
STL
TAD FREE
JMS RWROT
TAD IMRK
DCA IBUF
DCA IBUFE
TAD TEMP4
JMS FRSET /AND THEN GO HOME
ENPUT, RETRN PUTF /THATS ALL FOLKS
SWOUT, 0 /SWAP OUT THE SECOND HALF
TAD SWSTH /HOPE NOT SWAPPED BEFORE
SZA CLA
JMP ASWAP /ALREADY SWAPPED - SIZE(NO ROOM) ERROR
CLA CLL IAC
DCA SWSTH
TAD HISTR
DCA TEMP1
TAD (7400
DCA CNTR
MORXX, DCAI TEMP1 /PUT BLANKS ALL OVER THE PLACE
INC TEMP1
ISZ CNTR
JMP MORXX
TAD GPNT /MOVE GOOD DATA TO JBUF
DCA TEMP1
TAD TEMP1
TAD (400
DCA TEMP2
TAD HISTR
CMA IAC
IAC
TAD GPNT
DCA CNTR
MRCPY, TADI TEMP1
DCAI TEMP2
DCAI TEMP1
INC TEMP1
INC TEMP2
ISZ CNTR
JMP MRCPY
JMP I SWOUT /DONE
MSG7, TEXT 'ZRO7' /MAJOR DESASTER!!!
XXXY, 0 /CALLING FIELD GOES HERE
ERROR, 0 /WHERE WE CAME FROM GOES HERE
TAD XXXX /PUT CALLING FIELS ABOVE
DCA XXXY
CALL 1,ERROR /BAD LINKAGE SOMEWHERE
XXXX, ARG MSG7
CALL 0,EXIT
ASWAP, CALL 0,FCLOS /CLOSE THE FILE
CALL 1,ERROR /CAN ONLY SWAP ONCE!!!
ARG MSG6
ERROX, TAD CRFD /PUT A CDF CUR IN FCLOS
DCA FCLOS
TAD CRASHX
DCA FCLOS#
TAD IMRK /SET UP IBUF
DCA IBUF
TAD FREE
DCA IMRK
DCA FREE /AND CLEAR FREE
JMP CRSH /AND CLOSE THE FILE
CRASHX, CRASH /LETS END UP HERE
CRASH, CALL 1,ERROR /WHEN THERE WERE NONE LEFT AFTER
CRFD, ARG MSG5 /THIS ONE. A NO-NO SINCE MIGHT
MSG5, TEXT 'ZRO5' /HAVE SWAPPED
CPAGE 26
EMCHK, 0 /CHECK TO SEE IF EMPTY
CMA IAC
CMA
DCA 10 /USE AUTO INDEX
DCA DUM2
TAD MNWDS
DCA CNTR
EMCK1, TADI 10
SNA CLA
INC DUM2
ISZ CNTR
JMP EMCK1
CLA CLL
TAD DUM2
TAD MNWDS
SNA CLA
CMA /AC=-1 EMPTY
JMP I EMCHK /AC= 0 FULL
DUM2, 0 /TEMPORARY COUNTER
END