Directory of image this file is from
This file as a plain text file
/THIS PROGRAM SETS UP RASBOL-TYPE FILES / /THESE ARE THE PROGRAM DATA AREAS / FIELD 0 *6200 DETBLK, ZBLOCK 13 MASK, TEXT ' 0-' DMASK, TEXT ' / / ' FILEX, ZBLOCK 11 / *7200 DUMBLK, ZBLOCK 400 *6400 DEVHAN, ZBLOCK 400 / /THE MAIN PROGRAM STARTS HERE / /IT BEGINS BY SETTING THE TAB STOPS ON THE /TERMINET AND THEN SETTING UP THE WORK AREAS / FIELD 1 *7000 ZBLOCK 600 *0000 PRINT 01 ;TEXT '_' PRINTC 01 ;33 PRINTC 01 ;62 LOADIM ;12 STORE1 ;DETBLK TBSTLP, PRINTC 01 ;33 PRINTC 01 ;61 PRINT 12 ;TEXT ' ' DECGOZ ;.+4 ;DETBLK GOTO ;TBSTLP PRINTC 01 ;33 PRINTC 01 ;61 FILL ;-1 ;DUMBLK ;400 /FILL RECORD WITH 7777 FILL ;0 ;DETBLK ;13 /CLEAR DETAILS BLOCK PRINT 02 ;TEXT '_^' /FEED 1 LINE DATE /FETCH DATE PRINTU ;DMASK ;12 /PRINT IT / /THE DETAILS OF THE FILE ARE NOW INPUT, CHECKED AND VERIFIED / INPUTS, PRINT 22 ;TEXT '___^DEVICE NAME = ' /REQUEST DEVICE NAME TYPTEX ;DETBLK ;4 /ENTER IT PRINT 16 ;TEXT '_^FILE NAME = ' /REQUEST FILE NAME TYPTEX ;DETBLK+2 ;6 /ENTER IT PRINT 17 ;TEXT '_^EXTENSION = .' /REQUEST EXTENSION TYPTEX ;DETBLK+5 ;2 /ENTER IT ILENT, PRINT 32 ;TEXT '_^INDEX LENGTH IN BLOCKS =' /REQUEST INDEX LENGTH TYPIN 10 /ENTER IT PRINTU ;MASK ;5 /PRINT IT STORE1 ;DETBLK+6 /STORE IT DECIMAL SUBTIM ;39 /SUBTRACT 39 OCTAL GOIF ;RLENT ;RLENT /BRANCH IF O.K. PRINT 32 ;TEXT '^^TOO MANY: MAXIMUM IS 39!' /MESSAGE GOTO ;ILENT /BACK TO RE-ENTER RLENT, PRINT 32 ;TEXT '_^RECORD LENGTH IN WORDS =' /REQUEST RECORD LENGTH TYPIN 10 /ENTER IT PRINTU ;MASK ;5 /PRINT IT STORE1 ;DETBLK+11 /STORE IT DECIMAL SUBTIM ;256 /SUBTRACT 256 OCTAL GOIF ;KLENT ;KLENT /BRANCH IF O.K. PRINT 34 ;TEXT '^^TOO MANY: MAXIMUM IS 256! ' /MESSAGE GOTO ;RLENT /BACK TO RE-ENTER KLENT, PRINT 32 ;TEXT '_^LENGTH OF KEY IN WORDS =' /REQUEST KEY LENGTH TYPIN 10 /ENTER IT PRINTU ;MASK ;5 /PRINT IT STORE1 ;DETBLK+12 /STORE IT SUBTIM ;3 /SUBTRACT 3 GOIF ;FLENT ;FLENT /BRANCH IF O.K. PRINT 32 ;TEXT '^^TOO MANY: MAXIMUM IS 3! ' /MESSAGE GOTO ;KLENT /BACK TO RE-ENTER FLENT, PRINT 32 ;TEXT '_^FILE LENGTH IN BLOCKS = ' /REQUEST FILE LENGTH TYPIN 10 /ENTER IT PRINTU ;MASK ;5 /PRINT IT STORE1 ;LENGTH /STORE IT DECIMAL SUBTIM ;3241 /SUBTRACT 3241 OCTAL GOIF ;INCHK ;INCHK /BRANCH IF O.K. PRINT 34 ;TEXT '^^TOO MANY: MAXIMUM IS 3241!' /MESSAGE GOTO ;FLENT /BACK TO RE-ENTER INCHK, PRINT 14 ;TEXT '_^CORRECT? ' /PRINT QUERY YESNO ;RFEXIT /BRANCH IF WRONG PRINT 13 ;TEXT ' NEW FILE? ' YESNO ;OLDFIL / /THE FILE IS NOW SET UP / PRINT 02 ;TEXT '__' /SPACE 2 LINES GOPAL ;SETUPS /TO FILE SETUP ROUTINE / /TEST FOR ANY ERRORS IN FILE SET UP / GOIF ;SETOK ;SETOK /BRANCH IF O.K. PRINT 24 ;TEXT '_^FILE SET-UP ERROR ' /SET-UP ERROR...PRINT... PRINTU ;MASK ;3 /...APPROPRIATE ERROR FILL 10 ;EMTAB ;PRNMES+1;1 /SET TABLE ADDRESS SUBTIM ;1 /ERROR NUMBER - 1 MULTIM ;21 /MULTIPLIED BY 21 STORX1 /PLACE IN INDEX REGISTER 1 PRNMES, PRINTX 1 ;0 ;42 /PRINT MESSAGE GOTO ;RFEXIT /TO END OF JOB QUERY SETOK, PRINT 10 ;TEXT '_^FILE "' /FILE SET-UP CORRECT... PRINTX ;DETBLK+2 ;6 /PRINT MESSAGE PRINT 01 ;TEXT '.' PRINTX ;DETBLK+5 ;2 PRINT 20 ;TEXT '" NOW EXISTS ON ' PRINTX ;DETBLK ;4 / /THE PROGRAM MAY NOW BE USED AGAIN OR ENDED / RFEXIT, PRINT 16 ;TEXT '_^FINISHED? ' /PRINT QUERY YESNO ;INPUTS /BACK IF MORE FILES PRINT 14 ;TEXT '_^END OF JOB' /END OF RUN MESSAGE EXIT /RETURN TO OS/8 / /CONSTANTS...ERROR MESSAGES / EMTAB, TEXT '^^DEVICE NOT IN CURRENT SYSTEM____' TEXT '^^NO ROOM FOR FILE ON DEVICE ____'
TEXT '^^WRITE ERROR ON OUTPUT DEVICE____'
TEXT '^^CANNOT CLOSE FILE CORRECTLY ____' TEXT '^^NO ROOM FOR INDEX ON DIRECT.____' TEXT '^^ERROR WHILE WRITING A.I.W. ____' / /THIS ROUTINE SETS UP NEW VALUES IN THE FILE /INFORMATION AREA FOR THE FIRST UNUSED RECORD /OF THE OLD FILE / OLDFIL, MOVE 10 ;DETBLK ;OLDOPN+1 ;2 MOVE 10 ;DETBLK+2 ;OLDOPN+3 ;4 MOVE 10 ;DETBLK+2 ;OLDCLS+1 ;4 OLDOPN, OPEN ;DEVICE 0 ;FILENAME 0 ;FILEX MOVE ;DETBLK+6 ;FILEX+3 ;6 PRINT 23 ;TEXT '_^1ST UNUSED BLOCK=' TYPIN 10 PRINTU ;MASK ;6 STORE1 ;FILEX+4 PRINT 22 ;TEXT '_^1ST UNUSED WORD=' TYPIN 10 PRINTU ;MASK ;6 STORE1 ;FILEX+5 LOAD1 ;LENGTH NEGATE STORE1 ;FILEX+10 OLDCLS, CLOSE ;FILENAME 0 ;FILEX GOTO ;RFEXIT / /THIS PAL-III SUBROUTINE MAKES USE OF THE OS/8 USER SERVICE ROUTINE /TO SET UP THE SPECIFIED FILE ON THE DEVICE SELECTED BY THE USER / FIELD 0 *7000 SETUPS, 0 CLA CLL /CLEAR AC AND LINK RDF /FETCH CALLING FIELD TAD SUSCFI /ADD INSTRUCTION DCA SUSEX /SET IT / /FETCH OS/8 USR / CDF 0 CIF 10 JMS I (7700 /TO USR 10 /FUNCTION 10: USRIN / /RESET DEVICE HANDLER RESIDENCY TABLE / CDF 0 CIF 10 JMS I (200 /TO USR 13 /FUNCTION 13: RESET 0 /SAVE TENTATIVE FILES / /NOW FETCH DEVICE HANDLER AND ITS ENTRY POINT / TAD DETBLK /FETCH DEVICE NAME DCA SUS01 /SET IT TAD DETBLK+1 /FETCH DEVICE NAME DCA SUS02 /SET IT TAD DVHA /FETCH HANDLER ADDRESS DCA SUS03 /SET IT CDF 0 CIF 10 JMS I (200 /TO USR 1 /FUNCTION 1: FETCH SUS01, 0 /NAME1 SUS02, 0 /NAME2 - DEVICE NO. SUS03, 0 /HAND. ADD. - ENTRY JMP ERROR1 /ERROR RETURN / /CREATE AND OPEN A FILE WITH THE SPECIFIED NAME / CLA CLL TAD (DETBLK+2 /FETCH FILE NAME ADDRESS DCA SUS04 /SET IT TAD SUS02 /FETCH DEVICE NUMBER CDF 0 CIF 10 JMS I (200 /TO USR 3 /FUNCTION 3: ENTER SUS04, 0 /NAME - START BLOCK 0 JMP ERROR2 /ERROR RETURN / /NOW SET UP AN EMPTY RASBOL-TYPE FILE OF THE REQUIRED LENGTH / TAD SUS04 /FETCH START BLOCK NO. DCA SUS05 /SET IT TAD LENGTH /FETCH FILE LENGTH CIA /NEGATE DCA SUSKNT /SET AS COUNTER SUSWBL, CDF CIF 0 JMS I SUS03 /TO DEVICE HANDLER 4200 /OUTPUT ONE BLOCK DUMBLK /FROM HERE... SUS05, 0 /...TO HERE JMP ERROR3 /ERROR RETURN ISZ SUS05 /BLOCK NUMBER + 1 ISZ SUSKNT /COUNTER + 1 JMP SUSWBL /BACK IF NOT FINISHED / /THE FILE IS NOW CLOSED AND MADE PERMANENT / CLA CLL TAD SUS02 /FETCH DEVICE NUMBER CDF 0 CIF 10 JMS I (200 /TO USR 4 /FUNCTION 4: CLOSE DETBLK+2 /FILE NAME LENGTH, 0 /NUMBER OF BLOCKS JMP ERROR4 /ERROR RETURN / /THE NEW FILE IS NOW LOOKED UP / CLA CLL TAD (DETBLK+2 /FETCH FILE NAME ADDRESS DCA SUS06 /SET IT TAD SUS02 /FETCH DEVICE NUMBER CDF 0 CIF 10 JMS I (200 /TO USR 2 /FUNCTION 2: LOOKUP SUS06, 0 /FILE NAME POINTER 0 JMP ERROR4 /ERROR RETURN / /THE ADDITIONAL INFORMATION WORDS ARE NOW /SET UP AND WRITTEN BACK TO THE DIRECTORY / CLA CLL CDF 10 TAD I (1404 /FETCH NO. OF A.I.W. DCA SUSPT1 /STORE IT CLA CLL CML IAC RTL /SET 6 TAD SUSPT1 /ADD NUMBER SMA SZA CLA /WAS IT < 6? JMP ERROR6 /YES...ERROR EXIT TAD SUSPT1 /NO...FETCH NUMBER TAD I (17 /ADD POINTER IAC /INDEX OVER DATE CDF 0 CIF 10 JMS I (SUWAIW /TO SET AND WRITE / /THE PAL-III SUBROUTINE NOW RETURNS TO THE MAIN RASBOL PROGRAM / CLA CLL /CLEAR AC AND LINK JMP SUSERX /TO ROUTINE EXIT / /SET-UP SUBROUTINE ERROR EXITS / ERROR1, CLA CLL IAC /SET 1 JMP SUSERX /TO EXIT / ERROR2, CLA CLL IAC RAL /SET 2 JMP SUSERX /TO EXIT / ERROR3, CLA CLL CML IAC RAL /SET 3 JMP SUSERX /TO EXIT / ERROR4, CLA CLL IAC RTL /SET 4 JMP SUSERX /TO EXIT / ERROR6, CLA CLL CML IAC RTL /SET 6 / /THIS IS THE ACTUAL SUBROUTINE EXIT
/
SUSERX, DCA 42 /SET ERROR CODE... DCA 41 /...IN RASBOL 36... DCA 40 /...BIT ACCUMULATOR / /RESET TABLES...FORCES MICRO TO FETCH OWN HANDLERS / CDF 0 CIF 10 JMS I (200 /TO USR 13 /FUNCTION 13: RESET 0 /SAVE TENTATIVE FILES / /THE OS/8 USER SERVICE ROUTINE IS NOW DISMISSED FROM CORE / CDF 0 CIF 10 JMS I (200 /TO USR 11 /FUNCTION 11: USROUT SUSEX, 0 /RESET CALLING FIELD JMP I SETUPS /RETURN / /SET-UP SUBROUTINE CONSTANTS AND WORK AREAS / SUSCFI, CIF DVHA, DEVHAN+1 SUSKNT, 0 SUSPT1, 0 SUSPT2, 0 / /SUBROUTINE TO ACTUALLY WRITE /ADDITIONAL INFORMATION WORDS / /FIRST SET UP WORDS IN DIRECTORY SEGMENT / FIELD 1 *7400 SUWAIW, 0 DCA AIWPTR /STORE POINTER TO A.I.W. RDF /GET DATA FIELD TAD CIFINS /SET INSTRUCTION DCA REWDSX TAD DATADD /GET DATA ADDRESS DCA DATPTR /SET IT TAD SUWRM5 /SET -5 DCA SUWKNT /AS COUNTER SUAILP, CDF 0 TAD I DATPTR /GET DATA CDF 10 DCA I AIWPTR /STORE IN D. S. ISZ AIWPTR /INDEX A.I.W. POINTER ISZ DATPTR /INDEX DATA POINTER ISZ SUWKNT /INDEX COUNTER JMP SUAILP /BACK IF NOT FINISHED / /THE DIRECTORY SEGMENT IS NOW REWRITTEN / CDF 10 TAD 7 /GET KEY WORD AND SUWRP7 /EXTRACT SEGMENT NUMBER DCA SEGNUM /STORE IT CIF 0 JMS I 51 /TO DEVICE HANDLER 4210 /WRITE 2 PAGES (FIELD 1) 1400 /FROM HERE... SEGNUM, 0 /...TO HERE JMP .+3 /ERROR RETURN REWDSX, 0 JMP I SUWAIW /RETURN TAD SUWRP7 /SET ERROR CODE CIF 0 JMP I SUWERX /TO ERROR EXIT / /CONSTANTS / AIWPTR, 0 DATPTR, 0 SUWKNT, 0 CIFINS, CIF DATADD, DETBLK+6 SUWRM5, -5 SUWRP7, 7 SUWERX, SUSERX / $