File: USRS.LS of Disk: V50/Source/Source-Listing-RALF-1
(Source file text)
RALF V50A 8-APR-92 PAGE 1
/
/ SUBROUTINE USR (UNIT, NAME, FUNCT, STATUS) (FRTS)
/
/ SUBROUTINE USR3 (UNIT, NAME, FUNCT, STATUS) ASSEMBLE WITH /3 (FRUN)
/
/ THIS ROUTINE ALLOWS RUN-TIME DECLARATION OF FILES
/ IN D.E.C. FORTRAN IV FOR THE PDP-8. THE HANDLER
/ AND BUFFER ALLOCATION IS FULLY DYNAMICAL, I.E.
/ THE FUNCTIONS 'RELEASE' AND 'CLOSE' RECOVER
/ ALL SPACE USED FOR HANDLER AND BUFFER.
/
/ DESCRIPTION OF PARAMETERS:
/
/ UNIT - LOGICAL UNIT NUMBER
/ NUMBERS 1 THRU 9 ARE ALLOWED.
/ NAME - DEV:FILE.EX
/ STORED IN FORMAT 3A6 (6A3 FOR FRUN)
/ DEVICE ASSUMED TO BE DSK: IF NOT
/ EXPLICITLY STATED. THIS PARAMETER MAY
/ ALSO BE A HOLLERITH LITERAL.
/ SPACES ARE IGNORED IN THIS FIELD.
/ @ (NULL IN FRUN) IS END OF NAME
/ FUNCT - FUNCTION: 1 - RELEASE UNIT
/ 2 - OPEN FILE FOR INPUT
/ 3 - OPEN FILE FOR OUTPUT
/ 4 - CLOSE OUTPUT FILE
/ THE OUTPUT FILE NAME GIVEN FOR A <CLOSE>
/ MUST AGREE WITH THE CORRESPONDING <OPEN>
/ FILE NAME FOR THAT UNIT. CLOSING A FILE
/ WITH 0 BLOCKS OR AN INPUT (FUNCT=2) FILE WILL
/ DELETE THAT FILENAME FROM THE DIRECTORY.
/ STATUS - A POSITIVE CALLING VALUE INHIBITS FORMS CONTROL
/ A NEGATIVE CALLING VALUE ENABLES FORMS CONTROL
/ ON THE SPECIFIED UNIT. (ABS(STATUS)-1) IS
/ A DECLARATION OF THE MAXIMUM FILE LENGTH.
/ - RETURNS
/ IF NO ERRORS FILE LENGTH IF FUNCT=2
/ MAX FILE LENGTH IF FUNCT=3
/ 0 IF FUNCT=1 OR =4
/ IF ERROR THE STATUS WILL BE A NEGATIVE
/ ERROR NUMBER
/ -1 - ILLEGAL FUNCTION CODE FOR UNIT
/ -2 - ILLEGAL UNIT NUMBER
/ -3 - ILLEGAL FILE NAME
/ -4 - MEMORY OVERFLOW
/ -5 - DEVICE DOES NOT EXIST
/ -6 - FILE NOT FOUND OR DEVICE FULL
/ -7 - SYS: WRITE-LOCKED
/ -10 - I-O ERROR
RALF V50A 8-APR-92 PAGE 2
/NOTES:
/ 1 - UNIT NUMBERS 1-4 ARE NOT STRONGLY RECOMMENDED
/ BECAUSE THE INTERNAL HANDLERS CANNOT BE RE-
/ CLAIMED. OTHERWISE THEY ARE EQUIVALENT TO 5-9.
/ 2 - THE RELEASE FUNCTION (WHICH ALWAYS SUCCEEDS)
/ ALLOWS DELETING A UNIT EVEN IF NO FREE MEMORY
/ IS AVAILABLE. PRINCIPAL USE WILL BE FOR RE-
/ OPENING A UNIT FOR INPUT:
/ OPEN INPUT 1...PROG...EOF...RELEASE...OPEN INPUT 2
/ 3 - STANDARD PROCEDURE FOR DELETING A FILE IS:
/ RELEASE...OPEN INPUT...CLOSE
/ 4 - U S R CONSIST OF 2 PARTS:
/ USRS (FPP CODE) (1000 WORDS) (CAN BE IN OVERLAY)
/ USR8 (PDP8 CODE) (1000 WORDS) (MUST BE IN MAIN)
/ 5 - THE FATAL USER ERRORS CAN BE MADE NON-FATAL
/ FOR PROGRAM DEVELOPMENT BY USING /E IN FRTS.
/ 6 - A SLIGHTLY MODIFIED VERSION OF FRTS HAS TO BE
/ USED. IT CAN BE RECOGNIZED BY THE SINGLE LETTER
/ U IN IT'S VERSION NUMBER. (FRTS V5AXYZ U) <--
RALF V50A 8-APR-92 PAGE 3
/ THIS PROGRAM REQUIRES THAT THE LOCATIONS:
HKEY=2761
DSRN=4244
HPLACE=5200
MAXCOR=121
BOTHAN=122
TOPBUF=124
/ BE CONSISTENT WITH THE VERSION OF
/ FIV BEING USED.
EXTERN CGET
EXTERN CGET3 /FOR FRUN
EXTERN CPUT
EXTERN USRS8
EXTERN #ENDF
#DEV=USRS8+637
#FILE=USRS8+744
#LDSRN=USRS8+167
#LHNDR=USRS8+163
#LBUFF=USRS8+165
#USRLC=USRS8+171
#USRLD=USRS8+173
#CLNLC=USRS8+175
#CLBLC=USRS8+352
#SB=USRS8+34
#FUNCT=USRS8+160
#CLEN=USRS8+350
#SB2=USRS8+701
#FD1=USRS8+15
#FD2=USRS8+30
#FI1=USRS8+31
#FUSR=USRS8+13
#USRDF=USRS8+604
#UEXIT=USRS8+722
#USCLN=USRS8+147
#CBFIF=USRS8+330
RALF V50A 8-APR-92 PAGE 4
IFNSW 3 < SECT USR >
IFSW 3 < SECT USR3 >
00000 1030 JA #ST
00001 0162
#XR, ORG .+10 /THE 8 XR REGISTERS USED AS:
/0: PSEUDO ISN
/1: INCREMENTING
/5: FORMS CONTROL
/6: HCW OF THIS UNIT
/7: PERIOD SWITCH
00012 2523 TEXT +USR + /FOR TRACEBACK
00013 2240
00014 4000
00015 1100 #RET, SETX #XR /RESET TO MY XR,BASE WHEN
00016 0002
00017 1110 SETB #BASE /RETURNING FROM CALLED SUBROUTINE
00020 0023
00021 1030 JA .+3 /JUMP TO 'JSR' GENERATED 'JA CALL+2'
00022 0024
#BASE, ORG .+3 /GETS ABOVE 'JA' IN D.P. FORMAT
BDSRN, ORG .+3 /SECOND LOC FREE FOR USE BY SUBROUTINES
UNIT, ORG .+3 /MY ARGUMENTS. WELL ... NOT ALL
FUNCT, ORG .+3
ERROR, ORG .+3 /FUNCT,ERROR STAY AS ADDRESSES
00042 0000 X, F 0.0
00043 0000
00044 0000
00045 0000 I, F 0.0
00046 0000
00047 0000
00050 0000 N, F 0.0
00051 0000
00052 0000
ORG #BASE+30 /STANDARD LOCATION
00053 0040 FNOP
00054 1030 JA #RET /CALLED SUBROUTINE LOADS THIS RETURN
00055 0015
00056 0040 FNOP
00057 0000 #GOBAK, 0;0 /I STORE THE ABOVE RETURN HERE
00060 0000
00061 0002 #RTN, FCLA
00062 1030 JA #GOBAK /RETURN TO LOWER LEVEL XR,BASE RESET
00063 0057
RALF V50A 8-APR-92 PAGE 5
00064 0000 ENTLEN, F 0. /FILE LENGTH FOR ENTER
00065 0000
00066 0000
00067 0423 DSK, TEXT +DSK@@@+
00070 1300
00071 0000
00072 0006 COLON, F 58. /OCTAL 72
00073 3500
00074 0000
00075 0006 PERIOD, F 46. /OCTAL 56
00076 2700
00077 0000
00100 0001 F1, F 1.
00101 2000
00102 0000
00103 0003 F4, F 4.
00104 2000
00105 0000
00106 0003 F6, F 6.
00107 3000
00110 0000
00111 0004 F8, F 8.
00112 2000
00113 0000
00114 0004 F9, F 9.
00115 2200
00116 0000
00117 0005 F16, F 16.
00120 2000
00121 0000
00122 0005 F26, F 26.
00123 3200
00124 0000
00125 0006 F32, F 32.
00126 2000
00127 0000
00130 0015 F4096, F 4096.
00131 2000
00132 0000
RALF V50A 8-APR-92 PAGE 6
00133 0027 D00001, 27;0;1
00134 0000
00135 0001
00136 0027 D00200, 27;0;200
00137 0000
00140 0200
00141 0027 D00400, 27;0;400
00142 0000
00143 0400
00144 0027 D17400, 27;1;7400
00145 0001
00146 7400
00147 0027 DCDF, 27;0;CDF
00150 0000
00151 6201
00152 0027 DSBASE, 27;ADDR DSRN
00153 0000'
00154 4244
00155 0027 DSETXI, 27;SETX 0 /DUMMY SETX
00156 1100'
00157 0000
00160 0000 ADUSR8, ADDR USRS8
00161 0000
RALF V50A 8-APR-92 PAGE 7
BASE #BASE
00162 0006 #ST, STARTD /USUAL 'SETUP' ROUTINE
00163 0210 0210 /LOAD LOWER LEVEL BASE+30
00164 6400 FSTA #GOBAK,0 /AND STORE THAT 'JA #RET'
00165 0057
00166 0200 0200 /LOAD LL 'JA ARG'
00167 1100 SETX #XR
00170 0002
00171 1110 SETB #BASE /NOW WE ARE BORN!
00172 0023
00173 0101 LDX 0,1
00174 0000
00175 6200 FSTA #BASE /DON'T FORGET THIS GETS CLOBBERED
/IF WE CALL ANOTHER SUBROUTINE
00176 0710 FLDA% #BASE,1+ /PREINC XR 1 TO SKIP 'JA' AFTER CALL
00177 6202 FSTA UNIT
00200 0710 FLDA% #BASE,1+
00201 6400 FSTA# NAME
00202 0475
00203 0710 FLDA% #BASE,1+
00204 6203 FSTA FUNCT
00205 0710 FLDA% #BASE,1+
00206 6204 FSTA ERROR
00207 0005 STARTF
00210 0100 LDX 2,0 /FOR ERROR #2
00211 0002
00212 0105 LDX 0,5 /SET NO FORMS CONTROL
00213 0000
00214 0604 FLDA% ERROR /GET FORMS INDICATION
00215 1010 JGE FORM /GE 0 IS NO FORMS
00216 0222
00217 0105 LDX 2,5 /SET CORRECT VALUE FOR FORMS CONTROL
00220 0002
00221 0003 FNEG /FILE LENGTH IS POSITIVE
00222 1000 FORM, JEQ FZERO
00223 0225
00224 2217 FSUB F1 /FILE LENGTH IS ABS VALUE -1
00225 4224 FZERO, FMUL F16 /BUMP OVER DEV #
00226 6213 FSTA ENTLEN /KEEP IT FOR ENTER
00227 2227 FSUB F4096 /TOO BIG ?
00230 1010 JGE ERRARG /YES, BIGGER THAN 255 BLOCKS
00231 0731
00232 0602 FLDA% UNIT
00233 6202 FSTA UNIT
00234 2223 FSUB F9 /CHECK RANGE
00235 1060 JGT ERRARG
00236 0731
00237 0202 FLDA UNIT
00240 2217 FSUB F1 /MAKE UNIT # START FROM 0
00241 1050 JLT ERRARG
00242 0731
00243 4223 FMUL F9 /MAKE DSRN SLOT
00244 0010 ALN 0
00245 0006 STARTD
00246 1235 FADD DSBASE
RALF V50A 8-APR-92 PAGE 7-1
00247 6201 FSTA BDSRN /PUT IN BASE PAGE AND
00250 6400 FSTA# #LDSRN /STORE FAR AWAY
00251 0167
00252 0005 STARTF
00253 0603 FLDA% FUNCT
00254 2217 FSUB F1 /RELEASE DOES NOT USE USRUSR
00255 0006 STARTD
00256 1000 JEQ NOMEM /SO WE CAN RELEASE WITH 0 FREE PAGES
00257 0304
RALF V50A 8-APR-92 PAGE 8
/ INITIALIZE PROGRAM
/
00260 0100 LDX 4,0 /FOR ERROR #4
00261 0004
00262 0400' FLDA# BOTHAN
00263 0122
00264 6400 FSTA# #LHNDR
00265 0163
00266 0400' FLDA# TOPBUF
00267 0124
00270 6400 FSTA# #LBUFF
00271 0165
00272 2233 FSUB D17400 /IF PROG ENDS AT 17400
00273 1000 JEQ SPCLOC /WE MUST BE CAREFUL
00274 0310
00275 0400 FLDA# #LHNDR /FIND OUT IF WE HAVE
00276 0163
00277 2400 FSUB# #LBUFF /ENOUGH SPACE TO COPY
00300 0165
00301 2232 FSUB D00400 /'USRUSR' INTO (LENGTH 400)
00302 1050 JLT ERRARG /FATAL USER ERROR
00303 0731
00304 0400 NOMEM, FLDA# #LBUFF /OK, PUT 'USRUSR' AT TOP
00305 0165
00306 1030 JA OKMEM /OF PROGRAM AND BUFFERS.
00307 0321
00310 0400 SPCLOC, FLDA# #LHNDR /IF END OF PROG AT 17400
00311 0163
00312 2233 FSUB D17400 /WE MUST LOAD 'USRUSR' AT
00313 2232 FSUB D00400 /20000. CHECK IF ROOM
00314 2232 FSUB D00400 /UP TOO 20400
00315 1050 JLT ERRARG /NO! TOO BAD - ERROR
00316 0731
00317 0233 FLDA D17400 /OK, SET LOC TO 20000
00320 1232 FADD D00400 /THIS WAS ALL DONE IN D.P. MODE
00321 6400 OKMEM, FSTA# #USRLC /HOLDS LOC TO LOAD 'USRUSR'
00322 0171
00323 2400 FSUB# #USRLD /RELOCATION DISTANCE
00324 0173
00325 1400 FADD# FILADR /RELOCATED ADDRESS OF '#FILE'
00326 0562
00327 1100 SETX #SB2
00330 0701
00331 0020 ATX 0 /SET ADDRESS OF '#FILE'
RALF V50A 8-APR-92 PAGE 9
00332 1100 SETX #USRLC
00333 0171
00334 1120 JSA MAKCDF
00335 0740
00336 1100 SETX #FD1
00337 0015
00340 0020 ATX 0 /SET LOCATION FOR 'USRUSR' TRANSFER
00341 1100 SETX #USRDF
00342 0604
00343 0020 ATX 0 /ALSO IN 'USRUSR' ITSELF
00344 1230 FADD D00001 /MAKE IT CIF USRUSR
00345 1100 SETX #FI1
00346 0031
00347 0020 ATX 0 /FOR 'JMS% USRUSR'
00350 1100 SETX #USRLD /MAKE CDF ORIGINAL 'USRUSR'
00351 0173
00352 1120 JSA MAKCDF
00353 0740
00354 1100 SETX #FUSR
00355 0013
00356 0020 ATX 0 /FOR COPYING 'USRUSR'
00357 1100 SETX ADUSR8 /USE TRAP USRS8
00360 0160
00361 1120 JSA MAKCDF
00362 0740
00363 1100 SETX #FD2
00364 0030
00365 0020 ATX 0 /SET CURRENT FIELD IN USRS8
00366 1230 FADD D00001 /MAKE CIF CDF
00367 1230 FADD D00001
00370 1100 SETX #UEXIT
00371 0722
00372 0020 ATX 0 /FOR USRUSR RETURN TO USRS8
00373 1100 SETX #CLNLC
00374 0175
00375 1120 JSA MAKCDF
00376 0740
00377 1230 FADD D00001 /MAKE CIF
00400 1100 SETX #USCLN
00401 0147
00402 0020 ATX 0 /FOR JMS% #CLNLC+1
00403 1100 SETX #CLBLC
00404 0352
00405 1120 JSA MAKCDF
00406 0740
00407 1230 FADD D00001 /MAKE CIF
00410 1100 SETX #CBFIF
00411 0330
00412 0020 ATX 0 /FOR JMS% #CLBLC+1
RALF V50A 8-APR-92 PAGE 10
00413 1120 JSA SETDS
00414 0765
00415 0030 XTA 0 /GET HANDLER ENTRY POINT
00416 1100 SETX #XR
00417 0002
00420 0026 ATX 6 /KEEP FOR LATER
00421 0005 STARTF
00422 0603 FLDA% FUNCT /RELEASE IS ALWAYS ALLOWED
00423 2217 FSUB F1
00424 1000 JEQ OPINOT /OK: RELEASE
00425 0626
00426 0100 LDX 1,0 /FOR ERROR #1
00427 0001
00430 0036 XTA 6 /GET HCW BACK
00431 1000 JEQ FREE
00432 0441
00433 0603 FLDA% FUNCT
00434 2220 FSUB F4
00435 1000 JEQ GODFUN /OK: CLOSE
00436 0451
00437 1030 JA ERRARG /NO: BAD FUNCTION
00440 0731
00441 0603 FREE, FLDA% FUNCT /IF SLOT FREE
00442 2217 FSUB F1
00443 2217 FSUB F1
00444 1000 JEQ GODFUN /OPEN INPUT IS OK
00445 0451
00446 2217 FSUB F1
00447 1040 JNE ERRARG /NO OPEN OUTPUT IS BAD
00450 0731
RALF V50A 8-APR-92 PAGE 11
/ PUT DEV:FILE.EXT INTO CORRECT FORMAT FOR USR CALL
/
00451 0107 GODFUN, LDX -1,7 /NO PERIODS YET
00452 7777
00453 0100 LDX 3,0 /FOR ERROR #3
00454 0003
00455 0214 FLDA DSK /INIT DEV: TO DSK:
00456 6400 FSTA# #DEV
00457 0637
00460 0002 FCLA /INITIALIZE SOME VARIABLES...
00461 6400 FSTA# #FILE
00462 0744
00463 6400 FSTA# #FILE+3
00464 0747
00465 6207 FSTA N
00466 6206 FSTA I / DO I=1,18
00467 1030 JA SKIP
00470 0571
GETLUP,
00471 1130 IFNSW 3 < JSR CGET / CALL CGET (NAME, I, X) >
00472 0000
IFSW 3 < JSR CGET3 / CALL CGET3 (NAME, I, X) >
00473 1030 JA .+10
00474 0503
00475 1030 NAME, JA . /**RA FORMAL PARAM ADDRESS
00476 0475
00477 1030 JA I
00500 0045
00501 1030 JA X
00502 0042
00503 0205 FLDA X / IF (X.NE.COLON) GO TO NOCOL
00504 1000 JEQ EOIN /IGNORE NULLS
00505 0605
00506 2215 FSUB COLON
00507 1040 JNE NOCOL
00510 0526
00511 0206 FLDA I /COLON MUST BE COLUMN 5 OR BEFORE
00512 2221 FSUB F6
00513 1010 JGE ERRARG
00514 0731
00515 0400 FLDA# #FILE /COLON DEFINES DEVICE NAME
00516 0744
00517 6400 FSTA# #DEV
00520 0637
00521 0002 FCLA
00522 6400 FSTA# #FILE
00523 0744
00524 1030 JA SKIP
00525 0571
RALF V50A 8-APR-92 PAGE 12
00526 0205 NOCOL, FLDA X / IF (X.NE.PERIOD) GO TO NOPER
00527 2216 FSUB PERIOD
00530 1040 JNE NOPER
00531 0537
00532 2170 JXN ERRARG,7+ /ONLY ONE PERIOD ALLOWED
00533 0731
00534 0221 FLDA F6
00535 1030 JA SKIP /POSITION FOR EXTENSION
00536 0571
00537 0205 NOPER, FLDA X
IFNSW 3 <
00540 2225 FSUB F26
00541 1020 JLE GODCHR /ALPHAS
00542 0556
00543 2221 FSUB F6
00544 1050 JLT ERRARG /[ TO _ >
00545 0731
IFSW 3 <
FSUB F32
JLT ERRARG /CONTROL CODES >
00546 1000 JEQ IGNOR /SKIP SPACES
00547 0576
00550 2224 FSUB F16
00551 1050 JLT ERRARG /! TO /
00552 0731
00553 2223 FSUB F9
IFNSW 3 <
00554 1060 JGT ERRARG /: TO ?
00555 0731
/DIGITS >
IFSW 3 <
JLE GODCHR /DIGITS
FSUB F6
JLE ERRARG /: TO ?
FSUB F1
JEQ EOIN /@ IS NAME TERMINATOR
FSUB F26
JGT ERRARG /[ TO END (LOWER CASE)
/ALPHAS >
00556 1130 GODCHR, JSR CPUT / CALL CPUT (FILE, N, X)
00557 0000
00560 1030 JA .+10
00561 0570
00562 1030 FILADR, JA #FILE
00563 0744
00564 1030 JA N
00565 0050
00566 1030 JA X
00567 0042
00570 0207 FLDA N / N=N+1
00571 1217 SKIP, FADD F1
00572 6207 MORE, FSTA N
00573 2223 FSUB F9 /MORE THAN 8 CHARS?
00574 1060 JGT ERRARG /YES, PROTECT USRUSR
RALF V50A 8-APR-92 PAGE 12-1
00575 0731
00576 0206 IGNOR, FLDA I / CONTINUE
00577 1217 FADD F1
00600 6206 FSTA I
00601 2223 FSUB F9
00602 2223 FSUB F9
00603 1020 JLE GETLUP
00604 0471
RALF V50A 8-APR-92 PAGE 13
00605 0603 EOIN, FLDA% FUNCT
00606 2220 FSUB F4
00607 1000 JEQ XCLOSE /IT IS CLOSE
00610 0614
00611 0213 FLDA ENTLEN /GET INDICATED FILE-LENGTH
00612 1030 JA BYPASS /STORE IN '#SB'
00613 0620
00614 0006 XCLOSE, STARTD /USER PROGRAM HAS ENDFILED
00615 1120 JSA SETDS
00616 0765
00617 0037 XTA 7 /OUR FILE LENGTH
00620 1100 BYPASS, SETX #SB
00621 0034
00622 0020 ATX 0 /TO '#SB' FOR CLOSE
00623 0005 STARTF
00624 1100 SETX #XR
00625 0002
/ START OF RELEASE
00626 0035 OPINOT, XTA 5 /GET FORMS
00627 1100 SETX #FUNCT /USR XR TO PASS PARAMETERS
00630 0160
00631 0022 ATX 2 /TO #FORMS IN USRS8
00632 0603 FLDA% FUNCT
00633 0020 ATX 0
00634 4000 TRAP4 USRS8 /TRAP TO THE USR CALLING ROUTINE
00635 0000
00636 0031 XTA 1 /GET ERRNO AND RETURN IT
00637 1100 SETX #XR
00640 0002
00641 1040 JNE ERARUS /ERROR: LEAVE CORE INTACT
00642 0727
00643 0603 FLDA% FUNCT
00644 2220 FSUB F4 /CLOSE IS SPECIAL
00645 1000 JEQ ENDCLS
00646 0675
00647 0603 FLDA% FUNCT
00650 2217 FSUB F1
00651 1000 JEQ ENDCLS /RELEASE LIKE CLOSE
00652 0675
00653 0002 FCLA /FOR HW FPP!
00654 0006 STARTD
00655 0400 FLDA# #LHNDR /GET MODIFIED TOP-OF-MEM
00656 0163
00657 2400' FSUB# TOPBUF /OLD TOP-OF-BUFFERS
00660 0124
00661 2232 FSUB D00400 /NEED 400 FOR BUFFER
00662 1050 JLT OVRFLW /NO ROOM!
00663 0725
00664 0400 FLDA# #LHNDR
00665 0163
00666 6400' FSTA# BOTHAN /SET NEW BOTTOM OF HANDLRES
00667 0122
00670 0232 FLDA D00400
00671 5400' FADDM# TOPBUF /SET NEW TOP-OF-BUFFERS
00672 0124
RALF V50A 8-APR-92 PAGE 13-1
00673 1030 JA RETURN
00674 0714
RALF V50A 8-APR-92 PAGE 14
00675 1120 ENDCLS, JSA WIPE /WIPE-OUT UNIT SLOT
00676 0752
00677 0006 STARTD
00700 1100 SETX #CLEN
00701 0350
00702 0030 XTA 0 /GET SIZE OF DELETED HANDLER
00703 5400' FADDM# BOTHAN /GAINED SOME SPACE
00704 0122
00705 0031 XTA 1 /GET SIZE OF DELETED BUFFER
00706 5400' FADDM# TOPBUF /AND SOME MORE
00707 0124
00710 0005 STARTF
00711 0002 FCLA /RETURN WITH 0 STATUS
00712 1030 JA OK
00713 0734
00714 0005 RETURN, STARTF
00715 1100 SETX #SB
00716 0034
00717 0031 XTA 1 / GET FILE LENGTH (-2047 TO 2048)
00720 1010 JGE OK
00721 0734
00722 1227 FADD F4096 / NEG MEANS GT 2048
00723 1030 JA OK
00724 0734
00725 1120 OVRFLW, JSA WIPE /NOBODY KNOWS THE TROUBLE I HAVE
00726 0752
00727 1220 ERARUS, FADD F4 /BACK FROM USRUSR ERROR
00730 0020 ATX 0 /ERRORS (4)5-10
00731 0005 ERRARG, STARTF
00732 0030 XTA 0
00733 0003 FNEG /NEGATIVE ERROR STATUS
00734 0004 OK, FNORM
00735 6604 FSTA% ERROR
00736 1030 JA #RTN
00737 0061
RALF V50A 8-APR-92 PAGE 15
00740 1030 MAKCDF, JA . /ENTER IN D-MODE
00741 0740
00742 0005 STARTF
00743 0030 XTA 0 /GET FIELD
00744 4222 FMUL F8 /PUT IT INTO BITS 6-8
00745 0010 ALN 0 /CHANGE TO D-FORMAT
00746 0006 STARTD
00747 1234 FADD DCDF /MAKE IT CDF FIELD
00750 1030 JA MAKCDF
00751 0740
00752 1030 WIPE, JA . /WIPE OUT SLOT
00753 0752
00754 0005 STARTF
00755 0002 FCLA
00756 0101 LDX 0,1
00757 0000
00760 6611 FSTA% BDSRN,1
00761 6711 FSTA% BDSRN,1+
00762 6711 FSTA% BDSRN,1+
00763 1030 JA WIPE /THIS TIME I LIKE LENGTH 9
00764 0752
00765 1030 SETDS, JA . /ENTER IN D-MODE
00766 0765
00767 0201 FLDA BDSRN /GET SLOT AGAIN
00770 1236 FADD DSETXI /INITIALIZE SETX INSTRUCTION
00771 6400 FSTA# .+2
00772 0773
00773 1100' SETX DSRN /**RA MODIFIED BY RALF
00774 4244
00775 1030 JA SETDS
00776 0765
RALF V50A 8-APR-92 PAGE 15-1
NO ERRORS
96 SYMBOLS, 10 ABS REFS
# C 00000 #BASE 00023 #CBFIF 00330 #CLBLC 00352
#CLEN 00350 #CLNLC 00175 #DEV 00637 #ENDF X 00000
#FD1 00015 #FD2 00030 #FILE 00744 #FI1 00031
#FUNCT 00160 #FUSR 00013 #GOBAK 00057 #LBUFF 00165
#LDSRN 00167 #LHNDR 00163 #MAIN S 00000 #RET 00015
#RTN 00061 #SB 00034 #SB2 00701 #ST 00162
#UEXIT 00722 #USCLN 00147 #USRDF 00604 #USRLC 00171
#USRLD 00173 #XR 00002 ADUSR8 00160 BDSRN 00026
BOTHAN 00122 BYPASS 00620 CGET X 00000 CGET3 X 00000
COLON 00072 CPUT X 00000 DCDF 00147 DSBASE 00152
DSETXI 00155 DSK 00067 DSRN 04244 D00001 00133
D00200 00136 D00400 00141 D17400 00144 ENDCLS 00675
ENTLEN 00064 EOIN 00605 ERARUS 00727 ERRARG 00731
ERROR 00037 FILADR 00562 FORM 00222 FREE 00441
FUNCT 00034 FZERO 00225 F1 00100 F16 00117
F26 00122 F32 00125 F4 00103 F4096 00130
F6 00106 F8 00111 F9 00114 GETLUP 00471
GODCHR 00556 GODFUN 00451 HKEY 02761 HPLACE 05200
I 00045 IGNOR 00576 MAKCDF 00740 MAXCOR 00121
MORE 00572 N 00050 NAME 00475 NOCOL 00526
NOMEM 00304 NOPER 00537 OK 00734 OKMEM 00321
OPINOT 00626 OVRFLW 00725 PERIOD 00075 RETURN 00714
SETDS 00765 SKIP 00571 SPCLOC 00310 TOPBUF 00124
UNIT 00031 USR S 00777 USRS8 X 00000 WIPE 00752
X 00042 XCLOSE 00614