ߋtv ?B-NO BOOT ON VOLUME @w p@w wP׭ ׭ w f& fwW#w x   @ @wP  @& 7 $  BLOCK@   IS BAD   -̂@ &    # p@ |w 7 P7 R & B g wD ѕ  Rì     s   r z] ^\ 1  f s  -4(w,  @B5 Sr;zaX'5lem7 ?B-NO MONITR.SYS 7 ?B-NOT ENOUGH CORE e&^e  ee bn"tCeetHa a a,] t?a !aW, `p %e8?ae?w P $ @5V@l@f ,4@>>>C8E:E>E@EBEFEHE>r?BK>@&A CLRLST: LCHAN ;LAST CHANNEL NUMBER OUCHAN ;OUTPUT CHANNEL NUMBER .IF NDF MBUILD ASCII ;(/A) FBIN ;(/B) IGNORE ;(/G) ALLDIR ;(/W) .ENDC CURRNT ;(/C) FILENO ;(/M) QUERY ;(/Q) SYSBAD ;(/Y) EMPTY ;(/E RELATED) NOINFO ;(/F RELATED) XMODE ;(/X) DIRSIZ ;(/N VALUE) ZXTRA ;(/Z VALUE) FBLOKS ;DIRECTORY COUNTS NFILS NBLOX DIRDES ;DIRECTORY LIST FILE DIRFLG ;DIRECTORY LISTING IN PROGRESS FLAG 0 ;END OF LIST .SBTTL SWITCH TABLE MODE= 200 ACTION= 0 SWTCHS: .IF NDF MBUILD SWITCH A ASCII MODE SWITCH B FBIN MODE SWITCH D DELETE ACTION SWITCH G IGNORE MODE SWITCH K BLKSCN ACTION SWITCH S COMPRS ACTION SWITCH T EXTEND ACTION SWITCH V VERSON ACTION SWITCH W ALLDIR MODE .ENDC SWITCH C CURRNT MODE SWITCH E FULDIR ACTION SWITCH F FASDIR ACTION SWITCH I COPY ACTION SWITCH L DIRECT ACTION SWITCH M NUMBER MODE FILENO SWITCH N NSWIT MODE DIRSIZ SWITCH O REBOOT ACTION SWITCH Q QUERY MODE SWITCH R RENAME ACTION SWITCH U BOOT ACTION SWITCH X XMODE MODE SWITCH Y SYSBAD MODE SWITCH Z ZEROD ACTION ZXTRA 0 .SBTTL HANDLER FETCH HANERR: ERROR FETCH: MOV #FILDES,R2 ;POINTER TO CSI OUTPUT MOV #FREE,R4 ;ADDRESS OF FREE CORE MOV #FILDES+36,R1 ;ADDRESS OF INPUT LIST .IF NDF MBUILD 1$: TST (R2) ;IS DEVICE NAME NULL? (/E, /L, ETC.) BEQ 2$ ;YES, DON'T FETCH A HANDLER .FETCH R4,R2 ;LOAD HANDLER IN FREE CORE BCS HANERR ;ILLEGAL DEVICE (PROBABLY) MOV R0,R4 ;SAVE UPDATED FREE CORE ADDRESS 2$: ADD #12,R2 ;BUMP LIST POINTER CMP R2,R1 ;ARE WE IN THE INPUT LIST ?? BLOS 1$ ;NO, INCREMENT WAS CORRECT TST -(R2) ;INPUT LIST ELEMENTS ARE 1 WORD SHORTER CMP R2,#FILDES+116 ;DONE WITH LIST ?? BLO 1$ ;NO, LOOP .ENDC MOV R4,INFILS ;SAVE START OF EXPANDED INPUT LIST MOV R4,R2 ;AND PUT IT INTO R2 ;NOTE: R1=#FILDES+36 .SBTTL INPUT EXPANDER EXPAND: ADD #COPY,R3 ;COPY IS THE DEFAULT OPERATION MOV R3,-(SP) ;ADDRESS OF CORRECT ROUTINE MOV #6,-(SP) ;CSI INPUT LIST COUNT EXPLUP: CLR R3 ;STAR SWITCH MOV R2,R4 ;SAVE START OF NEXT EXPANDED ENTRY JSR PC,CORCHK ;INSURE ENUF FREE CORE FOR NXT FILENAM ;### MOV (R1)+,(R2)+ ;COPY DEVICE NAME FROM SHORT INP LIST BNE NOTNUL ;ENTRY WAS NOT NULL TST -(R2) ;NULL ENTRY, BACKUP EXPANDED LIST PTR ADD #6,R1 ;SKIP OVER THIS SHORT LIST ENTRY INFCNT: .CLOSE 0 ;CLOSE CHANNEL USED FOR DIR READS JSR PC,UNLOCK ;RELEASE USR AND RE-ENABLE CTRL/C INTERRUPTS DEC @SP ;ANY MORE TO EXPAND?? BNE EXPLUP ;YES MOV (SP)+,(R2)+ ;POP 0 TO ZERO END OF EXPANDED LIST MOV #FILDES,R4 ;POINTER TO OUTPUT LIST MOV (PC)+,R5 ;POINTER TO EXPANDED INPUT LIST INFILS: 0 ;NOTE: R2 POINTS TO FREE CORE JMP @(SP)+ ;JMP TO COMMAND HANDLER NOTNUL: CMP (R1),#R50STAR ;WAS FILE NAME * ?? BNE 1$ ;NO COMB R3 ;SET STAR NAME SWITCH 1$: MOV (R1)+,(R2)+ ;COPY THE NAME MOV (R1)+,(R2)+ ;TWO WORDS OF RAD 50 MOV (R1),(R2)+ ;COPY THE EXTENSION CMP (R1)+,#R50STAR ;IS THE EXTENSION * ?? BNE 2$ ;NO BIS #100000,R3 ;YES, SET STAR EXTENSION SWITCH 2$: TST R3 ;IS NAME OR EXT STARRED ?? BEQ INFCNT ;NO, NO EXPANSION MOV #DEVNAM,R5 ;POINTER TO NON DIR DEV NAM BLOCK MOV (R4),(R5) ;PUT IN THE DEVICE NAME MOV R4,R2 ;RESET PTR TO START OF EXPANDED ENTRY JSR PC,GETDIR ;GET THE FIRST BLOCK OF THE DIRECTORY EXPNDB: MOV R0,-(SP) ;SAVE NEXT BLOCK EXPNDL: BIT (R5),#DIREOB ;IS IT THE END OF BLOCK ?? BEQ NOEOB ;NO, CHECK FOR PERM MOV (SP)+,R0 ;IS THIS THE LAST DIR BLOCK ?? BEQ INFCNT ;YES, END OF EXPANSION JSR PC,RDDIR ;READ NEXT DIRECTORY BLOCK BR EXPNDB ;CONTINUE EXPANSION NOEOB: BIT (R5)+,#DIRPRM ;IS IT A PERM FILE ?? BEQ NOMACH ;NOT UNLESS THIS BIT IS SET TSTB R3 ;WAS THE NAME STARRED ?? BMI NMATCH ;YES, DON'T CARE ABOUT THE NAME CMP (R5),2(R4) ;NO STAR, DOES NAME MATCH ?? BNE NOMACH ;NO CMP 2(R5),4(R4) ;CHECK BOTH WORDS OF THE NAME BNE NOMACH NMATCH: TST R3 ;WAS THE EXTENSION STARRED ?? BMI EMATCH ;YES, DON'T CARE ABOUT THE EXTENSION CMP 4(R5),6(R4) ;NO STAR, DOES EXTENSION MATCH ?? BNE NOMACH ;NO EMATCH: TST CURRNT ;SHOULD WE INCLUDE ONLY TODAY'S? BEQ 2$ ;NO CMP 12(R5),TODAY ;DOES DATE MATCH TODAY'S? BNE NOMACH ;NO-DON'T INCLUDE IT 2$: TST QUERY ;SHOULD WE VERIFY THIS FILE ? BEQ 1$ ;NO JSR PC,FNAML ;LIST FILE NAME SUB #6,R5 ;FIX R5 MESSAGE <"?"> JSR PC,YESCHK ;IS IT YES ? BNE NOMACH ;NOPE 1$: MOV (R4),(R2)+ ;THIS FILE MATCHES, COPY INTO EXP LIST MOV (R5),(R2)+ ;COPY MATCHING FILE NAME MOV 2(R5),(R2)+ MOV 4(R5),(R2)+ ;INTO EXPANDED LIST NOMACH: ADD #DIRESZ-2,R5 ;BUMP R5 TO NEXT FILE ENTRY ADD (PC)+,R5 ;DON'T FORGET EXTRA WORDS XTRABY: 0 BR EXPNDL ;LOOK AT NEXT FILE NAME .IF NDF MBUILD .SBTTL DELETE DELETE: TST (R4) ;ANY OUTPUT FILES SPECIFIED? BEQ 1$ ;NO-COMMAND OK JMP ILLCMD ;YES-ILLEGAL /D COMMAND SYNTAX 1$: TST (R5) ;NULL INPUT LIST? BEQ FNF ;YES-GIVE FNF ERROR 2$: TST (R5) ;ANY FILES LEFT TO DELETE ?? BEQ STL1V ;NO, DO NEXT PIP COMMAND MOV R5,R0 ;POINTER TO NEXT FILE DESCRIPTOR ADD #10,R5 ;BUMP INPUT LIST POINTER JSR PC,SYSCHK ;CHECK FOR SPECIAL EXTENSIONS BEQ 2$ ;DON'T DELETE .BAD OR .SYS WITHOUT /S JSR PC,TSTNUM ;GET CONTENTS OF FILENO INTO XTRA ARG EMT ^O375 ;DELETE VERSION 2 (CODE 0) BCC 2$ ;OK, DO NEXT ONE .ENDC FNF: ERROR ;TSTNUM ENTERS THE /M SWITCH ARGUMENT FOR LOOKUP, ENTER, AND DELETE ;IT ALSO SETS UP THE VERSION 2 ARG LIST. TSTNUM: MOV R0,-(SP) ;SAVE POINTER TO FILE NAME MOV #FBLOCK,R0 ;POINT TO AREA MOV FILENO,@R0 ;INSET FILE COUNT (-0 IF /M NOT GIVEN) MOV @R0,-(R0) ;BOTH FBLOCK AND FLEN MOV (SP)+,-(R0) ;POINT TO FILE NAME CLR -(R0) ;CHANNEL 0,CODE 0 RTS PC .SBTTL RENAME RENAME: TST (R5) ;NULL INPUT LIST? BEQ FNF ;YES-REPORT ERROR 1$: TST (R5) ;ANY MORE FILES TO RENAME ?? BEQ STL1V ;NO, RETURN TO PIP MOV R5,R0 ;PT R0 TO FILE JSR PC,MTCA ;IF MT OR CT, BR ILLREN ;DISALLOW RENAME EVEN THO MONITR WILL, TOO CMP (R4),(R5) ;ARE DEVICES THE SAME ??? BNE ILLREN ;NO, PROBABLY AN ERROR JSR PC,OEXPND ;EXPAND NEXT OUTPUT FILE NAME MOV #OLNAME,R0 ;POINT TO OLD NAME MOV (R5)+,(R0)+ ;MOVE 4 WORDS OF OLD NAME INTO LIST MOV (R5)+,(R0)+ MOV (R5)+,(R0)+ MOV (R5)+,(R0)+ MOV #OLNAME,R0 ;RESTORE POINTER TO OLD NAME JSR PC,SYSCHK ;CHECK FOR PROTECTED FILES BEQ 1$ ;.SYS OR .BAD FILE .RENAME 0 ;DO THE RENAME .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC BCC 1$ ;CONTINUE IF FILE FOUND BR FNF ;ELSE FILE NOT FOUND ERROR ILLREN: ERROR STL1V: JMP START ;BACK TO PIP .SBTTL REBOOT REBOOT: JMP REBOT ;CALL REBOOT OVERLAY .SBTTL COPY EOF = 20000 ;EOF BIT IN CSW HDW = 1 ;HARD ERR BIT IN CSW COPY: MOV R2,-(SP) ;SAVE START ADDRESS OF FREE CORE TST (R5) ;NULL INPUT LIST? BNE ONE$ ;NO JMP FNF ;YES-REPORT ERROR ONE$: TST (R5) ;ANY MORE INPUT FILES TO OPEN ?? BEQ TWO$ ;NOPE, ALL OPENED AND SAVED JSR PC,CORCHK ;INSURE ENUF ROOM FOR SAVESTAT OR FOR ;### ;MT/CT FILENAME ;### MOV R5,R0 ;GET DEVICE NAME PTR JSR PC,MTCA ;IF MAGTAPE OR CASSETTE, BR DOMC ;GO COPY FILE NAME JSR PC,LOOKUP ;ELSE, LOOKUP THIS FILE MOV R2,R0 ;PUT STATUS BLOCK IN FREE CORE ADD #12,R2 ;FIVE WORDS EACH .SAVEST 0 ;SAVE THE FILE STATUS BR ONE$ ;DO NEXT ONE DOMC: MOV (R5)+,(R2)+ ;MOVE INPUT LIST TO CORE BLOCK MOV (R5)+,(R2)+ ;FOR MT AND CT INSTEAD OF STATUS BLOCK MOV (R5)+,(R2)+ MOV (R5)+,(R2)+ MOV #-1,(R2)+ ;SET LAST WORD NEG. TO INDICATE MT OR CA BR ONE$ ;THEN GET NEXT INPUT ELEMENT TWO$: CLR (R2)+ ;MARK END OF LIST FOR COMBINE COPY JSR PC,DFNBUF ;DEFINE BUFFER(S) ABOVE INPUT STATII MOV INFILS,R5 ;RESET POINTER TO INPUT LIST MCSTRT: MOV (SP),R2 ;RESET POINTER TO STATUS BLOCKS TST XMODE ;IS IT A MULTI-COPY ?? BNE ENTR15 ;YES, ENTER UP TO 15 AT A TIME CLR (R5) ;PREVENT JMP MCSTRT AFTER CLOSE OUT FILE MOV R4,R0 ;PREPARE TO ENTER OUTPUT FILE (ONLY 1) MOV OUCHAN,LCHAN ;SAVE # OF OUTPUT CHANNEL JSR PC,ENTER ;DO IT BNE DOCOMB ;OK, GO DO THE COMBINE COPY STLNK1: JMP START ;.SYS OR .BAD, BACK TO START ENTR15: MOV #15,OUCHAN ;ENTER UP TO 14 AT A TIME 6$: TST (R5) ;ANY INPUT FILES LEFT ?? BEQ 7$ ;NO, GO MOVE WHAT WE HAVE JSR PC,OEXPND ;GET NEXT OUTPUT FILE NAME MOV R5,R0 ;SAVE DEV NAME PTR FOR MTCA BELOW ADD #10,R5 ;MOVE POINTER TO NEXT INPUT FILE MOV 4(R2),(R3) ;SAME SIZE AS INPUT (OR LESS) JSR PC,MTCA ;IS INPUT FROM MT OR CT? CLR (R3) ;IF SO,WE MUST DO 0 LENGTH ENTER ADD #12,R2 ;BUMP STATUS BLOCK POINTER MOV #NEWNAM,R0 ;PREPARE TO ENTER THIS FILE JSR PC,ENTER ;ENTER THE FILE MOV #NEWNAM,R0 ;POINT TO OUTPUT DEVICE NAME AGAIN JSR PC,MTCA ;AND IF MT OR CA, BR 7$ ;DO NO MORE ENTERS TST -2(R2) ;IS INPUT FILE MT OR CA? BMI 7$ ;YES-DO NO MORE ENTERS ;IF MT OR CA IS INVOLVED IN EITHER SIDE OF TRANSFER,END THIS BATCH OF ;ENTERS,BECAUSE ONLY ONE FILE CAN BE TRANSFERRED AT A TIME DEC OUCHAN ;ELSE, ANY CHANNELS LEFT? BPL 6$ ;IF SO, ENTER ANOTHER FILE 7$: MOV OUCHAN,LCHAN ;SAVE NUMBER OF LAST ENTERED CHANNEL MOV #15,OUCHAN ;ELSE, PREPARE TO COPY 14 FILES MCLOOP: MOV OUCHAN,WAITN ;COPY CURRENT OUTPUT CHANNEL NUMBER ADD (PC)+,(PC) ;MAKE IT A WAIT AND EXECUTE IT .WAIT 1 WAITN: HALT BCS NOMC ;NO FILE ENTERRED HERE DOCOMB: CLR OUBLK ;ZERO OUTPUT FILE BLOCK NUMBER MOV OUBUF,R2 ;INITIALIZE WRITEC COMBIN: MOV (SP),R0 ;POINTER TO STATUS OF INPUT FILE TST (R0) ;IS STATUS WORD 0 BEQ DOCLOS ;YES, END OF COMBINE COPY TST 10(R0) ;IF LAST WORD OF BLOCK<0, BMI MTORCA ;THEN DO THE MT OR CA LOOKUP NOW .REOPEN 0 ;ELSE, RE-OPEN THE INPUT FILE BR MNORC MTORCA: MOV R5,-(SP) ;SAVE R5 AROUND LOOKUP SUBROUTINE MOV R0,R5 ;R0 POINTS TO ELEMENT IN CORE BLOCK JSR PC,LOOKUP ;LOOKUP LOOKS UP ELEMENT PT'D TO BY R5 MOV (SP)+,R5 ;RESTORE R5 MNORC: CLR INBLK ;ZERO INPUT FILE BLOCK NUMBER .IF NDF MBUILD CLR INBUFE ;INITIALIZE READC AND READB TST FBIN ;FORMATTED BINARY BNE BMCOPY ;YES TST ASCII ;WAS IT /A ?? BEQ IMCOPY ;NO, COPY IN IMAGE MODE 12$: JSR PC,READC ;READ A CHAR BEQ MCEOF ;END OF INPUT FILE JSR PC,WRITEC ;WRITE CHAR BR 12$ ;DO NEXT CHAR .IFF BR IMCOPY ;COPY IN IMAGE MODE .ENDC IMLOOP: JSR PC,WRITE ;WRITE THE BUFFER LOAD BCS 1$ ;GOT A REPORTED ERR. THIS TIME MOV OUCHAN,R0 ;SEE IF ERR UNREPORTED INC R0 MOV R0,-(SP) ASL R0 ASL R0 ADD (SP)+,R0 ;POINT R0 TO CSW FOR THIS WRITE ASL R0 ;MAKE IT BYTES CMP (R0)+,(R0)+ ADD @#SYSPTR,R0 BIT #EOF+HDW,(R0) BEQ IMCOPY 1$: JMP OUTER ;OUTPUT ERRORS IMCOPY: JSR PC,READ ;READ A BUFFER LOAD BNE IMLOOP ;NO EOF, DON'T QUIT MCEOF: .CLOSE 0 ;CLOSE THE INPUT FILE ADD #12,(SP) ;BUMP STATUS BLOCK POINTER TST XMODE ;IS IT A COMBINE COPY ?? BEQ COMBIN ;YES, APPEND NEXT INPUT FILE DOCLOS: .IF NDF MBUILD MOV ASCII,-(SP) ;IF IT IS NEITHER ASCII BIS FBIN,(SP)+ ; NOR FORMATTED BINARY BEQ NOFILL ; THEN DO NOT FILL BUFFER JSR PC,FILBUF ;FILL END OF BUFFER WITH NULLS .ENDC NOFILL: MOV #NEWNAM,R0 ;POINTER TO DEVICE NAME IN R0 JSR PC,MTCA ;SEE IF MT OR CA BR 1$ ;IF SO,ONLY ONE FILE IS OPEN AT A TIME MOV (SP),R0 ;IF INPUT FILE IS MT OR CA AS WELL, TST -(R0) ;ONLY ONE FILE WILL BE OPEN AT A TIME BMI 1$ DEC OUCHAN ;GO DOWN ONE CHANNEL BPL MCLOOP ;IF MORE TO DO, TRY ANOTHER XFER 1$: MOV (PC)+,R2 ;SETUP .CLOSE IMAGE .CLOSE 0 18$: MOV R2,(PC) ;MOV INSTRUCTION AND EXECUTE IT HALT INC R2 ;BUMP CLOSE CHANNEL NUMBER CMP R2,(PC)+ ;IS IT DONE ?? .CLOSE 17 BNE 18$ ;NO, KEEP CLOSING TST (R5) ;ANY MORE FILES AT ALL ?? BEQ STLNK5 ;NO-BACK TO PIP JMP MCSTRT ;YES-DO NEXT BATCH NOMC: ADD #12,(SP) ;BUMP INPUT LIST POINTER BR NOFILL .IF NDF MBUILD BMCOPY: MOV R4,R4SAV ;SAVE R4 MOV #FIRSTBY,R4 21$: JSR PC,READB ;READ FORMATTED BINARY BEQ 22$ ;END OF FILE JSR PC,WRITEC ;WRITE A CHARACTER BR 21$ ;AGAIN 22$: MOV (PC)+,R4 ;RESTORE R4 R4SAV: .WORD 0 BR MCEOF .ENDC ;MTCA TESTS FOR UNIT NAME POINTED TO BY R0 MAGTAPE OR CASSETTE. IF SO, ;IT RETURNS TO LOCATION FOLLOWING CALL. IF NOT, IT RETURNS TO LOCATION +2. ;THUS MOV NAMADR,R0 ; JSR PC,MTCA ; BR MTORCA ; BR NOTMTORCA MTCA: .DSTATU #DEVINF ;GET STATUS OF THIS DEVICE MTCA1: MOV #DEVINF,R0 ;POINT R0 TO STATUS WORD CMPB @R0,#TMIDEN ;TM11 MAGTAPE ? BEQ 1$ CMPB @R0,#TJIDEN ;TJU16 MAGTAPE? BEQ 1$ ;YES CMPB @R0,#CTIDEN ;TA11 CASSETTE? BEQ 1$ ADD #2,(SP) ;IF NOT, BUMP RETURN 1$: RTS PC STLNK5: JMP START .SBTTL DIRECTORY FASDIR: MOV SP,(PC)+ ;ONLY GIVE FILE NAMES NOINFO: .WORD 0 BR DIRECT FULDIR: MOV SP,(PC)+ ;LIST EMPTIES AND THEIR SIZES EMPTY: .WORD 0 DIRECT: INC (PC)+ ;SET DIRECTORY LISTING IN PROGRESS FLAG DIRFLG: 0 ADD #10,R2 ;MAKE ROOM FOR POSSIBLE EXTRA ENTRY MOV R5,DEVSAV ;REMEMBER THE DEVICE POINTER MOV R5,R0 ;SAVE POINTER FOR FETCH TST (R5) ;IS INPUT DEVICE SPECIFIED? BNE 1$ ;YES, USE WHAT HE SPECIFIED TST FILDES+36 ;IS THIS /L OR NULL EXPANDED LIST? BEQ 4$ ;JUST /L MOV FILDES+36,(R5)+ ;REMEMBER INPUT DEVICE (DEGENERATE CASE) BR 2$ 4$: MOV (PC)+,(R5)+ ;AND PUT IN THE DK: .RAD50 /DK / .FETCH R2 ;MAKE SURE DK HANDLER IS IN CORE BCC 2$ ;BOGUS DEVICE ASSIGNED TO DK? JMP HANERR ;GIVE AN ERROR IF SO 2$: MOV R0,R2 ;GOOD, RESET AVAILABLE CORE CLR (R5) ;CLEAR TARGET FILE NAME CLR 6(R5) ;AND MARK END OF LIST 1$: JSR PC,DFNBUF ;DEFINE OUTPUT BUFFERS CMP (R4),(PC)+ ;IS OUTPUT DEVICE TT: ?? .RAD50 "TT " BNE 3$ ;NO, ENTER DIRECTORY FILE CLR (R4) ;YES, MAKE IT 0 3$: MOV (R4),DIRDES ;ENABLE LISTING ON DEVICE MOV R4,R0 ;POINTER TO OUTPUT FILE NAME JSR PC,ENTER ;ENTER DIR FILE MOV #DEVNAM,R5 ;POINTER TO DEVICE NAME BLOCK MOV @INFILS,(R5) ;PUT IN THE DEVICE NAME JSR PC,GETDIR ;START DIRECTORY STUFF MOV R0,-(SP) ;SAVE NEXT BLOCK MOV R5,-(SP) ;SAVE DIR PTR MOV -(R5),DEVLOC ;SAVE START BLOCK OF SEGMENT TST NOINFO ;SUPPRESS DATE ON FAST DIRECTORY BNE DIRLUP MOV TODAY,R3 ;GET TODAY'S DATE INTO R3 JSR PC,DATOUT ;PRINT THE DATE AND A CRLF NXTLIN: JSR PC,CRLF DIRLUP: MOV (SP),R5 ;BUMP R5 TO THE NEXT ENTRY ADD XTRABY,(SP) ;COMPUTE ADDR OF NEXT ENTRY ADD #DIRESZ,(SP) MOV INFILS,R0 ;POINTER TO TARGET LIST BIT @R5,#DIREOB ;IS IT END OF BLOCK ? BNE ENDBLK ;YES ADD 10(R5),DEVLOC ;UPDATE POSITION ON DEVICE BIT (R5)+,#DIRPRM ;IS THIS A PERM FILE ?? BNE TARG1 ;YES, SEE IF ITS A TARGET ADD 6(R5),FBLOKS ;ADD TO NUMBER OF FREE BLOCKS TST EMPTY ;WAS IT /E ?? BEQ DIRLUP ;NO, DON'T PRINT EMPTIES MESSAGE <"< UNUSED > "> ;PRINT THE UNUSED MESSAGE MOV 6(R5),R0 ;GET SIZE OF EMPTY JSR PC,R10OVT ;OUTPUT DECIMAL BR NXTLIN ;PRINT CRLF AND CONTINUE TARGCK: CMP (R5),(R0)+ ;DOES IT MATCH THIS TARGET FILE ? BNE 1$ ;NO CMP 2(R5),(R0) BNE 1$ CMP 4(R5),2(R0) BEQ TARGET ;A HIT ! 1$: CMP (R0)+,(R0)+ ;ADVANCE TO NEXT IN TARGET LIST TARG1: TST (R0)+ ;END OF LIST ? BNE TARGCK ;NO, CONTINUE TST FILDES+40 ;PRINT IT ANYWAY ? BNE DIRLUP ;NOPE TARGET: TST CURRNT ;SHOULD WE INCLUDE ONLY TODAY'S? BEQ 8$ ;NO CMP 12(R5),TODAY ;DOES THIS DATE MATCH TODAY'S? BNE DIRLUP ;NO-DON'T INCLUDE IT 8$: INC NFILS ;BUMP HIT COUNTER JSR PC,FNAML ;LIST FILE NAME ADD (R5),NBLOX ;BUMP BLOCK CTR TST NOINFO ;WAS IT /F ?? BNE NXTLIN ;YES, NO SIZE OR DATE MESSAGE <" "> ;PRINT A SPACE MOV (R5)+,R0 ;GET MAX SIZE JSR PC,R10OVT ;OUTPUT DECIMAL MESSAGE <" "> ;PRINT A SPACE TST (R5)+ ;ADVANCE TO DATE WORD MOV (R5),R3 ;GET DATE WORD JSR PC,DATOUT ;PRINT DATE .IF NDF MBUILD TST ALLDIR ;START BLK & EXTRAS? BEQ NXTLIN ;NOPE TST (R5)+ ;WAS DATE = 0 ? BNE 10$ ;NO MOV #9.,R1 ;PRINT 9 SPACES 9$: MESSAGE <" "> DEC R1 BNE 9$ 10$: MOV DEVLOC,R0 ;GET STARTING BLOCK SUB -6(R5),R0 ;FIX UP DEVICE BLOCK # 11$: JSR PC,R8OUT ;PRHNT IT OCTAL CMP R5,(SP) ;DONE LAST EXTRA WORD ? BHIS NXTLIN ;YES MOV (R5)+,R0 ;GET AN EXTRA WORD BR 11$ ;PRINT IT .IFF BR NXTLIN ;DO NEXT LINE .ENDC ENDBLK: TST (SP)+ ;REMOVE R5 THING FROM STACK MOV (SP)+,R0 ;GET REL PTR TO NEXT DIR BLK BEQ ENDDIR ;IF ZERO, END OF THIS DIRECTORY JSR PC,RDDIR ;READ NEXT DIR SEGMENT MOV R0,-(SP) ;SAVE NEXT BLOCK # MOV R5,-(SP) ;AND DIR PTR MOV -(R5),(PC)+ ;SAVE START POSITION DEVLOC: 0 MOV FILDES+40,-(SP) ;INTER-BLOCK GAP ? BIS CURRNT,(SP)+ ; OR /C? BNE DIRLUP ;NO MOV DEVSAV,R0 JSR PC,MTCA ;IS THIS MT OR CT? BR DIRLUP ;YES-NO BLANK LINES BR NXTLIN ;PRINT BLANK LINE TO MARK NEW SEGMENT ENDDIR: TST NOINFO ;IS IT FAST ? BNE ENDLST ;YES, NO FREE BLOCK MSG MOV (PC)+,R0 ;GET FILE COUNT NFILS: 0 CMP R0,#1 ;IS IT WORTH IT ? BLOS LSTFRE ;NO CLR R3 ;LEFT JUSTIFY IT JSR PC,R10CNV ;YES, LIST IT MESSAGE <" FILES, "> MOV (PC)+,R0 ;GET BLOCK COUNT NBLOX: 0 JSR PC,R10CNV ;PRINT IT MESSAGE <" BLOCKS"<015><012>> LSTFRE: MOV (PC)+,R0 ;NAME OF DEVICE BEING LISTED INTO R0 DEVSAV: 0 JSR PC,MTCA ;MT OR CT? BR ENDLST ;YES-DONT PRINT FREE BLOCK MESSAGE MOV (PC)+,R0 ;GET TOTAL NUMBER OF UNUSED BLOCKS FBLOKS: 0 JSR PC,R10OVT ;OUTPUT THE FREE BLOCKS MESSAGE MESSAGE <" FREE BLOCKS"<015><012>> ENDLST: .IF NDF MBUILD TST DIRDES ;WAS OUTPUT DEVICE TT: ?? BEQ STLNK2 ;YES, NO BUFFER TO DUMP JSR PC,FILBUF ;FILL THE BUFFER WITH NULLS .CLOSE 1 ;CLOSE THE FILE .ENDC STLNK2: JMP START ;DO NEXT PIP COMMAND .SBTTL ZERO DIRECTORY ZEROD: CMP DIRSIZ,#NLIMIT ;DID HE SPECIFY A /N SRG TOO LARGE? BHI ILLCMD ;YES-ERROR MOV (R5),R0 ;ANY DEVICE GIVEN ?? BEQ ILLCMD ;NO,BAD COMMAND TST 2(R5) ;IS A FILE NAME GIVEN BNE ILLCMD ;YES-THIS MUST BE A MISTAKE JSR PC,R50OUT ;OUTPUT THE DEVICE NAME MESSAGE <":/Z ARE YOU SURE ?"> JSR PC,YESCHK ;TRY FOR A "Y" BNE STLNK2 ;NO, DON'T ZERO MOV R5,R0 ;GET PTR TO FILE NAME JSR PC,MTCA ;IF MT OR CA, BR DODEL ;INITIALIZE VOLUME JSR PC,OPNDIR ;ELSE, OPEN THE DIRECTORY FOR WRITING .REOPEN 1 ;ON CHANNEL 1 ZERIT: MOV USRBUF,R4 ;USE USR'S DIR BUFFER MOV DIRSIZ,R5 ;DIRECTORY SIZE IN SEGMENTS (/N:XXXX) BNE 1$ ;IF NOT ZERO, OK MOV #4,R5 ;OTHERWISE MAKE IT 4 SEGMENTS 1$: MOV R5,(R4)+ ;THATS FIRST WORD OF THE DIRECTORY ASL R5 ;MAKE IT A BLOCK COUNT CLR (R4)+ ;ZERO LINK TO NEXT SEGMENT MOV ZXTRA,R3 ;GET NUMBER OF EXTRA WORDS (/Z:XXXX) ASL R3 ;MAKE IT THE EXTRA BYTE COUNT MOV #1,R0 ;SET UP DIRECTORY SEGMENT NUMBER MOV R0,(R4)+ ;SET INITIAL HIGHEST SEGMENT = 1 MOV R3,(R4)+ ;NUMBER OF XTRA BYTES INTO DIR HEADER ADD #DIRBLK,R5 ;GIVES TOTAL NUMBER BLOCKS USED MOV R5,(R4)+ ;WHICH IS ALSO START BLOCK OF FILES MOV R3,XTRABY ;SAVE IT MOV DEVINF+6,R1 ;GET THE TOTAL SIZE OF THE DEVICE SUB R5,R1 ;MINUS THE AMOUNT USED BY DIR JSR PC,MAKEMT ;CREATE THE EMPTY MOV #DIREOB,(R4)+ ;PUT IN THE END OF BLOCK MARKER JSR PC,DIRWR ;WRITE OUT THE DIRECTORY IN SEG 1 CLR R0 ;BLOCK # IS 0 .WRITW 1,#BTMSGP,#400 ;WRITE DUMMY BOOTSTRAP ON BLK 0 .IF NDF MBUILD BCC 2$ ;BRANCH IF NO ERROR .IFF BCC STLNK2 ;BACK TO CSI .ENDC 3$: JMP OUTER ;PRINT ?OUT ER? MESSAGE .IF NDF MBUILD 2$: CMPB DEVINF,#DXIDEN ;IS THIS RX11/RX01 FLOPPY DISK? BNE STLNK2 ;BRANCH IF NOT TO RESTART PIP MOV #DXAREA,R0 ;ELSE DO SPFUN REQUEST EMT 375 ;TO WRITE VOL ID IN TRACK 0,SECTOR 7 BCS 3$ ;BRANCH IF HARDWARE ERROR BR STLNK2 ;BACK TO PIP .ENDC ILLCMD: ERROR .IF NDF MBUILD ;ARGUMENT AREA FOR FLOPPY INIT SPFUN REQUEST DXAREA: .BYTE 1,32 ;CHANNEL 1,SPFUN REQ 7 ;SECTOR 7 DXBUFF ;ADDRESS OF BUFFER TO BE WRITTEN 0 ;TRACK 0 .BYTE 377,376 ;SECTOR WRITE COMMAND 0 ;WAIT FOR COMPLETION ;BUFFER USED TO WRITE FLOPPY VOL ID. ONLY FIRST 4 BYTES ;ARE SIGNIFICANT DXBUFF: .WORD 0 ;SPFUN USES FIRST WORD FOR DD FLAG .ASCII /RT11/ .ENDC ;********************************************************* ;DUMMY BOOT WRITTEN INTO BLOCK 0 OF ALL DEVICES PROPERLY ZEROED TPB = 177566 TPS = 177564 BTMSGP: NOP ;ALL BOOTS START WITH NOP CHECK MOV #BTMSG-BTMSGP,R0 1$: TSTB @#TPS BPL 1$ 2$: MOVB (R0)+,@#TPB BPL 1$ BR . BTMSG: .BYTE 0,0,15,12,0,0,0,0,0,0,0,0,0,0 .ASCII /?B-NO BOOT ON VOLUME/ .BYTE 15,12,200 .EVEN ;********************************************************* .IF NDF MBUILD DODEL: .DELETE 16,R5 ;ZERO TAPE BCC 1$ ;IF NO ERROR 2$: JMP ERRWRD ;OTHERWISE REPORT DIR ERROR 1$: .CLOSE 0 ;MAKE SURE CHANNEL 0 CLOSED .LOOKUP 0,R5 ;LOOKUP MT OR CT BCS 2$ ;STRANGE LOOKUP ERROR JSR R5,SPFUN ;REWIND TAPE .BYTE 377,-5 JSR PC,SKPVL1 ;IF MT,SKIP VOL1 1 LABEL STLNK4: JMP START .IFF DODEL: JMP HANERR ;IILLEGAL FOR MBUILD TO ZERO MT .ENDC ;SUBROUTINE SKPVL1 ;IF DEVICE LAST DSTATUSED INTO DEVINF IS MT,ISSUES A ;SPFUN CALL TO SPACE FORWARD 1 BLOCK SKPVL1: CMPB DEVINF,#TMIDEN ;TM11 MAGTAPE? BEQ 2$ ;YES CMPB DEVINF,#TJIDEN ;TJU16 MAGTAPE? BNE 1$ ;NO-DONE 2$: JSR R5,SPFUN1 ;YES-SPACE OVER VOL1 LABEL .BYTE 377,-2 ;SPACE 1 BLOCK JSR PC,LOCK ;LOCK USR MOV R5,-(SP) ;SAVE R5 MOV USRBUF,R5 ;POINT R5 TO USR BUFFER .READW 0,R5,#400 ;READ BLOCK FOLLOWING VOL1 BCC 4$ ;NO ERROR JMP BADDIR ;REPORT READ ERROR 4$: CMP (R5),#240 ;WAS IT BOOT BLOCK? BEQ 3$ ;MUST BE BOOT BLOCK:POSITION AFTER IT JSR R5,SPFUN1 ;NO-BACKUP AND POSITION BEFORE IT .BYTE 377,-3 ;BACKSPACE ONE BLOCK 3$: MOV (SP)+,R5 ;RESTORE R5 1$: RTS PC ;RETURN .IF NDF MBUILD .SBTTL BAD BLOCK SCAN BLKSCN: TST (R5) ;ANY DEVICE GIVEN? ILLCM2: BEQ ILLCMD ;NO-ERROR TST 2(R5) ;IS FILE NAME GIVEN? ILLCM1: BNE ILLCMD ;YES-PROBABLY A MISTAKE .DSTATU #OLNAME,R5 ;GET DEVICE STATUS INFO TST OLNAME ;IS DEVICE FILE STRUCTURED? BPL ILLCMD ;NO-THIS IS A MISTAKE .LOOKUP 1,R5 ;LOOKUP DEVICE BCC BLKSC1 HANER2: JMP HANERR ;SHOULD NEVER GET HERE BLKSC1: CLR R5 ;R5 IS BLOCK # MOV OLNAME+6,R4 ;R4 IS BLOCK COUNT FOR DEVICE 3$: .READW 1,R2,#400,R5 ;READ A BLOCK INTO FREE CORE BCC 2$ ;NO ERROR ;ERROR CLR DIRDES ;MAKE OUTPUT GO TO TTY MESSAGE <"BLOCK"> MOV R5,R0 ;COPY BLOCK # INTO R0 JSR PC,R8OUT ;PRINT BLOCK # MESSAGE <" IS BAD"<015><012>> 2$: INC R5 ;BUMP BLOCK # DEC R4 ;DECREASE BLOCK COUNT BEQ STLNK4 ;IF ZERO,WE ARE ALL DONE BR 3$ ;AND LOOP .SBTTL COMPRESS COMPRS: JSR PC,FGCHK ;MAKE SURE NO F JOB ACTIVE TST (R5) ;ANY INPUT FILE ?? BEQ ILLCM2 ;NO, BAD COMMAND CMP DIRSIZ,#NLIMIT ;IS ARG TO /N TOO LARGE? BHI ILLCM1 ;YES-BAD COMMAND MOV R5,R0 ;PT R0 TO FILE JSR PC,MTCA ;ON MT OR CA, BR HANER2 ;DISALLOW SCRUNCH JSR PC,LOCK ;LOCK USR IN CORE MOV R4,R0 ;SET TO CHECK OUTPUT DEVICE TST (R4) ;WAS OUTPUT DEVICE GIVEN ? BEQ 1$ ;NO. IT IS A 1-DEVICE SQUISH CMP (R4),(R5) ;IS OUT DEV = IN DEV ? BNE 2$ ;NO. IT IS A 2-DEVICE SQUISH CLR (R4) ;SET 1-DEVICE FLAG 1$: DEC IGNORE ;SET /G IF NOT SET ALREADY MOV R5,R0 ;SET TO CHECK INPUT DEVICE 2$: JSR PC,SYSALL ;CHECK FOR SYSTEMS DEVICE COM OUCHAN ;WRITE ON CHANNEL 0 CLR ASCII ;DON'T WANT SPLIT BUFFERS CLR FBIN ;DON'T SPLIT BUFFERS JSR PC,DFNBUF ;DEFINE BUFFERS MOV SP,@NOCTLC ;DISABLE CTRL/C FOR COMPRESS MOV R5,R2 MOV R4,(PC)+ ;SAVE OUTPUT DEVICE NAME OUTDEV: 0 TST (R4) ;2 DEVICE TRANSFER? BNE DOSQ ;YES: IGNORE REARRANGING DIRECTORY CMP R0,#1024. ;MUST HAVE AT LEAST THREE BUFFERS BHIS 10$ ; TO WORK WITH. JMP COROVR ;NO CORE AVAILABLE 10$: MOV #TBUFF,R1 ;SCAN DIRECTORY TO DETERMINE ORDER OF ;DIRECTORY SEGMENTS. JSR PC,GETDIR ;READ IN 1ST DIRECTORY SEGMENT MOVB #1,(R1)+ ;HEAD OF THE LIST IS ALWAYS SEGMENT #1 1$: MOVB R0,(R1)+ ;SAVE LINK TO NEXT SEGMENT BEQ 2$ ;ZERO INDICATES LAST SEGMENT JSR PC,RDDIR ;READ IN NEXT DIRECTORY SEGMENT BR 1$ ;CONTINUE UNTIL LAST SEGMENT HAS BEEN ; READ IN. 2$: MOV #1,R3 ;BEGIN AT TOP OF TABLE 3$: TSTB TBUFF-1(R3) ;ZERO INDICATES END OF THE LIST BEQ DOSQ CMPB TBUFF-1(R3),R3 ;SEE IF ENTRY IS IN ITS CORRECT ; POSITION. BNE 4$ ;NO: SEE IF ITS ALREADY BEEN HANDLED THEN MOV R3,R0 ;READ IN SEGMENT, UPDATE LINKAGE JSR PC,RDDIR ; TO NEXT SEGMENT AND WRITE IT MOV USRBUF,R1 ; BACK OUT. (SKIP LAST SEGMENT THOUGH) TST 2(R1) BEQ 9$ MOV R3,2(R1) INC 2(R1) MOV R3,R0 JSR PC,DIRWR 9$: COMB TBUFF-1(R3) ;INDICATE THIS SEGMENT IS ALREADY IN THE BR 5$ ; RIGHT PLACE. 4$: TSTB TBUFF-1(R3) ;DO WE HAVE TO SAVE THE SEGMENT TO MAKE ; ROOM? BGT 6$ ;YES: SAVE BLOCK IN TEMPORARY AREA ; TO FREE UP A HOLE ON DISK. 5$: INC R3 ;NO: LOOK AT NEXT ENTRY IN LIST BR 3$ 6$: MOV R3,R0 ;SAVE THIS DIRECTORY SEGMENT IN A TEMPORARY ; AREA. THIS WILL FREE UP A ; HOLE ON THE DISK TO ALLOW THE ; SHUFFLING PROCESS TO BEGIN. MOV INBUF,R5 ;PUT THE SEGMENT HERE MOV @BLKEY,R1 ;SAVE '@BLKEY' SINCE THIS ISN'T GOING ; INTO THE USER'S BUFFER. JSR PC,REDDIR MOV R1,@BLKEY ;RESTORE SEGMENT NUMBER MOVB R3,SAVBLK ;SAVE NUMBER OF SAVED SEGMENT 8$: MOVB TBUFF-1(R3),R0 ;TRANSFER SEGMENT TO CORRECT POSITION JSR PC,RDDIR MOV R3,R0 MOV USRBUF,R1 ;INSERT NEW SEGMENT # UNLESS ITS THE LAST ONE TST 2(R1) BEQ 11$ MOV R0,2(R1) INC 2(R1) 11$: JSR PC,DIRWR 7$: MOVB TBUFF-1(R3),R0 ;SAVE SEGMENT # WHICH WAS JUST TRANSFERRED COMB TBUFF-1(R3) ;INDICATE THIS SEGMENT IS DONE MOV R0,R3 ;SEE IF WE'RE AT THE SPOT WHERE CMPB TBUFF-1(R3),SAVBLK ; THE 'SAVED' BLOCK SHOULD GO? BNE 8$ ;NO: DO THE NEXT SEGMENT IN THIS ; SEQUENCE. MOV USRBUF,-(SP) ;TRANSFER SAVED BLOCK NOW FROM TEMPORARY MOV INBUF,R1 ; BUFFER. MOV R1,USRBUF ;INSERT NEW SEGMENT # UNLESS ITS THE LAST ONE TST 2(R1) BEQ 12$ MOV R3,2(R1) INC 2(R1) 12$: JSR PC,DIRWR MOV (SP)+,USRBUF COMB TBUFF-1(R3) ;INDICATE THIS SEGMENT HAS BEEN WRITTEN OUT BR 2$ ;RESCAN LIST AGAIN ; DOSQ: CLR R1 ;CLEAR UNUSED BLOCKS COUNT SUB #512.,BUFSIZ ;REMOVE A SEGMENT SIZE FROM THE CURRENT MOV INBUF,(PC)+ ; FREE BUFFER AREA. SECBUF: 0 ADD #1024.,INBUF ADD #1024.,OUBUF MOV R2,R5 JSR PC,GETDIR ;GET FIRST DIRECTORY BLOCK MOV -(R5),OUBLK ;BEGIN WRITING AT THIS BLOCK MOV R0,-(SP) ;SAVE LINK TO NEXT DIR BLOCK TST (R4) ;IS THERE A DIFFERENT OUTPUT DEV ? BEQ 3$ ;NO, JUST COMPRESS THIS DEVICE TO ITSELF MOV R5,-(SP) ;SAVE INPUT DIRECTORY POINTER MOV R4,R5 ;SETUP POINTER TO OUTPUT DEVICE JSR PC,OPNDIR ;SETUP CHKEY FOR OUTPUT DEVICE .REOPEN 1 ;OPEN THE OUTPUT DEVICE ON CHANNEL 1 MOV #1,@BLKEY ;INITIALIZE DIR SEGMENT IN CORE NUMBER CLR OUCHAN ;SETUP TO WRITE DIR ON CH. 1 MOV (SP)+,R5 ;RESTORE INPUT DIR POINTER MOV DIRSIZ,R0 ;GET NUMBER OF DIR BLOCKS WANTED BEQ 3$ ;NOT SPECIFIED, USE INPUT CMP R0,-10(R5) ;TOO FEW FOR INPUT ? BLOS 3$ ;YES, USE INPUT ASL R0 ;FIND FIRST OUTPUT BLOCK ADD #DIRBLK,R0 MOV R0,OUBLK ;AND SET UP NUMBER BR 4$ ;START THE SQUISH 3$: MOV -10(R5),DIRSIZ ;SET OUTPUT HIGHEST = INPUT HIGHEST 4$: MOV R5,R4 ;SETUP DIRECTORY WRITE POINTER MOV DIRSIZ,-10(R5) ;SET HIGHEST DIR SEGMENT MOV (R5)+,INBLK ;REMEMBER WHER FILES BEGIN ON OLD COPY MOV OUBLK,(R4)+ ;STORE NEW FILE BEGINNING BLOCK MOV R4,(PC)+ ;CALCULATE END OF USR BUFFER ENDUSR: 0 ADD #1024.-14,ENDUSR BR NXTDB ;ENTER COMPRESS LOOP ; READ NEXT DIRECTORY BLOCK, IF ANY, INTO CORE ; IF END OF DIRECTORY, SQUISH IS DONE NEXTDB: MOV (SP)+,R0 ;RELATIVE POINTER TO NEXT DIR BLOCK MOV SECBUF,R5 ;READ NEXT DIRECTORY BLOCK INTO 2ND DIRECTORY ; BUFFER. MOV @BLKEY,-(SP) ;SAVE TEMP JSR PC,REDDIR MOV (SP)+,@BLKEY ;RESTORE FOR OUTPUT'S USE TST -(R5) ;POINT TO FILE BEGINING WORD MOV R0,-(SP) ;SAVE LINK TO NEXT DIR BLOCK JSR PC,CKEND ;CHECK ROOM IN DIRECTORY BEFORE PUTTING ; ANOTHER ENTRY INTO IT. MOV (R5)+,INBLK ;BEGIN READING FROM THIS BLOCK NXTDB: CLR R3 ;CLEAR BLOCK TRANSFER COUNT NXTDN3: JSR PC,CKEND ;CHECK ROOM IN DIRECTORY BEFORE PUTTING ; ANOTHER ENTRY INTO IT. MOV 10(R5),-(SP) ;GET NUMBER OF BLOCKS IN THIS ENTRY BIT (R5),#DIRPRM ;IS IT A PERMANENT FILE ?? BEQ UNPERM ;NO CMP 6(R5),(PC)+ ;IS THE EXTENSION .BAD ?? .RAD50 "BAD" BNE NOTBAD ;NO, GENERAL CASE JSR PC,MOVFLS ;MOVE ANY FILES PREVIOUSLY PAST TST OUCHAN ;DV1:=DV2:/S ?? BEQ SKPBAD ;YES, TREAT .BAD LIKE UNUSED TST R1 ;IS THERE ANY EMPTY TO MAKE? BEQ 1$ ;NO, AVOID CLOBBERING A GOOD ENTRY JSR PC,MAKEMT ;GENERATE AN EMPTY 1$: ADD (SP),INBLK ;PUSH INPUT BLOCK POINTER OVER THE BAD CLR (SP) ;AND DON'T LET HIM BUMP TRANSFER COUNT MOV INBLK,OUBLK ;BEGIN WRITING AFTER .BAD FILE JSR PC,CKEND ;CHECK ROOM IN DIRECTORY BEFORE PUTTING ; ANOTHER ENTRY INTO IT. NOTBAD: MOV XTRABY,R0 ;NUMBER OF EXTRA BYTES PER ENTRY ASR R0 ;MAKE IT A WORD COUNT ADD #7,R0 ;NUMBER OF WORDS IN ENTRY TO MOVE 3$: MOV (R5)+,(R4)+ ;MOVE THE ENTRY DEC R0 BNE 3$ ADD (SP)+,R3 ;INCREMENT NUMBER OF BLOCKS IN TRANSFER BR NXTDN3 ;PROCESS NEXT ENTRY ; EMPTY DIRECTORY SLOT FOUND ; MOVE ANY CHUNK OF FILES FOUND SO FAR, ; THEN PUSH THE INPUT BLOCK POINTER PAST THE EMPTY ; AND SKIP OVER IT UNPERM: JSR PC,MOVFLS ;MOVE FILES ON ANY NON PERMANENT BIT (R5),#DIREOB ;IS IT THE END OF BLOCK BNE DBDONE ;YES ADD (SP),R1 ;INCREMENT NUMBER OF UNUSED BLOCKS SKPBAD: ADD (SP)+,INBLK ;INCREMENT READ POINTER BY UNUSED ADD #16,R5 ;SKIP REST OF THIS ENTRY ADD XTRABY,R5 BR NXTDN3 ; END OF DIRECTORY BLOCK ; EOB ENTRIES HAVE NO SIZE, SO THE SIZE IS PURGED FROM THE STACK ; IF THIS IS THE LAST SEGMENT, AN EMPTY ENTRY IS CREATED ; WHICH IS THE SIZE OF ALL ACCUMULATED FREE SPACE ; THE EOB MARKER IS MADE, AND THE SEGMENT IS WRITTEN DBDONE: TST (SP)+ ;PURGE ENTRY SIZE FROM STACK TST (SP) ;IS THIS THE LAST BLOCK ?? BNE NEXTDB ;NO, READ IN NEXT SEGMENT THEN MOV DEVINF+6,R1 ;GET TOTAL SIZE OF OUTPUT DEVICE SUB OUBLK,R1 ;MINUS THE NUMBER OF BLOCKS USED JSR PC,MAKEMT ;CREATE AN EMPTY OF THIS SIZE MOV #DIREOB,(R4) ;PUT IN EOB MARKER MOV USRBUF,R4 ;SHOW LAST SEGMENT IN CHAIN CLR 2(R4) JSR PC,WRDIR ;WRITE OUT THIS DIR BLOCK ; COMPRESS FINISHED, NOW FIX UP WORD 3 OF SEGMENT #1 TO CONTAIN ; THE HIGHEST ACTIVE SEGMENT # IN USE. MOV @BLKEY,R2 ;GET LAST SEGMENT # USED CLR @BLKEY CLR @CHKEY MOV OUTDEV,R5 TST (R5) ;TWO DEVICE SQUISH? BNE 1$ ;YES MOV #1,R0 ;NO: READ IN FIRST DIRECTORY SEGMENT JSR PC,RDDIR ; AGAIN. BR 2$ 1$: .CLOSE 0 ;CLOSE OUT CHAN #0 JSR PC,GETDIR ;GET THE FIRST DIRECTORY SEGMENT ; FROM OUTPUT CHANNEL. 2$: MOV USRBUF,R1 ;UPDATE HIGHEST ACTIVE SEGMENT # MOV R2,4(R1) JSR PC,WRDIR ;NOW WRITE IT BACK OUT JMP STLNK3 ;COMPRESS COMPLETE ; HERE WE MOVE A CHUNK OF FILES WHICH WERE FOUND BETWEEN EMPTIES ; IF IT IS A ONE-DEVICE SQUISH AND THE INPUT AND OUTPUT BLOCK NUMBERS ; ARE THE SAME, NO I/O IS DONE. ; OTHERWISE, THE BLOCKS ARE TRANSFERRED AS ONE BIG CHUNK MOVFLS: TST OUCHAN ;IS IT A TWO DEVICE COMPRESS ?? BEQ 2$ ;YES, COPY ALWAYS CMP INBLK,OUBLK ;ARE READ AND WRITE BLOCKS THE SAME ?? BNE 2$ ;NO, DO THE MOVE ADD R3,INBLK ;OTHERWISE JUST BUMP BLOCK NUMBERS ADD R3,OUBLK 1$: CLR R3 ;CLEAR BLOCK TRANSFER COUNT RTS PC 2$: TST R3 ;ANY MORE BLOCKS TO MOVE ? BLE 1$ ;NO MOV BUFSIZ,R0 ;SIZE OF BUFFER SWAB R0 ;MAKE IT A BLOCK COUNT SUB R0,R3 ;DOES IT ALL FIT IN CORE ?? BCC 3$ ADD R3,R0 ;YES, ONLY TRANSFER THAT AMOUNT 3$: SWAB R0 ;MAKE IT A WORD COUNT AGAIN JSR PC,READN ;READ N BLOCKS JSR PC,WRITE ;THEN WRITE THEM BCC 2$ ;OUT OF ROOM OR OUTPUT ERROR .PRINT #OUMES ;TELL HIM ABOUT AN OUTPUT ERROR TST OUCHAN ;ONE DEVICE SQUISH ? BNE 2$ ;YES, PUSH ONWARD CLR @BLKEY CLR DIRSIZ CLR ZXTRA JMP ZERIT ; CHECK ROOM IN DIRECTORY BLOCK BEFORE PUTTING ANOTHER ENTRY INTO IT. ; IF FULL, WRITE BLOCK OUT AND RESET WRITE BUFFER POINTERS. CKEND: MOV XTRABY,-(SP) ;MAKE SURE THERE'S ROOM FOR AN ADDITIONAL ENTRY ADD #16,(SP) ADD R4,(SP) CMP (SP)+,ENDUSR BLOS 1$ ;ROOM LEFT: RETURN ;NO: CLEAN UP THIS SEGMENT, WRITE IT ; OUT AND START ANOTHER ONE. JSR PC,MOVFLS ;MOVE FILES ACCUMULATED SO FAR MOV USRBUF,R0 ;INSERT LINKAGE TO NEXT SEGMENT MOV @BLKEY,R2 INC R2 MOV R2,2(R0) MOV #DIREOB,(R4) ;SET "END OF BLOCK" ID JSR PC,WRDIR ;WRITE OUT DIRECTORY SEGMENT MOV USRBUF,R4 ;RESET POINTER TO BEGINNING OF BLOCK ; TO START NEW SEGMENT. ADD #10,R4 ;UPDATE FILE STARTING BLOCK MOV OUBLK,(R4)+ INC @BLKEY ;SHOW THAT NEXT SEGMENT IS THE ONE WE'RE 1$: RTS PC ; GOING TO WORK ON NEXT. TBUFF: .BLKW 20 ;STORAGE AREA FOR MAP OF DIRECTORY ; SEGMENTS PRIOR TO SHUFFLING. SAVBLK = .-1 ;SAVED BLOCK NUMBER DURING SHUFFLING .SBTTL EXTEND EXTEND: TST (R4) ;IS THERE AN OUTPUT DEVICE BEQ STLNK3 ;NO MOV R4,R0 ;CHECK FOR .SYS AND .BAD JSR PC,SYSCHK ;DON'T EXTEND THEM WITHOUT /Y BEQ STLNK3 ;NO GOOD JSR PC,LOCK ;LOCK USR IN CORE MOV SP,@NOCTLC ;DISABLE CTL/C FOR EXTEND EXTTRY: COM OUCHAN ;PREPARE TO WRITE ON CHANNEL 0 MOV #DEVNAM,R5 ;OPEN DEVICE AS NON FILE STRUCTURED MOV (R4),(R5) ;PUT IN DEVICE NAME JSR PC,GETDIR ;GET FIRST DIRECTORY BLOCK MOV 10(R4),R1 ;DESIRED SIZE OF FILE BR LTSTEB ;BEGIN SEARCHING FOR FILE LOCATE: TST R0 ;IS THIS THE LAST DIR BLOCK ?? BEQ EXTNEW ;YES, CREATE FILE JSR PC,RDDIR ;READ NEXT DIRECTORY BLOCK BR LTSTEB ;BEGIN SEARCHING THIS BLOCK LSKP14: TST (R5)+ ;SKIP FIRST WORD OF NAME LSKP12: TST (R5)+ ;SKIP SECOND WORD OF NAME LSKP10: TST (R5)+ ;SKIP EXTENSION WORD LSKP6: ADD #6,R5 ;SKIP SIZE WORDS AND DATE ADD XTRABY,R5 ;SKIP EXTRA WORDS LTSTEB: BIT #DIREOB,(R5) ;IS THIS THE END OF BLOCK ?? BNE LOCATE ;YES, GET NEXT BLOCK BIT #DIRPRM,(R5)+ ;IS THIS A PERM FILE ?? BEQ LSKP14 ;NO, SKIP TO NEXT ENTRY CMP 2(R4),(R5)+ ;CHECK FIRST WORD OF NAME BNE LSKP12 ;NO MATCH CMP 4(R4),(R5)+ ;CHECK SECOND WORD BNE LSKP10 ;NO MATCH CMP 6(R4),(R5)+ ;CHECK EXTENSION BNE LSKP6 ;NO MATCH SUB (R5)+,R1 ;AMOUNT NEEDED BCS EXTNEG ;NEGATIVE EXTEND ?? MOV R5,-(SP) ;SAVE POSITION (IN CASE WE SWITCH MOV @BLKEY,-(SP) ; DIRECTORY BLOCKS) CMP (R5)+,(R5)+ ;SKIP DATA SIZE AND DATE ADD XTRABY,R5 ;SKIP XTRA WORDS BIT #DIREOB,(R5) ;IS NEXT THING AN END OF BLOCK ?? BEQ NOEEB ;NO TST R0 ;LAST SEGMENT ? BEQ EXTROM ;YES, NO CAN DO JSR PC,RDDIR ;YES, READ NEXT DIRECTORY BLOCK NOEEB: BIT #DIREMP,(R5) ;IS NEXT THING AN EMPTY () ?? BEQ EXTROM ;NO, ERROR SUB R1,10(R5) ;THIS IS THE EXCESS BCS EXTROM ;NOT ENOUGH ROOM CMP (SP),@BLKEY ;IS EMPTY IN SAME BLOCK AS FILE ?? BEQ SAMDB ;YES, SAME DIRECTORY BLOCK JSR PC,WRDIR ;NO, WRITE FIRST MODIFIED BLOCK SAMDB: MOV (SP)+,R0 ;GET BLOCK NUMBER OF FIRST DIR BLK JSR PC,RDDIR ;READ BLOCK CONTAINING FILE MOV (SP)+,R5 ;RESTORE POINTER TO SIZE OF FILE ADD R1,-(R5) ;MODIFY THIE SIZE JSR PC,WRDIR ;WRITE OUT THIS MODIFIED BLOCK STLNK3: JMP START ;BACK TO PIP EXTNEW: INC OUCHAN ;WORK WITH CHANNEL 1 MOV R4,R0 ;CREATE A NEW FILE JSR PC,ENTER ;ENTER IT BEQ STLNK3 ;.SYS OR .BAD .CLOSE 0 ;CLOSE DIRECTORY .CLOSE 1 ;CLOSE THE FILE BR EXTTRY ;AND DO IT AGAIN RIGHT EXTNEG: ERROR EXTROM: ERROR .ENDC .SBTTL BOOTSTRAP COPY ;BOOT COPY PROVIDES A METHOD OF TRANSFERRING THE RT-11 ;BOOTSTRAP BLOCKS BETWEEN DEVICES. THE SYNTAX IS: ; *ODEV:FILE=IDEV:BOOTF/U ;THE INPUT FILE IS A FILE WHICH CONTAINS THE RT-11 ;BOOTSTRAP BLOCKS IN BLOCKS 0 AND 1. BOOT COPY READS THESE ;TWO BLOCKS AND WRITES THEM INTO BLOCKS 0 AND 2 OF THE ;OUTPUT DEVICE. USUALLY, THE INPUT FILE WILL BE MONITR.SYS. BOOT: MOV R4,R0 ;PT R0 TO FILE JSR PC,MTCA ;IF MT OR CT, BR BADBOT ;DISALLOW BOOT JSR PC,DFNBUF ;DEFINE BUFFERS CMP R0,#1000 ;NEED TWO BLOCKS AT LEAST BLO COROVR ;NOT ENOUGH BUFFER TST (R4) ;IS THERE AN OUTPUT DEVICE BEQ BADBOT JSR PC,LOOKUP ;OPEN INPUT FILE ON CH. 0 CLR 2(R4) ;OPEN OUTPUT AS NON-FILE DEVICE .LOOKUP 1,R4 ;OPEN CHANNEL 1 FOR OUTPUT .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC BCS BADBOT MOV #1000,R0 ;READ 2 BLOCKS JSR PC,READN CLR OUBLK ;WRITE BLOCK 0 MOV #400,R0 ;ONE BLOCK JSR PC,WRITE BCS 1$ ;ERROR ON WRITE MOV #2,OUBLK ;AND NOW BLOCK 2 ADD #1000,OUBUF ;SECOND RECORD JSR PC,WRITE .IF NDF MBUILD BCC STLNK3 ;IF NO ERRORS,WE ARE DONE .IFF BCS 1$ ;REPORT ERROR JMP START ;IF NO ERRORS,WE ARE DONE .ENDC 1$: JMP OUTER BADBOT: ERROR .IF NDF MBUILD .SBTTL VERSION VERSON: .PRINT #VMESAG ;TELL HIM OUR VERSION NUMBER BR STLNK3 ;BACK TO PIP VMESAG: .ASCIZ "PIP V04-06 " .ENDC .EVEN .SBTTL DFNBUF (DEFINE BUFFER(S)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; DFNBUF IS ENTERED WITH R2 POINTING TO THE START OF THE ; AVAILABLE BUFFER SPACE. BUFFER ALLOCATION IS DONE ; DEPENDING ON THE AMOUNT OF AVAILABLE CORE AND ON THE ; ASCII SWITCH. INBUF, OUBUF, OUBUFE, AND BUFSIZ ARE SET ; AND CHECKS ARE MADE FOR INSUFFICIENT BUFFER SPACE. ; REGISTER 2 IS LEFT POINTING AT THE START OF THE OUTPUT ; BUFFER. R0 IS USED AS A TEMPORARY. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DFNBUF: MOV USRBUF,R0 ;POINTER TO USR DIRECTORY BUFFER MOV R2,INBUF ;SAVE START OF INPUT BUFFER SUB R2,R0 ;TOTAL SPACE FOR BUFFERS BCS COROVR ;NO ROOM FOR BUFFER(S) BIC #777,R0 ;ROUND TO BLOCKS .IF NDF MBUILD MOV ASCII,-(SP) ;IF IT IS NEITHER ASCII BIS FBIN,(SP)+ ; NOR FORMATTED BINARY BEQ 1$ ; THEN WE NEED BUT ONE BUFFER BIC #1000,R0 ;SINCE WERE SPLITTING,NEED EVEN # OF BLOCKS ROR R0 ;HALVE THE BUFFER SIZE (/A USES 2) ADD R0,R2 ;GET START ADDR OF OUTPUT BUFFER .ENDC 1$: MOV R2,OUBUF ;SAVE START ADDRESS OF OUTPUT BUFFER MOV R2,(PC)+ ;GET ENDING ADDRESS OF OUTPUT BUFFER OUBUFE: 0 ADD R0,OUBUFE ROR R0 ;GET SIZE OF BUFFER(S) IN WORDS MOV R0,BUFSIZ ;SAVE IT BNE RTSPC ;RETURN OK IF BUFFERS NON-ZERO COROVR: ERROR ;NO ROOM IN CORE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; CORCHK IS ENTERED WITH R2 POINTING TO START OF AVAILABLE ; CORE. WE CHECK IF THERE IS ENOUGH ROOM FOR A SAVESTATUS ; BLOCK, OR FOR A MT/CT FILENAME, OR FOR THE NEXT FILE ; NAME IN AN INPUT EXPANSION. ALL THREE ARE CHECKED BY ; INSURING THERE IS AT LEAST 12. BYTES OF FREE CORE LEFT. ; CALLED FROM INPUT EXPANDER AND FROM COPY ROUTINE. (BC) ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CORCHK: MOV USRBUF,-(SP) ;USE SAME CHECK THAT DFNBUF USES ;### MOV R2,-(SP) ;PUT FREE CORE PTR ON STACK ;### ADD #14,(SP) ;ADD 14 TO FREE CORE PTR-NEED 6 WDS ;### SUB (SP)+,(SP)+ ;DO THE SUBTRACT ;### BCC RTSPC ;IF CC-ENUF ROOM-JUST RETN. ;### BR COROVR ;NOT ENUF ROOM-GIVE CORE MSG ;### .SBTTL OEXPND (EXPAND OUTPUT LIST) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; OEXPND EXAMINES THE CURRENT OUTPUT FILE ENTRY FOR A POSSIBLE ; WILD CARD (*) CHARACTER IN EITHER THE FILE NAME OR EXTENSION. ; IF SUCH EXISTS, THE CORRESPONDING PART OF THE CURRENT INPUT ; FILE IS MOVED INTO THE OUTPUT FILE DESCRIPTOR. THE NEW ; OUTPUT FILE DESCRIPTOR IS STORED IN THE FOUR WORD BLOCK ; NEWNAM. THE ROUTINE IS ENTERED WITH R4 POINTING TO THE ; CURRENT OUTPUT FILE AND R5 POINTING TO THE CURRENT INPUT ; FILE. THE OUTPUT LIST POINTER IS INCREMENTED AS REQUIRED. ONE ; CALL TO OEXPND PRODUCES ONE OUTPUT FILE. R0 IS USED AS ; A TEMPORARY. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; OEXPND: CLR R0 ;CLEAR OUTPUT LIST BACKUP COUNT CMP R4,#FILDES+36 ;ARE WE GETTING INTO INPUT COUNTRY? BHIS BADOUF ; THAT'S A NO-NO MOV #NEWNAM,R3 ;POINTER TO SPACE FOR NEW NAME MOV (R4)+,(R3)+ ;COPY DEVICE NAME CMP (R4),#R50STAR ;IS FILE NAME * ?? BNE 1$ ;NO MOV 2(R5),(R3)+ ;YES, SUBSTITUTE NAME FROM INPUT LIST MOV 4(R5),(R3)+ ;(TWO WORDS) CMP (R4)+,(R4)+ ;MOVE OUTPUT LIST POINTER TO EXTENSION MOV #12,R0 ;SET BACKUP COUNT BR 2$ ;GO CHECK EXTENSION 1$: MOV (R4)+,(R3)+ ;COPY NAME FROM OUTPUT LIST MOV (R4)+,(R3)+ 2$: CMP (R4),#R50STAR ;IS EXT .* ?? BNE 3$ ;NO MOV 6(R5),(R3)+ ;YES, USE EXTENSION FROM INPUT LIST TST (R4)+ ;BUMP OUTPUT LIST POINTER MOV #12,R0 ;SET OUTPUT LIST BACKUP COUNT BR 4$ 3$: MOV (R4)+,(R3)+ ;EXT IS OK, COPY IT 4$: TST (R4)+ ;SKIP OUTPUT FILE SIZE FROM CSI SUB R0,R4 ;SUBTRACT BACKUP COUNT RTSPC: RTS PC ;RETURN OUTPUT FILE NAME IN NEWNAM .SBTTL ENTER ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ENTER IS USED TO DO AN RT-11 ENTER OF THE FILE WHO'S ; NAME IS POINTED TO BY R0. CHECKS ARE MADE FOR ALL KNOWN ; ILLEGAL CASES (* IN FILE NAME OR EXTENSION OR NULL FILE). ; OUCHAN CONTAINS THE CHANNEL NUMBER TO BE USED FOR THE ; FILE. ATTEMPTS TO ENTER A .SYS OR .BAD FILE WITHOUT A ; /Y WILL CAUSE ENTER TO RETURN WITH Z=1. A SUCCESSFUL ; ENTER RETURNS WITH Z=0 (BEQ FAILS). OUBLK IS CLEARED ; TO INITIALIZE WRITE. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ENTER: TST (R0) ;ANY FILE TO ENTER BEQ 2$ ;NO, RETURN WITH Z=1 CMP 2(R0),#R50STAR ;IS NAME * ?? BEQ BADOUF ;YES, BAD OUTPUT FILE CMP 6(R0),#R50STAR ;HOW ABOUT THE EXT ?? BEQ BADOUF ;YUP, ITS BAD TST 2(R0) ;NULL NAME? BNE 1$ ;NO-OK MOV R0,-(SP) ;YES-SAVE R0 .DSTATU #DEVINF ;GET DEVICE STATUS .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC TST DEVINF ;FILE STRUCTURED? BMI BADOUF ;YES-DISALLOW THE ENTER MOV (SP)+,R0 ;RESTORE R0 1$: JSR PC,SYSCHK ;DON'T WRITE .SYS FILE UNLESS /Y 2$: BEQ RTSPC ;.BAD OR .SYS RETURN WITH Z=1 MOV 10(R0),-(SP) ;PUSH SIZE CLR OUBLK ;SET OUTPUT FILE BLOCK NUMBER TO 0 JSR PC,TSTNUM ;SET UP REST OF LIST MOV (SP)+,FLEN ;RETRIEVE LENGTH MOV #2*400,(R0) ;INSERT ENTER CODE (2) IN HI BYTE MOVB OUCHAN,(R0) ;CHANNEL IN LO BYTE INCB (R0) EMT 375 .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC BCS 3$ ;ENTER BAD-REPORT ERROR JMP CLZRTS ;ENTER OK,RETURN AFTER CLZ 3$: ERROR BADOUF: ERROR .SBTTL LOOKUP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; LOOKUP DOES AN RT-11 LOOKUP OF THE FILE WHO'S NAME IS ; POINTED TO BY R5. THIS REGISTER IS THEN INCREMENTED PAST ; THE FILE DESCRIPTOR. LOOKUP INITIALIZES READ AND READC BY ; CLEARING INBLK AND INBUFE. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LOOKUP: MOV R5,R0 ;GET FILE DESCRIPTOR POINTER CLR INBLK ;INITIALIZE INPUT FILE BLOCK NUMBER .IF NDF MBUILD CLR INBUFE ;INITIALIZE READC ROUTINE .ENDC ADD #10,R5 ;BUMP INPUT LIST POINTER JSR PC,TSTNUM ;GET XTRA ARG FOR MT AND CA MOV #1*400,(R0) ;SET CODE TO LOOKUP, CHANNEL 0 EMT 375 ;THEN DO V2 LOOKUP .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC BCC RTS7 ;LOOKUP OK, RETURN ADD (PC)+,(PC) ;ON ERROR CLOSE LAST OUTPUT CHANNEL .CLOSE 1 ;IN CASE MT OR CA, BECAUSE THESE PRECEDE LOOKUPS LCHAN: HALT ;IGNORE POSSIBLE ERROR ON CLOSE ERROR .SBTTL READ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; READ IS USED TO READ BUFSIZ NUMBER OF WORDS FROM THE INPUT ; FILE CURRENTLY OPEN ON CHANNEL 0. INBLK IS THE RELATIVE ; BLOCK NUMBER, AND INBUF IS THE BUFFER ADDRESS. IF THE READ ; IS COMPLETELY SUCCESSFUL, READ RETURNS WITH Z=0 (BEQ FAILS) ; AND THE ACTUAL NUMBER OF WORDS READ IN R0. THIS MAY BE LESS ; THAN BUFSIZ IF THE READ OVERLAPPED THE END OF FILE. IF THE ; READ IS UNSUCCESSFUL (EOF ENCOUNTERRED) Z=1 UPON RETURN ; SIGNALING THAT NOTHING WAS READ. READ WILL IGNORE HARD ; INPUT ERRORS IF THE /G SWITCH WAS SPECIFIED. READ WILL ; INCREMENT THE INPUT FILE BLOCK NUMBER (INBLK) BY THE ; NUMBER OF BLOCKS TRANSFERRED. READN WILL READ THE NUMBER ; OF WORDS IN R0. ; BEFORE BEGINNING THE READ OPERATION,A SPECIAL CASE CHECK IS ; MADE TO SEE IF THE INPUT DEVICE IS CASSETTE OR MAGTAPE. ; IF IT IS,THE BUFFER SIZE IS REDUCED TO 256 WORDS,TO PREVENT ; FILE ELONGATION BY EXTRA NULLS DURING THE TRANSFER. A FURTHER SPECIAL ; CASE CHECK IS MADE FOR CASSETTE,AND IF CASSETTE IS THE INPUT ; DEVICE,THE 256 WORD BUFFER IS "READ" BY FOUR SMALLER READS TO ; THE CASSETTE OF ONE RECORD EACH (64 WORDS). THIS IS NECESSARY TO ; PROPERLY DETECT END-OF FILE,WHICH MAY COME AFTER AN ODD NUMBER ; OF RECORDS ON CASSETTE. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; READ: MOV 2(SP),R0 ;GET PTR TO CORE BLOCK RCOM: MOV 10(R0),MTCARD ;AND TEST 5TH WORD FOR < 0 BPL CORBL ;IF NOT, DO BUFFERS SIZE XFERS MOV #256.,BUFSIZ ;ELSE (MT OR CA) DO SMALLER XFERS MOV OUBUF,OUBUFE ADD #1000,OUBUFE ;RESET OUTPUT BUFFER LIMITS .DSTATU #DEVINF ;DETERMINE CURRENT INPUT DEVICE CMPB DEVINF,#CTIDEN ;IS IT TA11? BNE CORBL ;NO .IF NDF MBUILD MOV INBUF,CTBADD ;YES-SET UP BUFFER ADDRESS 1$: MOV #READBK,R0 ;POINTER TO ARG LIST IN R0 EMT 375 ;V2 READ CALL BCC 4$ ;ERROR MUST BE HARD JSR PC,RDERR ;SEE IF EOF OR HARD ERROR BEQ RTS7 ;EOF 4$: MOV @#SYSPTR,R0 ;BASE ADDR OF RESIDENT INTO R0 MOV 4(R0),SSB ;CSW FOR CHANNEL 0 INTO SSB BIT #CSWEOF,SSB ;DID LAST READ DETECT EOF? BNE 2$ ;YES-IGNORE LAST RECORD ADD #64.*2,CTBADD ;NO-BUMP BUFFER ADDR OVER NEW MATERIAL 2$: MOV CTBADD,R0 ;ADDR OF NEXT BUFFER INTO R0 SUB INBUF,R0 ;DETERMINE HOW MANY BYTES READ SO FAR ROR R0 ;MAKE INTO WORDS BEQ SEZRTS ;IF NOTHING WAS READ AT ALL,WE HAVE LOGICAL EOF BIT #CSWEOF,SSB ;DID LAST READ DETECT EOF? BNE CLZRTS ;YES-RETURN WHAT WE HAVE SO FAR CMP R0,#256. ;IS BUFFER COMPLETE YET BLT 1$ ;NO-READ NEXT RECORD BR CLZRTS ;"READ" COMPLETE;WC IS IN R0 ;AREA PACKET FOR CASSETTE READ READBK: .BYTE 0,10 ;READW ON CHANNEL 0 1 ;BLOCK # ALWAYS 1 CTBADD: 0 ;BUFFER ADDR 64. ;WORD COUNT = 64 WORDS 0 ;WAIT MODE .IFF HALT ;IMPOSSIBLE TO GET HERE .ENDC CORBL: MOV (PC)+,R0 ;ELSE, READ A BUFFER LOAD BUFSIZ: 0 READN: CLR -(SP) ;USE WAIT I/O MOV R0,-(SP) ;PUSH WORD COUNT MOV (PC)+,-(SP) ;PUSH BUFFER ADDRESS INBUF: 0 MOV (PC)+,R0 ;GET RELATIVE BLOCK NUMBER INBLK: 0 .READ 0 ;READ CHANNEL 0 ROR -(SP) ;SAVE CARRY BIT FOR ERROR CHECK SWAB R0 ;NUMBER OF BLOCKS ACTUALLY READ ADD R0,INBLK ;INCREMENT RELATIVE BLOCK NUMBER SWAB R0 ;RESTORE IT TO A WORD COUNT TST (SP)+ ;DID READ GIVE ERROR ? BMI RDERR ;YES, CHECK ON IT MOV R0,-(SP) ;SAVE WORD COUNT TST (PC)+ ;IS THIS MAGTAPE OR CASSETTE? MTCARD: .WORD 0 ; BMI 1$ ;YES-SPECIAL CASE EOF CHECK MOV (SP)+,R0 ;NO-RESTORE WORD COUNT BR CLZRTS ;AND RETURN 1$: MOV @#SYSPTR,R0 ;BAS OF MONITR INTO R0 MOV 4(R0),SSB ;FIRST WORD OF $CSW FOR CHANNEL 0 NTO SSB MOV (SP)+,R0 ;RESTORE COUNT BIT #CSWEOF,SSB ;DID LAST READ RESULT IN NFS EOF? BEQ CLZRTS ;BIT OFF MEANS MORE TO COME SEZRTS: SEZ ;BIT ON MEANS EOF FOR CT OR MT RTS PC CLZRTS: CLZ ;CLEAR EOF INDICATOR RTS7: RTS PC RDERR: TSTB @#EMTERR ;WHAT KIND OF ERROR ?? BEQ RTS7 ;RETURN WITH COND CODES =0 .IF NDF MBUILD TST IGNORE ;SHOULD WE IGNORE IT (/G) BGT CLZRTS ;YES, REGULAR IGNORE BEQ EBOMB ;NO, BOMB ON ERROR MOV R0,-(SP) ;SAVE ACTUAL COUNT .PRINT #INERR ;SQUISH! PRINT, BUT CONTINUE RR0RTS: MOV (SP)+,R0 ;RESTORE COUNT BR CLZRTS ;SO RETURN .ENDC EBOMB: JSR R0,MSG ;PRINT AN ERROR AND DIE .NLIST BEX INERR: .ASCIZ "?IN ER?" .LIST BEX .IF NDF MBUILD .SBTTL READC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; READC IS USED TO READ CHARACTERS FROM THE CURRENT INPUT FILE ; (OPEN ON CHANNEL 0). R1 IS USED AS THE BUFFER POINTER ; AND THE CHARACTERS ARE RETURNED ONE AT A TIME IN R0 AS SEVEN ; BIT ASCII. READC USES READ TO DO THE ACTUAL READING. ; IF THE EOF IS ENCOUNTERRED, READC RETURNS WITH ; Z=1 (BNE FAILS). ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; READC: CMP R1,(PC)+ ;IS BUFFER EMPTY ?? INBUFE: 0 BLO 1$ ;NO, DON'T READ MOV 2(SP),R0 JSR PC,RCOM ;EMPTY BUFFER, READ SOME BEQ 2$ ;END OF FILE MOV INBUF,R1 ;RESET BUFFER POINTER ASL R0 ;GET ACTUAL NUMBER OF BYTES READ ADD R1,R0 ;NOW GET ADDR OF END OF BUFFER MOV R0,INBUFE ;SAVE THIS 1$: MOVB (R1)+,R0 ;GET A CHARACTER FROM THE FILE BIC #177600,R0 ;MAKE IT SEVEN BIT BEQ READC ;IGNORE NULLS CMP R0,#177 ;IS IT A RUBOUT ?? BEQ READC ;YES, IGNORE IT CMP R0,#32 ;IS IT CTRL/Z? (NE RETURNS CHAR,EQ RETURNS EOF) 2$: RTS PC ;RETURN CHARACTER .SBTTL FORMATTED BINARY READ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; READB IS USED TO READ FORMATTED BINARY FILES ; IT WILL DISCARD ANY DATA BEFORE THE BYTE 001 ; MARKING THE FIRST BLOCK ; USED REGISTERS 0,1, AND 4 ; PLEASE NOTE, REGISTER 4 MUST BE INITALLY SET TO FIRSTBY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; READB: CMP R1,INBUFE ;END OF BUFFER? BLO 2$ ;NO MOV 2(SP),R0 ;GET PTR TO CORE BLOCK JSR PC,RCOM ;READ SOME MORE DATA BEQ NFIL ;END OF FILE MOV INBUF,R1 ASL R0 ;MAKE WORD COUNT , BYTE COUNT ADD R1,R0 ;THIS IS END OF INPUT BUFFER MOV R0,INBUFE ; 2$: MOV @R4,PC ;THIS IS A JMP IN DISGUISE BYTE1: DECB (R1)+ ;IS THIS BYTE AN 001 ? BNE READB ;WELL, NOT A BLOCK INCB -(R1) ;FIX REG 1 AND THE BYTE CLR CKSUM ;CLEAR THE CHECKSUM CLR BYSIZ ;CLEAR THE BYTE COUNTER BR OUTCHA ;ADVANCE THREAD AND OUTPUT BYTE BSIZE: MOVB (R1),(PC)+ ;STORE FIRST BYTE OF BYTE SIZE BYTMP: 0 BR OUTCHA ;OUTPUT THIS CHARACTER BSIZE2: MOVB (R1),BYTMP+1 ;STORE SECOND BYT OF BYTE SIZE ADD BYTMP,BYSIZ ;COMPUTE BYTE SIZE INC BYSIZ ;ADJUST FOR CHECKSUM BYTE ;FALL THRU TO FINISH THE BLOCK OUTCHA: TST (R4)+ ;ADVANCE THE THREAD OUTCH: MOVB (R1)+,R0 ;FOR WRITEC ADD R0,(PC)+ CKSUM: 0 ;CALCULATE CHECKSUM DEC (PC)+ ;DECREMENT BYTE COUNTER BYSIZ: 0 BNE NFIL ;AND EXIT TSTB CKSUM ;IS CHECKSUM EQUAL TO ZERO BNE CKERR ;NO, ERROR CCONT: MOV #FIRSTBY,R4 ;RESET FOR A NEW BLOCK ; (ALSO SET NON-ZERO RETURN CODE) NFIL: RTS PC ;RETURN WITH CHARACTER IN R0 CKERR: TST IGNORE ;IGNORE READ ERRORS BNE CCONT ;YES, CONTINUE ERROR FIRSTBY:.WORD BYTE1 ;FIND A BYTE CONTAINING 001 .WORD OUTCHA ;OUTPUT THE NULL AFTER THE 001 .WORD BSIZE ;SAVE & OUTPUT THE FIRST .WORD BSIZE2 ; AND 2ND COUNT BYTES .WORD OUTCH ;THEN OUTPUT WITHOUT UPDATING THREAD .ENDC .SBTTL WRITE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; WRITE IS USED TO WRITE SOME NUMBER OF WORDS ONTO THE CHANNEL ; OUCHAN FROM THE BUFFER OUBUF TO THE RELATIVE BLOCK ; NUMBER OUBLK. THE WORD COUNT IS SPECIFIED BY R0. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WRITE: CLR -(SP) ;USE WAIT I/O SWAB R0 ;MAKE WORD COUNT A BLOCK COUNT MOV R0,-(SP) ;PUT ONTO STACK MOV (PC)+,R0 ;GET RELATIVE BLOCK NUMBER OUBLK: 0 ADD (SP),OUBLK ;UPDATE THE BLOCK NUMBER SWAB (SP) ;MAKE THE STACK ENTRY A WORD COUNT MOV (PC)+,-(SP) ;PUSH BUFFER ADDRESS OUBUF: 0 MOV (PC)+,-(SP) ;GET CHANNEL NUMBER OUCHAN: 0 ADD (PC)+,(SP) ;ADD PROTOTYPE EMT .WRITE 1 MOV (SP)+,(PC) ;PUT IT IN LINE 0 ; AND DO THE WRITE RTS PC OUTER: JSR R0,MSG .NLIST BEX OUMES: .ASCIZ '?OUT ER?' .LIST BEX .EVEN .IF NDF MBUILD .SBTTL WRITEC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; WRITEC IS USED TO WRITE CHARACTERS TO THE CURRENT OUTPUT FILE ; OPEN ON CHANNEL OUCHAN. R2 IS USED AS THE OUTPUT BUFFER ; POINTER, AND WRITE IS USED TO DO THE ACTUAL IO TRANSFER. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WRITEC: CMP R2,OUBUFE ;IS BUFFER FULL ?? BLO 1$ ;NO, DON'T WRITE IT MOV R0,-(SP) ;SAVE CHARACTER TO BE WRITTEN MOV BUFSIZ,R0 ;PUT WORD COUNT INTO R0 JSR PC,WRITE ;WRITE ONE BUFFER LOAD BCS OUTER ;OUTPUT ERROR MOV (SP)+,R0 ;RESTORE CHARACTER MOV OUBUF,R2 ;SETUP BUFFER POINTER 1$: MOVB R0,(R2)+ ;STUFF CHARACTER INTO BUFFER RTS PC .SBTTL FILBUF ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; FILBUF FILLS THE CURRENT BLOCK OF THE OUTPUT BUFFER WITH ; NULLS AND THEN WRITES OUT THE LAST BUFFER LOAD. THIS ; MAY BE SHORTER THAN BUFSIZ. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; FILL: CLRB (R2)+ ;PUT IN ANOTHER NULL FILBUF: MOV R2,R0 ;GET CURRENT BUFFER POINTER SUB OUBUF,R0 ;GET CURRENT BUFFER SIZE BIT #777,R0 ;IS SIZE A MULTIPLE OF 1000 BYTES ? BNE FILL ;NO, MORE NULLS ASR R0 ;MAKE THIS A WORD COUNT JSR PC,WRITE ;WRITE OUT LAST PIECE OF FILE BCS OUTER ;A WRITE ERROR RTS PC .ENDC .SBTTL SYSCHK ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; SYSCHK USED TO PROTECT .SYS AND .BAD FILES FROM INADVERTENT ; DELETION, RENAMING, OR MODIFICATION. THE ROUTINE IS ENTERRED ; WITH R0 POINTING TO THE FILE DESCRIPTOR TO BE CHECKED. ; IF THE FILE HAS AN EXTENSION OF .BAD OR .SYS AND THE /Y SWITCH ; HAS NOT BEEN SET, SYSCHK WILL RETURN WITH Z=1 (BEQ ; SUCCEEDS). OTHERWISE THE RETURN IS WITH Z=0 (BEQ FAILS). ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SYSCHK: CMP 6(R0),(PC)+ ;IS IT A .BAD FILE ?? .RAD50 "BAD" BEQ 1$ ;YES, GO CHECK /Y CMP 6(R0),(PC)+ ;IS IT A .SYS FILE ?? .RAD50 "SYS" BNE SCRET ;NO, JUST RETURN 1$: TST SYSBAD ;WAS THERE A /Y ?? BEQ CHKMES ;INFORM USER SYSALL: MOV R0,-(SP) ;SAVE REGISTER ZERO .DSTATU #DEVINF ;GET DEVICE STATUS INFORMATION MOV #DEVINF+4,R0 ;POINT TO DEVINF+4 (USED AS SCRATCH TOO) CMP @R0,@#SYSPTR ;IS THIS IS A SYS DEVICE BLO POPST ;NO CLR -(R0) ;SET UP FOR NON-FILE-STRUCTURED MOV @(SP),-(R0) ;PUT IN THE DEVICE NAME .LOOKUP 0 ;OPEN THE DEVICE NON-STRUCTURED .SAVEST 0,#SSB ;AND GET INFORMATION THEREON MOV @#SYSPTR,R0 ;BASE OF RES INTO R0 CMPB SYSUNT(R0),SSB+11 ;IS IT SYSTEM DEVICE? BNE POPST ;NOT SYS DEVICE (AT LAST) CLR REBMES ;SET SWITCH SO REBOOT PRINTED WHEN DONE POPST: MOV (SP)+,R0 ;RESTORE REGISTER 0 CHKSLS: TST SYSBAD ;WAS THERE A /Y ?? SCRET: RTS PC CHKMES: CLR SYSMES ;SET FLAG TO PRINT MESSAGE BR CHKSLS .NLIST BEX SYSMSG: .ASCIZ '?NO .SYS/.BAD ACTION?' RBMSG: .ASCIZ '?'<7>'REBOOT'<7>'?' .EVEN .LIST BEX .SBTTL GETDIR AND RDDIR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; GETDIR IS USED TO OPEN A DIRECTORY AND TO READ ITS FIRST ; BLOCK INTO THE USR DIRECTORY BUFFER. R5 SHOULD POINT TO THE ; DEVICE NAME IN RAD50 FOLLOWED BY A ZERO WORD. THE DEVICE ; IS THEN OPENNED ON CHANNEL 0 AS A NON FILE STRUCTURED ; DEVICE, ALLOWING READING OF ABSOLUTE BLOCKS. GETDIR ; WILL SET CHKEY TO THE INDEX OF THE DEVICE WHO'S DIRECTORY ; IS BEING EXAMINED. THE REMAINING FUNCTIONS OF GETDIR ARE ; THE SAME AS THOSE OF RDDIR. ; RDDIR IS USED TO READ SUCCESSIVE DIRECTORY BLOCKS. IT ; WILL UPDATE BLKEY TO REFLECT THE ABSOLUTE BLOCK NUMBER ; OF THE DIRECTORY BLOCK CURRENTLY IN THE USR'S BUFFER. ; THIS PREVENTS UNECCESSARY DIRECTORY READS IN THE USR. ; GETDIR AND RDDIR ALSO EXAMINE THE TWO KEYS (BLKEY ; AND CHKEY) BEFORE READING TO DETERMINE IF THE BLOCK ; DESIRED IS ALREADY IN CORE. ; UPON EXIT R5 POINTS TO THE FIRST ENTRY OF THE CURRENT ; DIRECTORY BLOCK, R0 CONTAINS THE ABSOLUTE BLOCK NUMBER OF ; THE NEXT DIRECTORY BLOCK (0 MEANS THIS IS THE LAST), AND ; XTRABY CONTAINS THE NUMBER OF EXTRA BYTES IN EACH ; DIRECTORY ENTRY. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GETDIR: JSR PC,LOCK ;LOCK USR IN CORE MOV #NOP,RDDIR ;INITIALIZE CONDITIONAL BRANCH MOV R5,R0 ;POINT TO DEVICE NAME JSR PC,MTCA ;AND IF MT OR CA BR MCDIR ;GO DO SPECIAL DIRECTORY PROCESS JSR PC,OPNDIR ;ELSE, OPEN THE DIRECTORY .REOPEN 0 ;ON CHANNEL 0 MOV #1,R0 ;READ FIRST DIRECTORY BLOCK RDDIR: NOP ;EITHER NOP OR BR TO MTCT CODE MOV (PC)+,R5 ;USE THE USR DIRECTORY BUFFER USRBUF: 0 ;POINTER TO RMON-USRSIZ CMP R0,@BLKEY ;IS THIS BLOCK ALREADY HERE ?? BEQ DIRIN ;YES, DON'T READ AGAIN REDDIR: MOV R0,-(SP) ;SAVE BLOCK NUMBER ASL R0 ;MAKE IT AN ABSOLUTE BLOCK NUMBER ADD #DIRBLK-2,R0 .READW 0,R5,#512. ;READ 2 BLOCKS INTO USRBUF BCS BADDIR ;ERROR READING DIRECTORY CMP 4(R5),#37 ;THIS ISNT A SURE TEST BHI ILGER MOV (SP)+,@(PC)+ ;SAVE BLOCK NUMBER IN USER BLKEY: 0 DIRIN: TST (R5)+ ;SKIP NBLOCKS MOV (R5)+,R0 ;POINTER TO NEXT DIR BLOCK TST (R5)+ ;SKIP HIGHEST SEGMENT NUMBER MOV (R5)+,XTRABY ;GET EXTRA WORD COUNT TST (R5)+ ;SKIP FILE BEGINNING BLOCK RTS PC BADDIR: ERROR ILGER: ERROR .SBTTL MCDIR ;MCDIR READS AN MT OR CT DIRECTORY. ;WHEN ENTERED THROUGH MCDIR IT REWINDS THE VOLUME READS ITS 1ST LABEL ;AND RETURNS AN ENTRY IN USRBUF SIMILAR TO THOSE IN THE DIRECTORY OF A FILE ;STRUCTURED DEVICE. ON SUBSEQUENT CALLS TO MCDIRR IT READS AND RETURNS THE NEXT LABEL ;IT ENCOUNTERS. WHEN IT REACHES LEOT OR PEOT IT RETURNS AN END-OF- ;DIRECTORY ENTRY. MCDIR: MOV #MCDIRR-RDDIR/2+377,RDDIR ;NEXT RDDIR BR'S DOWN CLR 2(R5) ;NON-FILE LOOKUP TO OPEN CHANNEL .LOOKUP 0,R5 .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC BCS BADDIR JSR R5,SPFUN ;REWIND BEFORE DIRECTORY .BYTE 377,-5 JSR PC,SKPVL1 ;SKIP VOL1 IF MT MCDIRR: MOV R1,-(SP) ;SAVE R1 MOV R4,-(SP) ;AND R4 MOV USRBUF,R5 ;POINT R5 TO INPUT BUFFER FOR READS MOV R5,R4 ;USE 2ND HALF OF BUFFER FOR DIRECTORY ADD #1000,R4 .IF NDF MBUILD CMPB DEVINF,#CTIDEN ;IF CT, BEQ CTDIR ;GO DO A CT DIRECTORY .ENDC RDHDR1: CLR R0 ;BLOCK # IS 0 .READW 0,R5,#40. ;READ THE NEXT BLOCK (HDR1) ;### BDIR1: BCS REWDIR CMP (R5),#HDR1 ;IS THIS A HDR1? BNE DUNMCD ;IF NOT,WE MUST HAVE LEOT CMP (R5)+,(R5)+ ;POINT R5 TO NAME JSR PC,ASCR50 ;GET NAME FROM ASCII TO RAD50 DUNNAM: JSR R5,SPFUN ;SPACE TO EOF1 LABEL .BYTE 377,-2 ;(FORWSP CODE) BCS REWDIR JSR R5,SPFUN .BYTE 377,-2 ;(FORWSP CODE) BCS REWDIR MOV USRBUF,R5 ;POINT TO INPUT BUFFER AGAIN CLR R0 ;BLOCK # IS 0 .READW 0,R5,#40. ;READ THE EOF1 LABEL ;### BCS REWDIR CMP (R5),#EOF1 ;IF EOF1 NOT READ, BNE ENDSEG ;ASSUME BTE CAUSED LACK OF EOF1 AND ;IGNORE ITS CONTENTS OKEOF: ADD #74,R5 ;POINT R5 TO 1ST DIGIT OF BLOCK COUNT JSR PC,ASCOCT ;CHANGE 6 DIGITS OF ASCII TO OCTAL IN (R4) MOV (R4)+,(R4)+ ;COPY COUNT INTO NEXT WORD, TOO SUB #11,R5 ;POINT R5 TO FIRST YEAR DIGIT JSR PC,ASCOCT ;GET BIN FOR YEAR IN (R4) SUB #110,(R4) ;YEAR-72(10) MOV (R4),(PC)+ ;SAVE YEAR YEAR: 0 MOV #28.,FEB ;INIT MONTH TABLE FOR NORMAL YEAR ROR (R4) ROR (R4) ;IF BOTH LOW ORDER BITS=0,THEN LEAP YEAR BCS 1$ ;BRANCH IF NOT LEAP BMI 1$ ;BRANCH IF NOT LEAP INC FEB ;FEBRUARY HAS 29 DAYS THIS YEAR 1$: CMPB (R5)+,(R5)+ ;BUMP R5 BY 2 CLRB (R5) ;MARK END OF DATE FIELD ADD #4,R5 ;POINT R5 TO FIRST DIGIT OF DAY JSR PC,ASCOCT ;BINARY FOR DAYS IN @R4 MOV #MONTAB,R1 ;R1 POINTS TO MONTH TABLE 2$: SUB (R1)+,(R4) ;SUB THIS MONTHS DAYS FROM TOTAL BGT 2$ ;IF MORE LEFT,CONTINUE ADD -(R1),(R4) ;ON OVERFLOW,BACK UP ONE MO SUB #MONTAB,R1 ;(MONTH*2)-2 IN R1 CMPB (R1)+,(R1)+ ;ADD 2 TO MAKE MONTH*2 ASL R1 ASL R1 ASL R1 ;SLIDE MO OVER ASL R1 ADD R1,(R4) ;COMBINE MO AND DAY ASL (R4) ASL (R4) ASL (R4) ;SLIDE MO AND DAY OVER ASL (R4) ASL (R4) ADD YEAR,(R4)+ ;COMBINE YEAR;RT-11 DATE NOW @R4 JSR R5,SPFUN ;SPACE TO NEXT HDR1 .BYTE 377,-2 ;(FORWSP CODE) BCSDIR: BCS REWDIR BR ENDSEG ;ELSE, END THIS SEGMENT DUNMCD: JSR R5,SPFUN ;ON DONE,REWIND TO BEGINNING OF TAPE .BYTE 377,-5 ;(REWIND CODE) JSR PC,SKPVL1 ;IF MT,FSPACE OVER VOL1 ENDIR: CLR R0 ;WHEN DONE, SET R0 TO NO MORE DIRECTORY ENDSEG: MOV #DIREOB,(R4)+ ;SET END OF SEGMENT MARKER MOV USRBUF,R5 ;POINT R5 TO DIRECTORY ADD #1000,R5 CLR XTRABY ;SAY NO EXTRA WORDS MOV (SP)+,R4 ;RESTORE R4 MOV (SP)+,R1 ;RESTORE R1 RTS PC ;AND RETURN REWDIR: JSR R5,SPFUN ;ON ERROR, REWIND TO GET KNOWN POSITION .BYTE 377,-5 ;(REWIND CODE) JSR PC,SKPVL1 ;IF MT,FSPACE OVER VOL1 JMP BADDIR ;AND TAKE ERROR EXIT .IF NDF MBUILD ;CTDIR CONVERT THE LABELS ON A CASSETTE TO DIRECTORY FORMAT CTDIR: CLR R0 ;BLOCK # TO 0 .READW 0,R5,#20 ;READ THE FIRST LABEL INTO BUFFER BCS REWDIR TSTB (R5) ;IF NULL NAME, BEQ DUNMCD ;SENTINAL FILE, DONE TSTB 14(R5) ;IS SEQUENCE NUMBER 0? BEQ 3$ ;YES-CONTINUE TST DIRFLG ;NO-IS A DIRECTORY LISTING IN PROGRESS? BNE 3$ ;YES-CONTINUE JSR R5,SPFUN ;OTHERWISE,IGNORE THIS FILE .BYTE 377,-3 ;SPACE TO NEXT FILE BCS DUNMCD ;ASSUME ERROR IS EOT BR CTDIR ;TRY NEXT FILE 3$: JSR PC,ASCR50 ;ELSE, GET NAME INTO DIRECTORY ADD #3,R5 ;POINT TO SEQ NO BIC #177400,(R5) ;STRIP LEVEL IDENTIFIER MOV (R5)+,(R4)+ ;INSERT SEQ NO. BYTE AS BLOCK COUNT CLR (R4)+ ;0 DATA LENGTH CMPB (R5),#60 ;IS THERE A DATE THERE BGE 1$ ;YES CLR (R4) ;NO:ZERO DATE WORD IN DIRECT BR 2$ 1$: ADD #5,R5 ;POINT R5 TO NEXT TO LAST BYTE OF DATE JSR PC,ASCOCT ;CONVERT 5 DIGITS OF DATE TO BINARY EQUIVALENT 2$: MOV (R4),R1 ;SAVE THIS VALUE IN R1 BEQ NULDAT ;NO DATE HERE CLR (R4) ;CLEAR DATE MOV USRBUF,R5 MOVB 23(R5),(R4) ;PUT IN LAST DIGIT OF DATE FROM LABEL SUB #60,(R4) ;LESS ITS ASCII PART MOV #TENTH,R5 ;PT. R5 TO TABLE OF DECIMAL VALUES MOV #OCTH,R0 ;PT. R0 TO TABLE OF OCTAL VALUES ;THE THREE VALUES IN THE DECIMAL TABLE CORRESPOND TO THE 3 PLACES IN THE ;ORIGINAL DECIMAL DATE WHERE MONTH, DAY, AND YEAR BEGIN. ;THE THREE VALUES IN THE OCTAL TABLE PT. TO THE BITS WHERE ;THE DAY, MONTH, AND YEAR START IN THE RT11 FORMATTED DATE. SUBDAY: SUB (R5),R1 ;SUBTRACT CURRENT TEN VALUE FROM DEC. DATE BLT DUNDAY ;IF DATE GOES <0, THIS PART OF DATE DONE ADD (R0),(R4) ;ELSE, ADD CURRENT OCTAL TO RT11 DATE BR SUBDAY ;AND GO SUBTRACT AGAIN DUNDAY: ADD (R5),R1 ;WHEN VALUE GOES <0, ADD BACK THE LAST SUB CMP -(R5),-(R5) ;THEN PT R5 TO NEXT TEN VALUE (THIS ONE/1000) TST -(R0) ;AND R0 TO NEXT OCTAL BGT SUBDAY ;IF NOT END OF OCTAL LIST (A 0), DO NEXT PART SUB #110,(R4) ;RT11 USES DATE-110 NULDAT: TST (R4)+ ;POP R4 TO NEXT ENTYR JSR R5,SPFUN ;SPACE TO NEXT FILE .BYTE 377,-3 ;(NEXTFILE CODE) BCS DUNMCD ;ON ERR ASSUME PHYSICAL EOT BR ENDSEG ;ELSE, END THIS SEGMENT .ENDC ;SPFUN EXECUTES THE SPECIAL FUNCTION WHOSE CODE FOLLOWS THE SUBROUTINE ;CALL. IT DOES SO BY SETTING UP THE LIST AND EXECUTING EMT 375. ;SPFUN SETS THE WCOUNT TO 0,SPFUN1 SETS IT TO -1 SPFUN1: MOV #1,-(SP) ;WC TO 1 BR SPFUN2 SPFUN: CLR -(SP) ;WC TO 0 SPFUN2: MOV #LIST,R0 ;PT R0 TO LIST MOV #32*400+0,(R0) ;LOAD SPECIAL FUNC. CODE, CHANNEL 17 MOV (R5)+,10(R0) ;GET CODE INTO 5TH WORD MOV (SP)+,6(R0) ;SET UP WC MOV R0,-(SP) ;SAVE R0 (IT GETS ZEROED) EMT 375 ;THEN DO IT MOV (SP)+,R0 ;GET R0 BACK RTS R5 ;AND GO BACK ;ASCR50 DETERMINES THE TYPE OF ENTRY, NULL OR GOOD, BY THE FIRST LETTER ;OF THE FILE NAME POINTED TO BY R5 AND INSERTS THIS INFORMATION AS THE ;STATUS OF THIS DIRECTORY ENTRY IN THE SLOT POINTED TO BY R4 ;THEN IT CONVERTS THE ASCII STRING POINTED TO BY R5 TO 3 RAD50 WORDS ;IN THE SPACE POINTED TO BY R4. ;### ASCR50 WILL IGNORE A '.' (DOT) IN COLUMN 7 OF THE ASCII FILENAME ;AND EXTENSION STRING, SINCE THE MT HANDLER PUTS ONE THERE FOR EASE ;OF TRANSFERABILITY TO RSX ASCR50 WILL ALSO MAKE FILENAMES ;LIKE 'ABC.DAT' ON MAGTAPE (OR CASSETTE) LOOK LIKE PROPER RT ;FILENAMES ON THE DIR LISTING. B.C. ;### ASCR50: MOV #DIREMP,R0 ;SET EMPTY IF NON-NULL NAME CMPB (R5),#RUBOUT ;DELETED FILES START WITH RUBOUT BEQ NULNAM CMPB (R5),#ASTRSK ;DELETED FILES ALSO START WITH * BEQ NULNAM ASL R0 ;TYPE 4 FOR GOOD NAME NULNAM: MOV R0,(R4)+ ;INSERT TYPE AS STATUS OF THIS ENTRY MOV #9.,(PC)+ ;COUNT 9 CHARACTERS CTR: .WORD 0 NXTCAR: MOVB (R5)+,R0 ;GET CHAR INTO R0 CMPB #'.,R0 ;IS CHAR A DOT? ;### BNE R50PAK ;IF NE-NO ;### CMP CTR,#3 ;IS THIS CHAR POS 7? ;### BLO R50PAK ;IF PAST 7, TREAT DOT AS DOT ;### BEQ NXTCAR ;IF AT POS. 7 JUST IGNORE DOT ;### MOV #40,R0 ;IF BEFORE 7, MAKE DOT A SPACE ;### DEC R5 ;AND ADJ PTR TO PAD FILNAM W/SPACES ;### R50PAK: DEC (PC)+ ;COUNT DOWN FROM 3 R50CTR: .WORD 0 BGT 1$ ;SPACE LEFT, SO GO *50 CLR (R4)+ ;CLEAR THE NEXT WORD MOV #3,R50CTR ;RESET COUNT 1$: SUB #72,R0 ;CHECK FOR DIGIT ADD #12,R0 BCC 2$ ;NO, GO TRY FOR LETTER ADD #36,R0 ;SCALE DIGIT BR 4$ 2$: SUB #20,R0 ;REDUCE TO LETTER RANGE BLE 3$ ;DELIMITER! CMP R0,#32 ;A TO Z? BLE 4$ ;GOT IT SUB #40,R0 ;MAY AS WELL TRY LOWER CASE BGT 2$ 3$: CLR R0 ;(DELIMITER)-CALL IT A SPACE ;### 4$: ASL -(R4) ;*50+CHAR ASL @R4 ASL @R4 ADD @R4,R0 ASL @R4 ASL @R4 ADD R0,(R4)+ ;KEEP POINTING PAST IT DEC CTR ;COUNT THIS CHARACTER BGT NXTCAR ;IF MORE LEFT, GET NEXT CHAR DDUN: RTS PC ;ASCOCT CONVERTS THE 6 DIGITS POINTED TO BY R5 FROM ASCII DECIMAL TO ;OCTAL IN THE WORD POINTED TO BY R4. ;IT DOES THIS BY GOING THROUGH EACH DIGIT OF THE VALUE ADDING TO ;THE COUNT THE CORRESPONDING BINARY EQUIVALENT OF THAT PLACE ENOUGH ;TIMES TO SEND THAT DIGIT TO 0. ASCOCT: MOV #TENS,R0 ;POINT R0 TO DEC. EQUIVALENTS CLR (R4) ;CLEAR BLOCK COUNT IN DIRECTORY DIG: MOVB -(R5),R1 ;GET ASCII/DECIMAL DIGIT NOTZER: SUB #60,R1 ;RID ASCII BLT DDUN ;THEN FINAL BLANK(MT) OR 0(CT) GOES <0 DDEC: BEQ NDIG ;WHEN DIGIT REACHES 0, GO TO NEXT ADD (R0),(R4) ;ELSE, ADD EQUIVALENT TO COUNT DEC R1 ;AND KNOCK DIGIT DOWN ONE BR DDEC NDIG: TST (R0)+ ;WHEN DIGIT DONE, PT TO NEXT TENS BR DIG ;AND DO NEXT HIGHER DIGIT ;LIST FOR V2 EMT'S LIST: .WORD 0 ;CODE/CHANNEL FFILE: .WORD 0 ;FILE NAME OR SPECIAL FUNCTION BLOCK FLEN: .WORD 0 ;LENGTH FOR ENTER, BLOCK FOR DELETE AND LOOKUP, BUFFER FOR SPECIAL FUNCTION FBLOCK: .WORD 0 ;BLOCK FOR ENTER, WC FOR SPECIAL FUNCTION FWC: .WORD 0 ;FUNCTION CODE FOR SPECIAL FUNCTION FCONT: .WORD 0 ;CONTINUATION ADDR.(NOT USED) .WORD 0 ;USED BY SPFUNC CALL ;THE FOLLOWING TABLE CONTAINS OCTAL EQUIVALENTS OF DECIMAL POWERS OF ;TEN. .WORD 1 ;KLUDGEY WORD FOR DATE CONVERSION TENS: .WORD 1 ;1. .WORD 12 ;10. .WORD 144 ;100. TENTH: .WORD 1750 ;1000. .WORD 23420 ;10000. .WORD 0 ;100000. (TOO BIG FOR 16 BITS) ;THE TABLE BELOW POINTS TO THE BITS IN THE RT11 FORMAT DATE WHERE ;MONTH, YEAR, AND DAY BEGIN. .WORD 12 ;POINTER TO YEAR PLACE*10 .WORD 2000 ;POINTER TO MONTH PLACE OCTH: .WORD 40 ;POINTER TO DAY PLACE ;THE FOLLOWING MONTH TAVLE IS USED TO CONVERT JULIAN MAGTAPE DATES ;TO RT-11 FORMAT MONTAB: 31. ;JAN FEB: 28. ;FEB 31. ;MAR 30. ;APR 31. ;MAY 30. ;JUN 31. ;JUL 31. ;AUG 30. ;SEP 31. ;OCT 30. ;NOV 31. ;DEC .SBTTL OPNDIR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; OPNDIR WILL OPEN THE DEVICE SPECIFIED BY THE STRING ; POINTED TO BY R5 ON CHANNEL 17 AND SET UP THE RMON ; CHANNEL CONTROL WORD CHKEY. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; OPNDIR: JSR PC,LOCK ;LOCK USR IN CORE CLR 2(R5) ;DO A NON-FILE-STRUCTURED LOOKUP .LOOKUP 16,R5 ;LOOKUP THE FILE (OPEN NON-STRUCT) .IF DF MBUILD JSR PC,FATERR ;CHECK TO SEE IF FATAL ERROR .ENDC BCS BADJMP ;ERROR LOOKING UP DIRECTORY .DSTATU #DEVINF,R5 ;FIND OUT WHAT KIND OF DEVICE TST DEVINF ;WELL, IS IT FILE STRUCTURED? SEC ;SET C FOR BRANCH VECTOR BPL BADJMP ;NOT A DIRECTORY DEVICE .SAVEST 16,#SSB ;SAVE THE STATUS OF THE DEVICE MOV #SSB,R0 ;RESTORE THAT POINTER (CALLER EXPECTS IT!) MOV 10(R0),-(SP) ;GET INDEX AND POINTER FOR CHKEY MOVB (R0),(SP) BIC #301,(SP) CMP (SP),@CHKEY ;IS IT THE SAME AS CURRENTLY ?? BEQ 1$ ;YES, MAYBE NO READ NEEDED CLR @BLKEY ;NO, CAN'T AVOID A READ 1$: MOV (SP)+,@(PC)+ ;PUT IN NEW CHANNEL KEY CHKEY: 0 ;POINTER TO RMON+206 RTS PC BADJMP: JMP BADDIR ;ERROR VECTOR .SBTTL WRDIR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; WRDIR WILL WRITE OUT THE DIRECTORY CURRENTLY IN THE USR'S ; DIRECTORY BUFFER ONTO THE DEVICE SPECIFIED BY CHKEY AT ; THE BLOCK SPECIFIED BY BLKEY USING CHANNEL OUCHAN. ; DIRWR WILL WRITE OUT THE DIRECTORY SEGMENT SPECIFIED BY R0. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WRDIR: MOV @BLKEY,R0 ;BLOCK NUMBER OF DIR BLOCK IN CORE DIRWR: ASL R0 ;MAKE IT AN ABSOLUTE BLOCK NUMBER ADD #DIRBLK-2,R0 CLR -(SP) ;WAIT I/O MOV #1000,-(SP) ;TWO BLOCKS MOV USRBUF,-(SP) ;FROM THE USR BUFFER MOV OUCHAN,1$ ;GET THE OUTPUT CHANNEL NUMBER ADD (PC)+,(PC) ;ADD IN THE .WRITE IMAGE .WRITE 1 1$: 0 ;AND EXECUTE THE WRITE BCC GDRTS ;OK ERRWRD: ERROR ;SUPER BAD ERROR .SBTTL MAKEMT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; MAKEMT WILL CREATE AN EMPTY ENTRY IN THE DIRECTORY AT ; THE PLACE POINTED TO BY R4 USING R1 AS THE SIZE IN ; BLOCKS. R4 IS THEN BUMPED TO POINT TO THE START OF THE NEXT ; DIRECTORY ENTRY. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAKEMT: MOV #DIREMP,(R4) ;CREATE AN EMPTY ENTRY MOV R1,10(R4) ;SIZE OF EMPTY IS PREVIOUS UNUSED CLR R1 ;NO MORE UNUSED AT THIS POINT ADD #DIRESZ,R4 ;BUMP NEW DIRECTORY POINTER ADD XTRABY,R4 ;PAST THIS ENTRY GDRTS: RTS PC .SBTTL CONV ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; CONV WILL CONVERT THE NUMBER IN R0 TO A DIGIT STRING ; USING RADIX. THE RESULTING STRING OF DIGITS (LESS ; LEADING ZEROES WILL BE POINTED TO BY R1, WITH A NEGATIVE ; BYTE TO INDICATE THE END OF STRING. R3 MAY BE SET TO THE ; DESIRED FIELD WIDTH, IN WHICH CASE CONV WILL OUTPUT (VIA ; DIRLST) SUFFICIENT BLANKS TO RIGHT JUSTIFY THE DIGITS ; IN THAT FIELD. R4 IS USED AS A TEMPORARY. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CONV: MOV #DIGITS,R1 ;POINTER TO DIGITS OUTPUT AREA MOV R4,-(SP) ;PRESERVE R4 CNVLUP: CLR R4 ;CLEAR REMAINDER WORD MOV #17,-(SP) ;SET BIT COUNT DIVLUP: ASL R0 ;SHIFT DIVIDEND-QUOTIENT REG ROL R4 ;SHIFT REMAINDER REG CMP R4,RADIX ;BIG ENOUGH TO SUBTRACT ?? BLO NOFIT ;NO SUB (PC)+,R4 ;SUBTRACT DIVISOR RADIX: 0 INC R0 ;SET CORRESPONDING BIT IN QUOTIENT NOFIT: DEC (SP) ;ANY MORE BITS ?? BPL DIVLUP ;YES MOVB R4,-(R1) ;SAVE REMAINDER AS RIGHTMOST DIGIT ADD (SP)+,R3 ;DECREMENT DIGIT COUNT TST R0 ;ANYTHING LEFT ?? BNE CNVLUP ;YES, KEEP DIVIDING BLFILL: DEC R3 ;ENOUGH CHARACTERS ?? BMI 2$ ;YES, RETURN MOV #' ,R0 ;NO, PUT OUT ANOTHER BLANK JSR PC,DIRLST BR BLFILL 2$: MOV (SP)+,R4 ;RESTORE R4 DONE: RTS PC .NLIST BEX .BYTE 0,0,0,0,0,0,0 DIGITS: .BYTE 377 .LIST BEX .SBTTL R10OUT AND R10OVT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; R10OUT WILL OUTPUT THE NUMBER IN R0 IN DECIMAL VIA DIRLST, ; WITH A FIELD WIDTH OF 2. R10OVT WILL USE A FIELD WIDTH OF 4. ; BOTH ROUTINES USE CONV. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; R10OVT: MOV #4,R3 ;PRINT 4 DIGIT FIELD BR R10CNV R10OUT: MOV #2,R3 ;STANDARD IS 2 DIGITS R10CNV: MOV #10.,RADIX ;SET RADIX TO 10. R810: JSR PC,CONV ;CONVERT THE NUMBER 1$: MOVB (R1)+,R0 ;GET NEXT DIGIT BMI DONE ;NEGATIVE IS INDICATOR ADD #'0,R0 ;MAKE ITT ASCII JSR PC,DIRLST ;PRINT ON DIRECTORY LISTING FILE BR 1$ ;DO NEXT DIGIT .IF NDF MBUILD R8OUT: MOV #7,R3 ;OCTAL FIELDS ARE 7 LONG MOV #10,RADIX BR R810 .ENDC .SBTTL R50OUT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; R50OUT WILL OUTPUT (VIA DIRLST) THE WORD IN R0 AS THREE ; RADIX 50 CHARACTERS. SPACES ARE PRINTED FOR 0,33,34,35. ; R50OUT USES CONV. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; FNAML: JSR PC,R50WD ;FIRST 3 CHARS JSR PC,R50WD ;NEXT 3 MOV #' ,R0 ;PREPARE TO PRINT . OR BLANK TST (R5) ;IS EXTENSION NON-BLANK ?? BEQ 1$ MOV #'.,R0 ;NO, PUT OUT DOT FIRST 1$: JSR PC,DIRLST ;PRINT IT R50WD: MOV (R5)+,R0 ;GET THE RAD50 WORD R50OUT: MOV R3,-(SP) ;PRESERVES R3, R1 MOV R1,-(SP) MOV #3,R3 ;OUTPUT THREE CHARS ALWAYS MOV #50,RADIX ;SET RADIX TO 50 JSR PC,CONV ;CONVERT FROM RAD 50 1$: MOVB (R1)+,R0 ;GET NEXT CHARACTER BMI 5$ ;MINUS IS INDICATOR CHARACTER BEQ 2$ ;ZERO IS A BLANK CMP R0,#32 ;IS IT A LETTER (1-32) ?? BLE 3$ ;YES SUB #36,R0 ;IS IT A DIGIT (36-47) ?? BCC 4$ ;YES 2$: MOV #-40,R0 ;PRINT A SPACE FOR 0,33,34,35 3$: ADD #20,R0 ;CONVERT FROM (1-32) TO (101-132) 4$: ADD #60,R0 ;CONVERT FROM (36-47) TO (60-71) JSR PC,DIRLST ;OUTPUT THE CHAR BR 1$ 5$: MOV (SP)+,R1 MOV (SP)+,R3 RTS PC .SBTTL YESCHK ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; YESCHK GETS A FULL LINE FROM THE TTY ; IT RETURNS CC EQUAL IF THE FIRST CHAR WAS "Y" ; OTHERWISE CC NONEQUAL ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; YESCHK: .TTYIN ;READ CHARACTER FROM TT: MOV R0,-(SP) ;SAVE THE RESPONSE CHARACTER 1$: .TTYIN ;GET NEXT TT: CHARACTER CMP R0,#12 ;IS IT A LINE FEED ?? BNE 1$ ;NO, KEEP SKIPPING CMP (SP)+,#'Y ;WAS RESPONSE "Y......" ?? RTS PC .SBTTL PUTMSG AND CRLF ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; PUTMSG WILL OUTPUT A TEXT STRING VIA DIRLST. THE CALL IS : ; JSR R3,PUTMSG ; .ASCIZ "TEXT OF MESSAGE" ; .EVEN ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MSGLUP: JSR PC,DIRLST ;PRINT ODD CHAR MOVB (R3)+,R0 ;GET ODD CHAR BEQ MSGDUN ;IF ZERO, END OF MESSAGE JSR PC,DIRLST ;PRINT EVEN CHARACTER PUTMSG: MOVB (R3)+,R0 ;GET EVEN CHAR BNE MSGLUP ;NOT ZERO, GO PRINT IT INC R3 ;EVEN OFF THE RETURN REGISTER MSGDUN: RTS R3 .SBTTL DATOUT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; DATOUT OUTPUTS R3 VIA DIRLST AS A DATE. THE DATE ; WILL ALWAYS OCCUPY 9 CHARACTERS WITH A LEADING BLANK ; INSERTED IF NECESSARY. THE FORMAT IS : 12-SEP-73 ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DATOUT: BIT #36000,R3 ;MAKE SURE DATE IS VALID BEQ DIRRTS ;DON'T PRINT, JUST RETURN 1$: MOV R3,-(SP) ;PUSH RIGHTMOST FIELD OF DATE WORD BIC #177740,(SP) ;ONLY 5 BITS ASR R3 ;SHIFT TO NEXT DATE FIELD ASR R3 ASR R3 ASR R3 ASR R3 BNE 1$ ;MORE FIELDS (DATE CAN'T BE 0) MOV 2(SP),R0 ;GET DAY JSR PC,R10OUT ;OUTPUT 2 DIGITS DECIMAL MOV (SP)+,R3 ;GET MONTH ASL R3 ;TIMES FOUR ASL R3 ADD #MONTHS-4,R3 ;POINTER TO MONTH TABLE MOV #5,(SP) ;OUTPUT MONTH (-XXX-) 2$: MOVB (R3)+,R0 ;GET NEXT CHAR OF MONTH JSR PC,DIRLST ;PRINT IT DEC (SP) ;MORE ?? BNE 2$ ;YES TST (SP)+ ;PURGE COUNTER WORD MOV (SP)+,R0 ;GET YEAR ADD #72.,R0 ;ADD 72 FOR BASE YEAR OF 1973 BR R10OUT ;OUTPUT DECIMAL, R10OUT RETURNS .NLIST BEX MONTHS: .ASCII "-JAN-FEB-MAR-APR-MAY-JUN-JUL-AUG-SEP-OCT-NOV-DEC-" .LIST BEX .EVEN .SBTTL DIRLST ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; DIRLST WILL OUTPUT A CHARACTER TO THE DIRECTORY LISTING ; FILE IF THE SWITCH LISTOF IS 0. A SPECIAL CASE CHECK IS ; MADE FOR THE DEVICE TT: AND THE SYSTEM'S TELETYPE ; HANDLER IS USED DIRECTLY. ; ; ; CRLF WILL OUTPUT A CARRIAGE RETURN LINE FEED VIA DIRLST. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CRLF: MOV #15,R0 ;OUTPUT A CARRIAGE RETURN JSR PC,DIRLST MOV #12,R0 ;THEN A LINE FEED DIRLST: TST (PC)+ ;IS ANY OUTPUT DEVICE GIVEN ?? DIRDES: 0 BNE NOTTT ;YES, ITS NOT TT: .TTYOUT ;IF TT: USE SYSTEM TT: HANDLER DIRRTS: RTS PC NOTTT: .IF NDF MBUILD JMP WRITEC ;WRITE CHARACTER TO DIRLST FILE .IFF JMP HANERR ;ILLEGAL DEVICE .ENDC .SBTTL FGCHK ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; PRINTS "FG PRESENT" ERROR MESSAGE AND RETURNS ; TO START IF A FOREGROUND JOB IS IN CORE. ; USES R0 ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; .ENABL LSB FGCHK: MOV @#SYSPTR,R0 ;START ADDR OF RES IN R0 BIT #FGACTV,CONFIG(R0) ;TEST FG BIT IN CONFIG WORD BEQ 1$ ;RETURN IF NO FG AROUND ERROR .SBTTL LOCK AND UNLOCK ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; LOCK SERVES TO ASSURE THAT PIP HAS POSSESSION OF THE USR ; BEFORE IT USES THE USR BUFFER FOR DIRECTORY EXAMINATION. ; UNLOCK SERVES TO RELEASE CONTROL SO THE FOREGROUND CAN GET ; TO USR AGAIN WHEN PIP IS DONE WITH IT. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LOCK: TST (PC)+ ;USR IN CORE ALREADY? LOCKF: 0 BNE 1$ ;YES INC LOCKF ;NO-SET FLAG AS WE ARE ABOUT TO GET IT .LOCK ;PULL USR IN CORE 1$: RTS PC UNLOCK: TST LOCKF ;USR IN CORE? BEQ 2$ ;NO-NO NEED TO DO ANYTHING CLR LOCKF ;YES-WE ARE GOING TO KICK IT OUT .IF NDF MBUILD CLR @(PC)+ ;RE-ENABLE CTRL/C'S NOCTLC: 0 ;POINTER TO RMON+212 .ENDC .UNLOCK ;BOOT USR OUT 2$: RTS PC .DSABL LSB .IF DF MBUILD .SBTTL FATAL ERROR AND TRAP HANDLING CODE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; FATERR HANDLES THE FATAL ERROR RETURNS CAUSED BY THE .SERR ; ISSUED WHEN MBUILD STARTS. IT PRINTS AN APPROPRIATE MESSAGE ; IF THE CODE IS MEANINGFUL,ELSE IT LETS NORMAL BCS FOLLOWING ; EMT EXECUTE. IF CODE IS VALID,FATERR RESTARTS MBUILD ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; FATERR: ROR -(SP) ;SAVE CARRY MOVB @#52,R0 ;GET ERROR CODE BMI 1$ ;BRANCH IF FATAL 2$: ROL (SP)+ ;RESTORE CARRY RTS PC ;AND RETURN 1$: NEG R0 ;MAKE ERROR POSITIVE DEC R0 ;ADJUST BY ONE ASL R0 ;TURN ERROR CODE INTO INDEX MOV FATTBL(R0),R0 ;GET ADDRESS OF APPROPRIATE MESSAGE BEQ 2$ ;IF NO MESSAGE,LET ORIGINAL CODE HANDLE IT .PRINT ;PRINT MESSAGE JMP START ;AND RESTART MBUILD FATTBL: 0 M2 M3 0 0 M6 0 0 0 M2: .ASCIZ /?ILL DEV?/ M3: .ASCIZ /?M-DIR IO ERR?/ M6: .ASCIZ /?M-DIR OVFLO?/ .EVEN ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; TRPLOC HANDLES TRAPS TO 4 AND 10 BY PRINTING ERROR MESSAGE ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TRPLOC: MOV R0,-(SP) ;SAVE R0 .PRINT #TRP410 ;PRINT ERROR MESSAGE .TRPSET #TAREA,#TRPLOC ;REISSUE TRPSET MOV (SP)+,R0 ;RESTORE R0 RTI TAREA: .WORD 0,0 TRP410: .ASCIZ /?M-TRAP TO 4 OR 10?/ .EVEN .ENDC .SBTTL STORAGE DECLARATIONS OLNAME: .WORD 0,0,0,0 ;OLD NAME SPACE FOR RENAME NEWNAM: .WORD 0,0,0,0,0 ;NEW NAME SPACE FOR RENAME DEVNAM: .WORD 0,0 ;USED FOR NON FILE STRUCTURED OPEN DEFEXT: .WORD 0,0,0,0 ;DEFAULT EXTENSIONS (ALL BLANK) DEVINF: .BLKW 5 ;DEVICE INFORMATION BLOCK SSB: .BLKW 5 ;SAVE STATUS BLOCK FILDES: .BLKW 47 ;OUTPUT AREA FOR CSI FREE: ;FREE CORE ;HANDLERS ;EXPANDED INPUT LIST ;STATUS BLOCKS FOR INPUT LIST (/X & /R) ;BUFFER(S) .SBTTL INITIALIZATION CODE BEGIN: .IF DF MBUILD .SRESET ;FLUSH ANYTHING ACTIVE .PRINT #VMESAG ;IDENTIFY SELF .SERR ;WE'LL HANDLE ALL ERRORS .TRPSET #TAREA,#TRPLOC ;AND ALL TRAPS .ENDC MOV @#SYSPTR,R2 ;POINTER TO RMON ADD #OFFSET,R2 ;GET ADDRESS OF BLKEY MOV R2,BLKEY TST (R2)+ ;GET ADDRESS OF CHKEY MOV R2,CHKEY CMP (R2)+,(R2)+ .IF NDF MBUILD MOV R2,NOCTLC .IFF MOV SP,@(R2) ;PERMANENTLY DISABLE CTRL C .ENDC TST (R2)+ ;GE ADDRESS OF USR BUFFER POINTER MOV (R2),USRBUF CMP USRBUF,#BEGIN+512. ;WE NEED AT LEAST 1 BLOCK OF BUFFER BHI 1$ ;THERE IS ENOUGH .PRINT #NOCOR ;PRINT FATAL ERROR .EXIT ;AND RETURN TO MONITOR 1$: MOV (R2),R0 ;USR BUFFER IS JUST ABOVE KMON TST -(R0) ;BUFFERS GO UP TO USR .SETTOP ;TEL THE MONITOR ABOUT IT BIS #20000,@#JSW ;SET REENTERABLE BIT MOV #START,@#STRTAD ;SETUP START ADDRESS JMP START ;START PROGRAM NOCOR: .ASCIZ /?OVR COR?/ .IF DF MBUILD VMESAG: .ASCIZ "MBUILD V02-03 " .SBTTL CODE TO WRITE MBUILD CORE IMAGE BR BEGIN ;MBUILD ENTERED AT RE-ENTRY ADDRS ;BY MSBOOT BEGINM: .CSIGEN #FREEM,#DEFEXT,#0 ;GET NAME OF OUTPUT FILE BCS MWERR ;ERROR IN COMMAND STRING MOV #20000,R0 ;WRITE FROM ADRESSES 0-37777 MOV #-1,OUCHAN ;USE CHANNEL 0 (DEFAULT IS 1) JSR PC,WRITE ;WRITE CORE IMAGE ON CHANNEL 0 BCS MWERR ;SOMETHING IS WRONG WITH WRITE .CLOSE 0 ;CLOSE CHANNEL 0 BCS MWERR ;SOMETHING WENT WRPMG MBEXIT: .EXIT ;RETURN TO MONITOR MWERR: .PRINT #OUMES ;PRINT "?OUT ER?" BR MBEXIT ;AND EXIT TO MONITOR FREEM: .ENDC .IF NDF MBUILD .END BEGIN .IFF .END BEGINM .ENDC .IF DF MBUILD .TITLE MBUILD OVERLAY V02-03 .IFF .TITLE PIP OVERLAY V04-06 .ENDC ; RT-11 PIP (PERIPHERAL INTERCHANGE PROGRAM) ; AND ; RT-11 MBUILD (MAGTAPE BUILD PROGRAM ; ; DEC-11-ORPPA-E ; ; COPYRIGHT (C) 1973,1974,1975 ; ; DIGITAL EQUIPMENT CORPORATION ; MAYNARD, MASSACHUSETTS 01754 ; ; THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ; ON A SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY 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 EXCEPT FOR USE ON SUCH SYSTEM AND TO ; ONE WHO AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE ; SOFTWARE SHALL AT ALL TIMES REMAIN IN DIGITAL. ; ; 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 ; WHICH IS NOT SUPPLIED BY DIGITAL. ; ; MAY 2, 1973 ; ; HANK MAURER ; LOUISE GERHART ; ANTON CHERNOFF ; JUNE 25, 1974 ; ; BOB FRIEDENTHAL ; ; NOVEMBER 1974,JANUARY 1975,AUGUST 1975 ; ; BOB BEAN ; ; .SBTTL MACRO DEFINITIONS .MCALL ..V1.. .MCALL .CLOSE, .CSISPC,.DELETE,.DSTATU,.FETCH, .HRESET .MCALL .LOOKUP,.PRINT, .RCTRLO,.RENAME,.REOPEN,.SAVEST .MCALL .SETTOP,.SRESET,.TTYIN, .TTYOUT,.UNLOCK,.LOCK .MCALL .READW, .WAIT, .DATE, .WRITW, .EXIT, .REGDEF .MCALL .CSIGEN,.SERR ,.TRPSET,...CM1,...CM2,...CM3 ..V1.. ;USE V1 MACRO FORMAT .REGDEF ;DEFINE REGISTERS .MACRO MESSAGE TEXT JSR R3,PUTMSG .ASCIZ TEXT .EVEN .ENDM MESSAGE .MACRO ERROR TEXT JSR R0,MSG .ASCIZ "?TEXT?" .EVEN .ENDM ERROR .MACRO SWITCH CHAR,ADR,MODE,VALUE .BYTE ''CHAR,MODE .IF B VALUE .WORD 0 .IFF VALUE: .WORD 0 .ENDC .IF EQ MODE .WORD ADR-COPY .IFF ADR: .WORD 0 .ENDC .ENDM SWITCH ;THE FOLLOWING MONITOR FEATURES ARE USED IN NON-STANDARD CALLS ; HENCE, THE USUAL MACROS ARE NOT USED .MACRO .ENTER CH EMT 40+CH .ENDM .ENTER .MACRO .READ CH EMT 200+CH .ENDM .READ .MACRO .WRITE CH EMT 220+CH .ENDM .WRITE ;SYMBOL DEFINITIONS NLIMIT = 37 ;MAX # OF DIRECTORY SEGMENTS ALLOWED STRTAD = 40 ;USER PROGRAM START ADDRESS JSW = 44 ;JOB STATUS WORD EMTERR = 52 ;RT-11 ERROR RETURN WORD SYSPTR = 54 ;POINTER TO RT-11 RESIDENT DIRBLK = 6 ;STARTING BLOCK OF DIRECTORIES OFFSET = 256 ;OFFSET TO VITAL RMON WORDS ;OFFSET IS DIFF OF BLKEY AND $RMON SYSUNT = 275 ;OFFSET TO SYSTEM DEVICE UNIT # CONFIG = 300 ;OFFSET TO CONFIG WORD R50STAR = 132500 ;* IN RADIZ 50 (FROM CSI) DIREOB = 4000 ;DIRECTORY BIT SAYING END OF BLOCK DIRPRM = 2000 ;BIT SAYING PERMANENT FILE DIREMP = 1000 ;BIT SAYING EMPTY ENTRY DIRESZ = 16 ;SIZE OF 1 ENTRY (+ XTRABY) FGACTV = 200 ;BIT IN CONFIG SAYING FG ACTIVE CSWEOF = 20000 ;EOF BIT IN CSW HDR1 = 42110 ;ASCII H,D EOF1 = 47505 ;ASCII E,O RXCS = 177170 ;ADDRESS OF RX11 CONTROL/STATUS REGISTER .IF NDF MBUSSC RSCS2 = 172050 ;ADDRESS OF RH11/RJS03/4 CONT REG 2 .ENDC .IF DF MBUSSC RSCS2 = 176310 ;ADDRESS OF RH11/RJS03/4 CR2 .ENDC ;DEVICE IDENTIFICATION CODES IN $STAT RKIDEN=0 ;RK11/RK05,RK03 DTIDEN=1 ;TC11/TU56 TMIDEN=11 ;TM11/TU10/TSO3 RFIDEN=12 ;RF11/RS11 CTIDEN=13 ;TA11/TU60 RJIDEN=16 ;RJS03/4 TJIDEN=20 ;TJU16 DPIDEN=21 ;RP11/RP02,RP03 DXIDEN=22 ;RX11/RX01 ;ASCII CHARACTERS RUBOUT=377 ;RUBOUT ASTRSK=52 ;ASTERISK .GLOBL ILLCMD,FGCHK,DEVINF,SSB,HANERR,REBOT,FILDES .SBTTL REBOOT ; ; THIS CODE REBOOTS THE SYSTEM FROM ANY OF THE DEVICES ; SPECIFIED IN THE TABLE AT BOOTDV. THE COMMAND IS ANALYZED,THE ; DEVICE IS LOOKED UP IN THE TABLE,AND IF FOUND,THE CORRESPONDING ; ROUTINE IN THE TABLE AT BOOTAD IS ENTERED TO PEFORM THE BOOT ; ;BOOTDV-TABLE OF DEVICE CODES WHICH LISTS DEVICES FROM WHICH RT-11 ;CAN BE BOOTED. THIS TABLE IS ORDERED TO CORRESPOND WITH THE ;TABLE BOOTAD,WHICH CONTAINS THE ADDRESSES OF THE CORRESPONDING ;BOOTSTRAP ROUTINE FOR EACH DEVICE. BOOTDV: .IF NDF MBUILD .BYTE DTIDEN ;TC11/TU56 DECTAPE .BYTE DXIDEN ;RX11/RX01 FLOPPY DISK .ENDC .BYTE RFIDEN ;RF11/RS11 FIXED HEAD DISK .BYTE DPIDEN ;RP11/RP02,RP03 DISK CARTRIDGE .BYTE RKIDEN ;RK11/RK05,RK03 DECPACK DISK .BYTE RJIDEN ;RH11/RJSO3/4 FIXED HEAD DISK BDVEND: .EVEN ;END OF TABLE ;BOOTAD-TABLE OF ADDRESSES FOR BOOTSRAP ROUTINES FOR EACH OF THE ;DEVICES SPECIFIED IN BOOTDV. INDEX OF DEVICE IN BOOTDV IS ;USED AS INDEX INTO THIS JUMP TABLE. BOOTAD: .IF NDF MBUILD DTBOOT ;TC11 DXBOOT ;RX11 .ENDC RFBOOT ;RF11 DPBOOT ;RP11 RKBOOT ;RK11 RJBOOT ;RJSO3/4 ;REBOOT ROUTINE ;ANALYZES /O COMMAND TO DETERMINE WHICH DEVICE WAS SPECIFED BY ;LOOKING FOR THE CODE OF THE SPECIFIED DEVICE IN BOOTDV. IF THE ;CODE IS FOUND,THE APPROPRIATE ROUTINE IS ENTERED REBOT: JSR PC,FGCHK ;MAKE SURE FG IS NOT PRESENT MOV #FILDES+36,R5 ;POINT TO INPUT LIST TST (R5) ;WAS A DEVICE SPECIFIED? BEQ 4$ ;NO TST (R4) ;ANY OUTPUT FILES SPECIFIED? BEQ 3$ ;NO 4$: JMP ILLCMD ;BAD COMMAND 3$: TST 2(R5) ;ANY INPUT FILES? BNE 4$ ;YES-/O PROBABLY MISTAKE .DSTATU #DEVINF,R5 ;GET CODE FOR THE DEVICE .LOOKUP 1,R5 ;NON-FILE STRUCTURED LOOKUP ON DEVICE,FOLLOWED .SAVEST 1,#SSB ;BY A SAVESTATUS WILL MAKE UNIT # AVAILABLE MOV #BOOTDV,R0 ;POINT TO LEGAL DEVICE CODE TABLE 1$: CMPB DEVINF,(R0)+ ;LOOK FOR DECIE BEQ DVFND ;FOUND THE DEVICE CMP R0,#BDVEND ;END OF TABLE? BLO 1$ ;NO-EXAMINE NEXT ENTRY HANER1: JMP HANERR ;YES-DEVICE SPECIFIED MUST BE ILLEGAL DVFND: SUB #BOOTDV+1,R0 ;GET INDEX OF DEV IN BOOTDV ASL R0 ;ADDRESSES ARE EVEN JMP @BOOTAD(R0) ;ENTER BOOT ROUTINE FOR DEVICE ;BM793-COMMON BOOTSTRAP ROUTINE FOR RP11,RK11,TC11,RF11 ;ON ENTRY,R0 POINTS TO CONTROLLER WORD COUNT REGISTER ;R1 CONTAINS CONTROLLER COMMAND VALUE TO CAUSE A READ ;R2 CONTAINS APPROPRAITE UNIT VALUE TO PUT IN CONTROLLER ;R3 CONTAINS ADDRESS OF CONTOLLER REGISTER TO RECIEVE R2 BM793: .HRESET ;NOW BEGINS THE BOOT 2$: RESET MOV R2,@R3 ;PUT UNIT # IN REGISTER POINTED TO BY R3 MOV R0,R5 ;WE CAN'T DESTROY R0 MOV #-256.,@R5 ;SET WORD COUNT CMP R5,#177344 ;IS THIS DECTAPE? BNE 3$ ;NO MOV #4002,-(R5) ;YES-MUST SEARCH FOR BLOCK 0 TST @R5 BPL .-2 TST -(R5) BPL 2$ CMP (R5)+,(R5)+ ;AT BLOCK 0-POINT R5 TO COMMAND REGISTER 3$: MOV R1,-(R5) ;STUFF COMMAND REGISTER WITH READ COMMAND TSTB @R5 ;WAIT TO FINISH BPL .-2 TST @R5 ;ERROR? BMI 2$ ;YES-TRY AGAIN CLRB @R5 ;NO-STOP DEVICE JMP @#0 ;AND START SECONDARY BOOT CODE .IF NDF MBUILD ;FLOPPY BOOT ROUTINE PS: RTI ;USED TO LOAD PS FROM STACK IN MACHINE ;INDEPENDENT FASHION DXBOOT: .HRESET ;STOP ALL RT-11 I/O RESET ;STOP TERMINAL AND CLOCK DECB SSB+11 ;UNIT #-1 IN SAVED STATUS BLOCK BMI UNIT0 ;IF RESULT<0,UNIT WAS 0 BNE HANER1 ;ANY UNIT BUT 0 OR 1 ILLEGAL MOV #20,R2 ;BOOT FROM UNIT 1 BR UNIT1 UNIT0: CLR R2 UNIT1: BIS #100247,R2 ;R2=20 FOR UNIT 1 BOOT MOV #340,-(SP) ;PUT DESIRED PRIORITY ON STACK ;THS FOLLOWING INSTRUCTION IS MACHINE ;INDEPENDENT WAY TO LOAD PS JSR PC,PS ;LOAD PS FROM STACK WITH RTI INST 1$: MOV #RXCS,R1 ;POINT R1 TO STATUS REGISTER FOR CONTROLLER 2$: BITB R2,@R1 ;WAIT FOR FLOPPY DONE BEQ 2$ MOVB #7,R3 ;SET SECTOR/TRACK/LOOP CONTROL MOV R1,R0 ;SET UP TO POINT TO RXDB MOV R2,(R0)+ ;LOAD READ AND GO FUNCTION BR 4$ ;GO TO WAIT LOOP 3$: MOV #1,@R0 ;1ST SECTOR 1, 2ND TRACK 1, 3RD JUNK 4$: ASR R3 ;STEP THROUGH SECTOR/TRACK SEQ BCS 6$ ;BRANCH TO WAIT,SIT CYCLE NOT DONE MOVB (PC)+,@R1 ;LOAD EMPTY BUFFER COMMAND 5$: MOVB @R0,(R3)+ ;MOVE DATA BYTE TO MEMORY 6$: BIT R2,@R1 ;WAIT FOR TR DONE OR ERROR BEQ 6$ BMI 1$ ;BRANCH TO RETRY IF ERROR BCS 3$ ;BRANCH IF IN SECTOR/TRACK LOOP TSTB @R1 ;IS DATA TRANSFER DONE BMI 5$ ;BRANCH TO TRANSFER MORE CLR R0 ;MAKE SURE LOC 0 IS 240 CMP #240,@R0 BNE 1$ ;BRANCH IF NOT TO RETRY CMPB #247,R2 ;SET C=1 IF UNIT 1 BOOT ADC R0 ;R0=0 IF UNIT0,1 IF UNIT 1 CLR PC ;GO TO SECONDARY BOOT ;TC11 BOOT ROUTINE DTBOOT: MOV #177344,R0 ;ADDR OF WC REGISTER IN R0 .ENDC ONEONL: TSTB SSB+11 ;ONLY UNIT 0 ALLOWED BNE HANER1 ;ILLEGAL DEVICE IF UNIT NOT 0 CLR R3 ;DON'T NEED UNIT POINTER READ5G: MOV #5,R1 ;READ COMMAND IS READ (4)+GO (1) BR BM793 ;DO COMMON BOOT ;RK11 BOOT ROUTINE RKBOOT: MOVB SSB+11,R2 ;UNIT INTO R2 CLC ROR R2 ;SLIDE UNIT TO BITS 15-13 ROR R2 ROR R2 ROR R2 MOV #177412,R3 ;R3 POINTS TO UNIT REGISTER MOV #177406,R0 ;R0 POINTS TO WC BR READ5G ;SET READ COMMAND AND GO TO BOOT ;RF11 ROUTINE RFBOOT: MOV #177462,R0 ;POINT R0 TO WC BR ONEONL ;THE RESET IS SHARED WITH DECTAPE ;RP11 ROUTINE DPBOOT: MOV #176716,R0 ;POINT RO TO WC MOV SSB+10,R1 ;UNIT # INTO R1 BIC #174377,R1 ;STRIP TO UNIT BITS ADD #5,R1 ;READ COMMAND IN R1 CLR R3 ;DON'T NEED SEPERATE UNIT BR BM793 ;RJS03/4 ROUTINE RJBOOT: .HRESET ;STOP ALL RT-11 I/O,INCLUDING TTY RESET ;AND STOP ALL PDP-11 I/O MOV #RSCS2,R5 ;POINT R5 TO RH11 CONROL REG 2 MOVB SSB+11,(R5) ;SET UNIT CLR -(R5) ;READ BLOCK 0 CLR -(R5) ;INTO ADRRESS 0 MOV #177400,-(R5) ;READ ONE BLOCK MOV #71,-(R5) ;GO 1$: BIT #100200,(R5) ;TEST FOR DONE OR ERROR BEQ 1$ ;WAIT BMI RJBOOT ;KEEP TRYING ON ERROR CLR PC ;BOOT DONE-START SECONDARY .END ;END OF BOOTSRAP OVERLAY (V7 B((( &.&?p?$?$?p$?$pP.L$$p?$$?p?$t.r?$?p$?$p$$N.p?$$!@ʆ?$d/ݽ?p!@ʆ?$.p!@ʆ$d/ݽp!@ʆ$p.?pd@/݆?$!?p$!ʽp$ d@/݆$!?p?$! \| \ o.`WHITE BLACK'I2'I8'I2 B.  .W. I2'I8 BLACK: WHITE: .'BLACK WINS' ITS A TIE'WHITE WINSo" WHAT? (088@E .0@XBhBBb.ABABB0BA!*8?Gr@n/@)\Y> <A>  ?  .N@Tq@@y:}@F;@ .Jw_@9wK@yd@S@9zժ@}.۪@vū@Sq@Y@S5@.}@}}@Yp@ zd@&p@.M" @/q}@S5@S۪@@.Sū@Sժ@zժ@K}@@U.T;@Sū@S۪@z۪@;@.ժ@"v@xs@&}@Ѫ@.@G9@!@B9@y@.Ȫ@t@K@,L@:@.@q;@z˫@8@9zū@.@S}@vժ@T۪@L@.ժ@Y @Sɪ@ū@Sժ@.5@u~@@u~p@Iū@;@.Y@S@zɪ@1}@@&XȪ@Q@@y@h.NTq  Tqy:}.F;Tq Tq Jw_$*F;Tq Tq Tq2 *Tq 9wKND .ydF;S Z NS\Tm.N9zժ \ ۪ZvūfW.SqY\ TYZLF;PzY,SF; S F;S5dE*F;S5 F;S5X3,F;S5 Z F;S5Tq(.S5  TqS5Tq ,Tq Tq }t*F;Tq` }}F;.S5 Tq S5Tq.S5 Tq TqTqY.} F; TqpTqZ|.Tq YpF;TqtG&.TqXTq  YpN8.Tq S5 TqS5?L*TqTq $ Tq w\u,}F;Tq ^  zdXjd.F;Tq Tq f?p?$?$?p$?$p$$p?$$?pd@/ݽp?pd/ݽp$?$?pd@/ݽp?pd/ݽp?p?$?$?p?$$p$$p?pd@/݆$!? WHITE BLACK'I2'I8'I2 B.  W. I2'I8 BLACK: WHITE: 'BLACK WINS' ITS A TIE'WHITE WINS WHAT? (08 @XBhBBABABB0BA?Gr@n/@)\Y> <AABB0BA?Gr@n/@)\Y> <Aq^Tq.0 zd F;TqTq<776%<776*<77776r$< 6&< 8< 8<Df=D86767 < 8< 8<7<7<7<7<7L7L7N7N7P7P776<7 6!<7R7R7T7T7V7V776<70776 <74776 <77X7X7Z7Z776<76"<77f6:'<6#<77\7\7^7^776<76"<77&6:'<6#<77`7`7b7b776<776"<776<776"<776<776"<=d7d76<776"< 8<-8QR7<77j7j7l7l7=nbTn7n6<776P<067 2< 8<28QR7"<77t7t7v7v="xbTx7x76<776P<567 < 8<7 8<88=Rf=7<8QR7<8QR7"<77777="TT@R77=TT@R776<7877n=76 <=6767<76#<7 6#<7 6#<76#<6(<6&<7&< 8(77z7<7777777>7:6<7dBn=B<8&b= 77B6"<8Bb=76#<7677:6<8&b= 77B6"<6(<8&Z=U7<8(Z=U774<=>7n<=>7F<7&<7( TO EXIT++ r+V++8++鈀w$w#wwf , T$, H@:+0, r+鈀w$w#wwf`, Td, H:+p, rE6,,fw@ T,,ۉ,  3 , ݉   ߉ w wB w5@d&  & \V ׉ pw" x ppwt5 ۉ & ( Njdd - 0pw< & e&  pwE]E] r. w@&&\ W#& \f\\ @ \&\7 V<.  H7 D4.. &f& &S.@  \7  77 --w- :e77    7 7 E@5 E  -$e@E @78w>@*& ^.^.^.^./  eP 0P 7  U P P\ UU  w\U& e f& ,. Qh0  |S0Tz0xχ N\%%& #5ebf 4 $%47 \7 7 (7 7 + 4 4nf f &4 X f B   Xv4.w:f $  @w"f 41 e%4 7 77777" 7D 7   @Xf Sf6w52 52p32p4 2p~5 \4 wr4eww f,5f z  j d * $V NJ7 <7 <? >E ,w0e5  5  5 UEA f   eww,^ ` 7 I% 2%@,?r9H4 %H4\4\.D?Tw\4ww"%44 %ww?$   w?$ #Tr4v4~44TA4444T@_?@@?_`__k(ththT(T(t,^ `D%  Z j.5 DE 7a$DEv 7anj    b  \4l ՐU  H40\4J\4   5,^ `,} BU   U `B6`5 e3d ډ& "35 5  X %cԉ . @ ы@ Չe 6e RD \&&Af&  e\ \ \& \\%\%\%\%\%\'\'\'\ ' ' \\\& \\U\N E\N MEP\֋\܋\\ȋ\  3RDZ  S3`D Z\\\\&\\\&\\\& \ \ \\\\f&f&  e `e& e eB : N"Q$B(< U& * u @ 3 PA &eW!9 :Cf   t8߉ۉ܉݉# B   ` ׮PU ׮PU, މU1 0 555U U& @&&3&3 ¥#  , @ & 5ff@ & 爄  Mff z\\PH\PPd:d:c:% \ PAUSE -- ͥЉ b snf&R 35gȋp 5 4 54- :p&d :  5@a3 s 5@ @ 3@ 3 r3 p3!  #p  3 :5@5#E 5m5 ҕ   mU  U Eȋى .<`5w2&s55 T 3 T   4 m E% % C χ։ɕ swd 3 D 3 r3 p3 X \ \<&=\?\<&=\H=& & e:  STMT & e\e\e\e\e\e\g\g\g\\\\\\\\\\ \ \& \ \ \& \ \\ \ \ \ \&&\ \ \f&̋T 5 Eť1 ť+ť$ 3 Tť0  @s ̋m 54 w0 > f B % % e@ ( B`  ` A@^   A ^”E eBCIE `-    D E A@D D e0bb   ҕ* V W -D $?*?PPO P`D>>NNNN&4 4-45@  @&vC j5EUe  & 4-* . @& &v    ߋ*3 pr ׉U3 rp؉wAA A f  f3! nH ASTOP --    ;3  ,FF3 F V {` `3 V3 Tl ,FFBFFy R q  3iAse Z a  T  `U `R DNB (;  D  @ B   D \rpV& D D 3 V3  r3 F  `P B3 \ @  vExD H3I \sJ JsL% ދ H w)H :  X RH ?  H鈇& e:   낃 (  G %@"GwG?ERR 60 STACK OVERFLOWED ABCDEFGHIJKLMNOPQRSTUVWXYZ$. 0123456789FROMIN ROUTINE "" LINE ?ERR ||| 11 FLOATING UNDERFLOW6 OUTPUT CONVERSION ERROR4 COMPUTED GOTO OUT OF RANGE 12 FLOATING ZERO DIVIDE2 INTEGER ZERO DIVIDE3 COMPILER GENERATED ERROR16 WRONG NUMBER OF ARGUMENTS 13 SQRT OF NEGATIVE NUMBER1 INTEGER OVERFLOW 10 FLOATING OVERFLOW5 INPUT CONVERSION ERROR14 UNDEFINED EXPONENTIATION OPERATION15 LOG OF NEGATIVE NUMBER=61 ILLEGAL MEMORY REFERENCE20 INVALID LOGICAL UNIT NUMBER21 OUT OF AVAILABLE LOGICAL UNITS22 INPUT RECORD TOO LONG23 HARDWARE I/O ERROR?63 ILLEGAL INSTRUCTION TRAP24 ATTEMPT TO READ/WRITE PAST END OF FILE25 ATTEMPT TO READ AFTER WRITE26 RECURSIVE I/O NOT ALLOWED-45 INCOMPATIBLE VARIABLE AND FORMAT TYPES27 ATTEMPT TO USE DEVICE NOT IN SYSTEM31 NO AVAILABLE I/O CHANNEL28 OPEN FAILED FOR FILE29 NO ROOM FOR DEVICE HANDLER$36 BAD FILE SPECIFICATION STRING,44 2ND RECORD REQUEST IN ENCODE/DECODE 32 FMTD-UNFMTD-RANDOM I/O TO SAME FILE!33 ATTEMPT TO READ PAST END OF RECORD"34 UNFMTD I/O TO TTY OR LPT%37 RANDOM ACCESS READ/WRITE BEFORE DEFINE FILE&38 RANDOM I/O NOT ALLOWED TO TTY OR LPT'39 RECORD LARGER THAN RECORD SIZE IN DEFINE FILE(40 REQUEST FOR BLOCK LARGER THAN 65535)41 DEFINE FILE ATTEMPTED ON OPEN UNIT#35 ATTEMPT TO OUTPUT TO READ ONLY FILE30 NO ROOM FOR BUFFERS*42 MEMORY OVERFLOW COMPILING OBJECT TIME FORMAT.46 INFINITE FORMAT LOOP+43 SYNTAX ERROR IN OBJECT TIME FORMAT149 ENDFILE ON RANDOM FILE048 UNIT ALREADY OPEN0 NON-FORTRAN ERROR CALL &f$&  h % % U@     < .`D A @ 耎     e lO    e &f  ”E   CPQCQBm     v   &   5@%PeE T  <5eN N (E D A @  eb" b"    D A @ &f&f eD A @ eA @ e@ e&f&f   <%PeE D A @ E@E ED &f& @ &   6&C  8   h   6c6#m    (   # 6 ඌ cmc ` ҕ- 9 |E@ e0Ґ (   ( eC Hҕ ( %% ҕ0ҕ. ҕ0 Ґ+-  Ґʕ/ e:rC e e ҕ* 6 6 &  f 6A  v  6N\@A& &f Qf KN @@ʉ?=e  ! C DR DDC D@ C @ %R ` ` D@ B \ˉ  ̉&    \B`    @%  @ %   &\\@A& &CBf @ E   E `ʉˉ  =   &  @  @ CaB a@ CaB a   C B 5CA aC`B \5ee @e@A& &ew4 @e@A& &e&f . 1fABAD5 a C%!e e B V  B\E CP   D a@ C`B `%ֆ C ӆBEІʉ  %C ‹Á  C B ‹ B ˉ    &    C 5UA B C C  \‰     C 5UA B C C  \‰ =@7h=7:.=j7ZX >.=68$7!=7.=68$7!=7.=68$7!=7.=68686<.=7:.=A7 2 ,U $] , e  & U  7  A  ]]e ] U   ]    w@T7 N7  < | <U nU d]`]X hR e  7 6 ....../ DIMENSION IBUF(2000),ICELL(8,8),BL(16),WH(32),NUM(1) DIMENSION IDX(8),IDY(8),IFLAG(8),KOUNT(2) DATA IDX/1,0,-1,0,1,-1,-1,1/ DATA IDY/0,1,0,-1,1,1,-1,-1/ DATA BL/.37,0.,.262,.262,0.,.37,-.262,.262, 1 -.37,0.,-.262,-.262,0.,-.37,.262,-.262/ DATA WH/.37,.894,-.37,0.,.37,-.894,-.37,0., 1 -.262,.262,0.,.37,.894,-.37,0.,.37, 2 -.894,-.37,0.,.37,.262,.262,.37,0., 3 .262,-.262,0.,-.37,-.262,-.262,-.37,0./ 1 CALL INIT(IBUF,2000) CALL SCROL(6,744) CALL SCAL(0.,1.,13.5,14.5) CONTINUE CALL STOP C... INITIALIZE CELL MATRIX TO REPRESENT BLANK BOARD DO 10 I=1,8 DO 10 J=1,8 10 ICELL(I,J)=0 C... INITIALIZE FIRST FOUR COUNTERS ICELL(4,4)=1 ICELL(5,5)=1 ICELL(4,5)=-1 ICELL(5,4)=-1 C... INITIALIZE SCORE COUNTERS. KOUNT(1) FOR BLACK. KOUNT(2) FOR WHITE.. KOUNT(1)=2 KOUNT(2)=2 CALL APNT(9.,7.5,-1,-6,-1) CALL TEXT('WHITE BLACK') CALL APNT(9.25,7.,-1,-6,-1) CALL NMBR(4,KOUNT(2),'I2') CALL NMBR(5,KOUNT(1),'I8') C... -1=BLACK 1=WHITE 0=BLANK C... CREATE SUBPICTURES FOR WHITE AND BLACK PIECES. INTEGER BLACK,WHITE DATA BLACK,WHITE/9,11/ CALL APNT(9.5,8.,-1,-5,0) CALL SUBP(WHITE) CALL FIGR(WH,32) CALL ESUB CALL APNT(11.,8.,-1,-5,0) CALL SUBP(BLACK) CALL FIGR(BL,16) CALL ESUB C... DRAW FIRST FOUR PIECES IN THE CENTER OF THE BOARD. CALL APNT(4.,4.,-1,-5,0) CALL SUBP(128,WHITE) CALL RDOT(0.,1.) CALL SUBP(136,BLACK) CALL RDOT(1.,0.) CALL SUBP(137,WHITE) CALL RDOT(0.,-1.) CALL SUBP(129,BLACK) C... DRAW THE CHECKER BOARD LINES. DO 20 I=1,9 X=I CALL APNT(X-.315,.947,-1,-6,0) CALL VECT(0.,8.) 20 CONTINUE DO 30 I=1,9 Y=I CALL APNT(.685,Y-.053,-1,-6,0) CALL VECT(8.,0) 30 CONTINUE C... PLACE SQUARE NUMBERS ON THE CHECKER BOARD. DO 40 I=1,8 DO 40 J=1,8 NUM(1)=8*(J-1)+I X=I Y=J CALL APNT(X-.315+.5,Y-.053+.5,-1,-6,0) CALL NMBR(500+NUM(1),NUM,'I2') 40 CONTINUE C... ERASE THE CENTER FOUR NUMBERS. CALL ERAS(528) CALL ERAS(529) CALL ERAS(536) CALL ERAS(537) CALL CMPRS CALL CONT C... ICHK= CURRENT MOVE NCHK= OPPONENT C ICHK=1 WHITE TO PLAY, ICHK=-1 BLACK TO PLAY ICHK=-1 NCHK=1 C... ACCEPT INPUT ENTRY 2 IF(ICHK.EQ.-1)TYPE 100 100 FORMAT(' B. '$) IF(ICHK.EQ.1)TYPE 101 101 FORMAT(' W. '$) ACCEPT 103,NUM(1) 103 FORMAT(I2) C... CHECK VALIDITY OF ENTRY IF(NUM(1).LT.0)GO TO 700 IF(NUM(1).EQ.0.OR.NUM(1).GT.64)GO TO 900 C... CALCULATE COORDINATE VALUES FOR THE SQUARE. IX=NUM(1)-8*((NUM(1)-1)/8) IY=(NUM(1)-1)/8+1 C... CHECK IF THE CELL IS EMPTY. IF(ICELL(IX,IY).NE.0)GO TO 900 C... CHECK LEGALITY OF THE CURRENT MOVE. ICAP=0 DO 54 L=1,8 IFLAG(L)=0 DO 51 LL=1,7 LX=IX+LL*IDX(L) LY=IY+LL*IDY(L) IF(LX.LT.1.OR.LX.GT.8)GO TO 52 IF(LY.LT.1.OR.LY.GT.8)GO TO 52 ITAG=ICELL(LX,LY) IF(ITAG.EQ.ICHK)GO TO 53 IF(ITAG.EQ.0)GO TO 52 IFLAG(L)=LL 51 CONTINUE 52 IFLAG(L)=0 53 ICAP=ICAP+IFLAG(L) 54 CONTINUE IF(ICAP.EQ.0)GO TO 900 C.. CREATE BRIGHTER DISPLAY OF THE CURRENT MOVE. C.. ERASE THE NUMBER IN THE CURRENT SQUARE PLAYED. ICELL(IX,IY)=ICHK XX=IX YY=IY CALL APNT(XX,YY,-1,-8,-1) KPIC=100+NUM(1) CALL SUBP(KPIC,ICHK+10) CALL ERAS(KPIC+400) CALL TIME(60) 200 CALL TIMR(IE) IF(IE.NE.0)GO TO 200 C... REVERSE THOSE OPPONENT'S PIECES C... WHICH ARE FLANKED BY THE PLAYER'S PIECES. DO 60 L=1,8 IF(IFLAG(L).EQ.0)GO TO 60 DO 61 LL=1,IFLAG(L) LX=IX+LL*IDX(L) LY=IY+LL*IDY(L) X=LX Y=LY JPIC=100+8*(LY-1)+LX CALL ERAS(JPIC) CALL APNT(X,Y,-1,-5,-1) CALL SUBP(JPIC,ICHK+10) ICELL(LX,LY)=ICHK CALL TIME(10) 201 CALL TIMR(IE) IF(IE.NE.0)GO TO 201 61 CONTINUE CALL TIME(20) 202 CALL TIMR(IE) IF(IE.NE.0)GO TO 202 60 CONTINUE C... RESTORE INTENSITY OF THE DISPLAY OF THE CURRENT ENTRY. CALL ERAS(KPIC) CALL APNT(XX,YY,-1,-5,-1) CALL SUBP(KPIC,ICHK+10) CALL CMPRS C... KEEP TALLY OF THE SCORE. STOP THE GAME IF BOARD IS FULL, C... OR COUNTERS ARE EXHAUSTED. I=(ICHK+3)/2 J=(NCHK+3)/2 KOUNT(I)=KOUNT(I)+ICAP+1 KOUNT(J)=KOUNT(J)-ICAP CALL APNT(9.25,7.,-1,-6,-1) CALL NMBR(4,KOUNT(2),'I2') CALL NMBR(5,KOUNT(1),'I8') CALL APNT(9.5,5.,-1,-6,-1) TYPE 600 , KOUNT 600 FORMAT(' BLACK: 'I2,3X,'WHITE: 'I2) IF(KOUNT(1)+KOUNT(2).EQ.64)GO TO 800 IF(KOUNT(1).EQ.0)GO TO 803 IF(KOUNT(2).EQ.0)GO TO 801 C... CHANGE THE INDEX FOR NEXT MOVE. 700 ICHK=-ICHK NCHK=-NCHK GO TO 2 800 IF(KOUNT(2)-KOUNT(1))801,802,803 801 CALL TEXT('BLACK WINS') GO TO 3 802 CALL TEXT(' ITS A TIE') GO TO 3 803 CALL TEXT('WHITE WINS') GO TO 3 900 TYPE 901 901 FORMAT(' WHAT?') GO TO 2 3 CONTINUE STOP END TRY POINT FOR USR RETURN. .ENABL LSB U$NLOK: CMPB USROWN,JOBNUM ;DO WE OWN THE USR? BNE EMTRTI ;NO, WE HAVE NO RIGHT TO UNLOCK IT TSTB USRLVL ;WE OWN IT. DID WE LOCK IT? BEQ 1$ ;NO, IT'S NOT CALLED MONOUT: BIC #USRRN$,@CNTXT ;TURN ON ADDRESS CHECKING AGAIN DECB USRLVL ;UP A LEVEL BNE EMTDON ;USR CALLED SELF. LEAVE IT IN CORE 1$: JSR PC,RIDUSR ;OUT OF USR. GET RID OF IT JMP EMTDON ;AND EXIT .DSABL LSB ; EMT 17--USED FOR INTERNAL PURPOSES ONLY. SHOULD NOT BE ; CALLED BY THE USER. MOVES AN ERROR CODE INTO LOCATION ; SET ASIDE FOR THE CODE, AND TURNS THE C BIT ON IN THE ; OFFENDING EMT'S STATUS. EMT17: ASR R4 ;NEED NUMBER BETWEEN 0-17 MOVB R4,@#ERRBYT BIS #1,ERRPS(SP) BR EMTRTI ;************************************************** ; SERR AND HERR GOVERN THE REPORTING OF FATAL MONITOR ERRORS. ; .SERR INDICATES THAT NO FATAL ERRORS ARE TO BE REPORTED. ; .HERR INDICATES THAT HARD ERRORS ARE TO BE REPORTED. ;************************************************** S$ERR: INC R2 ;R2 WAS 0 FROM EMTPRO H$ERR: MOVB R2,I.SERR(R5) ;PUT THE VALUE INTO FLAG RTILK1: BR EMTRTI .SBTTL SOFT RESET ; EMT 16(10) - SOFT RESET ; SOFT RESET CLEARS ALL CHANNELS (EXCEPT 17 IF OVERLAYING IS ON) ; IT THEN FALLS INTO QRESET, WHICH RESETS THE I/O QUEUE TO ; ONE ELEMENT. ; FOR THE BACKGROUND, ANY NON-LOADED HANDLERS ARE PURGED S$RSET: JSR PC,REVERT ;QUIESCE IO, REVERT CHANNELS, ;RESET QUEUE, RELEASE HANDLERS MOV I.CSW(R3),R1 ;POINT TO CHANNELS MOV #16.*5,R0 ;ORIGINAL 16 CHANNELS, 5 WDS EACH BIT #OVLY$,@#JSW ;OVERLAID? BEQ 1$ ;NYET SUB #5,R0 ;DA, REDUCING COUNT 1$: CLR (R1)+ ;ZAP DEC R0 ;REZAP? BNE 1$ ;ZIP BR RTILK1 ;ZOOP ; THE FOLLOWING SUBROUTINE WAITS FOR ALL I/O TO STOP QUIESCE:MOV CNTXT,R3 ;GET IMPURE POINTER JSR R4,$SYSWT ;WAIT FOR I/O TO COMPLETE .WORD EXIT$ MOV I.IOCT(R3),-(SP) ;SET C IF NON-0 NEG (SP)+ JSR PC,@(SP)+ ;RETURN RTS PC .SBTTL CLOSE, PURGE, EMT 16, USR CALLS ; CLOSE EMT ; IF NO DIRECTORY OPERATION IS REQUIRED, THE CHANNEL IS DISSOCIATED, ; AND WE ARE DONE. IF DIRECTORY WORK IS REQUIRED, THE USR IS CALLED. C$LOSE: BIT #RENAM$+DWRIT$,@R3 ;DIRECTORY REWRITE NEEDED? BNE C$LOS2 ;YES. CALL USR P$URGE: CLR (R3)+ ;DISSOCIATE CHANNEL BR RTILK1 ;EXIT EMT16: TST (R4)+ ;R4 HAS SUB CODE TO DO ADD PC,R4 ADD (R4),PC LST16: 10$: T$TIN -10$ T$TOUT-10$ D$STAT-10$ ;DEVICE STATUS F$ETCH-10$ ;FETCH/RELEASE C$SIGN-10$ ;GENERAL MODE CSI C$SISP-10$ ;SPECIAL MODE CSI L$OCK -10$ ;LOCK USR U$NLOK-10$ ;RELEASE USR ..EXIT = . - 10$ E$XIT -10$ ;EXIT PROGRAM P$RINT-10$ ;STRING PRINT S$RSET-10$ ;SOFT RESET Q$SET -10$ ;SET IO QUEUE S$ETOP-10$ ;SET TOP OF CORE R$CTLO-10$ ;RESET ^O BIT EMTRTI-10$ H$RSET-10$ ;HARD RESET .ENABL LSB C$SIGN: TST (PC)+ ;CLEAR THE CARRY C$SISP: SEC ;SET THE CARRY BIS #CSIRN$,@R5 ;SAY THAT THE CSI IS RUNNING BIC R4,R4 ;CLEAR R4 ROR R4 ;PUT GENERAL/SPECIAL FLAG IN SIGN BIT MOV #..CSI,R2 ;CSI CALL IS NUMBER 10. TST @R1 ;IS INPUT STRING FROM THE TTY? BNE EMTUSR ;NYET. GO DOING THINGS INCB R4 ;IF WE DON'T OWN USR YET, WE WILL ;ENTER IT AT A DEPTH OF CALL OF 1 CMPB USROWN,JOBNUM ;WELL, OWN WE IT? BNE 1$ ;NOOOO INCB USRLVL ;YES. THE CSI CALL IS ANOTHER LEVEL CSIERR: CLRB R4 ;PICK UP LEVEL IN LOW BYTE OF R4 BISB USRLVL,R4 JSR PC,RIDUSR ;THROW IT AWAY WHILE WE COLLECT A LINE 1$: MOV CNTXT,R1 ;R1 -> IMPURE AREA ;DV25 BIC #TTSPC$,I.TERM(R1) ;DON'T GATHER STRING IN SPEC. MODE ;DV25 MOV $ENTRY+BA.NUM,R0 ;IS BATCH RESIDENT BEQ 11$ ;NO, WE MUST WAIT! TST 6(R0) ;YES. IS IT ACTIVE? BEQ 11$ ;NO, GOTTA WAIT TST JOBNUM ;BATCH IN AND ACTIVE. IS WE DA BG? BEQ 12$ ;YES, AVOID THE WAIT 11$: .TTYOUT #'* ;PRINT THE PROMPT JSR R4,$SYSWT ;WAIT FOR A LINE ;DV25 .WORD TTIWT$ TST I.TTLC(R1) ;GOT LINE YET? BNE 2$ ;YES, LEAVE C=0 SEC ;NO, SET CARRY 2$: JSR PC,@(SP)+ ;RETURN TO WAITER 12$: MOV #..CSI,R2 ;CSI INDEX JSR PC,CALUSR ;GET THE USR IN CORE AND OURS MOVB R4,USRLVL ;RESTORE (OR SET) PROPER DEPTH CLRB R4 ;R4 = SPECIAL/GENERAL FLAG BIS #CSIRN$,@CNTXT ;FLAG CSI IS RUNNING ;DV7 BR 10$ ;WELL, GO DO IT! ; FOLLOWING IS A TABLE OF CALLS INTO THE USR. R2 IS ; USED AS AN INDEX TO THE PROPER FUNCTION ONCE CONTROL ; HAS PASSED INTO THE USR. D$STAT: INC R2 ;DEVICE STATUS R$NAME: INC R2 ;RENAME L$OOK: INC R2 ;LOOKUP E$NTER: INC R2 ;ENTER C$LOS2: INC R2 ;CLOSE F$ETCH: INC R2 ;FETCH/RELEASE D$LETE: INC R2 ;DELETE Q$SET: ;SET IO QUEUE EMTUSR: JSR PC,CALUSR ;GRAB THE USR 10$: BIS #USRRN$,@CNTXT ;SAY THAT THE USR IS IN CONTROL JMP @USRLOC .DSABL LSB .SBTTL EXIT ; "YOU WILL SOFTLY AND SUDDENLY VANISH AWAY ; AND NEVER BE MET WITH AGAIN." - LEWIS CARROLL ; "THE HUNTING OF THE SNARK" ; EXIT CAUSES THE EXECUTING PROGRAM TO RETURN TO THE MONITOR. ; EXIT FIRST RELEASES THE USR AND WAITS FOR ALL USER I/O TO COMPLETE. ; IF THE FG IS EXITING, IT IS LINKED INTO THE FREE SPACE LIST. ; IF THE BG JOB IS EXITING, IT IS SWAPPED OUT IF NECESSARY ; AND THE KMON AND USR ARE READ INTO THEIR STANDARD PLACE. .ENABL LSB C$HAIN: BIS #CHAIN$,@#JSW ;CHAIN SIMPLY SETS CHAIN BIT MOV SP,R0 ;AVOID HARD EXIT BR 15$ ERRXIT: .PRINT ;PRINT THE MESSAGE CLR R0 ;INDICATE HARD EXIT E$XIT: BIC #CHAIN$,@#JSW ;INDICATE NO CHAINING 15$: MOV R0,-(SP) ;PRESERVE HARD/SOFT FLAG MOV JOBNUM,R2 ;GET OUR JOB NUMBER CMPB USROWN,R2 ;DO WE OWN THE USR? BNE 1$ ;NO CLR BLKEY JSR PC,RIDUSR ;GET RID OF USR 1$: TST @CNTXT ;TRYING EXIT FROM COMPLETION? BMI UABTLK ;THAT'S NAUGHTY ENSYS 16$ JMP CMKALL ;CANCEL ALL OUTSTANDING MARK TIMES 16$: JSR PC,REVERT ;WAIT FOR ALL I/O TO STOP ADD #I.SPLS,R3 ;POINT TO IMPURE GOODIES MOV @R3,R1 ;POINT TO SPECIAL LIST TO KILL ON EXIT BEQ 4$ ;NOTHING CLR @R3 ;TURN IT OFF JUST IN CASE IT TRAPS BR 3$ ;ENTER LOOP 2$: MOV (R1)+,@R2 ;JAM A WORD 3$: MOV (R1)+,R2 ;GET A POINTER BNE 2$ 4$: MOV (R3)+,(R3)+ ;CLEAR TRAP INTERCEPT (JAM ADDR NOW 0) CLR (R3)+ ;CLEAR FPP INTERCEPT CLR (R3)+ ;CLEAR SPECIAL SWAPS CMP (R3)+,(R3)+ ;SKIP OVER SWAP2, SAVED SP ADDR LOWMAP,R5 ;POINT TO BIT MAP MOV #MAPSIZ,R2 ;CLEAR ALL MAP WORDS 5$: BIC @R3,(R5)+ ;CLEAR PERM. MAP CLR (R3)+ ;AND JOB MAP DEC R2 ;LOOP BNE 5$ TST JOBNUM ;ARE WE EXITING FROM THE FG? BNE 50$ ;YES. NO KMON, NO NOTHING. MOV SP,(PC)+ ;FLAG B/G ABORT IN PROGRESS EXTFLG: .WORD 0 ADD #SPTR->,R5 ;SWITCH TO MONITOR STACK MOV (SP)+,-(R5) ;PUT PASSED R0 ONTO NEW STACK MOV R5,SP MOV $KMLOC,R2 ;POINT TO PERM ADDRESS FOR KMON TST KMLOC ;IS KEYBOARD IN CORE? BNE 11$ ;YES, JUST GO TO IT JSR PC,ENQUSR ;WE MUST OWN THE USR FOR THIS ADD #USRSWP-,R5 ;POINT TO SWAP DATA CLR (R5)+ ;USR DOES NOT SWAP MOV (R5)+,R0 ;GET START OF SWAP AREA MOV R2,@R5 ;SET POINTER TO KMON BIC #777,@R5 ;ROUND IT DOWN TO SWAP OUT MOV (R5)+,@R5 ;COMPUTE AMOUNT TO WRITE OUT SUB @#USERTOP,@R5 ;IT'S A NEGATIVE NUMBER BHI 6$ ;KMON ROUNDED > HIS TOP, DON'T WRITE ROR @R5 ;MAKE IT A WORD COUNT DEC @R5 ;TOP WAS OFF BY 2 TST -(R5) ;FIX R5 JSR PC,$SYS ;AND SWAP THE GUY OUT BCS SWPERR ;ERROR, GO ABORT THE JOB TST (R5)+ ;FIX R5 SO 6$ ENTERED SAME WAY 6$: CMP (R5)+,(R5)+ ;ADVANCE POINTER TO SWAP-IN IOB ADD #SWAPSZ,R0 ;AND POINT TO BLOCK WITH KMON CMP -(R2),-(R2) ;BACK UP SO WE CALL LOCATE FIRST JSR PC,$SYS ;READ IN THE KMON/USR BCC 11$ ;AOK READ, GO ENTER AT MEXIT JSR R0,9$ ;OOPS, THAT'S REALLY BAD. SAVE R0 .ASCIZ /?M-SYS ERR/ ;PRINT THIS MESSAGE .EVEN 9$: .PRINT ;DO THE PRINT MOV (SP)+,R0 ;RESTORE BLOCK NUMBER 10$: JSR PC,$SYS ;AND KEEP TRYING DESPERATELY BCS 10$ ;UNTIL IT SUCCEEDS 11$: JMP MEXIT2-KMON(R2) ;ENTER THE KMON 50$: MOV CNTXT,R0 ;FLUSH OUTPUT BUFFER 51$: TSTB I.OCTR(R0) ;DONE? BNE 51$ ;LOOP BIS #NORUN$,@CNTXT ;DO NOT LET HIM RUN AGAIN ADDR TTIUSR,R4 ;THROW AWAY THE TTY JSR PC,CTRL.B ;BY GIVING IT TO THE BG JMP USWAPO ;SAY GOODNIGHT, DICK. .DSABL LSB SWPERR: .HRESET ;STOP EVERYTHING CLR @#USERTOP ;DON'T TRY TO WRITE THE GUY OUT JSR R0,ERRXIT ;PRINT ERROR AND EXIT .ASCIZ /?M-SWAP ERR/ .EVEN UABTLK: JMP UABORT ;GO TO ABORTER .SBTTL SWAP USR ROUTINE ; CALUSR---- ; THIS ROUTINE LOADS THE USR INTO CORE. ; THE USER PROGRAM IS SWAPPED OUT IF NECESSARY. .ENABL LSB CALUSR: JSR PC,ENQUSR ;OWN THE USR BEFORE USING IT INCB USRLVL ;BUMP USAGE COUNT TST USRLOC ;MONITOR IN CORE? BNE 4$ MOV $USRLC,-(SP) ;IF NOT FLOATING, IT GOES HERE TST USRSWP ;FLOAT? BEQ 3$ ;NO, READ IN A GOOD PERM COPY MOV @#UFLOAT,@SP ;ADDRESS OF FLOATING USR BEQ 1$ ;DOESN'T FLOAT. SEE IF RESIDENT. JSR R5,CHKSP ;CHECK LOW LIMIT BR 90$ ;ERROR ADD #USRSIZE-2,@SP ;CHECK TOP LIMIT JSR R5,CHKSP ;CHECK HIGH LIMIT BR 90$ SUB #USRSIZE-2,@SP ;FIX ADDRESS BR 2$ ;OK, CONTINUE 1$: TST JOBNUM ;ONLY BG CAN SWAP IN STANDARD PLACE BNE 90$ ;AND THIS ISN'T HE MOV $USRLC,@SP ;AH. SWAP IT THERE 2$: MOV (PC)+,R5 ;POINT TO IOB FOR SYSTEM WRITE SWOPTR: .WORD SWOIOB ;*** BOOT *** MOV @SP,@R5 ;PUT IN ADDRESS OF BUFFER JSR PC,$SYSSW ;DO I/O TO SWAP BLOCKS BCS SWPERR ;SWAP ERROR 3$: MOV (PC)+,R5 ;POINT TO IOB FOR SYSTEM READ SWIPTR: .WORD SWIIOB ;*** BOOT *** MOV (PC)+,R0 ;GET BLOCK NUMBER OF USR $MONBL: .WORD 0 ;*** BOOT *** MOV @SP,@R5 ;PUT IN ADDRESS OF AREA JSR PC,$SYS ;DO THE I/O BCS SWPERR ;OOPS, GOT AN ERROR MOV (SP)+,USRLOC ;WE NOW HAVE A GOOD USR COPY IN CORE 4$: RTS PC ;RETURN WITH USR IN CORE 90$: CMP (SP)+,(SP)+ ;PRUNE MONERR USRX,,FATAL ;ATTEMPT TO SWAP USR INTO ILLEGAL AREA ; "WELL, IT'S BLAST-OFF TIME FOR GALACTO-CITY." - PERRY RHODAN RDOVLY: CLR KMONIN ;KMON DEAD AS SOON AS READ STARTS JSR PC,$SYS ;THE KMON SET UP KMBLK FOR FINAL READ BCS SWPERR ;BAD SAVE FILE, GIVE '?M-SWAP ERR' ENTRPG: MOV @#USERSP,SP ;NEW STACK POINTER CLR KMONIN ;USER IS RUNNING ;DV16 CLRB USRLVL ;GET RID OF THE USR MOV R2,-(SP) ;SET TO RETURN TO THE USER START ADDRESS BR DEQUSR ;AND RELEASE THE USR WITH NO SWAPPING .DSABL LSB .SBTTL ENQ / DEQ ON USR ; THE FOLLOWING SUBROUTINE OBTAINS EXCLUSIVE USE OF THE USR ; FOR THE RUNNING JOB. IT IS CALLED FROM USER STATE WITH A JSR PC,ENQUSR ; AND MAY SWITCH INTO SYSTEM STATE IF IT HAS TO WAIT. ; IN ANY CASE, IT INCREMENTS THE USR LEVEL OF CALL ENQUSR: CMPB JOBNUM,USROWN ;DO WE OWN IT ALREADY? BEQ 1$ ;YEP ENSYS ENQUSR ;NO, ENTER SYSTEM STATE TO GET IT CMPB USROWN,#377 ;IS IT FREE? BNE 2$ ;NO, DELAY UNTIL IT IS OURS MOVB JOBNUM,USROWN ;YES. STAKE OUR CLAIM 1$: RTS PC ;GET OUT OF SYSTEM STATE 2$: JMP DLYUSR ;JUMP TO DELAY CODE ; SWAP USR OUT IF NECESSARY, THEN FREE IT RIDUSR: BIC #USRRN$+CSIRN$,@CNTXT CLRB USRLVL ;INSURE 0 LEVEL BIT #ABORT$,@CNTXT ;WAS ABORT REQUESTED DURING DIRECTORY OP? BNE UABTLK ;YEP. TST USRSWP ;IS THE USR SWAPPING? BEQ DEQUSR ;NO. DON'T SWAP. CLR BLKEY ;KILLS DIRECTORY IN CORE MOV SWIPTR,R5 ;POINT TO IOB FOR SYSTEM READ MOV SWOIOB,@R5 ;READ INTO SAME PLACE WE LAST WROTE USER BEQ 1$ ;NO READ DONE! JSR PC,$SYSSW ;DO I/O TO SWAP BLOCKS BCS SWPERR ;SWAPPING ERROR! CLR SWOIOB ;INDICATE NO USER IS OUT THERE 1$: CLR USRLOC ;USR NO LONGER IN CORE ; THIS ROUTINE RELEASES USE OF THE USR. ; IT DECREMENTS USR LEVEL, AND IF ZERO, RELEASES EXCLUSIVE USE ; OF IT AND GIVES IT TO ANY OTHER GUY WHO WANTS IT DEQUSR: CMPB JOBNUM,USROWN ;DO WE OWN THE USR? BNE 2$ ;NO, IGNORE ATTEMPTS TO DISOWN IT ENSYS 2$ ;GOTTA GIVE IT AWAY MOVB #377,USROWN ;MARK IT NOT IN USE MOV IMPLOC,R4 ;POINT TO IMPURE POINTERS ;DV16 1$: MOV -(R4),R5 ;GET AN IMPURE POINTER BEQ 1$ ;JOB NOT ACTIVE INC R5 ;END OF TABLE? BEQ 2$ ;YES. IT IS FREE BITB #USRWT$,-(R5) ;IS HE WAITING FOR THE USR? BEQ 1$ ;NO JSR R4,UNBLOK ;YES. LET A GUY RUN .WORD USRWT$ MOVB I.JNUM(R5),USROWN ;AND GIVE IT TO HIM 2$: RTS PC .SBTTL RESIDENT TELETYPE HANDLER .ENABL LSB TTCMPL+2-. ;OFFSET TO ABORT ENTRY 0 ;HANDLER HOLD FLAG TTLQE: 0 ;POINTER TO LAST Q ELEMENT TTCQE: 0 ;CURRENT Q ELEMENT MOV TTCQE,R3 ;R3 -> CQE MOV (R3)+,R4 ;R4 = BLOCK # MOV (R3)+,R1 ;R1 HAS JOB NUMBER SWAB R1 ;PUT IT IN PLACE ASR R1 ASR R1 ASR R1 BIC #177761,R1 ;ISOLATE NUMBER ADD PC,R1 ;POINT TO IMPURE AREA (PIC) MOV $IMPUR-.(R1),R2 ASL 2(R3) ;WORD COUNT -> BYTE COUNT BEQ TTCMPL ;0 => DONE SEEK BCS 5$ ;<0 => WRITE MOV R2,(PC)+ ;READ. SAVE IMPURE OF INPUT USER TTHIUS: 0 TST R4 ;IS THIS BLOCK 0? BNE TTHIN ;NO MOVB #'^,R4 ;YES. PUT A PROMPT IN HIS BUFFER JSR PC,TTOPT2 ; TTHIN IS ENTERED WHEN THE HANDLER IS FIRST CALLED, AND AGAIN ; EACH TIME THE RESIDENT SERVICE DETECTS A LINE DELIMITER. ; IT ATTEMPTS TO GET AS MANY LINES AS POSSIBLE OUT OF THE RING BUFFER TTHIN: MOV TTCQE,R3 ;R3 -> Q ELEMENT CMP (R3)+,(R3)+ ;ADVNACE TO BUFFER POINTER 1$: MOV TTHIUS,R2 ;R2 -> IMPURE AREA TST I.TTLC(R2) ;MAN GOTTUM LINE? BEQ 6$ ;NO JSR PC,IGET ;YES. GETTUM CHARACTER BEQ $RQABT ;^C ABORTS CMPB #'Z-100,R4 ;END OF FILE MARKER? BEQ 3$ ;YES MOVB R4,@(R3)+ ;PUT BYTE IN BUFFER DEC @R3 ;DECREMENT BYTE COUNTER BEQ 35$ ;EMPTY, GO COMPLETE IO INC -(R3) ;BUMP BUFFER POINTER BR 1$ ;LOOP 2$: INC -(R3) ;BUMP BUFFER POINTER 3$: CLRB @(R3)+ ;CLEAR AN UNFULFILLED BYTE DEC @R3 ;COUNT DOWN BNE 2$ ;KEEP GOING BIS #EOF$,@Q.CSW-Q.WCNT(R3) ;SET END OF FILE 35$: MOV R5,R3 ;PRESERVE R5 JSR PC,TTCMPL ;CALL COMPLETION MOV R3,R5 ;RESTORE R5 MOV R0,R4 ;PUT CHAR TO ECHO IN R4 6$: RTS PC ;RETURN TO TT OR MONITOR TTCMPL: CLR TTHIUS ;STOP USING THE TT: CLR TTHOUS ADDR TTCQE,R4 ;POINT TO CQE JMP COMPLT ;EXIT VIA COMPLETION 5$: MOV (R3)+,-(SP) ;REVERSE BUFFER POINTER AND BYTE COUNT MOV @R3,-(R3) ; SO THAT IT RESEMBLES THE MONITOR'S NEG (R3)+ ; RING POINTERS (AND CONVERT TO REAL MOV (SP)+,@R3 MOV R2,TTHOUS ;SAY WE ARE USING IT BR TTOENB ;TURN ON TTY IF NOT ALREADY ON .DSABL LSB ; GET A CHARACTER FROM A USER'S INPUT RING BUFFER ; ENTER WITH R2 -> IMPURE AREA, EXIT WITH CHARACTER IN R4 ; CONDITION CODES READ ZERO IF ^C READ IGET: ADD #I.IGET,R2 ;MOVE UP TO GET POINTER INC @R2 ;BUMP POINTER CMP (R2)+,@R2 ;TIME TO WRAP? BNE 1$ SUB #TTYIN,-2(R2) ;WRAP THE BUFFER 1$: MOVB @-(R2),R4 ;GET THE CHARACTER DEC -(R2) ;DECREASE THE COUNT JSR PC,EOLTST ;END OF LINE (^C, ^Z, LF) BNE 2$ DEC I.TTLC-I.ICTR(R2) ;DECREMENT # OF LINES LEFT CMPB #'C-100,R4 ;SET ZERO IF CTRL C 2$: RTS PC TTRSET: MOV @#JSW,R3 ;JSW IN R3 ;DV25 BIC #127777,R3 ;CLEAR ALL BUT TTSPC$ & TTLC$ ;DV25 BIT #TTSPC$,R3 ;IS SPECIAL BIT ON IN JSW? ;DV25 BEQ 1$ ;NO SPECIAL MODE ADD #I.ICTR-I.TTLC,R1 ;R1 -> CHAR COUNT FOR SPECIAL 1$: MOV R3,I.TERM(R5) ;SAVE TERMINAL STATUS OF JOB ;DV25 RTS PC ; PUT A CHARACTER OUT TO THE TT, WAITING IF NECESSARY TTOUT1: JSR R4,$SYSWT ;WAIT FOR ROOM IN OUTPUT BUFFER .WORD TTOWT$ CMPB #TTYOUT-1,@R2 ;SET CARRY IF STILL NO ROOM JSR PC,@(SP)+ ;COROUTINE RETURN TTOUT: MOV CNTXT,R2 ;POINT TO IMPURE AREA JSR PC,TTOPT2 ;CALL ROUTINE TO PUT IT OUT BCC 1$ ;GOT IT, RETURN BIT @R0,@#JSW ;NO ROOM. DOES HE WANT C-BIT? BEQ TTOUT1 ;TCBIT OFF, OR DOING .PRINT 1$: BIT (R0)+,R1 ;POP R0 WITHOUT CHANGING CARRY RTS R0 ;RETURN TO CALLER .SBTTL TTY INPUT INTERRUPT .ENABL LSB CTRL.C: JSR R5,ECHO0C ;TYPE A ^C AND CR/LF .BYTE CR,LF CMP R0,I.PTTI(R5) ;IS IT SECOND ^C? BNE TTINC3 ;NO. IGNORE IT FOR NOW. TST I.JNUM(R5) ;TYPED TO B/G? BNE 20$ ;BR IF NOT TST EXTFLG ;EXIT IN PROGRESS? BNE TTINC3 ;YES,SKIP THIS MOV $ENTRY+BA.NUM,R3 ;BA.SYS RESIDENT? BEQ 20$ ;BR IF NOT CLR 6(R3) ;STOP BATCH IF ACTIVE 20$: ; YES. ASK FOR AN ABORT WHEN WE ARE ABOUT TO RETURN FROM LEVEL 0 ; THE FOLLOWING ROUTINE REQUESTS THAT A USER BE ABORTED ; IT IS CALLED FROM SYSTEM STATE WITH R5 -> USER'S IMPURE AREA ; $RQABT: BIS #100000,INTACT ;SET 'ABORT PENDING' FLAG BIS #ABORT$,@R5 ;TURN ON ABORT REQUEST IN USER'S JSTAT RTS PC ;RETURN CTRL.Q: CLR XEDOFF ;ALLOW THE TYPER TO TYPE TSTB TTCNFG ;ARE WE SUPPOSED TO IGNORE THIS? BMI 2$ ;YES, GO DO OUR THING JSR PC,TTIDSP ;NO, GO PROCESS THE CHARACTER 2$: CLR @TTPS BR TTOENB ;INTERRUPT IT IF IDLE CTRL.B: MOV BCNTXT,R0 1$: MOV R0,@R4 ;SET NEW TTIUSR CMP -(R4),R0 ;IS NEW GUY ALSO TTOUSR? BEQ 3$ MOV R0,@R4 ;NO, GIVE HIM TELETYPE MOV I.TID(R0),-(R4) ;PRINT ID CHANGE TTOENB: MOV #IENABL,@TTPS 3$: RTS PC CTRL.F: MOV FCNTXT,R0 ;POINT TO FG IMPURE AREA BEQ 4$ ;NO FG! BIT #NORUN$,@R0 ;BE HE DEAD? BEQ 1$ ;NAY, HE LIVETH 4$: JSR R5,ECHO ;SMITE HIM WHO TYPETH ^F .BYTE 'F,'? ECHOCL: JSR R5,ECHO ;PUT OUT CR/LF .BYTE CR,LF RTS PC TTIINT: JSR R5,$INTEN ;* DO INTERRUPT COMMON ENTRY .WORD ^C&PR7 ; (LEVEL 4) JSR R3,SAVE30 ;SAVE REGS 3-0 MOV @TTKB,R0 ;CHARACTER TO R0 ;*** FOLLOWING LINE MODIFIED BY GT ON TO INTERCEPT INTERRUPTS *** SCLNK2: BIC #177600,R0 ;CLEAR PARITY BEQ 3$ ;EXIT ON NULLS. ADDR LIST,R2 ;POINT TO SPECIALS LIST MOV R2,R4 ;COPY POINTER FOR ^F, ^B MOV -(R4),R5 ;R4 -> TTIUSR (= R5) MOV R5,R1 ;COPY IMPURE PTR ADD #I.ICTR,R1 ;R1 -> INPUT RING COUNT BIT #TTLC$,I.TERM(R5) ;CONVERT TO UPPER CASE LEGAL? ;DV25 BNE 10$ ;NO, CONVERSION IS DISABLED. CMP R0,#'A+40 ;IF LOWER CASE, CONVERT BLT 10$ ;TO UPPER CASE CMP R0,#'Z+40 BGT 10$ BIC #40,R0 ;UPPER CASE CONVERSION. 10$: .DSABL LSB .ENABL LSB 2$: MOVB (R2)+,R3 ;OFFSET TO R3 BEQ TTINCC ;DONE SPECIALS IF ZERO ASLB R3 ;MAKE IT A WORD. DONE GENERALS? BEQ TTIDSP ;YES CMPB (R2)+,R0 ;A MATCH? BNE 2$ ADD R3,PC ;DO A NON-STANDARD JUMP TTIBASE: ;THIS IS USED TO BASE THE SPECIAL LIST .35$: CLR @R5 ;CLEAR PREVIOUS INPUT CHAR BR ECHOCL ;ECHO CR/LF CTRL.S: MOVB TTCNFG,XEDOFF ;SET X-ED OFF SWITCH BMI 4$ ;IF ENABLED, IT'S ON, SO RETURN TTIDSP: BIT #TTSPC$,I.TERM(R5) ;IS IT IN SPECIAL MODE? ;DV25 BEQ 2$ ;NO, FINISH PROCESSING FOR USER BR TTINC3 ;YES ALT: MOV #ESCAPE,R0 ;USE 33 CODE AS STANDARD TTINCC: CMP I.PTTI(R5),#RUBOUT ;WAS PREVIOUS A RUBOUT? BNE TTINC3 TST TTCNFG ;CONSOLE IS VT05? BMI TTINC3 ;YES, NO \ JSR R5,ECHO ;YES. TYPE \ FIRST .BYTE '\,0 TTINC3: CMP @R1,#TTYIN ;WILL IT FIT IN BUFF? BGE 25$ ;NO. MOV R0,R4 ;COPY CHAR. FOR ECHOING INC @R1 ;BUMP COUNT INC -(R1) ;BUMP INPUT POINTER CMP @R1,6(R1) ;TIME TO WRAP? BNE 6$ SUB #TTYIN,@R1 ;CYCLE THE BUFFER. 6$: MOVB R0,@(R1)+ ;PUT CHARACTER INTO BUFFER. JSR PC,EOLTST ;END OF LINE TEST BNE 7$ ;NOT EOL. INC I.TTLC(R5) ;BUMP LINE COUNT CMP TTHIUS,R5 ;IS HE USING THE TT: HANDLER FOR INPUT? BNE 7$ ;NO JSR PC,TTHIN ;YES, CALL THE HANDLER 7$: MOV R0,I.PTTI(R5) ;SAVE PREVIOUS CHAR. JSR R4,UNBLOK ; WE UNBLOCK HIM .WORD TTIWT$ BIT #TTSPC$,I.TERM(R5) ;DON'T ECHO IN SPECIAL MODE ;DV25 BNE 10$ JSR PC,TTOPT3 ;ECHO THE CHARACTER ; NOTICE THAT SINCE WE IGNORE THE CARRY, IF IT WON'T FIT IT ; WON'T ECHO 10$: ADD #LF-CR,R0 ;IS CHAR A CR? CMP #LF,R0 ;IF YES, PUT IN A LINE FEED BEQ TTINC3 4$: RTS PC CTRL.O: ADD #I.OCTR-I.ICTR,R1 ;R1 -> OUTPUT COUNT. CLRB (R1)+ ;CLEAR THE COUNT MOVB @R1,-(SP) ;GET FORMER ^O CONDITION CLRB (R1)+ ;TURN IT OFF TEMPORARILY MOV (R1),-4(R1) ;SET BUFFER PTRS. EQUAL. JSR R5,ECHO0C ;ECHO ^O CR LF .BYTE CR,LF COM @SP ;FLIP THE FLOP MOVB (SP)+,-(R1) ;AND SET IT UP BEQ 20$ ;TURNING IT ON IS EASY JSR R4,UNBLOK ;TURNING OFF TTY OUTPUT MEANS .WORD TTOWT$ ; INFINITE ROOM IN BUFFER 20$: RTS PC ;RETURN FROM INTERRUPT 25$: MOV #BELL,R4 ;DING HIM FOR OVERFLOW MOV R0,I.PTTI(R5) ;BUT BE WARY OF ^C ^C BR TTOPT4 ;GO DING .DSABL LSB .ENABL LSB CTRL.U: JSR PC,ECHOR0 ;ECHO ^U RUB: ADD #I.PTTI,R5 ;R5 -> PREVIOUS INPUT CHAR 30$: TST @R1 ;ANY CHARS TO DELETE? BEQ .35$ ;NO. MOVB @-(R1),R4 ;CHARACTER TO R4 JSR PC,EOLTST ;LINE TERMINATOR? BEQ .35$ ;NO. CMP @R1,-2(R1) ;NEED TO WRAP AROUND BACKWARDS? BNE 31$ ;NO ADD #TTYIN,@R1 ;YES. BUMP TO TOP OF BUFFER 31$: DEC (R1)+ ;BACK UP POINTER DEC @R1 ;DECREASE CHARACTER COUNT CMPB #'U-100,R0 ;ARE WE DOING ^U? BEQ 30$ ;YES. TRY ANOTHER RUBOUT TST TTCNFG ;NO, IT'S A RUBOUT. VT05? BPL 32$ ;NO, NORMAL ECHO JSR R5,ECHO ;YES, ECHO BS,SPACE,BS .BYTE BS,40 MOV #BS,R4 ;LAST ECHO BR TTOPT4 ;PUT IT OUT AND SAY BYE 32$: MOV R4,-(SP) ;SAVE CHAR BEING RUBBED CMP @R5,R0 ;WAS LAST A RUBOUT? BEQ 33$ ;YES MOV R0,@R5 ;REPLACE PREVIOUS CHARACTER TYPED JSR R5,ECHO ;NO, TYPE THE LEADING \ .BYTE '\,0 33$: MOV (SP)+,R0 ;RESTORE THE MOV R0,R4 ; CHARACTER TO DELETE BR TTOPT3 ;OUTPUT THE CHARACTER, EXIT .DSABL LSB .MACRO INLST LOC,CHAR .BYTE /2,CHAR .ENDM INLST ; TTOID POINTS TO A JOB ID AREA WHEN ONE IS BEING PRINTED. ; THE JOB ID IS "B>" FOR BACKGROUND, SIMILAR FOR FG. ; TTIUSR/TTOUSR POINT TO THE IMPURE AREAS OF THE JOBS CURRENTLY ; CONTROLLING THE TTY INPUT AND OUTPUT, RESPECTIVELY. TTOID: .WORD 0 ;POINTS TO ID WHEN ID PRINT IN PROGRESS TTOUSR: .WORD BKGND ;*** BOOT *** INITIALLY POINT TO BACKGROUND TTIUSR: .WORD BKGND ;*** BOOT *** LIST: INLST CTRL.C,'C-100 INLST CTRL.O,'O-100 INLST CTRL.S,'S-100 INLST CTRL.Q,'Q-100 LISTFB: INLST CTRL.F,'F-100 INLST CTRL.B,'B-100 .BYTE 200 ;END OF GENERAL LIST INLST CTRL.U,'U-100 INLST ALT,175 INLST ALT,176 INLST RUB,RUBOUT .BYTE 0 .EVEN .SBTTL TTY OUTPUT SUBROUTINES ; NOTE THAT THIS ROUTINE RETURNS CONDITION IN C BIT ; IT DOES NOT SWAP THE USER, SINCE IT MAY BE CALLED FROM INTERRUPT LEVEL .ENABL LSB ECHOR0: MOV #'^,R4 ;PUT OUT AN ^ JSR PC,TTOPT3 ;PUT OUT THE ^ MOV R0,R4 ;GET THE CONTROL CHAR BIS #100,R4 ;MAKE IT VISIBLE, FALL INTO PRINTER TTOPT3: CMP #'C-100,R4 ;REFUSE TO ECHO ^C BEQ 3$ CMP #ESCAPE,R4 ;SPECIAL INPUT ECHO OF ESCAPE BNE 10$ MOV #'$,R4 ;WHICH IS $ 10$: CMP #40,R4 ;IS IT PRINTABLE? BLOS TTOPT4 ;YES CMP #15,R4 ;SPECIAL RANGE? BLO ECHOR0 ;ECHO AS ^(R0) CMP #11,R4 ;OTHER END OF RANGE BHI ECHOR0 TTOPT4: MOV TTIUSR,R2 ;PUT CHARACTERS INTO INPUT OWNERS BUFF TTOPT2: ADD #I.OCTR,R2 ;POINT TO OUTPUT COUNT TST @R2 ;< 0 MEANS CONTROL O BMI 3$ ;YES. ACT LIKE SUCCESS BIC #177600,R4 ;EXTRANEOUS BITS OUT CMP #TTYOUT-1,@R2 ;WILL THIS FIT? BLO 3$ ;NO, RETURN CARRY SET (EVIL) MOVB R4,@-(R2) ;INSERT CHARACTER INTO RING INC @R2 ;BUMP THE POINTER CMP 6(R2),@R2 ;TIME TO WRAP AROUND? BHI 1$ SUB #TTYOUT,@R2 ;NOTE THAT THIS CLEARS THE CARRY 1$: INC 2(R2) ;BUMP COUNT JMP TTOENB ;ENABLE OUTPUT INTERRUPTS ECHO0C: JSR PC,ECHOR0 ;FIRST ECHO ^ [R0] ECHO: MOVB (R5)+,R4 ;ECHO 1 OR 2 BYTES JSR PC,TTOPT4 MOVB (R5)+,R4 BEQ 2$ ;ONLY ONE JSR PC,TTOPT4 ;PRINT THE OTHER 2$: RTS R5 EOLTST: CMPB #LF,R4 ;IS IT A LINE FEED? BEQ 3$ CMPB #'Z-100,R4 BEQ 3$ CMPB #'C-100,R4 ;IS IT ^C 3$: RTS PC .DSABL LSB .SBTTL TTY OUTPUT INTERRUPT .ENABL LSB OFILL: DEC NFILLS CLR @TTPB ;PUT OUT A NULL RTS PC TTOINT: JSR R5,$INTEN ;* DO USUAL INTERRUPT ENTRY .WORD ^C&PR7 ; CHECK FOR FILLERS SPECIFIED IN SYSCOM LOC. 56 TST (PC)+ ;FILLING? NFILLS: 0 BNE OFILL ;YEP TSTB (PC)+ ;XOFF GIVEN? XEDOFF: 0 BMI 9$ ;YEP ; CHECK FOR TAB TO SPACE CONVERSION FOON: ADDR FILCTR,R4 ;CHECK FOR TAB OR FREE CRLF INCB @R4 ;COUNT FILLS BMI 8$ ;STILL FILLING. PUT IT OUT CLRB (R4)+ ;FIX CTR, POP R4 MOV TTOID,R5 ;PRINTING AN ID? BEQ 3$ ;NO 1$: MOVB (R5)+,(R4)+ ;YES. SET CHAR OF ID BNE 2$ ;GOT ONE CLR R5 ;END OF ID 2$: MOV R5,TTOID ;SAVE NEW TTOID BNE 8$ ;PUT OUT CHARACTER DEC R4 ;FIX R4 3$: MOV TTOUSR,R5 ;GET USER'S IMPURE PTR CMPB @R4,#LF ;TIME TO ARBITRATE? BNE 5$ ;NO MOV IMPLOC,R4 ;YES, POINT TO JOB TABLES ;DV16 4$: MOV -(R4),R5 ;GET PTR BEQ 4$ ;NO SUCH JOB CMP #-1,R5 ;END OF TABLE? BEQ .20$ ;YES. NOBODY WANTS TO TALK BIT #NORUN$,@R5 ;DEAD MEN SPEAK NOT BNE 4$ CMP (PC)+,R5 ;IS HE USING THE TT: FOR OUTPUT? TTHOUS: 0 ;IMPURE AREA PTR FOR OUTPUT USER BEQ 45$ ;YES, ERGO HE CAN SPEAK TSTB I.OCTR(R5) ;A JOB. DOES HE HAVE OUTPUT? BEQ 4$ ;SILENT 45$: ADDR OUTCHR,R4 ;YES. FIX R4 POINTER CMP TTOUSR,R5 ;SAME GUY? BEQ 5$ ;YES. DO NOT PRINT ID MOV R5,TTOUSR ;NO, CHANGE USERS MOV I.TID(R5),R5 ;GET ID POINTER BR 1$ ;PRINT THE ID 5$: CMP TTHOUS,R5 ;IF HE IS USING THE HANDLER BEQ TTHOUT ; DO SPECIAL STUFF JSR R4,UNBLOK ;UNBLOCK THE LUCKY GUY .WORD TTOWT$ ADD #I.OTOP,R5 ;POINT TO RING POINTERS CMP @R5,-(R5) ;TIME TO WRAP? BNE 6$ ;NO SUB #TTYOUT,@R5 ;YES 6$: TSTB -2(R5) ;ANYTHING TO PRINT? BEQ .20$ ;NO MOVB @(R5)+,@R4 ;GET BYTE TO PRINT .65$: BICB #200,@R4 ;7 BIT ASCII CMPB (R4)+,#40 ;PRINTABLE? BLO .10$ ;MAYBE NOT INCB @R4 ;YES. BUMP LINE POSITION BIT #CRLF$,TTCNFG ;DOES HE WANT FREE CRLF'S? BEQ OBUMP ;NO, TYPE IT CMPB @R4,TTWIDTH ;OVER TT LINE WIDTH? BLOS OBUMP ;NOT YET CLRB @R4 ;YES. GIVE CR/LF. CLEAR LINPOS DEC R4 MOV #177000+LF,-(R4) ;1 FILL OF LF BR 8$ ;DO NOT CYCLE POINTERS OCKCR: CMPB (R4)+,#CR ;IS SPECIAL A CR? BNE OBUMP ;NO CLRB @R4 ;YES. CLEAR LINE POSITION OBUMP: INC -(R5) ;BUMP OUTPUT RING PTR DEC -(R5) ;COUNT DOWN CHARACTERS 8$: MOVB -(R4),@TTPB ;PRINT CMPB @R4,@#TTFILL ;NEED FILLERS? BNE 9$ ;NO MOVB @#TTNFIL,NFILLS ;YES. SET EM UP 9$: RTS PC ;RETURN FROM INTERRUPT .DSABL LSB TTHOCM: JSR PC,TTCMPL ;CALL COMPLETION FUNCTION FOR TT: OUTPUT BR FOON ;AND TRY THE INTERRUPT AGAIN .ENABL LSB .10$: CMPB -(R4),#TAB ;A TAB? BEQ 11$ ;YES CMPB (R4)+,#BS ;NO. A BACKSPACE? BEQ 14$ ;YES CMPB -(R4),#FF ;IS IT A FORM FEED? BNE OCKCR ;NO, GO CHECK FOR CR BIT #FORM$,TTCNFG ;DOES HE HAVE HARDWARE FORM? BNE 13$ ;YES, DO NOT SIMULATE MOV #174000+LF,-(R4) ;SIMULATE EIGHT FORM FEEDS BR 13$ ;FIX R4 11$: BIT #HWTAB$,TTCNFG ;HARDWARE TABS? BNE 12$ ;YES MOV @R4,-(R4) ;MOVE LINPOS TO FILLCTR CLRB @R4 ;BLANKS BIS #174000+40,@R4 ;SET TO FILL WITH BLANKS 12$: ADD #8.*400,LINPOS-1 ;FIX UP LINE POSITION BIC #7*400,LINPOS-1 13$: INC R4 ; BUMP POINTER BR OBUMP ;PUT IT OUT 14$: TST TTCNFG ;VT05 MODE ON? BPL OBUMP ;NO DECB @R4 ;YES. BACK UP BR OBUMP .20$: CLR @TTPS ;NO OUTPUT. TURN OFF TTY RTS PC TTHOUT: TST I.OCTR(R5) ;IF HE HIT ^O BMI TTHOCM ;COMPLETE VERY QUICKLY MOV TTCQE,R5 ;POINT TO Q ELEMENT ADD #Q.BUFF-Q.BLKN,R5 ;POINT TO BYTE COUNT TTHOU1: TST (R5)+ ;OUTPUT COMPLETE? BEQ TTHOCM ;YEAH MOVB @(R5)+,@R4 ;GET A BYTE BNE .65$ ;PRINT NON NULLS INC -(R5) ;BUMP BYTE POINTER DEC -(R5) ;DROP CHAR COUNTER BR TTHOU1 ;LOOP .DSABL LSB .SBTTL SPECIAL FUNCTIONS, RCVD, READ ; SPECIAL FUNCTION CALLS LOOK LIKE READ EMT'S, BUT THE 3RD ; WORD OF THE ARG LIST IS IN THE FORM .BYTE 377,CODE ; WHERE CODE IS THE FUNCTION TO BE DONE. WORD 4 CONTAINS THE ACTUAL ; COMPLETION FUNCTION S$PFUN: MOV @R3,R2 ;GET CSW STATUS WORD BIC #177701,R2 ;ISOLATE DEVICE INDEX ADD PC,R2 ;PIC CODE IS FUN BIT $STAT-.(R2),#SPFUN$ ;IS THIS A SPECIAL DEVICE? ;DV17 BEQ RWXT ;YUP. IGNORE THE STRANGE CALL CMP (R1)+,(R1)+ ;ADVANCE R1 TST @R1 ;DID HE SHIP US A POSITIVE CODE? BPL RWXTE0 ;YUP. SHIP HIM BACK AN ERROR 0 MOVB #377,@R1 ;MAKE SURE THE 377 IS THERE MOV 2(R1),R2 ;R2 = COMPLETION FUNCTION JSR R4,TSWSPC ;DO COMMON STUFF BR SPREAD ;BRANCH TO SPECIAL READ ENTRY ; "I'M QUITE ILLITERATE, BUT I READ A LOT." ; - J.D. SALINGER, "THE CATCHER IN THE RYE" .ENABL LSB ; RCVD POINTS R3 TO THE PSEUDO MESSAGE CHANNEL IN THE IMPURE AREA, ; AND FALLS INTO THE NORMAL READ CODE. IF THE OTHER JOB ISN'T PRESENT, ; ERROR 0 IS GENERATED AS IF FROM A READ REQUEST. R$CVD: JSR PC,OTHRJB ;GET POINTER TO OTHER JOB BEQ 5$ ;IT DOESN'T EXIST MOV R5,R3 ADD #I.MSG,R3 R$EAD: MOV 4(R1),R2 ;R2 = COMPLETION FUNCTION JSR R4,TSWCNT ;DO SOME CHECKING NOP ;NON-FILE OR DIRECTORY. IGNORE FACT NOP ;IGNORE IF READ WAS SHORTENED SPREAD: MOV R4,@SP ;SET WORD COUNT FOR R0 1$: TST -(R1) ;FIX PTR TO ARG LIST BIT #HDERR$,@R3 ;HARD ERROR? BNE 6$ BIT #EOF$,@R3 ;END OF MEDIUM? BNE 4$ MOV R1,R5 ;POINT R5 TO ARG LIST MOV (R3),R2 ;ISOLATE ENTRY VALUE OF HANDLER BIC #177701,R2 ADD PC,R2 ;IN A PIC MANNER, MOV $ENTRY-.(R2),R2 ;POINT TO ENTRY POINT BEQ 2$ ;NO HANDLER! ZOUNDS, MAN! ADD C.SBLK(R3),R0 ;MAKE BLOCK ABSOLUTE. MOV C.DEVQ(R3),R1 ;UNIT # TO R1 CLRB R1 JSR PC,QMANGR ;QUEUE AN ENTRY BIT #HDERR$,(R3) ;HARDWARE GOOF? BNE 6$ RWXT: MOV #3,R2 ;3 ARGUMENTS TO CLEAN UP JMP EMTDON 2$: MONERR NODV ;NO DEVICE HANDLER BR RWXT 3$: TST (SP)+ ;PURGE STACK 4$: BIC #EOF$,(R3) ;CLEAR EOF BIT RWXTE0: 5$: EMTERR+0 BR RWXT 6$: BIC #HDERR$,(R3) ;CLEAR ERROR BIT EMTERR+1 BR RWXT 7$: TST (SP)+ 8$: EMTERR+2 BR RWXT .SBTTL SDAT, WRITE ; SDAT IS SIMILAR TO WRITE. R3 IS POINTED TO THE OTHER JOB'S ; CHANNEL AND THEN A WRITE IS EXECUTED ON THE MESSAGE ; PSEUDO CHANNEL. IF THE OTHER JOB IS NOT IN CORE, ; THE ERROR 0 RETURN IS TAKEN. S$DAT: JSR PC,OTHRJB BEQ 5$ ;NO RECEIVER PRESENT MOV R5,R3 ;R5 RETURNS POINTING TO THE ADD #I.MSG,R3 ;OTHER'S IMPURE AREA ; "THEIR MANNER OF WRITING IS VERY PECULIAR, BEING NEITHER FROM THE ; LEFT TO THE RIGHT, LIKE THE EUROPEANS; NOR FROM THE RIGHT TO THE ; LEFT, LIKE THE ARABIANS; FROM UP TO DOWN, LIKE THE CHINESE; NOR ; FROM DOWN TO UP, LIKE THE CASCAGIANS" ; - J. SWIFT, "GULLIVER'S TRAVELS" W$RITE: MOV 4(R1),R2 ;R2 = COMPLETION FUNCTION JSR R4,TSWCNT BR NFWRIT ;NON FILE OR DIRECTORY OP. EMTERR+0 ;GIVE ERROR IF SHORTENED, BUT DO IT CMP R5,C.USED(R3) ;CHECK FOR GOING OVER HIGHEST WRITTEN BLOS NFWRIT BIT #DWRIT$,@R3 ;ENTERED ? BEQ NFWRIT ;NO MOV R5,C.USED(R3) NFWRIT: MOV R4,@SP ;WORD COUNT FOR R0 NEG R4 ;MAKE IT A WRITE BR 1$ ;DO COMMON STUFF .SBTTL READ/WRITE COMMON ROUTINE ; "'SO IT DOES!' SAID POOH. 'IT GOES IN!' ; 'SO IT DOES!' SAID PIGLET. 'AND IT COMES OUT!' ; 'DOESN'T IT?' SAID EEYORE. ; -A.A. MILNE, "WINNIE THE POOH" ; TSWCNT DOES VALIDITY CHECKING FOR THE READ/WRITE EMTS. ; THE NUMBER OF CHANNELS IS CHECKED, AS WELL AS THE ; BUFFER TRANSFER ADDRESSES. R1 IS A POINTER TO THE ; ARGUMENTS FOR THE OPERATION. R3 IS THE CHANNEL AREA ; POINTER. IF THE STARTING BLOCK OF A CHANNEL ; IS 0, THE OPERATION IS EITHER NON-FILE STRUCTURED, OR ; A DIRECTORY OPERATION. IN EITHER CASE, THE OPERATION IS ; ALLOWED TO PROGRESS. TSWCNT: MOV (R1)+,@SP ;BUFFER ADDRESS TO OLD R4 ;(EMT DISPATCHER ALREADY CHECKED THIS) MOV (R1)+,-(SP) ;COMPUTE LAST WORD OF XFER BEQ 85$ ;DON'T MESS UP SEEK DEC @SP ;(NOT FIRST WORD AFTER IT) ASL @SP ;(WORD COUNT!) 85$: ADD (SP)+,@SP JSR R5,CHKSP ;VALIDITY OF END ADDRESS BR TSERR TSWSPC: CMP R2,#1 ;DOING COMPLETION IO? BLOS 9$ MOV R2,@SP ;YES. CHECK ADD. OF ROUTINE JSR R5,CHKSP BR TSERR ;BAD ADDRESS 9$: MOV -(R1),R5 ;WORD COUNT TO R5 MOV R5,@SP ;RETURN W.C. IN R4 MOV @R3,R2 ;GET DEVICE INDEX IN R2 BPL 7$ ;GT MEANS CHANNEL CLOSED! BIC #177701,R2 ;ISOLATE INDEX ADD PC,R2 ;PICLY, TST $STAT-.(R2) ; SEE IF FILE STRUCTURED DEVICE BPL TSWOUT ;NO. LET XFER GO. BIC #EOF$,@R3 ;CLEAR EOF BIT FOR FILE DEV. TST C.SBLK(R3) ;START BLOCK 0? BEQ TSWOUT ;YES. PROBABLE DIRECTORY OP. CMP (R4)+,(R4)+ ;BUMP TO LEGAL RETURN. MOV C.LENG(R3),R2 ;GET # OF BLOCKS IN FILE CMP R0,R2 ;IS R0 LEGAL BLOCK? BHIS 3$ ;NO. GIVE EOF ERROR. ADD #377,R5 ;CHANGE WORDS TO BLOCKS CLRB R5 SWAB R5 ADD R0,R5 ;WILL XFER REACH EOF? SUB R5,R2 BPL TSWOUT ;NO. IT ALL FITS. ADD R2,R5 MOV R5,(SP) ;GIVE BACK WHAT WE READ SUB R0,(SP) SWAB (SP) TST -(R4) ;BACK OFF TO SHORTENED RETURN TSWOUT: RTS R4 TSERR: TST (SP)+ MONERR ADDR ;GIVE ERROR BR RWXT ;AND ABORT OPERATION .DSABL LSB .SBTTL SAVESTATUS ,REOPEN, WAIT, MWAIT, CSTATUS, GTJB S$AVST: TST @R3 ;IS THIS CHANNEL OPEN? BPL 1$ ;NO. SAVE 'NOT OPEN' STATUS TSTB @R3 ;WAS AN 'ENTER'DONE? BMI E5ER1 ;YES. NO SAVESTATUS PERMITTED 1$: MOV @R3,(R0)+ ;CHANNEL STAT. WORD CLR (R3)+ ;DEACTIVATE CHANNEL. .REPT 4 ;FILL IN REMAINING DATA MOV (R3)+,(R0)+ .ENDR XCLOSE: JMP EMTRTI R$OPEN: TST @R3 ;CHANNEL CAN'T BE IN USE BMI E5ER0 ;AMAZING! REOPEN IS INVERSE OF SAVE! .REPT 5 ;REPLACE THE WORDS MOV (R0)+,(R3)+ .ENDR BR XCLOSE E5ER0: EMTERR+0 BR XCLOSE ; EMT12--WAIT ON I/O. THIS EMT RETURNS AN ERROR IF THE ; CHANNEL IS NOT ACTIVE, GIVING A WAY TO CHECK TO SEE IF ; A CHANNEL IS CURRENTLY IN USE. M$WAIT: MOV R5,R3 ;POINT TO MESSAGE CHANNEL ADD #I.MSG,R3 W$AIT: TST @R3 ;CHANNEL ACTIVE? BPL E5ER0 ;>0=> NO JSR PC,CHWAIT ;YES, SWAP OUT & WAIT BIT #HDERR$,@R3 ;WAS THERE AN ERROR? BEQ XCLOSE ;NO. RETURN TO USER BIC #HDERR$,@R3 ;YES. CLEAR HARD ERROR BIT E5ER1: EMTERR+1 BR XCLOSE ; GET JOB PARAMETERS OF RUNNING JOB ; RETURNS JOB NUMBER, HIGH LIMIT, LOW LIMIT G$TJB: MOV JOBNUM,R1 ;GET JOB NUMBER MOV R1,(R0)+ ;GIVE IT HIM ASL R1 ;DOUBLE FOR TABLE REFERENCE ADDR $JBLIM,R1,ADD ;POINT TO LIMIT TABLE MOV (R1)+,(R0)+ MOV (R1)+,(R0)+ MOV I.CSW(R5),(R0)+ ;START OF CHANNEL AREA BR XCLOSE ; CHANNEL STATUS ; RETURNS CSW, START BLOCK OF FILE, LENGTH, HIGHEST BLOCK WRITTEN, ; UNIT #, RAD50 OF ASSOCIATED DEVICE C$STAT: MOV @R3,R4 ;GET DEVICE INDEX BIC #^C<76>,R4 MOV (R3)+,(R0)+ ;CSW BPL E5ER0 ;ERROR, CHANNEL INACTIVE MOV (R3)+,(R0)+ MOV (R3)+,(R0)+ MOV (R3)+,(R0)+ MOV @R3,@R0 ;UNIT NUMBER CLRB @R0 SWAB (R0)+ ADD PC,R4 ;GET PIC DEVICE NAME MOV $PNAME-.(R4),(R0)+ BR XCLOSE .SBTTL ADDRESS CHECK, GET OTHER JOB NUMBER ;********************************************************************** ; CHKSP CHECKS THE ADDRESS ON THE STACK FOR VALIDITY ; THE CALLING SEQUENCE IS: ; TOP OF STACK = ADDR TO BE CHECKED ; JSR R5,CHKSP ; ERROR RETURN ; NORMAL RETURN ; THE ERROR RETURN IS TAKEN IF THE ADDRESS IS OUT OF BOUNDS OR ODD CHKSP: MOV R2,-(SP) ;PRESERVE R2 MOV 4(SP),-(SP) ;PUT ARG CLOSER. BEQ 1$ ;LET ADDRESS 0 ALONE BIT #USRRN$+CSIRN$+BATRN$+CMPLT$,@CNTXT ;IS USR RUNNING? BGT 1$ ;YES BIT #1,(SP) ;IS IT ODD? BNE 2$ MOV JOBNUM,R2 ;CHECK IT AGAINST LIMITS BNE 10$ ;NOT BG, CANNOT BE KMON TST KMONIN ;KMON DOING IT? BNE 1$ ;YES, ASSUME IT'S SMARTER THAN US 10$: ASL R2 ;$JBLIM IS 2 WORDS/ENTRY ADDR $JBLIM,R2,ADD ;R2 TO LIMIT CMP (SP),(R2)+ ;ABOVE UPPER LIMIT? BHIS 2$ CMP (SP),(R2) ;BELOW LOW LIMIT? BLO 2$ 1$: TST (R5)+ ;ADVANCE TO NON-ERROR RETURN 2$: TST (SP)+ ;REMOVE STACK THING MOV (SP)+,R2 ;RESTORE R2 RTS R5 ;********************************************************************** ; OTHRJB MUST BE CHANGED WHEN RT11 EXPANDS TO MORE THAN 2 JOBS ; IT ENABLES US TO GET THE IMPURE POINTER TO ; THE ONLY OTHER JOB THAT CAN BE IN THE SYSTEM. ; THE CALL IS: ; JSR R5,OTHRJB ; ERROR RETURN ;NO OTHER JOB AROUND ; NORMAL RETURN ; ON RETURN, R2 POINTS TO THE IMPURE AREA OF THE JOB. OTHRJB: MOV JOBNUM,R2 ;GET CURRENT JOB # NEG R2 ;OTHER JOB IS 4-THISJOB ADD PC,R2 ;GET OTHER IMPURE POINTER MOV $IMPUR+2-.(R2),R2 RTS PC ;RETURN ZERO CONDITION IF NO JOB .SBTTL SAVE 3-0 SAVE30: MOV R2,-(SP) ;SAVE REGS 3 - 0. CALLED BY JSR R3,SAVE30 MOV R1,-(SP) MOV R0,-(SP) JSR PC,@R3 ;CALL CALLER MOV (SP)+,R0 ;RESSTORE REGS MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 RTS PC .SBTTL MESSAGE HANDLER ;************************************************** ; THIS IS THE MESSAGE HANDLER FOR RT11. IT IS ; SET UP TO LOOK LIKE A DEVICE HANDLER, AS THAT IS ; INDEED THE NEATEST WAY TO SEND MESSAGES IN ; THE SYSTEM. THE BASIC OPERATION IS AS FOLLOWS: ; ON ENTRY, IF THERE IS NO MATCHING OPERATION ; WAITING FOR THIS ENTRY, THE CURRENT OP IS ; STORED IN THE INTERNAL Q OF WAITING REQUESTS. ; IF A MATCHING OPERATION IS FOUND, THE MESSAGE TRANSFER ; IS MADE, AND THE Q ELEMENTS USED ARE FREED FOR ; USE AGAIN. .ENABL LSB .WORD 0,0 JBLQE: .WORD 0 ;LAST ENTRY IN QUEUE JBCQE: .WORD 0 ;CURRENT Q ENTRY MOV JBCQE,R3 ;PICK UP CURRENT ENTRY TST (R3)+ ;POINT TO UNIT # MOV (R3)+,R4 ;UNIT # INTO R4 TST (R3)+ ;POINT TO WORD COUNT SWAB R4 ASR R4 ;SHIFT TO GET JOB # ASR R4 ASR R4 BIC #177761,R4 ;ISOLATE JOB NUMBER MOV R4,-(R3) ;SAVE IN UNUSED SLOT IN Q ELEM. TST @R3 ;BUT CHANGE QUEUES ON A WRITE BPL 1$ NEG R4 ;CHANGE 2 TO 0, 0 TO 2 ADD #2,R4 1$: ADDR JBQ,R4,ADD ;POINT R4 TO INTERNAL LIST HEADERS MOV @R4,R0 ;POINTER TO WAITING ELEMENT TO R0 BEQ 25$ ;NONE THERE. STORE ONE MOV @R0,R1 ;WHAT IS WAITING OPERATION? BPL 15$ ; >0 => RCVD WAITING. WE NEED A ;SDAT TO COMPLETE. CHECK FOR ONE. MOV @R3,R1 ;SDAT WAITING. IS THIS RCVD? BMI 20$ ;NO. ANOTHER SDAT. BEQ 10$ ;DON'T MESS WITH SEEKS! MOV -(R3),R2 ;R1=WD COUNT. R2=ADD TO READ TO MOV @R0,@R2 ;AMOUNT SENT IN SDAT MOV -(R0),R0 ;R0=BUFF TO WRITE FROM ;R2=BUFF TO READ TO ;R1=WORD COUNT TO XFER 3$: NEG (R2)+ ;RETURN AMOUNT SENT IN FIRST ;WORD OF THE BUFFER OF RECEIVER 5$: MOV (R0)+,(R2)+ DEC R1 BNE 5$ MOV @R4,R0 ;REMOVE ELEMENT FROM OUR LIST SUB #12,R0 ;POINT R0 TO START OF Q ELT TO FREE MOV @R0,@R4 ;ADVANCE INTERNAL QUEUE CLR (R0)+ ;CLEAR LINK IN ELEMENT SO WE DON'T REENTER TST (R0)+ ;NOW R0 -> 3RD WORD OF ELT (NORMAL CQE) ADDR JBCQE,R4 ;FREE THE SAVED ONE FIRST MOV (R4),-(SP) MOV R0,(R4) CLR -4(R0) ;AND CLEAR THIS LINK WORD (SHOULD BE 0) JSR PC,COMPLT ;THIS FREES THE ENTRY MOV (SP)+,JBCQE ;NOW FREE THE CURRENT ONE 10$: ADDR JBCQE,R4 JMP COMPLT ;FREE THIS ELEMENT 15$: BEQ 10$ ;0 WORDS TO TRANSFER TST @R3 ;RCVD WAITING. THIS A SDAT? BPL 20$ ;ANOTHER RCVD. STORE IT MOV -(R0),R2 ;RECEIVER'S BUFFER MOV @R3,@R2 ;RETURN THE AMOUNT SENT MOV -(R3),R0 ;SENDER'S BUFFER BR 3$ ;DO COMMON STUFF 19$: MOV R1,R0 ;LOOK AT NEXT ELEMENT 20$: SUB #12,R0 ;BACK UP TO REAL LINK WORD MOV @R0,R1 ;LINK FORWARD TO END OF QUEUE BNE 19$ ;KEEP GOING MOV R3,@R0 ;END. LINK LAST ELEMENT TO US ;TO THE WAITING WORD COUNT 22$: CLR -12(R3) ;ZERO LAST LINK WORD CLR JBLQE CLR JBCQE JBRTS: RTS PC ;1/2 DONE. WAIT FOR A CONNECTION 25$: MOV R3,@R4 ;STORE THE FIRST ELEMENT BR 22$ ; THIS ROUTINE IS CALLED FROM IORSET. IT FLUSHES ALL ; QUEUE ELEMENTS THAT MAY BE SITTING IN THE MESSAGE ; PROCESSORS INTERNAL QUEUE. JBABRT: MOV CNTXT,R0 ;R0 -> IMPURE AREA JSR R3,24$ ;SAVE R3, POINT TO JBQ JBQ: .WORD 0,0,-1 ;THIRD WORD IS STOPPER 24$: MOV R3,R1 ;R1 -> LAST LINK MOV (R3)+,R2 ;R2 -> FIRST ELEM BEQ 24$ ;BR IF IT EXISTS CMP R2,#-1 ;END OF TABLE? BNE 26$ ;NO, SEARCH THE QUEUE TST (SP)+ ;ELSE WE'RE DONE. RTS PC 26$: SUB #12,R2 ;ADJUST R2 -> TOP OF ELEM. CMP Q.BLKN(R2),JOBNUM ;ORIGINATED BY ABORTED JOB? BNE 27$ ;BR IF NOT CORRECT JOB # DEC I.IOCT(R0) ;DECREMENT PENDING I/O COUNT MOV @R2,@R1 ;AND LINK AROUND IT BEQ 24$ ;BR IF END OF THIS Q MOV @R2,R2 ;R2 -> NEXT ELEMENT BR 26$ 27$: MOV R2,R1 ;CHECK NEXT ELEM MOV @R2,R2 ;R2 -> NEXT ELEM, R1 -> PREV. BEQ 24$ ;BR IF END OF Q BR 26$ .DSABL LSB .SBTTL SYSTEM I/O HANDLER ; ALL IO REQUESTS FOR A PARTICULAR DEVICE ARE PUT INTO A QUEUE, ; AND THE INDIVIDUAL DEVICE DRIVERS TAKE THEIR JOBS FROM THAT QUEUE ; THE ENTRY POINT FOR MONITOR IO REQUESTS IS $SYS. ; THIS ENTRY SAVES ALL REGISTERS, AND CALLS THE Q MANAGER $SYSSW: MOV $SWPBL,R0 ;ENTER HERE TO DO I/O TO SWAP BLOCKS $SYS: JSR R3,SAVE30 ;SAVE REGISTERS ADD #$SYSCH-.,R3 ;POINT TO SYSTEM CHANNEL MOV R4,-(SP) MOV R5,-(SP) MOV SYUNIT,R1 ;UNIT # OF SYS. MOV (PC)+,R2 ;LAST Q ENTRY FOR SYS SYENTR: .WORD 0 SYENTO = SYENTR - $RMON ;COMPUTE OFFSET FOR BOOTSTRAP MOV 2(R5),R4 ;WORD COUNT IN R4 JSR PC,QMANGR ;Q A REQUEST MOV (SP)+,R5 ;RESTORE REGS MOV (SP)+,R4 ROR $SYSCH ;SEE IF ERROR IS ON RTS PC .SBTTL QUEUE MANAGER ; THE Q MANAGER IS ENTERED WHEN AN IO REQUEST IS TO BE PUT IN ; THE Q. ; CALLING SEQUENCE: ; JSR PC,QMANGR ; REGISTERS: ; 0 BLOCK # TO READ/WRITE ; 1 UNIT NUMBER IN LOW BITS OF ODD BYTE ; 2 POINTS TO 4TH WORD OF HANDLER ; 3 POINTER TO CHANNEL STATUS WORD ; 4 WORD COUNT ; 5 POINTER TO ARGUMENT LIST .ENABL LSB QMANGR: MOV R4,-(SP) ;SAVE REGS MOV R1,-(SP) MOV CNTXT,R1 ;POINT TO IMPURE AREA TST (R1)+ ;R1 -> HEAD OF AVAIL QUEUE QGTELT: SPL 7 ;GET Q ELT AT PRIORITY 7 MOV @R1,R4 ;* POINT TO AN ELEMENT BEQ QFULL ;* NO ELEMENTS THERE MOV @R4,@R1 ;* ADVANCE QUEUE SPL 0 ;* AND REENABLE INTERRUPTS INC I.IOCT-2(R1) ;INCREMENT # OF REQUESTS CLR (R4)+ ;CLEAR LINK WORD MOV R3,(R4)+ ;FILL IN PTR TO CSW INCB 10(R3) ;BUMP CHANNEL REQUEST COUNTER MOV R0,(R4)+ ;BLOCK # MOV (SP)+,@R4 ;UNIT # CLRB @R4 ;CLEAN OUT LOW BYTE MOV JOBNUM,R0 ;GET JOB # SWAB R0 ;PUT IT IN THE RIGHT BITS ASL R0 ASL R0 ASL R0 BIS R0,(R4)+ ;OR IN THE JOB NUMBER MOV (R5)+,(R4)+ ;BUFFER ADDRESS MOV (SP)+,(R4)+ ;WORD COUNT TST (R5)+ ;(SKIP R5 OVER W.C.) MOV (R5)+,@R4 ;COMPLETION CMPB @R4,#377 ;SPECIAL FUNCTION FOR MT/CT? BNE 1$ ;NO MOVB 1(R4),Q.FUNC-Q.COMP(R4) ;YES, PUT IN FUNCTION BYTE MOV (R5)+,@R4 ;AND PUT IN REAL COMPLETION FUNCTION 1$: ADD #Q.BLKN-Q.COMP,R4 ;FIX R4 TO POINT TO PROPER WORD MOV R3,-(SP) ;SAVE CSW POINTER ENSYS 10$ ;ENTER SYSTEM STATE MOV R2,R1 ;COPY HANDLER POINTER BIS #100000,-(R1) ;HOLD THE HANDLER TST (R2)+ ;IS LQE = 0? BNE 2$ ;NO, THE HANDLER IS ACTIVE CLR (R1)+ ;YES. UNHOLD THE HANDLER MOV R4,(R1)+ ;SET LQE MOV R4,(R1)+ ;SET CQE JMP @R1 ;GO TO HANDLER, IT RETURNS FOR US 2$: MOV @R2,R5 ;R5 -> NEXT ELEMENT 3$: MOV R5,R2 ;COPY POINTER CMP -(R2),-(R2) ;BACK UP R2 TO LINK WORD MOV @R2,R5 ;R5 -> NEXT ELEMENT BEQ 4$ ;END OF Q. PUT IT HERE CMP 2(R5),R0 ;ELT. JOB # : THIS JOB # ;DV8 BHIS 3$ ;ELT >= THIS, KEEP CHAINING 4$: MOV R5,-4(R4) ;LINK WORD TO THIS ELEMENT MOV R4,@R2 ;LINK PREV ELEMENT TO THIS ONE ASL @R1 ;DID HANDLER COMPLETE WHILE HELD? BPL 20$ ;NO, SAY GOODBYE CLR (R1)+ ;UNHOLD HANDLER TST (R1)+ ;ADVANCE R1 -> HANDLER CQE WORD BR CMPLT2 ;ENTER COMPLETION, WHICH RETURNS 10$: MOV (SP)+,R3 ;BACK IN USER STATE. RETRIEVE CSW PTR TST -(R5) ;WAIT FOR COMPLETION? BNE 20$ ;NO, RETURN CHWAIT: MOV CNTXT,R1 ;WE MUST WAIT. POINT TO IMPURE AREA MOV R3,I.CHWT(R1) ;SAVE POINTER TO CHANNEL BEING AWAITED JSR R4,$SYSWT ;ENTER SYSTEM STATE & WAIT .WORD CHNWT$ ;WITH THIS BLOCKING BIT MOVB 10(R3),R2 ;; COROUTINE DETERMINES IF BLOCKED NEGB R2 ;; SET CARRY IF <>0, ELSE CLEAR IT JSR PC,@(SP)+ ;; COROUTINE RETURN 20$: RTS PC QFULL: SPL 0 ;* NO ROOM. BACK TO LEVEL 0 USWAPO: ENSYS QGTELT ;ENTER SYSTEM STATE FOR WAITING MOV JOBNUM,R5 ;GET GUY'S JOB NUMBER (NOTE R5 SCR) BEQ 11$ ;THERE IS NO JOB # -2 TST -(R5) ;START SCHEDULING BELOW HIM! 11$: JMP $RQSIG ;ENTER SCHEDULE REQUEST AT SIG-EVENT ;NOTE THAT HE WILL RETURN TO THE ;LEVEL 0 INTERRUPT EXIT FOR US .DSABL LSB .SBTTL QUEUE COMPLETION ; WHEN A DEVICE TRANSFER COMPLETES, THE HANDLER TRANSFERS TO ; COMPLT, TO START A NEW REQUEST ; IF A COMPLETION ROUTINE IS ASSOCIATED WITH THE REQUEST, ; IT IS PLACED ON THE USER'S COMPLETION QUEUE AND, IF HE IS ; CURRENTLY AT NON-COMPLETION LEVEL, A TASK SWITCH FOR HIM IS ; REQUESTED. ; THE I/O COUNT FOR THE CHANNEL IS DECREMENTED, AND IF THE ; USER IS WAITING FOR THAT CHANNEL, HE IS UNBLOCKED FROM THE WAIT ; ENTER WITH R5 AND R4 ON STACK. R4 POINTS TO THE LOCATION ; IN THE HANDLER WHICH POINTS TO THE CURRENT Q ENTRY BEING ; PROCESSED. .ENABL LSB COMPLT: ASR -4(R4) ;IS HANDLER BEING HELD? BMI 7$ ;YES. FLAG IS ON, JUST RETURN JSR R3,SAVE30 ;NO. SAVE REGS 3-0 MOV R4,R1 ;R1 -> HANDLER CQE CMPLT2: MOV @R1,R4 ;R4 -> Q ELEMENT MOV -(R4),R3 ;R3 -> CHANNEL MOVB Q.JNUM-Q.CSW(R4),R5 ;GET JOB NUMBER OF OWNER ASR R5 ;EXTRACT JOB NUMBER ASR R5 ASR R5 BIC #177761,R5 ADD PC,R5 ;R5 -> HIS IMPURE AREA MOV $IMPUR-.(R5),R5 ; (PIC, OF COURSE) DECB 10(R3) ;DECREASE PENDING REQUESTS ON CHANNEL BNE 1$ ;IS CHANNEL FREE? CMP R3,I.CHWT(R5) ;IS HE WAITING FOR THIS ONE? BNE 1$ ;NO JSR R4,UNBLOK ;YES. UNBLOCK HIM IF NEED BE .WORD CHNWT$ 1$: DEC I.IOCT(R5) ;DECREASE # OF OUTSTANDING REQUESTS BNE 2$ ;NOT 0 JSR R4,UNBLOK ;NONE LEFT. LET HIM RUN IF WAITING FOR .WORD EXIT$ ; ALL I/O TO COMPLETE 2$: MOV -(R4),(R1)+ ;LINK DEVICE Q FORWARD (NOTE - NOT RUNNING) BEQ 3$ ;NOTHING LEFT ON DEVICE MOV R1,-(SP) ;SET ADDRESS TO CALL HANDLER BR 4$ ;MERGE 3$: MOV -(R1),-(R1) ;CLEAR OUT LQE FLAG 4$: CMP Q.COMP(R4),#1 ;COMPLETION? BLOS AQLINK ;NO, GO LINK INTO AVAIL QUEUE MOV @R3,Q.BUFF(R4) ;SAVE CHANNEL STATUS IN BUFFER PTR SUB I.CSW(R5),R3 ;MAKE R3 A CHANNEL OFFSET MOV R3,Q.WCNT(R4) ;SAVE CHANNEL OFFSET IN WORD COUNT WORD TST (R5)+ ;ADVANCE POINTER MOV R5,R2 ;SAVE R5 MOV I.JNUM-2(R5),R5 ;GET JOB NUMBER JSR PC,$RQTSW ;ASK THAT HE BE ELIGIBLE MOV R2,R5 ;RESTORE R5 BIS #CPEND$,-(R2) ;INDICATE COMPLETION PENDING CQLINK: TST (R5)+ ;ADVANCE R5 TO COMPLETION LAST ELT. CLR @R4 ;CLEAR LINK WORD IN ELEMENT JSR PC,GETPSW ;PS TO STACK ;DV15 SPL 7 ;UP ... MOV (R5)+,R0 ;* R0 -> LAST ELEMENT IN COMPL. Q BNE 5$ ;* (IF THERE IS ONE) MOV R5,R0 ;* SET R0 TO PLUG CQE = LQE 5$: MOV R4,@R0 ;* POINT LAST ELEMENT AT THIS ONE 6$: MOV R4,-(R5) ;* MAKE THIS THE LAST ELEMENT JSR PC,$MTPS ;* BACK TO PRIORITY N ;DV15 7$: RTS PC ;RETURN FROM INTERRUPT, MAYBE TO HANDLER AQLINK: TST (R5)+ ;BUMP R5 TO AVAIL QUEUE JSR PC,GETPSW ;PS TO STACK ;DV15 SPL 7 ;UPPPPP MOV (R5)+,@R4 ;* THIS ELEMENT'S LINK -> FORMER AVAIL BR 6$ ;* GO POINT AVAIL TO US $SYNCH: TST Q.COMP(R4) ;IS THIS NODE IN USE? BNE 20$ ;YES, ERROR HIM CMP (R5)+,(SP)+ ;POP TO GOOD RETURN, PRUNE STACK MOV R5,Q.COMP(R4) ;SAVE SYNCH ADDRESS IN NODE MOV #-1,Q.WCNT(R4) ;PLUG TO AVOID LINKING TO AVAIL Q LATER MOV 2(R4),R5 ;GET JOB NUMBER IN R5 BIT #177775,R5 ;IS IT 0 OR 2? BNE 7$ ;NO, JUST EXIT QUIETLY JSR PC,$RQTSW ;YES. REQUEST A TASK SWITCH FOR THE GUY ADD PC,R5 ;IN A PIC-Y WAY MOV $IMPUR-.(R5),R5 ;POINT TO NEW IMPURE AREA BEQ 7$ ;NO SUCH JOB. BOOT BIT #NORUN$,@R5 ;IS JOB DEAD? BNE 7$ ;YES, BAD BIS #CPEND$,@R5 ;NO. A COMPLETION ROUTINE IS HERE ADD #I.CMPL,R5 ;POINT TO HEAD OF QUEUE JSR PC,GETPSW ;PS TO STACK ;DV15 SPL 7 ;UPWARDS MOV (R5)+,@R4 ;PUT TOP C ELEMENT IN THIS LINK BNE 6$ ;TOP ELT EXISTS. MAKE THIS THE TOP MOV R4,-(R5) ;C. QUEUE EMPTY. MAKE THIS THE TOP BR 6$ ;AND GO MAKE IT THE LQE, TOO. 20$: RTS R5 ;RETURN IF SYNCH NODE IN USE. .DSABL LSB .SBTTL GET TIME OF DAY, CANCEL MARK TIME ; "PERFECTION IN A CLOCK DOES NOT CONSIST IN BEING FAST, ; BUT IN BEING ON TIME." - VAUVENARGUES, "REFLEXIONS" ; GET TIME OF DAY .ENABL LSB G$TIM: ENSYS EMTRTI 11$: ADDR $TIME+2,R1 ;R1 -> TIME ADDITIVE MOV PSCLKH,(R0)+ ;MOVE IN HIGH PSEUDO TIME MOV PSCLOK,@R0 ;MOVE IN LOW ORDER TIME ADD @R1,@R0 ;ADD IN THING TO MAKE IT TIME OF DAY ADC -(R0) ;PROPAGANDA CARRY ADD -(R1),@R0 ;AND SO ON ... CMP (R0)+,(PC)+ ;CHECK FOR MIDNIGHT TURNOVER GTM.HI: .WORD 117 ;INITIALLY ASSUME 60 CYCLE BLO 6$ ;NOT YET BHI 12$ ;EGAD, 2 DAYS GONE BY CMP @R0,#15000 ;MIDNIGHT YET? BLO 6$ ;NO 12$: SUB GTM.HI,(R1)+ ;ADJUST TIME WORDS SUB (PC)+,@R1 GTM.LO: .WORD 15000 SBC -(R1) ADD #40,$DATE ;FIX TODAY TST -(R0) ;ADJUST HIS POINTER BR 11$ ;TRY AGAIN ; CANCEL MARK TIME: TAKES AN IDENTIFYING NUMBER AND CANCELS ; THE FIRST MARK TIME ELEMENT FOR THAT JOB WHICH HAS THAT NUMBER. ; IF A TWO WORD AREA IS ALSO GIVEN, THE AMOUNT OF TIME REMAINING ; IS RETURNED IN THAT AREA C$MKT: ENSYS EMTRTI ;DO IT IN SYS STATE TO STOP CLOCK MOV #177377,SYSLIM ;SET SYSTEM ID LIMIT ;DV16 CMARKT: ADDR LKQUE+2,R4 ;POINT TO QUEUE HEADER 1$: MOV R4,R3 ;R3 -> PREV LINK WORD + 2 2$: MOV -(R3),R4 ;R4 -> NEXT ELEMENT BEQ 5$ ;END OF QUEUE ADD #C.JNUM,R4 ;POINT TO JOB NUMBER WORD CMP JOBNUM,@R4 ;IS ELEMENT FOR THIS JOB? BNE 1$ ;NO, SKIP IT TST R0 ;ARE WE CANCELING EVERYTHING? ;DV16 BNE 3$ ;NO ;DV16 CMP 2(R4),(PC)+ ;YES, THIS ONE A SYSTEM ELEM.? ;DV16 SYSLIM: .WORD 177777 ;HIGHEST ID TO CANCEL ;DV16 BLOS 20$ ;NO, DELETE IT ;DV16 ;NOTE: SINCE R0 = 0, CMP BELOW FAILS AND BRANCH GOES TO 1$ ;DV16 3$: CMP R0,2(R4) ;NO. IS THIS THE RIGHT IDENTIFIER? ;DV16 BNE 1$ ;NO. TRY AGAIN 20$: MOV -(R4),(R3)+ ;PUT OUR LINK INTO PREV. LINK WORD ;DV16 MOV -(R4),R2 ;R2 = LOW ORDER EXPIRATION TIME TST -(R4) ;POINT TO HIGH ORDER TOX TST R0 ;CANCELING ALL? BEQ 4$ ;YES. NO RETURN STUFF MOV @R1,R5 ;R5 -> AREA TO PUT ANSWER BEQ 4$ ;NONE. SUB PSCLOK,R2 ;CONVERT TOX TO TIME REMAINING MOV @R4,@R5 ;MOVE IN HIGH ORDER TIME REMAINING SBC (R5)+ MOV R2,@R5 ;MOVE IN LOW ORDER 4$: MOV CNTXT,R5 ;POINT TO IMPURE AREA JSR PC,AQLINK ;PLACE ELEMENT ON HIS AVAIL QUEUE TST R0 ;CANCELING ALL? BEQ 2$ ;YES, KEEP TRUCKING RTS PC ;NO. WE SUCCEEDED 5$: TST R0 ;RAN OFF END. CANCELING ALL? BEQ 6$ ;YES, THAT IS SUCCESS SYSER0: MOV TASKSP,R0 ;NO. WE COULDN'T FIND ONE WITH THAT ID. INC <1+6+4>*2(R0) ;SET C ABOVE PC+6 REGS+FAKE INTERRUPT 6$: RTS PC ;BACK! .DSABL LSB .SBTTL PROTECT VECTORS, COPY OTHER JOB'S CHANNEL .ENABL LSB P$ROTE: CMP #500,R0 ;ADDRESS MUST BE <500 AND =0 MOD 4 BLOS 2$ ;NO, GIVE ERROR 1 ASR R0 ;GET WORD PAIR INDEX BCS 2$ ;ADDRESS NOT =0 MOD 4 ASR R0 BCS 2$ ;ADDRESS NOT =0 MOD 4 MOV R0,R1 ;GET SHIFT COUNT BIC #177774,R1 ;0-3 MOV #3*400,R2 ;MASK IN R2 1$: ASR R2 ;SHIFT MASK ASR R2 DEC R1 ;RIGHT YET? BPL 1$ ASR R0 ;CONVERT TO BYTE NUMBER ASR R0 ADD R0,R5 ;OFFSET THE IMPURE PTR MOV R5,R3 ;COPY POINTER ADDR LOWMAP,R0,ADD ;POINT TO PERM MAP BYTE ENSYS EMTRTI BITB R2,@R0 ;ARE THOSE LOCATIONS ALREADY PROTECTED? BNE SYSER0 ;YES, GIVE ERROR 0 BISB R2,@R0 ;NO, PROTECT THEM BISB R2,I.BITM(R3) RTS PC ;GET OUT OF SYSTEM STATE 2$: EMTERR+1 ;GIVE ERROR 1 JMP EMTRTI ;GET OUT OF EMT C$PYCH: TST @R3 ;IS THIS JOB'S CHANNEL ACTIVE? BMI 2$ ;YES. GIVE ERROR 1 ENSYS EMTRTI JSR PC,OTHRJB ;GET POINTER TO OTHER JOB'S IMPURE BEQ SYSER0 ;NO SUCH JOB. ERROR 0 BIC #177400,R0 ;ISOLATE OTHER GUY'S CHANNEL NO. CMPB I.CNUM(R2),R0 ;DOES OTHER JOB HAVE ENOUGH CHANNELS? BLOS SYSER0 ;NAY MOV R0,R1 ASL R0 ;CHANNEL * 2 ASL R0 ;* 4 ADD R1,R0 ;* 5 ASL R0 ;* 10. ADD I.CSW(R2),R0 ;POINT TO THE CHANNEL MOV (R0)+,R1 ;SAVE FIRST WORD BPL SYSER0 ;ERROR, CHANNEL NOT ACTIVE MOV R1,@R3 ;COPY CSW BIC #DWRIT$+RENAM$,(R3)+ ;WE NO GOTTA REWRITE ON CLOSE MOV (R0)+,(R3)+ ;START BLOCK MOV (R0)+,(R3)+ ;HOLE SIZE MOV (R0)+,(R3)+ ;DATA SIZE TSTB R1 ;WAS THIS FILE ENTERED? BPL 3$ ;IF 0, LOOKED UP MOV -(R3),-(R3) ;CHANGE HOLE SIZE TO MAX SIZE USED BIC (R3)+,(R3)+ ;FIX R3, AND IT'S LIKE A LOOKUP! 3$: MOV (R0)+,@R3 ;UNIT # CLRB @R3 ;CLEAR I/O COUNT BYTE ;DV21 RTS PC .DSABL LSB .SBTTL FLOATING POINT INTERRUPT FPPINT: MOV #100000,(PC)+ ;SET FLAG SAYING INTERRUPT FPPFLG: 0 CMPB 2(SP),#PR7 ;DID WE INTERRUPT THE SYSTEM? BHIS EXRTI ;YES. OUT FAST MOVB 2(SP),1$ ;NO. GO DOWN APPROPRIATELY COMB 1$ JSR R5,$INTEN ;ENTER SYSTEM STATE 1$: 0 RTS PC ;AND PROCESS ERROR LATER .SBTTL CLOCK INTERRUPT HANDLER ; "THE TIME IS OUT OF JOINT; O CURSED SPITE, ; THAT EVER I WAS BORN TO SET IT RIGHT." - SHAKESPEARE ; "HAMLET" ; "TEMPORA LABUNTUR" - OVID .ENABL LSB LKINT: INC (PC)+ ;* BUMP CLOCK TICKER TIKCTR: 0 INC INTLVL ;* DID WE INTERRUPT THE USER? BGT EXINT ;* NO. GET OUT FAST AT LEVEL 7 MOV R5,-(SP) ;* PUSH R5 ONTO HIS STACK MOV SP,R5 ;* SAVE THE SP MOV RMONSP,SP ;* SWITCH TO MONITOR STACK SPL 0 ;* AND DOWN TO LEVEL 0 FAST MOV R4,-(R5) ;NOW CALMLY SAVE HIS R4 MOV R5,TASKSP ;AND HIS STACK POINTER MOV TIKCTR,R5 ;GET NUMBER OF ELAPSED TICKS TIMER: SUB R5,TIKCTR ;FIX UP NUMBER OF TICKS ; (WE MAY HAVE TICKED BETWEEN MOV & SUB) ADD R5,(PC)+ ;UPDATE SYSTEM PSEUDO-CLOCK PSCLOK: 0 1$: MOV (PC)+,R4 ;POINT TO CLOCK QUEUE LKQUE: 0 BCS 4$ ;DIFFERENT ROUTINE IF PSCLOCK OVERFLOW BEQ EXUSER ;OUT IF QUEUE EMPTY TST (R4)+ ;IS HIGH ORDER EXP. TIME = 0? BNE EXUSER ;NO. IT CANNOT EXPIRE CMP PSCLOK,(R4)+ ;IS PSEUDO CLOCK < EXP. TIME? BLO EXUSER ;NO. NOT EXPIRED 2$: ROR -(SP) ;SAVE CARRY MOV (R4)+,LKQUE ;LINK QUEUE FORWARD MOV @R4,R5 ;R5 = JOB NUMBER JSR PC,$RQTSW ;ASK FOR A SWITCH FOR HIM ADD PC,R5 MOV $IMPUR-.(R5),R5 ;POINT TO HIS IMPURE AREA BIS #CPEND$,(R5)+ ;SET COMPLETION PENDING SUB #C.JNUM,R4 ;POINT TO BEGINNING OF ELEMENT MOV R0,-(SP) ;SAVE R0 JSR PC,CQLINK ;LINK IT ONTO COMPLETION Q MOV (SP)+,R0 ROL (SP)+ ;RESTORE CARRY BR 1$ ;START WITH TOP OF Q AGAIN 3$: SUB #1,(R4)+ ;NORMALIZE Q ELEMENT, SET C IF EXPIRED BIT (R4)+,R0 ;ADVANCE POINTER OVER LOW TIME BCS 2$ ;IF CARRY ON, EXPIRED. GO DISPATCH MOV @R4,R4 ;ELSE LINK TO NEXT ELEMENT 4$: BNE 3$ ;IF ANY INC (PC)+ ;BUMP HIGH ORDER PSEUDO CLOCK PSCLKH: 0 CLC ;DONE NORMALIZING QUEUE BR 1$ ;LOOK FOR EXPIRED ELEMENTS .DSABL LSB .SBTTL COMMON INTERRUPT ENTRY AND EXIT ; "LIFE IS MADE UP OF INTERRUPTIONS." - W.S. GILBERT, "PATIENCE" ; "FOR SLEEP, HEALTH, AND WEALTH TO BE TRULY ENJOYED, THEY MUST ; BE INTERRUPTED." - J.P. RICHTER, "FLOWER, FRUIT, AND THORN PIECES" ; EVERY HANDLER AND EVERY INTERRUPT-LEVEL ROUTINE MUST CALL THE ; COMMON ENTRY CODE AT $INTEN. ; IF A HANDLER ASKS FOR A TASK SWITCH, THIS SWITCH WILL BE DEFERRED ; UNTIL WE ARE ABOUT TO RETURN TO THE USER. THIS KEEPS THE STACK FROM ; GETTING MESSED UP. FURTHERMORE, ALL INTERRUPT LEVEL CODE RUNS ; ON THE SYSTEM STACK. ; THE CALL IS OF THE FORM: ; MOV @#SYSPTR,-(SP) ; JSR R5,@(SP)+ (OR JSR R5,$INTEN INTERNALLY) ; (HANDLERS ARE GIVEN A POINTER TO $INTEN WHEN FETCHED) ; .WORD ^C&340 .ENABL LSB ; THE MONITOR CALLS $ENSYS TO ENTER SYSTEM STATE TO MANIPULATE ; THE TIMER QUEUE OR TO CHANGE CONTEXT, ETC. ; THE CALL IS: ; JSR R5,$ENSYS ; .WORD
-. ; .WORD PR7 ; THE ROUTINE FOLLOWING THE CALL IS EXECUTED IN SYSTEM STATE. ; IT MUST RETURN VIA AN RTS PC. $ENSYS: MOV R5,-(SP) ;SAVE USER RETURN ADDRESS ADD (R5)+,@SP ;FUDGE IT TO RETURN WHERE HE WANTS MOV 2(SP),-(SP) ;SAVE REAL R5 JSR PC,GETPSW ;GET THE PS ;DV15 MOV (SP)+,4(SP) ;SAVE PS IN PLACE ;DV15 SPL 7 ;ENTER HERE TO SWITCH INTO SYSTEM STATE $INTEN: MOV R4,-(SP) ;* SAVE R4 INC (PC)+ ;* BUMP LEVEL POINTER INTLVL: .WORD -1 BGT 1$ ;* GO IF ALREADY SWITCHED STACKS MOV SP,(PC)+ ;* SAVE USER'S STACK PTR TASKSP: 0 MOV (PC)+,SP ;* SWITCH TO SYSTEM STATE RMONSP: RMSTAK ;* *** BOOT *** ; THE FOLLOWING TWO INSTRUCTIONS ARE MODIFIED BY THE BOOT IF THE ; PROCESSOR IS FOUND TO BE AN LSI11. THE INSTRUCTION SEQUENCE BECOMES: ; ; MFPS R4 ; BIC (R5)+,R4 ; MTPS R4 ; 1$: MOV R4,-(SP) ;PRESERVE R4 ;DV15 MOV #PS,R4 ;R4 -> PS ;DV15 BIC (R5)+,@R4 ;* DOWN TO HANDLER PRIORITY ;DV15 MOV (SP)+,R4 ;RESTORE R4 (FOR $ENSYS ENTRY) ;DV15 JSR PC,@R5 ;CALL HANDLER BACK (HE WILL RTS BACK) ; AND NOW, WE PROCESS A RETURN FROM INTERRUPT LEVEL TST INTLVL ;TO WHERE ARE WE ABOUT TO RETURN? BNE RTICMN ;EXIT FROM SYSTEM IS EASY EXUSER: MOV TIKCTR,R5 ;ANY TIME GONE BY? BNE TIMER ;YES. PROCESS TIMER QUEUE ASL FPPFLG ;HATH HE A PENDANT FPP INTERRUPT? BCS 3$ ;YES. FORCE TO HIM AN INTERRUPT 2$: SPL 7 ;TO THE USER! MOV (PC)+,R4 ;* IS THERE ANY ACTION TO DO? INTACT: 0 BNE EXSWAP ;* YES. GO DO IT MOV TASKSP,SP ;* NO. SWITCH TO HIS STACK RTICMN: MOV (SP)+,R4 ;* RESTORE REGS MOV (SP)+,R5 EXINT: DEC INTLVL ;* FIX LEVEL EXRTI: RTI ;* AND RETURN TO HIM 3$: MOV TASKSP,R4 ;PUT AN FPP INTERRUPT ON HIS STACK MOV (R4)+,-(SP) ;SAVE HIS OLD R4/R5 MOV (R4)+,-(SP) BIT #HWFPU$,CONFIG ;DOES THE HARDWARE HAVE AN FPU? BEQ 4$ ;NO STST -(R4) ;YES. SAVE STATUS 4$: CLR -(R4) ;FAKE PS MOV CNTXT,R5 ;POINT TO USER'S IMPURE MOV I.FPP(R5),-(R4) ;SET TO RETURN TO HIS FPU ROUTINE CMP #1,@R4 ;GOT HE ANY? BLO 5$ ;YAH ADDR FPPERR,@R4 ;NO, USE OURS 5$: MOV #1,I.FPP(R5) ;AVOID RECURSION MOV (SP)+,-(R4) ;RESTORE HIS R4/R5 MOV (SP)+,-(R4) MOV R4,TASKSP ;RESET SP BR 2$ .DSABL LSB .SBTTL EXIT TO USER ; "IT IS ALWAYS THOSE WHO ARE READY WHO SUFFER IN DELAYS." ; - DANTE, "THE DIVINE COMEDY" ; HERE WE ARE ABOUT TO EXIT TO THE USER ; WE MUST SEE IF A TASK SWITCH HAS BEEN REQUESTED, OR IF AN ABORT ; IS IN PROGRESS. .ENABL LSB EXSWAP: BMI ABORT ;* DO AN ABORT CLR INTACT ;* DO A TASK SWITCH. CLEAR ACTION FLAG SPL 0 ;* ANY NEW REQUESTS ARE CAUGHT LATER INC R4 ;ADD 2 TO START SEARCH ASLB R4 ;MAKE IT A TRUE JOB NUMBER MOV R4,JOBNUM ;KEEP IT ; NOTE: A RACE CONDITION CANNOT DEVELOP HERE, SINCE AN ASYNCHRONOUS ; REQUEST FOR A SWITCH TO JOB 'JOBNUM' OR HIGHER WILL BE HONORED, ; AND ANY ASYNCHRONOUS REQUEST FOR JOBNUM-2 OR LOWER NEED NOT BE ; FORMALLY HONORED, SINCE WE WILL EXAMINE THAT JOB IN THE LOOP NOW. ; WE KEEP JOBNUM AS HIGH AS POSSIBLE AT ALL TIMES SO THAT SPURIOUS ; REQUESTS FOR A SWITCH TO A LOW PRIORITY JOB WILL NOT CAUSE A PASS ; THROUGH THE SCHEDULING LOOP. ADDR $IMPUR,R4,ADD ;POINT TO $IMPUR TABLE ENTRY 3$: SUB #2,JOBNUM ;WE ARE ABOUT TO EXAMINE THE NEXT JOB BMI 10$ ;NOTHING RUNNABLE! MOV -(R4),R5 ;GET POINTER TO IMPURE AREA BEQ 3$ ;JOB DOES NOT EXIST BIT #BLOCK$,@R5 ;ANY BLOCKING BITS ON? BEQ 4$ ;NO! WE CAN GO TO HIM! TST @R5 ;YES. IS HE BLOCKED IN COMPLETION? BMI 3$ ;YES, HE IS REALLY BLOCKED TSTB @R5 ;NO. DOES HE HAVE COMPLETION PENDING? BPL 3$ ;NO. BIT #KSPND$!NORUN$,@R5 ;DOES THE KMON HAVE HIM SUSPENDED? BNE 3$ ;YES. EVEN COMPLETION CANNOT RUN. 4$: JSR PC,CNTXSW ;NO, DO THE CONTEXT SWITCH! BR EXUSER ;AND TRY TO EXIT AGAIN ; "A SOURCE OF INNOCENT MERRIMENT!" ; - W.S. GILBERT, "MIKADO" ; "DID NOTHING IN PARTICULAR, AND DID IT VERY WELL" ; - W.S. GILBERT, "IOLANTHE" ; "TO BE IDLE IS THE ULTIMATE PURPOSE OF THE BUSY" ; - SAMUEL JOHNSON, "THE IDLER" 10$: DEC (PC)+ ;THE RT-11 LIGHTS ROUTINE! 20$: 1 BNE 14$ ;NOT TOO OFTEN ADD #512.,20$ ;RESET COUNT, CLEAR CARRY 16$: ROL 13$ ;JUGGLE THE LIGHTS BNE 11$ ;NOT CLEAR YET COM 13$ ;TURN ON LIGHTS, SET CARRY 11$: BCC 12$ ;NOTHING FELL OFF, KEEP MOVING ADD #100,16$ ;REVERSE DIRECTION BIC #200,16$ ;ROL/ROR FLIP ;12$: MOV (PC)+,@(PC)+ ;PUT IN LIGHTS(FOR 11/45) 12$: BR 14$ ;SKIP FOR OTHER MACHINES 13$: .WORD 0,SR 14$: MOVB #MXJNUM/2+200,INTACT ;DO A COMPLETE SCAN EXUSLK: BR EXUSER ;BACK INTO LOOKFOR LOOP .DSABL LSB .SBTTL ABORT USERS ; "BEHOLD THE LORD HIGH EXECUTIONER! ; A PERSONAGE OF NOBLE RANK AND TITLE - ; A DIGNIFIED AND POTENT OFFICER, ; WHOSE FUNCTIONS ARE PARTICULARLY VITAL." ; - W.S. GILBERT, "THE MIKADO" ; THE FOLLOWING ENTRY POINT IS USED TO ABORT A RUNNING JOB ; IT SWITCHES TO SYSTEM STATE, SETS THE ABORT BIT FOR THE USER, ; AND FALLS INTO THE ABORT CODE. UABORT: JSR R5,$ENSYS ;GET INTO SYSTEM STATE .WORD 0 .WORD PR7 ;AT PRIORITY 0 BIS #ABORT$,@CNTXT ;AND REQUEST THE ABORT ; THIS ROUTINE ABORTS ALL USER TASKS WHICH ARE WAITING TO BE ABORTED ; IT PURGES ALL I/O, STOPS ANY RUNNING I/O, CLEANS UP THE IMPURE ; AREA SO THAT THE GUY IS RUNNABLE, AND FORCES HIM TO RETURN TO ; $EXIT. ABORT: SPL 0 ;* DOWN TO PRIO 0 1$: JSR PC,SWAPME ;WE MUST CONSIDER CURRENT USER LATER CLRB INTACT+1 ;TURN OFF 'ABORT REQ' FLAG MOV IMPLOC,R4 ;POINT TO TABLE OF IMPURE PTRS ;DV16 2$: MOV -(R4),R5 ;GET AN IMPURE POINTER BEQ 2$ ;JOB NOT EXTANT CMP R5,#-1 ;END OF TABLE? BEQ EXUSLK ;YES. DONE WITH ABORT BIT #ABORT$,@R5 ;IS IT HE? BEQ 2$ ;NO TSTB DFLG ;IS JOB DOING DIRECTORY OPERATION? BEQ 3$ ;NO CMPB USROWN,I.JNUM(R5) ;IF SO, IS THIS THE JOB? BEQ 2$ ;YES, CATCH HIM LATER 3$: JSR PC,CNTXSW ;SWITCH TO ABORT CONTEXT JSR PC,IORSET ;RESET ANY ACTIVE IO MOV TASKSP,R5 ;POINT TO TASK'S STACK CMP (R5)+,(R5)+ ;SKIP OVER SAVED REGS ADDR GOEXIT,@R5 ;R0 -> EXIT ROUTINE MOV CNTXT,R5 ;CLEAN UP IMPURE AREA: CLR @R5 ;WIPE OUT SPECIAL JSTATUS CLR I.TTLC(R5) ;NO TYPE-AHEAD CLR I.SCTR(R5) ;CLEAR SUSPEND COUNT MOV I.IPUT(R5),I.IGET(R5) ;EQUALIZE INPUT BUFFER POINTERS CLR I.ICTR(R5) ;NO INPUT WAITS BIC #CHAIN$!TTSPC$!TCBIT$!TTLC$,@#JSW ;CLEAN UP SPECIAL STATUS MOV SP,R0 ;DO NOT HARD-RESET HIM IN KMON BR 1$ ;CONSIDER ABORTED GUY IN SWAP .SBTTL CHANGE CURRENT CONTEXT ; "IT IS BEST NOT TO SWAP HORSES WHILE CROSSING THE RIVER." ; - A. LINCOLN ; THIS ROUTINE IS ENTERED AT SYSTEM STATE LEVEL 0 TO CHANGE THE ; CONTEXT OF THE USER LEVEL ROUTINE. ; IT CLEVERLY AVOIDS WORK IF WE ARE ASKED TO SWITCH TO THE CURRENT GUY. ; IT WILL ALSO KLUDGE UP HIS STACK FOR COMPLETION ROUTINES IF THERE ; ARE ANY PENDING ; ENTRY: R5 -> IMPURE AREA OF NEW GUY ; EXIT: R4 = TASKSP .ENABL LSB CNTXSW: MOV TASKSP,R4 ;POINT TO CURRENT TASK'S STACK CMP CNTXT,R5 ;IS IT THE SAME JOB? BEQ 7$ ;YES, SKIP ALL THE SAVING STUFF MOV R3,-(R4) ;SAVE REGS ON HIS STACK MOV R2,-(R4) MOV R1,-(R4) MOV R0,-(R4) MOV #34,R0 ;SAVE LOW CORE STUFF 5$: MOV (R0)+,-(R4) CMP R0,#54 BLO 5$ MOV CNTXT,R1 ;GET OLD CONTEXT ADD #I.FPP,R1 ;POINT TO SPECIAL SWAP LIST TST (R1)+ ;WANNA SWAP FPU? BEQ 51$ ;NO BIT #HWFPU$,CONFIG ;GOT FPU TO SWAP? BEQ 51$ STFPS -(R4) ;STORE ALL FPU GORP SETD STD R0,-(R4) STD R1,-(R4) STD R2,-(R4) STD R3,-(R4) LDD R4,R0 STD R0,-(R4) LDD R5,R0 STD R0,-(R4) 51$: MOV (R1)+,R2 ;ANYTHING ELSE TO GO? BEQ 53$ ;NO 52$: MOV @(R2)+,-(R4) ;SWAP STUFF TST @R2 ;UNTIL NO MORE BNE 52$ 53$: MOV R2,(R1)+ ;SAVE TOP OF EXTRA STUFF MOV R4,(R1)+ ;SAVE OLD STACK PTR MOV R5,CNTXT ;SAVE CONTEXT OF NEW JOB ADD #I.SP,R5 ;POINT TO SAVED SP MOV @R5,R4 ;GET NEW USER STACK MOV -(R5),R2 ;GET TOP OF EXTRA SAVED TST -(R5) ;IS THE LIST DEFINED? BEQ 55$ ;NO 54$: MOV (R4)+,@-(R2) ;YES. RESTORE IT CMP @R5,R2 ;END OF LIST? BNE 54$ ;NO 55$: TST -(R5) ;FPU TO SWAP? BEQ 6$ ;NO BIT #HWFPU$,CONFIG ;GOT ONE? BEQ 6$ SETD LDD (R4)+,R0 STD R0,R5 LDD (R4)+,R0 STD R0,R4 LDD (R4)+,R3 LDD (R4)+,R2 LDD (R4)+,R1 LDD (R4)+,R0 LDFPS (R4)+ 6$: MOV (R4)+,-(R0) ;RESTORE LOW CORE CMP R0,#34 BHI 6$ MOV (R4)+,R0 ;RESTORE REGS MOV (R4)+,R1 MOV (R4)+,R2 MOV (R4)+,R3 MOV R4,TASKSP ;SAVE POINTER TO USER STACK 7$: MOV CNTXT,R5 ;RESTORE R5 MOV I.JNUM(R5),JOBNUM ;SET UP JOB NUMBER TST @R5 ;HE'S IN. IS HE DOING COMPLETION? BMI 8$ ;YES. JUST RETURN TSTB @R5 ;NO. SHOULD WE PUT HIM THERE? BPL 8$ ;NO. MOV (R4)+,-(SP) ;YES! KLUDGE UP HIS STACK WITH A FAKE MOV (R4)+,-(SP) ; INTERRUPT BIC #&^C,@R5 ;UNBLOCK HIM COMPLETELY BIS #CMPLT$,@R5 ;AND SAY HE IS IN COMPLETION ROUTINE ADD #I.CHWT,R5 ;SKIP OVER QUEUE HEADS MOV (R5)+,(R5)+ ;SAVE CHANNEL BEING WAITED FOR MOV @#ERRBYT,(R5)+ ;SAVE IMPORTANT STUFF LIKE ERROR BYTE CLR -(R4) ;A FAKE PS! MOV (PC)+,-(R4) ;GIVE HIM A PLACE TO WHICH TO RETURN .$CRTN: $CRTNE ;*** BOOT *** MOV (SP)+,-(R4) ;RESTORE HIS R4 & R5 MOV (SP)+,-(R4) MOV R4,TASKSP ;SAVE THIS 8$: RTS PC ;DONE SWAPPING CONTEXT. R5 = TASKSP .DSABL LSB .SBTTL HARD AND SOFT RESET ; HARD RESET GOES HERE. IT STOPS ANY ACTIVE IO, THEN DOES A SOFT RESET H$RSET: ENSYS S$RSET ;SOFT RESET WHEN DONE IORSET: JSR R3,SAVE30 ;SAVE REGS 3-0 ADDR $ENTRY,R2 ;POINT TO HANDLER ENTRY TABLE 1$: MOV (R2)+,R3 ;GET HANDLER ADDRESS BEQ 1$ ;NOT RESIDENT CMP R3,#-1 ;END OF TABLE? BEQ 10$ ;YES MOV -(R2),R0 ;ALSO POINT R0 AT HANDLER (NOTE! CARRY SET) ROR -(R0) ;SET HANDLER HOLD FLAG TST (R3)+ ;ADVANCE TO CQE POINTER BIT #HNDLR$,<$STAT-$ENTRY>(R2) ;FORCE ABORT ENTRY? ;DV16 BEQ 3$ ;NO, ONLY IF CQE PRESENT ;DV16 MOV @R3,R4 ;R4 -> CQE PTR ;DV16 BR 4$ ;JUMP INTO ENTRY CODE ;DV16 3$: JSR R1,8$ ;GET JOB NUMBER. IS IT OURS? ;DV16 4$: MOV -(R0),R1 ;YES. R1 = OFFSET TO INT. ENTRY ;DV16 ADD R0,R1 ;R1 -> INTERRUPT ENTRY MOV R4,-(SP) ;HE MIGHT DESTROY R4 MOV JOBNUM,R4 ;ENTER WITH R4 = JOB # ;DV16 JSR PC,-(R1) ;CALL ABORT ENTRY IN HANDLER MOV (SP)+,R4 BEQ 9$ ;GO ON IF NO CQE EXISTS ;DV16 6$: MOV R4,R3 ;R3 -> PREVIOUS ELEMENT 7$: JSR R1,8$ ;ISOLATE JOB NUMBER. IS IT OURS? MOV @R4,@R3 ;DISCARD ELEMENT (Q. RESET LATER) BR 7$ ;TRY AGAIN 8$: TST (SP)+ ;THROW AWAY BAD R1 MOV @R3,R4 ;R4 -> NEXT ELEMENT BEQ 9$ ;DONE. GO TO NEXT ELEMENT CMP -(R4),-(R4) ;BACK UP TO LINK WORD MOVB Q.JNUM(R4),-(SP) ;GET JOB NUMBER ASR @SP ;ISOLATE IT ASR @SP ASR @SP BIC #177761,@SP CMP (SP)+,JOBNUM ;IS IT OURS? BNE 6$ ;IF NOT, CONTINUE (ENTER) LOOP JMP @R1 ;IF SO, PROCESS AS HEAD OR OTHERWISE 9$: MOV (R2)+,R4 ;R4 -> HANDLER AGAIN ASL -(R4) ;TEST COMPLETION, RESET HOLD FLAG BPL 1$ ;TOP ELEMENT DID NOT COMPLETE CLR (R4)+ ;TOP ELEMENT COMPLETED. TURN OFF FLAG TST (R4)+ ;POINT TO CQE WD IN HANDLER JSR PC,COMPLT ;CALL QUEUE COMPLETION FOR TOP ELEMENT BR 1$ ;TRY ANOTHER DEVICE 10$: JSR PC,JBABRT ;GET RID OF HANGING MESSAGES CMKALL: MOV #-1,SYSLIM ;CANCEL ALL MARK TIMES ;DV16 CLR R0 ;FLAG CANCEL ALL ;DV16 JMP CMARKT .SBTTL REVERT TO ORIGINAL CHANNELS, QRESET & PURGE HANDLERS ; THESE ROUTINES RUN IN USER STATE REVERT: JSR PC,JBABRT ;CANCEL ANY MESSAGES FOR THIS JOB JSR PC,QUIESCE ;WAIT FOR I/O TO STOP ADDR $CSW,R1 ;POINT TO BG'S CHANNELS TST JOBNUM ;IS THIS THE BG? BEQ 1$ ;YUPPIE MOV R3,R1 ;NOPE, POINT TO FG IMPURE AREA ADD #I.SERR+16,R1 ;ADVANCE TO CHANNELS 1$: MOV #16.,I.CNUM(R3) ;HE NOW GOT ONLY 16 CHANNELS MOV R1,I.CSW(R3) ;AND THEY SITTIN' IN THE USUAL PLACE MOV R3,R5 ;QRESET WANTS IMPURE POINTER IN R5 QRESET: CLR I.SCTR(R5) ;RESET SUSPENSION, TOO TST (R5)+ ;ADVANCE TO AVAIL HEADER MOV R5,@R5 ;RESET TO POINT TO ADD #I.QUE-2,@R5 ; THE ONE ELEMENT CLR @(R5)+ ;WHOSE LINK WORD WE CLEAR CLR (R5)+ ;ZAP COMPLETION Q CLR (R5)+ TST JOBNUM ;IF WE ARE FG BNE 3$ ; WE ARE DONE ADDR $ENTRY,R2 ;ELSE PURGE NON-RESIDENT HANDLERS MOV #$SLOT,R1 1$: CMP @R2,SYSLOW ;IS THIS RESIDENT? BHIS 2$ ;YES. LEAVE IT ALONE CLR @R2 ;NO, CLOBBER IT 2$: TST (R2)+ DEC R1 ;COUNT DOWN BNE 1$ 3$: BIS #100,@TTKS ;MAKE SURE TTY IS RUNNIN' RTS PC ;GO BACK TO CALLER .SBTTL DEQUEUE A COMPLETION ROUTINE; EXIT FROM COMPLETION RTN ; "SO SHE WENT INTO THE GARDEN TO CUT A CABBAGE LEAF TO MAKE AN APPLE ; PIE; AND, AT THE SAME TIME, A GREAT SHE-BEAR COMING UP THE STREET ; POPS ITS HEAD INTO THE SHOP - "WHAT! NO SOAP!" SO HE DIED, ; AND SHE VERY IMPRUDENTLY MARRIED THE BARBER." ; - SAMUEL FOOTE ; THE FOLLOWING CODE EXITS FROM A USER'S COMPLETION ROUTINE ; AND ENTERS ANOTHER ONE, IF PENDING. ; IF NOTHING IS PENDING, WE RETURN TO MAIN CODE OURSELVES $CRTNE: MOV R1,-(SP) ;USER COMES HERE TO START COMPLETION MOV R0,-(SP) ;SAVE REGS 1$: MOV CNTXT,R1 ;POINT TO OUR IMPURE AREA ADD #I.PERR,R1 ;POINT TO STUFF TO RESTORE MOV @R1,@#ERRBYT ;RESTORE ERROR WORD MOV -(R1),-(R1) ;RESTORE CHANNEL WAIT SPL 7 ;LOCK OUT OTHERS MOV -(R1),R0 ;* GET A COMPLETION ROUTINE BNE 2$ ;* NONE, GO BACK TO MAIN LEVEL BIC #CMPLT$+CPEND$,I.JSTA-I.CMPL(R1) ;* TURN OFF FLAGS MOV (SP)+,R0 ;* MOV (SP)+,R1 ;* RESTORE REGS RTI ;* BACK TO USER'S MAIN ROUTINE 2$: MOV @R0,@R1 ;* LINK COMPL FORWARD CMP -(R1),R0 ;* END OF QUEUE? BNE 3$ ;* NO CLR @R1 ;* YEP. CLEAR LQE 3$: SPL 0 ;* DON'T SPEND TOO MUCH TIME AT 7 CMP #-1,Q.WCNT(R0) ;IS THIS A SYNCH ELEMENT? BEQ 35$ ;YUPPER SPL 7 ;NO, LINK INTO AVAIL AT PRIO 7 MOV -(R1),@R0 ;* PUT AVAIL PTR INTO ELEMENT MOV R0,@R1 ;* POINT AVAIL TO THIS ELEMENT SPL 0 ;* SAFE TO COME DOWN NOW 35$: ADD #Q.COMP,R0 ;POINT TO EXTRAS MOV @R0,-(SP) ;SAVE PLACE TO CALL CLR @R0 ;THIS NODE IS NOW FREE CLR R1 ;ACCUMULATE CHANNEL # IN R1 TST -(R0) ;POINT TO COUNT. IF <= 0 BLE 5$ ;USE 0 4$: INC R1 SUB #10.,@R0 ;CHEAPO DIVIDE BY 10. (= CHANNEL SIZE) BGT 4$ 5$: MOV -(R0),R0 ;R0 = CSW OR ID NUMBER JSR PC,@(SP)+ ;CALL YE ROUTINE BR 1$ ;AND AROUND AGAIN .SBTTL BLOCK A TASK ; "THERE'S A LONG, LONG NIGHT OF WAITING ; UNTIL MY DREAMS ALL COME TRUE." ; - STODDARD KING, "THERE'S A LONG, LONG TRAIL" ; "NOW THE SERPENT WAS MORE SUBTIL THAN ANY BEAST OF THE FIELD" ; - GENESIS 3:1 ; THE FOLLOWING ROUTINE IS USED IN THE MONITOR EMT PROCESSOR WHEN ; A USER HAS TO WAIT FOR A SPECIFIC CONDITION. IT SETS THE BLOCKING ; BIT FOR THE CONDITION, AND SWITCHES THE USER OUT. ; WHEN THE USER IS AGAIN RUNNABLE, THIS ROUTINE IS ENTERED AGAIN ; AND IT DETERMINES WHETHER THE CONDITION STILL WARRANTS BLOCKING ; (SPURIOUS UNBLOCKING CAN BE CAUSED BY COMPLETION ROUTINES). ; IF RUNNABLE, IT RETURNS TO THE CALLER (SOMEWHERE IN THE MONITOR). ; IF NOT, IT RE-ENABLES THE BLOCKING BIT AND GOES AWAY AGAIN. ; THE CALLING SEQUENCE IS: ; JSR R4,$SYSWT ; .WORD BLOCKBIT ; ROUTINE TO DETERMINE WHETHER ROUTINE SHOULD STAY BLOCKED: ; ROUTINE MUST SET CARRY IF BLOCKED, CLEAR IT IF RUNNABLE ; IT MAY ASSUME THAT IT HAS REGISTERS R0-R3 UNCHANGED ; JSR PC,@(SP)+ ;CALL TO RETURN CONDITION TO $SYSWT ; RETURN HERE IN USER STATE WHEN FINALLY UNBLOCKED $SYSWT: JSR PC,2(R4) ;STILL BLOCKED? (CALL IN USER MODE) BCS 1$ ;YES MOV (SP)+,R4 ;NO! GET RETURN ADDRESS RTS R4 ;AND RETURN TO UNBLOCKED CODE 1$: TST (SP)+ ;PURGE RETURN ADDRESS ENSYS $SYSWT BIS (R4)+,@CNTXT ;TURN ON BLOCKING BIT IN JSTAT JSR PC,@R4 ;NOW, SEE IF HE WAS UNBLOCKED A MOMENT AGO INC (SP)+ ;WE NEVER WANT TO RETURN NOW! BCS SWAPME ;IF HE WAS UNBLOCKED BEFORE THAT BIS BIC -(R4),@CNTXT ; UNBLOCK HIM AGAIN RTS PC ;AND RETURN FROM FAKE INTERRUPT WITHOUT ; REQUESTING A TASK SWITCH .SBTTL REQUEST TASK SWITCH, UNBLOCK A TASK ; "IF IT BE NOW, 'TIS NOT TO COME; IF IT BE NOT TO COME, IT WILL ; BE NOW; IF IT BE NOT NOW, YET IT WILL COME; THE READINESS IS ALL." ; - SHAKESPEARE, "HAMLET" ; SWAPME AND $RQTSW ARE USED FROM MONITOR LEVEL ROUTINES TO REQUEST ; A SCAN OF THE DISPATCH TABLE, STARTING AT THE JOB WHOSE NUMBER IS ; IS R5. SWAPME USES THE NUMBER OF THE CURRENT JOB. .ENABL LSB DLYUSR: BIS #USRWT$,@CNTXT ;DELAY FOR USR. SET BLOCK BIT SWAPME: MOV CNTXT,R5 ;GET CURRENT JOB NUMBER MOV I.JNUM(R5),R5 $RQTSW: CMP R5,JOBNUM ;WANT LOWER PRIORITY THAN CURRENT JOB? BLO 1$ ;YES, THAT'S POINTLESS $RQSIG: SEC ;TURN ON STRANGE BIT RORB R5 ; IN INTACT JSR PC,GETPSW ;SAVE PRIO TO COME DOWN TO ;DV15 SPL 7 ;COMPARE AND SET MUST BE TOGETHER CMPB R5,INTACT ;* HIGHER THAN LATEST REQUEST? BLOS 2$ ;* NO MOVB R5,INTACT ;* YES, SET IT 2$: JSR PC,$MTPS ;* DOWN TO PROPER LEVEL ;DV15 ASLB R5 ;FIX R5 1$: RTS PC .DSABL LSB ; THIS ROUTINE CAUSES A USER TO BE UNBLOCKED FROM A CONDITION ; IF HE IS CURRENTLY BLOCKED BY IT. IN ADDITION, IF THERE IS A ; CHANGE IN STATUS, A RESCHEDULE IS REQUESTED ; CALLING SEQUENCE: ; R5 -> JOB IMPURE AREA ; JSR R4,UNBLOK ; .WORD BLOCKBIT UNBLOK: BIT (R4)+,@R5 ;IS BLOCKING BIT ON IN JSTAT ? BEQ 1$ ;NO, DO NOT SWITCH BIC -2(R4),@R5 ;YES, UNBLOCK THE TASK MOV R5,-(SP) ;SAVE IMPURE POINTER MOV I.JNUM(R5),R5 ;GET JOB NUMBER JSR PC,$RQTSW ;TIME FOR A CHANGE MOV (SP)+,R5 ;REPOINT TO IMPURE AREA 1$: RTS R4 ;BACK TO HIM .SBTTL FILL COMPUTATIONS, HANDLER SPACE . = . + 74 SPTR = . . = . + 100 RMSTAK = . RMONSZ = . + MAXSYH - $RMON + 777 / 1000 ;RMON LENGTH IN BLOCKS RMSIZE = RMONSZ * 1000 ;RMON LENGTH IN BYTES RMLEN = RMONSZ * 400 ;RMON LENGTH IN WORDS RT11SZ = KMONSZ + USRSZ + RMONSZ ;NUMBER OF BLOCKS IN ALL RT-11 RTSIZE = RT11SZ * 1000 ;SIZE OF RT-11 IN BYTES RTLEN = RT11SZ * 400 ;SIZE OF RT-11 IN WORDS FILLER= RT11SZ*1000-<.-KMON+MAXSYH> ;AMOUNT TO FILL TO PLACE THE ;KMON OVERLAYS ON A BLOCK .CSECT SYSHND ; SYSTEM HANDLER FITS IN THIS CSECT . = . + MAXSYH + FILLER .IIF DF NLRMON, .LIST C.....CALL CURVX C..... (XO, XF, COEFF1, EXP1, COEFF2, EXP2, COEFF3, EXP3, COEFF4, EXP4) C..... C.....XO, XF ARE THE STARTING AND ENDING C..... VALUES OF X IN INCHES. C..... POLYNOMIAL. SUBROUTINE CURVX (X0,XF,A,E,B,F,C,G,D,H) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE CURVEX (X0,XF,A,E,B,F,C,G,D,H) C.....INITIALIZATION - C.....GET LINE LENGTH DX = XF - X0 I3 = 3 C.....DEVELOP FACTORED DELTA CALL WHERE (X,Y,XFCT) X = X0 DLT = 0.01/XFCT C.....CHECK LINE LENGTH (IF ZERO RETURN) IF (DX) 10,20,15 C.....IF NEGATIVE MAKE DELTA LIKEWISE 10 DLT = -DLT C.....COMPUTE NUMBER OF LINE POINTS 15 N = ABS(DX/DLT) + 1.0 C.....CURVE FITTING PLOT LOOP DO 17 IV= 1,N Y = A*X**E + B*X**F + C*X**G + D*X**H CALL PLOT (X,Y,I3) X = X + DLT 17 I3 = 2 C.....PLOT EXPLICIT FINAL POINT AND RETURN Y = A*XF**E + B*XF**F + C*XF**G +D*XF**H CALL PLOT (XF,Y,2) 20 RETURN END C.....CALL CURVY C..... (YO, YF, COEFF1, EXP1, COEFF2, EXP2, COEFF3, EXP3, COEFF4, EXP4) C..... C.....YO, YF ARE THE STARTING AND ENDING C..... VALUES OF Y IN INCHES. C.....COEFF1, COEFF2, COEFF3, COEFF4 ARE THE COEFFICIENTS OF THE C..... POLYNOMIAL. C.....EXP1, EXP2, EXP3, EXP4 ARE THE EXPONENTS OF THE C..... POLYNOMIAL. SUBROUTINE CURVY (Y0,YF,A,E,B,F,C,G,D,H) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE CURVEY (Y0,YF,A,E,B,F,C,G,D,H) C.....INITIALIZATION - C.....GET LINE LENGTH DY = YF - Y0 I3 = 3 C.....DEVELOP FACTORED DELTA CALL WHERE (X,Y,XFCT) Y = Y0 DLT = 0.01/XFCT C.....CHECK LINE LENGTH (IF ZERO RETURN) IF (DY) 10,20,15 C.....IF NEGATIVE MAKE DELTA LIKEWISE 10 DLT = -DLT C.....COMPUTE NUMBER OF LINE POINTS 15 N = ABS(DY/DLT) + 1.0 C.....CURVE FITTING PLOT LOOP DO 17 IV= 1,N X = A*Y**E + B*Y**F + C*Y**G + D*Y**H CALL PLOT (X,Y,I3) Y = Y + DLT 17 I3 = 2 C.....PLOT EXPLICIT FINAL POINT AND RETURN X = A*YF**E + B*YF**F + C*YF**G +D*YF**H CALL PLOT (X,YF,2) 20 RETURN END C X IS THE NAME OF THE ARRAY OF UNSCALED ORDINATE VALUES. C Y IS THE NAME OF THE ARRAY OF UNSCALED ABCISSA VALUES. C N IS THE NUMBER OF POINTS IN THE ARRAY, NEGATIVE TO FIT C K IS THE REPEAT CYCLE OF A MIXED ARRAY (NORMALLY = 1). C J IS THE ALTERNATE NUMBER OF DATA POINT TO PLOT A SYMBOL. C J WILL = 0 FOR LINE PLOT,NEGATIVE FOR POINT PLOT, C J = 1 FOR POINT FOR EVERY DATA POINT,2 FOR EVERY OTHER C L IS AN INTEGER DESCRIBING SYMBOL TO BE USED, SEE SYMBOL C ROUTINE FOR LIST C C NOTE THIS ROUTINE EXPECTS XMIN,DX,YMIN AND DY TO BE STORED IN C X(N*K+1),X(N*K+1+K),Y(N*K+1),AND Y(N*K+1+K) RESPECTIVELY. C SUBROUTINE FLINE (X,Y,NN,K,J,L) DIMENSION X(2), Y(2), INTEQ(2) INTEQ(1) = L N=IABS(NN) KK=K LMIN=N*KK+1 LDX =LMIN+KK NL =LMIN-KK XMIN=X(LMIN) YMIN=Y(LMIN) DX=X(LDX) DY=Y(LDX) CALL WHERE(XN,YN,DF) DF= AMAX1 ( ABS ((X( 1)-XMIN)/DX-XN), ABS ((Y( 1)-YMIN)/DY-YN)) DL= AMAX1 ( ABS ((X(NL)-XMIN)/DX-XN), ABS ((Y(NL)-YMIN)/DY-YN)) IC=3 IS=-1 NT= IABS (J) IF (J) 2,1,2 1 NT=1 2 IF (DF-DL) 3,3,4 3 NF=1 NA=NT GO TO 5 4 KK=-KK NF=NL NL=1 NA=((N-1)/NT)*NT+NT-N+1 5 IF (J) 6,7,8 6 ICA=3 ISA=-1 LSW=1 GO TO 9 7 NA=LDX 8 ICA=2 ISA=-2 LSW=0 9 XN1=(X(NF)-XMIN)/DX YN1=(Y(NF)-YMIN)/DY NF=NF+KK IF (NN) 10,10,25 10 X0=XN1 Y0=YN1 LP=NL NLP=LP-KK NFP = NF-KK U = (X(NF)-X(NFP))/DX V = (Y(NF)-Y(NFP))/DY U1=(X(LP)-X(NLP))/DX V1=(Y(LP)-Y(NLP))/DY SU=U SV=V IF (X(NFP)-X(LP)) 13,12,13 12 IF (Y(NFP)-Y(LP)) 13,25,13 13 NFP=NLP-KK SU=(X(NLP)-X(NFP))/DX SV=(Y(NLP)-Y(NFP))/DY CALL REFLX (U1,V1,SU,SV) C EARLIER VERSION USED C CALL REFLEX (U1,V1,SU,SV) NFP=NF+KK U1=(X(NFP)-X(NF))/DX V1=(Y(NFP)-Y(NF))/DY CALL REFLX (U,V,U1,V1) C EARLIER VERSION USED C CALL REFLEX (U,V,U1,V1) 25 DO 23 I=1,N XN=XN1 YN=YN1 IF (N-I) 11,11,14 14 XN1=(X(NF)-XMIN)/DX YN1=(Y(NF)-YMIN)/DY 11 NW=NA-NT IF (NW) 29,26,26 29 IF (LSW) 17,26,17 26 IF (NN) 16,24,15 15 CALL PLOT (XN,YN,IC) GO TO 20 16 IF (IC-2) 15,17,15 17 IF (N-I) 27,27,18 27 U2=SU V2=SV GO TO 19 18 U2=XN1-XN V2=YN1-YN 19 CALL FIT4(X0,Y0,XN,YN,U1,V1,U2,V2) U1=U V1=V U=U2 V=V2 X0=XN Y0=YN 20 NA=NA+1 IF (NW) 22,28,22 28 CALL SYMBOL(XN,YN,0.08,INTEQ,0.0,-1) NA=1 22 IC=ICA 23 NF=NF+KK 24 RETURN END SUBROUTINE LGAXS (XO,YO,IBCD,N,DIST,THETA,VORG,DELTA) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE LGAXIS(XO,YO,IBCD,N,DIST,THETA,VORG,DELTA) C (XO,YO) COORDINATES OF START OF AXIS. C IBCD AXIS TITLE, EITHER HOLLERITH LITERAL OR BCD ARRAY. C N NUMBER OF CHARACTERS IN IBCD TITLE. A NEGATIVE N PLACES C ANNOTATION ON CLOCK-WISE SIDE OF AXIS. C DIST LENGTH OF AXIS IN PAGE INCHES. C THETA ANGLE OF AXIS FROM X-DIRECTION, IN DEGREES. C VORG VALUE OF DATA AT START OF AXIS. C DELTA LOG-CYCLES PER INCH OR EQUIVALENTLY THE RECIPROCAL OF C THE LENGTH OF ONE CYCLE. C IF SCALOG IS USED TO SCALE A LOGARITHMIC ARRAY, VARRAY, C VORG=VARRAY(NV*K+1), AND DELTA=VARRAY(NV*K+K+1) WHERE C NV IS NUMBER OF VALUES USED AND K IS REPEAT CYCLE OF C C LOCATION OF VALUES IN ARRAY, AS DESCRIBED IN SCALOG. DIMENSION BLOG(10), IBCD(2) C C C SAVE ARGUMENTS IN X, Y, NC, SIZE. X = XO Y = YO NC = N SIZE = DIST C CONVERT DEGREES TO RADIANS, STORING IN TH. TH=0.01745329*THETA C STORE LOGS OF INTEGERS 2-10 ETO10 = 0.4342945 DO 10 I=1,9 10 BLOG(I) = ETO10*ALOG (FLOAT(I)) C SET FXMN TO GREATEST INTEGER POWER OF TEN LESS THAN OR EQUAL TO LOG C OF XMIN. FXMN = INT (ETO10*ALOG (VORG)+100.0001)-100 C CALCULATE LENGTH FROM BEGINNING OF CYCLE CONTAINING VORG TO BEGINNING C OF AXIS, PLUS FACTOR PREVENTING ROUND-OFF ERROR, STORING IN BLMN. BLMN = (ETO10*ALOG (VORG)-FXMN)/DELTA-0.0001 C STORE SIN AND COS OF TH. SINT=SIN(TH) COST=COS(TH) C SET OFFSET CONSTANTS OF ANNOTATION, DEPENDING ON SIGN OF NC. IF(NC) 20,40,30 20 D1=0.24*SINT D2=-0.24*COST D3=0.12*SINT-D2 D4=-0.12*COST+D1 D5=0.2*SINT-0.03*COST D6=-0.2*COST-0.03*SINT NC=-NC SONT=SINT CIST=COST BCDX= X +(SIZE-0.12*FLOAT(NC))/2.*COST + 0.48*SINT BCDY= Y +(SIZE-0.12*FLOAT(NC))/2.*SINT - 0.48*COST GO TO 40 30 D1=-0.1*SINT D2=0.1*COST D3=-0.22*SINT+0.24*COST SONT=-SINT CIST=-COST D4=0.22*COST+0.24*SINT D5=D1-0.03*COST D6=D2-0.03*SINT BCDX=X +(SIZE-0.12*FLOAT(NC))/2.*COST-0.34*SINT BCDY=Y +(SIZE-0.12*FLOAT(NC))/2.*SINT+0.34*COST C CALCULATE COORDINATES OF START OF CYCLE CONTAINING VORG, C AND STORE IN X0, Y0. 40 X0=X -BLMN*COST Y0=Y -BLMN*SINT C CALCULATE LENGTH OF AXIS PLUS LENGTH OF CYCLE PRECEEDING AXIS PLUS C ROUND-OFF ERROR FACTOR, AND STORE IN SIZE1. SIZE1=SIZE+BLMN+0.0002 C INITIALIZE CYCLE COUNTER FJ. FJ = 0. C MOVE PEN TO START OF AXIS. CALL PLOT(X,Y,3) C LOOP THRU CYCLE. C AI DETERMINES HEIGHT OF TIC MARK, LARGE TIC MARK FOR 10**N AXIS VALUE 55 AI = 0.14 DO 60 I=1,9 C CALCULATE NEW BLEN, LENGTH TO NEXT TIC MARK. BLEN = (BLOG(I)+FJ)/DELTA C IF TIC MARK IS BEFORE START OF AXIS, GO TO NEXT TIC MARK. IF (BLEN-BLMN) 60,56,56 C IF TIC MARK IS BEYOND END OF AXIS, GO TO DRAW LINE TO END OF AXIS. 56 IF (BLEN-SIZE1) 57,57,70 C CALCULATE COORDINATES OF TIC MARK AND PLOT IT. 57 X=X0+BLEN*COST Y=Y0+BLEN*SINT CALL PLOT(X,Y,2) CALL PLOT(X+ AI*SONT,Y- AI*CIST,2) CALL PLOT(X,Y,2) 60 AI = .07 C INCREMENT FJ TO NEXT CYCLE. FJ = FJ+1. C RETURN FOR NEXT CYCLE. GO TO 55 C DRAW LINE TO END OF AXIS. 70 CALL PLOT(X0+SIZE1*COST,Y0+SIZE1*SINT,2) C LOOP BACKWARD THRU CYCLE FOR ANNOTATING TIC MARKS. 85 DO 110 K=1,9 I=10-K C CALCULATE DISTANCE FROM START OF FIRST CYCLE TO TIC MARK. BLEN = (BLOG(I)+FJ)/DELTA C IF TIC MARK IS LOCATED BEFORE START OF AXIS, GO TO DRAW AXIS TITLE. IF (BLEN-BLMN) 120,86,86 C IF TIC MARK IS BEYOND END OF AXIS, GO TO NEXT TIC MARK. 86 IF (BLEN-SIZE1) 87,87,110 C IF TIC MARK IS AT INTEGER POWER OF 10, ANNOTATE WITH 10 AND EXPONENT. 87 IF(I-1) 100,90,100 90 CALL NUMBER(X0+BLEN*COST+D1,Y0+BLEN*SINT+D2,0.14,10.,THETA,-1) CALL NUMBER(X0+BLEN*COST+D3,Y0+BLEN*SINT+D4,0.07,FXMN+FJ,THETA,-1) GO TO 110 C IF CYCLE LENGTH IS LESS THAN 2 INCHES, GO TO NEXT TIC MARK. 100 IF (DELTA-0.5) 105,105,110 C ANNOTATE INTERMEDIATE TIC MARK. 105 CALL NUMBER(X0+BLEN*COST+D5,Y0+BLEN*SINT +D6, 10.105, FLOAT(I),THETA,-1) 110 CONTINUE C DECREMENT CYCLE COUNTER. FJ = FJ-1. C GO TO LOOP THRU NEXT CYCLE. GO TO 85 C TEST FOR ANNOTATING AXIS TITLE. 120 IF (NC) 125,130,125 C DRAW AXIS TITLE. 125 CALL SYMBOL(BCDX,BCDY,0.14,IBCD,THETA,NC) 130 RETURN END C.....SUBROUTINE POLAR (RARRAY,AARRAY, NPTS, INC, LINTYP, INTEQ,RMAX,DR) C..... C..... RARRAY IS THE ARRAY CONTAINING THE RADIAL VALUES OF THE POINTS C..... TO BE PLOTTED, IN INCHES. C..... C..... AARRAY IS THE ARRAY CONTAINING THE ANGULAR VALUES OF THE POINTS C..... TO BE PLOTTED, IN RADIANS. C..... C..... NPTS IS THE NUMBER OF DATA POINTS TO BE PLOTTED. C..... C..... INC IS THE INCREMENT BETWEEN ELEMENTS IN THE ARRAY. INC IS C..... GREATER THAN 1 IF THE VALUES TO BE PLOTTED ARE IN A C..... MIXED ARRAY. NORMALLY INC=1. C..... C..... LINTYP IS THE TYPE OF GRAPH TO BE PLOTTED. IF LINTYP EQUALS C..... 0 A LINE IS PLOTTED BETWEEN SUCCESSIVE DATA POINTS. C..... 1 A LINE PLOT IS PRODUCED, WITH A SYMBOL AT EACH C..... DATA POINT. C..... 2 A LINE PLOT IS PRODUCED, WITH A SYMBOL AT EVERY C..... SECOND DATA POINT. C..... N A LINE PLOT IS PRODUCED, WITH A SYMBOL AT EVERY C..... NTH DATA POINT. C..... -N CONNECTING LINES ARE NOT PLOTTED? A SYMBOL APPEARS C..... AT EVERY NTH DATA POINT. C..... C..... INTEQ IS THE INTEGER EQUIVALENT OF THE SYMBOL TO BE PLOTTED C..... AT EVERY NTH DATA POINT. C..... C..... RMAX IS THE MAXIMUM RADIUS FOR THE PLOTTING AREA. IF RMAX IS C..... POSITIVE, POLAR PERFORMS THE SCALING, AND RETURNS C..... THE SCALE FACTOR IN DR. C..... NEGATIVE, DR IS USED AS THE SCALE FACTOR. C..... C..... DR IS THE SCALE FACTOR WHEN RMAX IS NEGATIVE. C..... DR RETURNS THE SCALE FACTOR WHEN RMAX IS POSITIVE. C..... SUBROUTINE POLAR(RADAR,ANGAR,NPTS,INC,LTYP,INTEQ,RMAX,DR) DIMENSION RADAR(2), ANGAR(2), TEMP(4), INTE(2) INTE(1) = INTEQ K = INC IND1 = NPTS*K + 1 IND2 = IND1 + K NL = IND1 - K IF (RMAX) 80,80,10 10 RMAXM = 0.0 RMINM = 0.0 DO 50 I = 1,NL,K T = RADAR(I) IF (T-RMAXM) 30,50,20 20 RMAXM = T GO TO 50 30 IF (RMINM-T) 50,50,40 40 RMINM = T 50 CONTINUE IF (ABS(RMAXM)-ABS(RMINM)) 60,70,70 60 RMAXM = -RMINM 70 TEMP(1) = 0.0 TEMP(2) = RMAXM CALL SCALE (TEMP,RMAX,2,1) DR = TEMP(4) 80 CALL WHERE (RN,THN,R1) T = RADAR(1)/DR TH1 = ANGAR(1) R1 = T*COS(TH1) TH1 = T*SIN(TH1) DF = ABS(R1-RN) R1 = ABS(TH1-THN) IF (DF-R1) 90,100,100 90 DF = R1 100 T = RADAR(NL)/DR TH1 = ANGAR(NL) R1 = T*COS(TH1) TH1 = T*SIN(TH1) DL = ABS(R1-RN) R1 = ABS(TH1-THN) IF (DL-R1) 110,120,120 110 DL = R1 120 IC = 3 IS = -1 NT = IABS (LTYP) IF (NT) 140,130,140 130 NT = 1 140 IF (DF-DL) 160,160,150 150 NF = NL NA = ((NPTS-1)/NT)*NT + NT - NPTS + 1 KK = -K GO TO 170 160 NF = 1 NA = NT KK = K 170 IF (LTYP) 180,190,185 180 ICA = 3 ISA = -1 LSW = 1 GO TO 210 185 IC = 2 GO TO 200 190 NA = IND2 200 ICA = 2 ISA = -2 LSW = 0 210 DO 260 I = 1,NPTS TH1 = ANGAR(NF) T = RADAR(NF)/DR RN = T*COS(TH1) THN = T*SIN(TH1) IF (NA-NT) 220,230,240 220 IF (LSW) 250,240,250 230 CALL SYMBOL(RN, THN, 0.08, INTE, 0.0, IS) NA = 1 IS = ISA GO TO 260 240 CALL PLOT (RN,THN,IC) IC = ICA 250 NA = NA + 1 260 NF = NF + KK RETURN END C THE SMOOTH ROUTINE SIMULATES THE PLOT ROUTINE WITH A NEW PLOT C MODE (DRAWING A SMOOTH CURVE TO THE NEW POINT). THE SMOOTH MODE C IS INITIALIZED WITH THE UNITS DIGIT OF IC = 0 (FOR AN OPEN CURVE) C OR = 1 (FOR A CLOSED CURVE). C THE VALUE OF IC FOR SMOOTHING IS THE NEGATIVE OF C THE PEN VALUES FOR PLOTTING. THERE IS, THEREFORE, NO RE-ORIGINING C WHILE SMOOTHING. USING POSITIVE VALUES FOR IC WHILE SMOOTHING C WILL BE TREATED AS A CALL TO PLOT. TO END THE CURVE AND RETURN TO C THE PLOT MODE LET IC BE LESS THAN -23. SUBROUTINE SMOOT (XN,YN,IC) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE SMOOTH (XN,YN,IC) JC=IC KC=JC-JC/10*10 LC=NC-IPC PXN=XN PYN=YN IREP=0 IF(KC)1,4,14 1 IF(KC+1)2,5,4 2 IF(IPC)3,3,14 3 IF(JC+24)10,10,17 4 ISW=-1 GO TO 6 5 ISW=1 6 JSW=-1 NC=-KC/10*10 X3=PXN Y3=PYN MC=NC+3 9 IPC=KC RETURN 10 IF(IPC+1)11,13,13 11 IF(ISW-1)12,15,14 12 IF(ISW+1)14,16,14 13 KC=NC+2 IPC=1 CALL PLOT (X3,Y3,MC) 14 CALL PLOT (PXN,PYN,KC) RETURN 15 IREP=2 16 IREP=IREP+1 KC=1 17 IF(IABS(JSW)-1)14,18,14 18 X1=X2 Y1=Y2 X2=X3 Y2=Y3 X3=PXN Y3=PYN IF(IPC+1)20,19,19 19 VX3=X3-X2 VY3=Y3-Y2 D3 = VX3*VX3+VY3*VY3 SX1=X2 SX2=X3 SY1=Y2 SY2=Y3 GO TO 40 20 IF(JSW)21,14,23 21 IF(ISW)22,14,24 22 VX2=X3-X2 VY2=Y3-Y2 CALL REFLX (VX3,VY3,VX2,VY2) C EARLIER VERSION USED C CALL REFLEX(VX3,VY3,VX2,VY2) D2=VX2*VX2+VY2*VY2 GO TO 26 23 JSW=1 24 VX2=VX3 VY2=VY3 VX3=X3-X2 VY3=Y3-Y2 25 D2=D3 UX1=UX2 UY1=UY2 26 D3=VX3*VX3+VY3*VY3 UX2=D2*VX3+D3*VX2 UY2=D2*VY3+D3*VY2 DV = 1.0/SQRT(UX2*UX2+UY2*UY2+0.000001) UX2=DV*UX2 UY2=DV*UY2 IF(ISW-JSW)27,27,45 27 IF(JSW)23,14,28 28 T=0. CALL WHERE (X,Y,D) IF (ABS(X1-X)-0.01*D) 29,30,30 29 IF (ABS(Y1-Y)-0.01*D) 31,30,30 30 CALL PLOT (X1,Y1,MC) 31 IF(IPC+3)32,40,32 32 D=ABS (UX1*VX2+UY1*VY2) D1=D UUX1=D*UX1 UUY1=D*UY1 D=ABS (UX2*VX2+UY2*VY2) UUX2=D*UX2 UUY2=D*UY2 D=D+D1 AX=UUX2+UUX1-VX2-VX2 BX=VX2-UUX1-AX AY=UUY2+UUY1-VY2-VY2 BY=VY2-UUY1-AY N=10.*D+1. D=1./FLOAT (N) DO 33 I=1,N T=T+D X=((AX*T+BX)*T+UUX1)*T+X1 Y=((AY*T+BY)*T+UUY1)*T+Y1 33 CALL PLOT (X,Y,LC) 40 IF(IREP)9,9,41 41 IREP=IREP-1 IF(ISW)43,14,42 42 PXN=SX1 PYN=SY1 SX1=SX2 SY1=SY2 SX2=SX3 SY2=SY3 GO TO 18 43 CALL REFLX (VX3,VY3,VX2,VY2) C EARLIER VERSION USED C CALL REFLEX(VX3,VY3,VX2,VY2) X=VX3 Y=VY3 VX3=VX2 VY3=VY2 VX2=X VY2=Y X1=X2 Y1=Y2 GO TO 25 45 JSW=1 SX3=X3 SY3=Y3 GO TO 40 END SUBROUTINE FIT4(PX1,PY1,PX2,PY2,VECX1,VECY1,VECX3,VECY3) X1=PX1 Y1=PY1 CALL WHERE (X,Y,D) D = 0.01/D IF (ABS(X1-X)-D) 10,2,2 10 IF (ABS(Y1-Y)-D) 11,2,2 11 IF (VECX1-VX2) 5,12,5 12 IF (VECY1-VY2) 5,13,5 13 IF (VX3-PX2+X1) 5,14,5 14 IF (VY3-PY2+Y1) 5, 6,5 2 CALL PLOT (PX1,PY1,3) 5 VX3=PX2-X1 VY3=PY2-Y1 VX2=VECX1 VY2=VECY1 D2=VX2*VX2+VY2*VY2 T=1. GO TO 7 6 T=0. VX2=VX3 VY2=VY3 VX3=VECX3 VY3=VECY3 D2=D3 UX1=UX2 UY1=UY2 7 D3=VX3*VX3+VY3*VY3 UX2=D2*VX3+D3*VX2 UY2=D2*VY3+D3*VY2 DV = 1.0/SQRT(UX2*UX2+UY2*UY2+0.00001) UX2=DV*UX2 UY2=DV*UY2 IF(T)6,8,6 8 D=ABS(UX1*VX2+UY1*VY2) D1=D UUX1=D*UX1 UUY1=D*UY1 D=ABS(UX2*VX2+UY2*VY2) UUX2=D*UX2 UUY2=D*UY2 D=D+D1 AX=UUX2+UUX1-VX2-VX2 BX=VX2-UUX1-AX AY=UUY2+UUY1-VY2-VY2 BY=VY2-UUY1-AY N=10.*D+1. D=1./FLOAT (N) DO 9 I=1,N T=T+D X=((AX*T+BX)*T+UUX1)*T+X1 Y=((AY*T+BY)*T+UUY1)*T+Y1 9 CALL PLOT (X,Y,2) RETURN END SUBROUTINE REFLX (VX1,VY1,VX2,VY2) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE REFLEX (VX1,VY1,VX2,VY2) PS=VY1*VY1 DS=VX1*VX1 SS = DS+PS+0.00001 DS=DS-PS PS=2.0*VX1*VY1 TEMP=(PS*VY2+VX2*DS)/SS VY2=(PS*VX2-VY2*DS)/SS VX2=TEMP RETURN END C.....CALL CIRCL (XPAGE,YPAGE,THO,THF,RO,RF,DI) C.......XPAGE,YPAGE ARE THE COORDINATES OF THE STARTING POINT OF THE C....... ARC. C.......THO IS THE ANGLE FOR THE START OF THE ARC, IN DEGREES. C.......THF IS THE ANGLE FOR THE END OF THE ARC, IN DEGREES. C.......RO IS THE RADIUS AT THE START OF THE ARC. C.......RF IS THE RADIUS AT THE END OF THE ARC. C.......DI IS A CODE USED TO SPECIFY THE TYPE OF LINE... C....... 0.0 FOR A SOLID ARC. C....... 0.5 FOR A DASHED ARC. SUBROUTINE CIRCL (T,U,TH0,THF,R0,RF,DSHI) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE CIRCLE (T,U,TH0,THF,R0,RF,DSHI) I5 = 4.51+DSHI I2 = 2 X=T Y=U CALL PLOT (X,Y,3) CALL WHERE (DTH,DTH,FCTR) KNT = 7.0*FCTR R0RRF = ABS(R0)+ABS(RF)+0.00001 DTH = 0.03/(R0RRF) / FCTR T0 = TH0 / 57.2958 TF = THF / 57.2958 C = X - R0 * COS(T0) TN = (TF - T0) / DTH IF (TF - T0) 102,104,104 102 TN = ABS(TN) DTH = -DTH 104 B = Y - R0 * SIN(T0) N = TN IF (N) 115,115,105 105 TN = (RF-R0)/TN RN = R0-TN DO 110 I = 1,N T0 = T0 + DTH RN = RN + TN X = RN * COS(T0) + C Y = RN * SIN(T0) + B IF ( KNT ) 112,112,111 112 I2 = I5-I2 KNT = 7.0*FCTR 111 KNT = KNT - 1 110 CALL PLOT (X,Y,I2) 115 X = RF*COS(TF)+C Y = RF*SIN(TF)+B CALL PLOT (X,Y,I2) RETURN END C.....DASHL IS A FORTRAN SUBROUTINE WHICH DRAWS DASHED LINES C..... CONNECTING A SERIES OF DATA POINTS C..... C.....CALL DASHL (XARRAY,YARRAY,NPTS,INC) C.....XARRAY NAME OF ARRAY CONTAINING ABSCISSAS OF C..... DATA POINTS TO BE PLOTTED C.....YARRAY NAME OF ARRAY CONTAINING ORDINATES OF C..... DATA POINTS TO BE PLOTTED C.....NPTS NUMBER OF DATA POINTS TO BE PLOTTED C.....INC INCREMENT BETWEEN ELEMENTS OF THE ARRAY SUBROUTINE DASHL (X,Y,N,K) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE DASHLN (X,Y,N,K) DIMENSION X(2), Y(2) C.....TEST LESS THAN TWO POINTS IF (N-1) 90,90,80 C.....INITIALIZE POINT, MINIMUM AND DELTA INDEXES 80 NP=(N-1)*K+1 NM=NP+K ND = NM + K NO=1 KK=K C.....DETERMINE CURRENT PEN POSITION CALL WHERE(XN,YN,XX) C.....FIND NEAREST END OF LINE DX = AMAX1(ABS((X( 1)-X(NM))/X(ND)-XN), 1 ABS((Y( 1)-Y(NM))/Y(ND)-YN)) DY = AMAX1(ABS((X(NP)-X(NM))/X(ND)-XN), 1 ABS((Y(NP)-Y(NM))/Y(ND)-YN)) IF (DX-DY) 20,20,40 C.....REVERSE INCREMENT AND END TEST VALUE 40 NO=NP NP=1 KK=-KK 20 I=NO C.....COMPUTE DELTAS OF INDEXED LINE SEGMENT 30 J=I+KK DY =(Y(J) - Y(I) )/Y(ND) DX =(X(J) - X(I))/X(ND) DS = SQRT(DX*DX+DY*DY+0.000001) ID = 5.0 *DS IF (ID)10,10,11 C.....ASSURE DIVISOR NON ZERO 10 ID = 1 C.....DERIVE DASH LENGTH. 11 DDS = DS / FLOAT(2*ID+1) DY = DDS * DY / DS * Y(ND) DX = DDS * DX / DS * X(ND) C.....SET XT/YT TO SEGMENT START POINT XT = X(I) YT = Y(I) C.....PLOT WITH PEN UP TO XT/YT 1 CALL PLOT ((XT-X(NM))/X(ND),(YT-Y(NM))/Y(ND),3) C.....ADJUST XT/YT AND END TEST BY DASH LENGTH XT = XT + DX YT = YT + DY DS = DS - DDS C.....TEST LINE SEGMENT END IF (DS) 3,3,2 C.....PLOT TO XT/YT WITH PEN DOWN 2 CALL PLOT ((XT-X(NM))/X(ND),(YT-Y(NM))/Y(ND),2) C.....ADJUST XT/YT AND END TEST BY DASH LENGTH XT = XT + DX YT = YT + DY DS = DS - DDS C.....TEST LINE SEGMENT END IF (DS) 3,4,1 C.....PLOT SEGMENT FINISH POINT 'PEN DOWN' 3 CALL PLOT ((X(J)-X(NM))/X(ND),(Y(J)-Y(NM))/Y(ND),2) C.....TEST LAST LINE SEGMENT 4 IF(J-NP) 5,90,5 5 I=J GO TO 30 90 RETURN END C.....CALL DASHP (XPAGE,YPAGE,DASH) C..... C.....XPAGE, YPAGE ARE THE COORDINATES OF THE POINT TO WHICH THE DASHED C..... LINE IS TO BE DRAWN. C.....DASH IS THE LENGTH OF THE DASH AND SPACE BETWEEN DASHES. C..... C.....A DASHED LINE IS DRAWN IN INCHES FROM THE CURRENT PEN POSITION TO C.....THE SPECIFIED XPAGE, YPAGE. THE SIZE OF THE DASH WILL BE AS CALLED C.....FOR EXCEPT IF THE LINE LENGTH IS LESS THAN DOUBLE THE DASH SIZE C.....THE DASH IS ADJUSTED TO HALF THE LINE LENGTH. SUBROUTINE DASHP (X,Y,DL) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE DASHPT (X,Y,DL) C.....DETERMINE CURRENT PEN POSITION CALL WHERE (XT,YT,ST) C.....COMPUTE DELTAX AND DELTAY DX = X-XT DY = Y-YT DS = DL IC = 2 C.....DERIVE LINE LENGTH S = SQRT(DX*DX+DY*DY) IF (S-0.02*ST) 6,10,10 10 DS = DS/S C.....TEST IF LINE LESS THAN DOUBLE DASH LENGTH IF (DS-0.5) 2,2,7 C.....HALVE DASH LENGTH 7 DS = 0.5 C.....PROPORTION THE DELTAS BY THE LENGTH/DASH RATIO 2 DX = DX*DS DY = DY*DS C.....SET UP ADJUSTMENT AND END OF LINE TEST FROM ABS GREATEST DELTA S = DX ST = ABS(DX)-ABS(DY) IF (ST) 3,4,4 3 S = DY 4 ST = ABS( S/DS)-ABS( S) DS = ABS( S) C..... C.....DASHED LINE LOOP 5 XT = XT+DX YT = YT+DY ST = ST-DS CALL PLOT (XT,YT,IC) IC = 5-IC IF (ST) 6,6,5 C.....LAST SPECIFIC LINE SEGMENT CALL 6 CALL PLOT (X ,Y ,IC) RETURN END SUBROUTINE ELIPS (X0,Y0,A,B,ALPHA,THET0 ,THETF ,IV) IF (ABS(A)+ABS(B)) 4,20,4 4 ALP = ALPHA/57.2958 THE0 = THET0 / 57.2958 THEF = THETF / 57.2958 D=A*B/SQRT((A*SIN(THE0))**2+(B*COS(THE0))**2) XC = X0 - D * COS(THE0 + ALP) YC = Y0 - D * SIN(THE0 + ALP) BSQ=B*B ABSQ=A*A-BSQ AB=A*B CALL PLOT(X0,Y0,IV) CALL WHERE (DTHE,DTHE,FCTR) DTHE = 0.03/(ABS(A)+ABS(B))/FCTR N =(THEF - THE0)/DTHE IF (N) 6,5,7 5 N = -1 6 N = -N DTHE = -DTHE 7 THEN = THE0 + DTHE DO 10 I=1,N ST=SIN(THEN) D=AB/SQRT(ABSQ*ST*ST+BSQ) XF=XC+D*COS(THEN+ALP) YF=YC+D*SIN(THEN+ALP) CALL PLOT (XF,YF,2) 10 THEN = THEN + DTHE ST=SIN(THEF) D=AB/SQRT(ABSQ*ST*ST+BSQ) XF=XC+D*COS(THEF+ALP) YF=YC+D*SIN(THEF+ALP) CALL PLOT(XF,YF,2) RETURN 20 CALL PLOT(X0,Y0,IV) RETURN END SUBROUTINE FIT (XA,YA,XB,YB,XC,YC) DIMENSION SS(8,9),THETA(2) M = 2 DY = YC - YA DX = XC - XA Z3 = SQRT( DY**2 + DX**2 ) IF ( Z3 ) 20,20,21 21 DO 8 I = 1,2 IF(ABS(DX)-ABS(DY)) 1,2,2 1 THETA(I) = 1.5708 - ATAN(ABS(DX/DY)) GO TO 3 2 THETA (I)= ATAN(ABS(DY/DX)) 3 IF (DX) 25,26,26 25 IF (DY) 5,4,4 26 IF (DY) 4,5,5 4 THETA(I) = -THETA(I) 5 IF (DX) 6,7,7 6 THETA(I) = THETA(I) + 3.1416 7 DX = XB - XA 8 DY = YB - YA Z2 = SQRT(DY**2 + DX**2) * COS(THETA(2)-THETA(1)) IF ( Z2 ) 20,20,22 22 SS(1,3) = XA - XC SS(2,3) = XA - XB KTRA = 1 GO TO 13 16 A = SS(1,3) B = SS(2,3) SS(1,3) = YA - YC SS(2,3) = YA - YB KTRA = 2 GO TO 13 17 CALL WHERE (X,Y,FCTR) DZ =0.01 / FCTR Z = DZ CALL PLOT (XA,YA,3) C = SS(1,3) D= SS(2,3) 18 X = (A*Z+B)*Z+XA Y = (C*Z+D)*Z+YA CALL PLOT (X,Y,2) Z = Z + DZ IF (Z - Z3)18,19,19 19 CALL PLOT (XC,YC,2) RETURN 13 SS(1,1) = Z3 * Z3 SS(1,2) = Z3 SS(2,1) = Z2 * Z2 SS(2,2) = Z2 CALL SOLUT (SS,M) C EARLIER VERSION USED C CALL SOLUTN (SS,M) IF (M) 20,20,14 14 GO TO (16,17),KTRA 20 CALL PLOT(XA,YA,3) CALL PLOT(XB,YB,2) GO TO 19 END SUBROUTINE GRID (X,Y,XS,YS,M,N) C C WHERE - (X,Y) IS THE STARTING POSITION OF GRID C XS IS THE SPACE OF GRID IN X DIRECTION. C YS IS THE SPACE OF GRID IN Y DIRECTION C M IS THE NUMBER OF DIVISION IN X DIRECTION. C N IS THE NUMBER OF DIVISIONS IN Y DIRECTION. C Y0 = Y IM = N + 1 XF = X + XS * FLOAT(M) X0 = X CALL PLOT (X,Y,3) DO 10 I = 1,IM CALL PLOT (X0,Y0,2) CALL PLOT (XF,Y0,2) Y0 = Y0 + YS XT = XF XF = X0 10 X0 = XT X0 = X Y0 = Y XF = Y + YS * FLOAT(N) IM = M + 1 DO 20 I = 1,IM CALL PLOT (X0,XF,2) CALL PLOT (X0,Y0,2) X0 = X0 +XS XT = XF XF = Y0 20 Y0 = XT RETURN END SUBROUTINE POLY (X,Y,SL,RN,TH) N = RN XN = X YN = Y THO = TH * 0.01745 CALL PLOT (X,Y,3) IF (N) 10,100,20 10 TH1 = -6.2832 / RN TH2 = - TH1 * 2.0 N=-N DO 11 I = 1,N XN = XN + SL * COS(THO) YN = YN + SL * SIN(THO) CALL PLOT (XN,YN,2) THO = THO + TH1 XN = XN + SL * COS(THO) YN = YN + SL * SIN(THO) CALL PLOT (XN,YN,2) 11 THO = THO + TH2 100 RETURN 20 TH1 = 6.2832 / RN DO 21 I = 1,N XN = XN + SL * COS(THO) YN = YN + SL * SIN(THO) CALL PLOT (XN,YN,2) 21 THO = THO + TH1 RETURN END SUBROUTINE RECT (X,Y,H,W,TH,IV) THETA = TH/57.2958 XS = SIN(THETA) XC = COS(THETA) CALL PLOT (X,Y,IV) X1 = X - H * XS Y1 = Y + H * XC CALL PLOT (X1,Y1,2) X1 = X1 + W * XC Y1 = Y1 + W * XS CALL PLOT (X1,Y1,2) X1 = X + W * XC Y1 = Y + W * XS CALL PLOT (X1,Y1,2) CALL PLOT (X,Y,2) RETURN END SUBROUTINE SOLUT (X,N) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE SOLUTN (X,N) DIMENSION X(8,9) NM1 = N - 1 NP1 = N + 1 DO 10 I = 1,NM1 L = I + 1 IT = I DO 6 IN = L,N IF (ABS(X(IT,I))-ABS(X(IN,I))) 5,6,6 5 IT = IN 6 CONTINUE IF (X(IT,I)) 8,7,8 7 N = 0 RETURN 8 IF (IT - I) 17,17,16 16 DO 9 IN = I,NP1 XT = X(I,IN) X(I,IN) = X(IT,IN) 9 X(IT,IN) = XT 17 DO 10 J = L,N RATIO = X(J,I)/X(I,I) DO 10 K = L,NP1 10 X(J,K) = X(J,K)- RATIO * X(I,K) DO 40 I = 1,N DX = 0.0 K = N - I + 1 IF (I-1) 40,40,20 20 DO 30 J = 2,I L = N + 2 - J 30 DX = DX + X(K,L) * X(L,NP1) 40 X(K,NP1) =(-X(K,NP1) - DX) / X(K,K) RETURN END SUBROUTINE AROHD(X1,Y1,X2,Y2,A1,A2,K1) XS=X1 YS=Y1 XE=X2 YE=Y2 AL=A1 TW=A2*0.5 KK=K1 IF (A2) 99,2,3 2 TW=AL/3.0 3 AW=TW IF (KK) 4,99,5 4 KK=-KK CALL WHERE(XS,YS,ZZ) 5 XA=XE-XS YA=YE-YS ZZ= SQRT (XA*XA+YA*YA) IF (ZZ) 6,99,6 6 STH=YA/ZZ CTH=XA/ZZ KT=KK/10 KK=KK-10*KT GO TO (11,12,13,14,15,12,13,99,99),KK 11 ICB=2 ICD=2 ICE=2 ICF=3 GO TO 20 12 ICB=2 ICD=2 ICE=2 ICF=2 GO TO 20 13 ICB=2 ICD=3 ICE=3 ICF=2 GO TO 20 14 ICB=3 ICD=2 ICE=3 ICF=2 GO TO 20 15 ICB=3 ICD=3 ICE=3 ICF=2 20 ICA=3 CALL PLOT(XS,YS,3) IF (KT-1) 23,22,21 21 CALL PLOT(XS+AL*CTH,YS+AL*STH,3) GO TO 24 22 CALL PLOT(XS,YS,3) 24 ICA=2 23 XA=XE-AL*CTH YA=YE-AL*STH 30 CALL PLOT(XA ,YA ,ICA) CALL PLOT(XA+AW*STH,YA-AW*CTH,ICB) CALL PLOT(XE ,YE , 2) CALL PLOT(XA-AW*STH,YA+AW*CTH,ICD) CALL PLOT(XA ,YA ,ICE) CALL PLOT(XE ,YE ,ICF) IF (KK-5) 40,40,35 35 AW=AW-0.02 IF (AW) 37,37,36 36 CALL PLOT(XA+AW*STH,YA-AW*CTH, 3) CALL PLOT(XE ,YE , 2) CALL PLOT(XA-AW*STH,YA+AW*CTH,ICD) GO TO 35 37 CALL PLOT(XE,YE,3) 40 IF (KT-2) 99,41,99 41 KT=0 ZZ=XE XE=XS XS=ZZ ZZ=YE YE=YS YS=ZZ STH=-STH CTH=-CTH AW=TW ICA=3 GO TO 23 99 RETURN END SUBROUTINE ARROW (X,Y,N,K,NX) DIMENSION X(2), Y(2) NP = (N-1) * K + 1 N0 = NP - K N1 = NP + K N2 = N1 + K XMIN = X(N1) DX1 = X(N2) YMIN = Y(N1) DY1 = Y(N2) THETA = 1.5708 DTH = 0.0 DX = X(NP) - X(N0) DY = Y(NP) - Y(N0) IF (DY) 8,9,9 8 THETA = -1.5708 9 IF (DX) 10,12,11 10 DTH = 3.1416 11 THETA = ATAN(DY / DX) 12 THETA = THETA + DTH S30 =-0.30 * SIN(THETA) S05 = S30 / 6.0 C30 =-0.30 * COS(THETA) C05 = C30/ 6.0 X(N1) = X(NP) +(C30 - S05 ) * DX1 Y(N1) = Y(NP) + (C05 + S30 ) * DY1 N1 = N1 + K X(N1) = X(NP) +(C30 + S05 ) * DX1 Y(N1) = Y(NP) + (S30 - C05 )* DY1 N1 = N1 + K X(N1) = X(NP) Y(N1) = Y(NP) N1 = N1 + K X(N1) = X(NP) - S30 * DX1 Y(N1) = Y(NP) + C30 * DY1 N1 = N1 + K X(N1) = X(NP) + S30 * DX1 Y(N1) = Y(NP) - C30 * DY1 NP = N + NX N1 = NP *K +1 X(N1) = XMIN Y(N1) = YMIN N2 =N1 + K X(N2) = DX1 Y(N2) = DY1 CALL LINE (X,Y,NP,K,0,0) NP = N*K+1 NO = NP+K X(NP) = XMIN X(NO) = DX1 Y(NP) = YMIN Y(NO) = DY1 RETURN END SUBROUTINE CNTRL (X,Y,N,K) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE CNTRLN (X,Y,N,K) DIMENSION X(2), Y(2) IF (N-1) 90,90,80 80 NP=(N-2)*K+1 NM=NP+K+K ND = NM + K DO 4 I = 1,NP,K J = I + K DY2 = (Y(J) - Y(I)) / 11.0 DY1 = DY2 * 4.0 DX2 = (X(J) - X(I)) / 11.0 DX1 = DX2 * 4.0 CALL PLOT ((X(I)-X(NM))/X(ND),(Y(I)-Y(NM))/Y(ND),3) XT = X(I) + DX1 YT = Y(I) + DY1 CALL PLOT ((XT -X(NM))/X(ND),(YT -Y(NM))/Y(ND),2) XT = XT + DX2 YT = YT + DY2 CALL PLOT ((XT -X(NM))/X(ND),(YT -Y(NM))/Y(ND),3) XT = XT + DX2 YT = YT + DY2 CALL PLOT ((XT -X(NM))/X(ND),(YT -Y(NM))/Y(ND),2) XT = XT + DX2 YT = YT + DY2 CALL PLOT ((XT -X(NM))/X(ND),(YT -Y(NM))/Y(ND),3) CALL PLOT ((X(J)-X(NM))/X(ND),(Y(J)-Y(NM))/Y(ND),2) 4 CONTINUE 90 RETURN END SUBROUTINE DIMEN (X0,Y0,DS,THETA,SCAL) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE DIMENS (X0,Y0,DS,THETA,SCAL) DIMENSION WE(7),DE(7) TH=3.1416*THETA/180.0 D = DS*SCAL XC = COS(TH) XS = SIN(TH) DO10I=1,7 DE(I)=0.0 10 WE(I)=0.0 WE(4)=+.3 WE(5)=+.3 DE(1)=-.1 DE(2)=+.1 DE(4)=+.05 DE(5)=-.05 J=0 IF(D-99.999)406,406,404 404 FD=D/2.0-0.35 FL=FD-0.05 GO TO 420 406 IF(D-9.999)410,410,408 408 FD=D/2.0-0.31 FL=FD-0.05 GO TO 420 410 IF(D-1.19)414,414,412 412 FD=D/2.0-0.27 FL=FD-0.05 GO TO 420 414 IF(D-0.80)418,418,416 416 FD=D+0.42 FL=D/2.0 J=1 GO TO 420 418 FD=D+0.42 WE(4)=-WE(4) WE(5)=-WE(5) FL=-0.4 420 WE(7)=FL XD=X0+FD*XC +0.05*XS YD=Y0+FD*XS -0.05*XC I3=3 DO424I=1,7 XX=X0+WE(I)*XC -DE(I)*XS YY=Y0+WE(I)*XS +DE(I)*XC CALL PLOT (XX,YY,I3) 424 I3=2 CALL NUMBER ( XD,YD, 0.10,DS, THETA,3) I3=3 X1=X0+D*XC Y1=Y0+D*XS DO428I=1,7 I8 = 8- I XX=X1-WE(I8 )*XC -DE(I8 )*XS YY=Y1+DE(I8 )*XC -WE(I8 )*XS CALL PLOT (XX,YY,I3) 428 I3=2 IF(J)432,432,430 430 CALL PLOT (X1,Y1,2) XD=X1+0.4*XC YD=Y1+0.4*XS CALL PLOT (XD,YD,2) 432 RETURN END C SUBROUTINE LABEL(X1,Y1,X2,Y2,IBCD,NS,HEIGHT,ISIDE,DSTFLN,FPN,NN) C THIS ROUTINE PLOTS AN ARRAY OF SYMBOLS CENTERED ALONG A LINE. THE C SYMBOLS MUST FIT AT THE SPECIFIED HEIGHT AND LEAVE AT LEAST 0.1 INCH C MARGIN AT EACH END. IF NOT, THE CHARACTER HEIGHT IS MODIFIED SO THAT C THE SYMBOLS WILL FIT. HOWEVER, IF IT BECOMES NECESSARY TO ADJUST THE C CHARACTER HEIGHT TO LESS THAN 0.07 INCHES, THEN NOTHING IS PLOTTED. C THE SPECIFIED SYMBOLOGY MAY BE FOLLOWED BY A PLOTTED NUMBER. THE C NUMBER IS SPECIFIED AS A FLOATING POINT NUMBER, HOWEVER BOTH THE C SPECIFIED BCD SYMBOLS AND THE NUMERIC SYMBOLS REQUIRED FOR THE C NUMBER ARE CENTERED ALONG THE LINE. IF THE USER WANTS SPACE BETWEEN C THE SYMBOLS AND THE NUMBER,PROVIDE BLANKS IN THE BCD ARRAY. THIS C NUMBER APPENDAGING FEATURE IS PROVIDED FOR SUCH DRAFTING APPLICATIONS C THAT INVOLVE COMPUTED VALUES THAT FOLLOW DESCRIPTIVE INFORMATION C E.G.- RADIUS=308.86 C THIS FEATURE REQUIRES THE USE OF A CALCOMP SYMBOL ROUTINE WITH THE C LINE CONTINUATION FEATURE C*********************************************************************** C X1,Y1 - COORDINATES OF FIRST POINT -P1 C X2,Y2 - COORDINATES OF SECOND POINT-P2 C IBCD - ADDRESS OF ARRAY OF SYMBOLS C NS - NUMBER OF SYMBOLS TO PLOT C HEIGHT - HEIGHT OF SYMBOLS C ISIDE - ABSOLUTE VALUE=1, PLOT SYMBOLS ON CLOCKWISE SIDE OF LINE C - ABSOLUTE VALUE=2, PLOT SYMBOLS ON COUNTERCW SIDE OF LINE C -ABSOLUTE VALUE=11, SAME AS 1,EXCEPT THAT A FLOATING C POINT NUMBER IS TO BE PLOTTED ALONG WITH THE LABEL C -ABSOLUTE VALUE=12, SAME AS 2,EXCEPT FPN IS ALSO PLOTTED C - IF NEGATIVE, INVERT THE SYMBOLS 180 DEGREES WHEN THE C DIRECTION OF THE LINE P1 TO P2 IS GREATER THAN 93.0 C DEGREES AND LESS THAN 267.0 DEGREES. THIS FEATURE FORCES C SYMBOLOGY TO BE IN A READABLE ORIENTATION FOR STANDARD C DRAWINGS. C DSTFLN - THE DISTANCE (OR MARGIN) OF THE SYMBOLS FROM THE LINE. C FPN -THE FLOATING POINT NUMBER TO BE PLOTTED WHENEVER ISIDE C IS EQUAL TO 11 OR 12 C NN -THE NUMBER OF PLACES RIGHT OF DECIMAL POINT TO PLOT FPN SUBROUTINE LABEL(X1,Y1,X2,Y2,IBCD,NS,HGT,ISIDE,DST,FPN,NN) DIMENSION IBCD(2) C SAME IS USED TO CONCATENATE CALLS TO SYMBOL AND NUMBER SAME = 999.0 C SPACING TO HEIGHT RATIO OF CHARACTERS SHR = 1.0 C WIDTH TO HEIGHT RATIO OF CHARACTERS WHR=0.57143 C MINIMUM ANGLE FOR INVERSION THMIN=93.0 C MAXIMUM ANGLE FOR INVERSION THMAX=267.0 C SET THE MINIMUM CHARACTER HEIGHT ALLOWED (BY ADJUSTMENT) CHMIN=0.07 C SET THE MARGIN REQUIRED AT EACH END OF THE LINE ENDMA =0.1 C SET UP ENTRY COORDINATES-THEY WILL BE REVERSED IF ISIDE IS NEGATIVE C AND THE LINE P1-P2 IS IN THE 2ND OR 3RD QUADRANT FPNT=FPN X11=X1 Y11=Y1 X22=X2 Y22=Y2 IS=ISIDE C THIS PARAMETER CONTROLS WHICH SIDE OF THE LINE THE SYMBOLS WILL BE ON ISA=IABS(ISIDE) ISA1=ISA-10 C NSW IS A SWITCH THAT WILL CONTROL WHETHER A NUMBER IS ALSO PLOTTED NSW=1 IF(ISA1) 1,100,100 C YES -A NUMBER WILL BE PLOTTED, RESET ISA TO CONTROL SIDE OF LINE 100 NSW=2 ISA=ISA1 C COMPUTE DELTAS 1 DX=X22-X11 DY=Y22-Y11 C FIND THE ANGLE OF THE LINE P1 TO P2 C IF DX IS ZERO, DONT DIVIDE TO GET SLOPE IF(DX) 3,2,3 C SET TH FOR 90 DEGREES 2 TH=1.5708 C WHEN BOTH DX AND DY ARE ZERO,EXIT (99) WITH NO PLOTTING IF(DY) 4,99,10 C CALCULATE SLOPE AND ANGLE (IN RADIANS) FOR A 1ST QUADRANT ANGLE 3 SLP=ABS(DY/DX) TH=ATAN(SLP) TH1=TH IF(DY) 4,6,6 C IT IS IN EITHER THE 3RD OR 4TH QUADRANT 4 TH=TH+3.1416 C GO TO 10 IF IN 3RD QUADRANT IF(DX) 10,10,5 C IT IS IN THE 4TH QUADRANT 5 TH=6.2832-TH1 GO TO 10 C IT IS IN THE 1ST OR 2ND QUADRANT - GO TO 10 IF IN 1ST 6 IF(DX) 7,10,10 C IT IS IN THE 2ND QUADRANT 7 TH=3.1416-TH C GET ANGLE IN DEGREES 10 TH1=TH*57.295 C DOES IT QUALIFY FOR INVERTING CHARACTERS BY 180 DEGREES C DOES THE ENTRY PARAMETER,ISIDE,REQUEST IT IF (IS) 11,16,16 C YES- C IS THE ANGLE GREATER THAN THMIN DEGREES 11 IF(TH1-THMIN)16,16,12 C YES- C IS THE ANGLE LESS THAN THMAX DEGREES 12 IF(THMAX-TH1)16,16,13 C YES- C SWITCH PARAMETERS TO INVERT THE PLOTTED SYMBOLS C INTERCHANGE P1 AND P2 13 X11=X2 Y11=Y2 X22=X1 Y22=Y1 C SET POSITIVE SO IT CANT INVERT AGAIN THIS ENTRY IS=-IS C SWITCH ISA (ISIDE) SO THE SYMBOLS WILL STILL BE ON THE INTENDED SIDE C OF THE LINE EVEN THOUGH THEY ARE INVERTED C THEN MAKE ANOTHER PASS THROUGH THE LOGIC TO GET THE ANGLES IF(ISA-1) 14,14,15 14 ISA=2 GO TO 1 15 ISA=1 GO TO 1 C FLOAT THE NUMBER OF CHARACTERS C IS A NUMBER TO BE PLOTTED 16 GO TO (167,161),NSW C YES- DETERMINE TOTAL NUMBER OF PLOTTED CHARACTERS INCLUDING THE NUMB. C INITIALIZE COUNTERS 161 I=0 NC=1 C IS IT NEGATIVE IF(FPNT) 162,163,163 C YES- ADD 1 FOR NEGATIVE SIGN 162 NC=NC+1 C IS IT LESS THAN 10 163 IF(ABS(FPNT)-10.0)164,165,165 C YES- SYMBOL WILL BE A SINGLE DIGIT 164 NC=NC+1 GO TO 166 165 I=0.4343*ALOG(ABS(FPNT))+1.0000001 C CALCULATE TOTAL NUMBER OF CHARACTERS 166 TN=NC+I+NS+NN GO TO 168 167 TN=NS C GET THE ENTRY HEIGHT-IT MAY BE REDUCED 168 HT = HGT TEMP=TN*SHR-SHR+WHR C CALCULATE TOTAL LENGTH OF CHARACTERS TCW= HT*TEMP C CALCULATE LENGTH OF LINE DL= SQRT((DX**2)+(DY**2)) C CALCULATE MARGIN ON EACH END OF LINE DLL= (DL-TCW)/2.0 C THE MARGIN MUST EQUAL THE SET PARAMETER-ENDMA IF(DLL-ENDMA ) 17,19,19 C CALCULATE A CHARACTER HEIGHT THAT WILL FIT 17 HT=(DL-2.0*ENDMA )/TEMP C THE CHARACTER HEIGHT MUST EXCEED A SET MINIMUM -CHMIN IF(HT-CHMIN) 99,18,18 C CHARACTERS EXCEED NECESSARY MINIMUM AND MARGIN IS SET TO MINIMUM 18 DLL=ENDMA C IF CLOCKWISE SIDE OF LINE,GO TO 20 19 IF(ISA-1)20,20,21 C CLOCKWISE SIDE OF LINE BECAUSE ISIDE=1 20 X = X11+DLL*COS(TH)+(HT+DST)*SIN(TH) Y = Y11+DLL*SIN(TH)-(HT+DST)*COS(TH) GO TO 22 C COUNTER CLOCKWISE SIDE OF LINE ,BECAUSE ISIDE=2 21 X = X11+DLL*COS(TH)-DST*SIN(TH) Y = Y11+DLL*SIN(TH)+DST*COS(TH) 22 CALL SYMBOL(X,Y,HT,IBCD,TH1,NS) C IS A NUMBER TO BE PLOTTED GO TO (99,23),NSW C THIS CALL USES THE LINE CONTINUATION FEATURE OF THE SYMBOL ROUTINE 23 CALL NUMBER (SAME,SAME,HT,FPNT,TH1,NN) 99 RETURN END SUBROUTINE AXISB(XPAGE,YPAGE,IBCD,NCHAR,AXLEN,ANGLE,FIRST,DELTA) C C..... XPAGE,YPAGE COORDINATES OF STARTING POINT OF AXIS, IN INCHES C..... IBCD AXIS TITLE. C..... NCHAR NUMBER OF CHARACTERS IN TITLE. + FOR C.C-W SIDE. C..... AXLEN FLOATING POINT AXIS LENGTH IN INCHES. C..... ANGLE ANGLE OF AXIS FROM THE X-DIRECTION, IN DEGREES. C.... FIRST SCALE VALUE AT FIRST TIC MARK. C.... DELTA CHANGE IN SCALE BETWEEN TIC MARKS ONE INCH APART C DIMENSION INH(6),INTT(8),INM(6) DIMENSION INP(6),INHT(10),IBCD(2) DIMENSION ITNE(2) C C DATA ITNE/2H*1,2H0 / DATA INH/2HIN,2H H,2HUN,2HDR,2HED,2HS / DATA INTT/2HIN,2H T,2HEN,2H T,2HHO,2HUS,2HAN,2HDS/ DATA INM/2HIN,2H M,2HIL,2HLI,2HON,2HS / DATA INP/2HIN,2H T,2HHO,2HUS,2HAN,2HDS/ DATA INHT/2HIN,2H H,2HUN,2HDR,2HED,2H T,2HHO,2HUS,2HAN,2HDS/ C C C C C C C C C C C C C C C C C C C KN=NCHAR A=1.0 IF (KN) 1,2,2 1 A=-A KN=-KN 2 EX=0.0 ADX = ABS (DELTA) IF (ADX) 3,7,3 3 IF (ADX- 99.0) 6,4,4 4 ADX=ADX/10.0 EX=EX+1.0 GO TO 3 5 ADX=ADX*10.0 EX=EX-1.0 6 IF (ADX-0.01) 5,7,7 7 IF (EX) 9,9,8 8 EX=EX+1.0 9 XVAL = FIRST*10.0**(-EX) ADX = DELTA*10.0**(-EX) STH=ANGLE*0.0174533 CTH=COS(STH) STH=SIN(STH) DXB=-0.1 DYB=0.15*A-0.05 XN=XPAGE+DXB*CTH-DYB*STH YN=YPAGE+DYB*CTH+DXB*STH NTIC=AXLEN+1.0 NT=NTIC/2 DO 20 I=1,NTIC CALL NUMBER(XN,YN,0.105,XVAL,ANGLE,2) XVAL=XVAL+ADX XN=XN+CTH YN=YN+STH IF (NT) 20,11,20 11 Z=KN IF (EX) 12,13,12 12 Z=Z+7.0 13 DXB=-.07*Z+AXLEN*0.5 DYB=0.325*A-0.075 XT=XPAGE+DXB*CTH-DYB*STH YT=YPAGE+DYB*CTH+DXB*STH CALL SYMBOL (XT,YT,0.14,IBCD,ANGLE,KN) IF (EX) 14,20,14 14 Z=KN+2 XT=XT+Z*CTH*0.14 YT=YT+Z*STH*0.14 IF(EX) 29,20,21 21 IEX=EX+.5 IF (IEX-6) 22,22,29 22 GO TO (29,23,24,25,26,27),IEX 23 CALL SYMBOL(XT,YT,0.14,INH ,ANGLE,11) GO TO 20 24 CALL SYMBOL(XT,YT,0.14,INP ,ANGLE,12) GO TO 20 25 CALL SYMBOL(XT,YT,0.14,INTT ,ANGLE,16) GO TO 20 26 CALL SYMBOL(XT,YT,0.14,INHT ,ANGLE,20) GO TO 20 27 CALL SYMBOL(XT,YT,0.14,INM ,ANGLE,11) GO TO 20 29 CALL SYMBOL(XT,YT,0.14,ITNE,ANGLE,3) XT=XT+(3.0*CTH-0.8*STH)*0.14 YT=YT+(3.0*STH+0.8*CTH)*0.14 CALL NUMBER(XT,YT,0.07,EX,ANGLE,-1) 20 NT=NT-1 CALL PLOT(XPAGE+AXLEN*CTH,YPAGE+AXLEN*STH,3) DXB=-0.07*A*STH DYB=+0.07*A*CTH A=NTIC-1 XN=XPAGE+A*CTH YN=YPAGE+A*STH DO 30 I=1,NTIC CALL PLOT(XN,YN,2) CALL PLOT(XN+DXB,YN+DYB,2) CALL PLOT(XN,YN,2) XN=XN-CTH YN=YN-STH 30 CONTINUE RETURN END SUBROUTINE AXISC (X,Y,IBCD,NC,SIZE,THETA,YMIN,DY ) DIMENSION IMC(2),IM(2,12),IBCD(2) C C DATA IM/2HJA,2HN ,2HFE,2HB ,2HMA,2HR ,2HAR,2HR , 1 2HMA,2HY ,2HJU,2HN ,2HJU,2HL ,2HAU,2HG , 2 2HSE,2HP ,2HOC,2HT ,2HNO,2HV ,2HDE,2HC / C C C C C C C C C C SIG = 1.0 IF (NC) 1,2,2 1 SIG = -1.0 2 NAC = IABS(NC) TH = THETA * 0.017453 N = SIZE + 0.5 CTH = COS (TH) STH = SIN (TH) TN = N XB = X YB = Y XA=X-0.1*SIG *STH YA=Y+0.1*SIG *CTH CALL PLOT (XA,YA,3) DO 20 I = 1,N CALL PLOT (XB,YB,2) XC = XB + CTH YC = YB + STH CALL PLOT (XC,YC,2) XA = XA + CTH YA = YA + STH CALL PLOT (XA,YA,2) XB = XC 20 YB = YC ADY = ABS (DY) ABSV = YMIN + DY * TN XA = XB - (.2*SIG-.05)*STH-.0857*CTH YA = YB + (.2*SIG-.05)*CTH-.0857*STH IDY = DY IY = YMIN IMIN = IY + (N-1) * IDY 200 IF (IMIN - 12) 21,21,210 210 IMIN = IMIN - 12 GO TO 200 21 DO 30 I = 1,N XX=XA-.5*CTH YY=YA-.5*STH IMC(1)=IM(1,IMIN) IMC(2)=IM(2,IMIN) CALL SYMBOL (XX,YY,0.1, IMC,THETA,3) IMIN = IMIN - IDY IF (IMIN) 22,22,25 22 IMIN = 12 + IMIN 25 XA = XA - CTH 30 YA = YA - STH C DO LABEL TNC=NAC XA=X+(SIZE/2.-.07*TNC)*CTH-(-.07+SIG*.36)*STH YA=Y+(SIZE/2.-.07*TNC)*STH+(-.07+SIG*.36)*CTH CALL SYMBOL (XA,YA,0.14,IBCD,THETA,NAC) 50 RETURN END SUBROUTINE LBAXS (XO,YO,IBCD,N,DIST,THETA,VORG,DELTA) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE LBAXIS (XO,YO,IBCD,N,DIST,THETA,VORG,DELTA) C (XO,YO) COORDINATES OF START OF AXIS. C IBCD AXIS TITLE, EITHER HOLLERITH LITERAL OR BCD ARRAY. C N NUMBER OF CHARACTERS IN IBCD TITLE. A NEGATIVE N PLACES C ANNOTATION ON CLOCK-WISE SIDE OF AXIS. C DIST LENGTH OF AXIS IN PAGE INCHES. C THETA ANGLE OF AXIS FROM X-DIRECTION, IN DEGREES. C VORG VALUE OF DATA AT START OF AXIS. C DELTA LOG-CYCLES PER INCH OR EQUIVALENTLY THE RECIPROCAL OF C THE LENGTH OF ONE CYCLE. C IF SCALOG IS USED TO SCALE A LOGARITHMIC ARRAY, VARRAY, C VORG=VARRAY(NV*K+1), AND DELTA=VARRAY(NV*K+K+1) WHERE C NV IS NUMBER OF VALUES USED AND K IS REPEAT CYCLE OF C LOCATION OF VALUES IN ARRAY, AS DESCRIBED IN SCALOG. C DIMENSION BLOG(10), IBCD(2) C IUNIT CONTAINS BCD NUMBERS AS WORDS FOR TIC MARK ANNOTATION. C NCHR CONTAINS NUMBER OF CHARACTERS IN BCD NUMBERS. C IEND CONTAINS NUMBER ENDING, EITHER S OR THS. DIMENSION IUNIT(5,7),NCHR(7),IEND(2) C C DATA IEND/2HTH,2HS / DATA IUNIT /2H ,2H ,2H ,2H ,2H , 1 2H T,2HEN,2H ,2H ,2H , 3 2H T,2HHO,2HUS,2HAN,2HD , 2 2H H,2HUN,2HDR,2HED,2H , 4 2H M,2HIL,2HLI,2HON,2H , 5 2H B,2HLI,2HLI,2HON,2H , 6 2H T,2HRI,2HLL,2HIO,2HN / DATA NCHR 1 /1,4,8,9,8,8,9/ C C C C C C C C C C C C C C C C C C C C SAME IS USED TO CONCATENATE CALLS TO SYMBOL AND NUMBER SAME = 999.0 C SAVE ARGUMENTS IN X, Y, NC, SIZE. X = XO Y = YO NC = N SIZE = DIST C CONVERT DEGREES TO RADIANS, STORING IN TH. TH=0.01745329*THETA AUTO = SAME ETO10 = 0.4342945 C STORE LOGS OF INTEGERS 1-9 DO 10 I=1,9 10 BLOG(I) = ETO10*ALOG (FLOAT(I)) C SET IXMN TO GREATEST INTEGER POWER OF TEN LESS THAN OR EQUAL TO LOG C OF XMIN. 16 FXMN = INT (ETO10*ALOG (VORG)+100.0001)-100 C CALCULATE LENGTH FROM BEGINNING OF CYCLE CONTAINING VORG TO BEGINNING C OF AXIS, PLUS FACTOR PREVENTING ROUND-OFF ERROR, STORING IN BLMN. BLMN = (ETO10*ALOG (VORG)-FXMN)/DELTA-0.0001 C STORE SIN AND COS OF TH. SINT=SIN(TH) COST=COS(TH) C SET HT, HEIGHT OF NUMBER ANNOTATION, PROPORTIONAL TO CYCLE LENGTH. HT = 0.045/DELTA C IF HT IS GREATER THAN MAXIMUM ALLOWABLE HEIGHT, RESET TO MAX HEIGHT. IF (HT-.105) 18,18,17 17 HT = .105 C SET OFFSET CONSTANTS OF ANNOTATION, DEPENDING ON SIGN OF NC. 18 IF (NC) 20,40,30 20 D1=0.24*SINT D2=-0.24*COST D3=0.12*SINT-D2 D4=-0.12*COST+D1 D5=0.2*SINT-0.03*COST D6=-0.2*COST-0.03*SINT NC=-NC SONT=SINT CIST=COST D7 = (.23+HT)*SINT+.14*COST D8 = -(.23+HT)*COST+.14*SINT BCDX= X +(SIZE-0.12*FLOAT(NC))/2.*COST + 0.56*SINT BCDY= Y +(SIZE-0.12*FLOAT(NC))/2.*SINT - 0.56*COST GO TO 40 30 D1=-0.1*SINT D2=0.1*COST D3=-0.22*SINT+0.24*COST SONT=-SINT CIST=-COST D4=0.22*COST+0.24*SINT D5=D1-0.03*COST D6=D2-0.03*SINT D7 = -.23*SINT+.14*COST D8 = .23*COST+.14*SINT BCDX=X +(SIZE-0.12*FLOAT(NC))/2.*COST-0.42*SINT BCDY=Y +(SIZE-0.12*FLOAT(NC))/2.*SINT+0.42*COST C CALCULATE COORDINATES OF START OF CYCLE CONTAINING VORG, C AND STORE IN X0, Y0. 40 X0=X -BLMN*COST Y0=Y -BLMN*SINT C CALCULATE LENGTH OF AXIS PLUS LENGTH OF CYCLE PRECEEDING AXIS PLUS C ROUND-OFF ERROR FACTOR, AND STORE IN SIZE1. SIZE1=SIZE+BLMN+0.0002 C INITIALIZE CYCLE COUNTER FJ. FJ = 0. C MOVE PEN TO START OF AXIS. CALL PLOT(X,Y,3) C LOOP THRU CYCLE. 55 AI = 0.14 DO 60 I=1,9 C CALCULATE NEW BLEN, LENGTH TO NEXT TIC MARK. BLEN = (BLOG(I)+FJ)/DELTA C IF TIC MARK IS BEFORE START OF AXIS, GO TO NEXT TIC MARK. IF (BLEN-BLMN) 60,56,56 C IF TIC MARK IS BEYOND END OF AXIS, GO TO DRAW LINE TO END OF AXIS. 56 IF (BLEN-SIZE1) 57,57,70 C CALCULATE COORDINATES OF TIC MARK AND PLOT IT. 57 X=X0+BLEN*COST Y=Y0+BLEN*SINT CALL PLOT(X,Y,2) C AI DETERMINES HEIGHT OF TIC MARK, LARGE TIC MARK FOR 10**N AXIS VALUE CALL PLOT(X+ AI*SONT,Y- AI*CIST,2) CALL PLOT(X,Y,2) 60 AI = 0.07 C INCREMENT FJ TO NEXT CYCLE. FJ = FJ+1.0 GO TO 55 C DRAW LINE TO END OF AXIS. 70 CALL PLOT(X0+SIZE1*COST,Y0+SIZE1*SINT,2) C LOOP BACKWARD THRU CYCLE FOR ANNOTATING TIC MARKS. 85 DO 110 K=1,9 I = 10-K C CALCULATE DISTANCE FROM START OF FIRST CYCLE TO TIC MARK. BLEN = (BLOG(I)+FJ)/DELTA C IF TIC MARK IS LOCATED BEFORE START OF AXIS, GO TO DRAW AXIS TITLE. IF (BLEN-BLMN) 120,86,86 C IF TIC MARK IS BEYOND END OF AXIS, GO TO NEXT TIC MARK. 86 IF (BLEN-SIZE1) 87,87,110 C IF TIC MARK IS AT INTERMEDIATE VALUE, GO TO DRAW DIGIT VALUE. 87 IF(I-1)100,90,100 C DRAW DIGIT 1 BY INTEGER-POWER-OF-TEN TIC MARK. 90 CALL NUMBER(X0+BLEN*COST+D1,Y0+BLEN*SINT+D2,0.14,1. ,THETA,-1) C COMPUTE POWER OF TEN FOR THIS CYCLE. IE = FXMN + FJ C INITIALIZE INDEX OF ANNOTATION ENDING TO PRODUCE S, E.G. TENS. I3 = 2 C TEST FOR REQUIRED ENDING. IF IE=0 GO TO NEXT TIC MARK. IF (IE) 95,110,96 C SET ENDING INDEX TO PRODUCE THS, E.G. TENTHS. 95 I3 = 1 IE = IABS(IE) C IF IE IS OUTSIDE RANGE FOR WORD ANNOTATION, USE DIGIT ANNOTATION. 96 IF (IE-14) 97,97,190 C IF ANNOTATION EXTENDS BEYOND END OF AXIS, GO TO NEXT TIC MARK. 97 IF (BLEN+HT*20.-SIZE1) 98,98,110 C SET INDEX OF START OF ANNOTATION, BLANK, TEN, OR HUNDRED. 98 I1 = MOD(IE,3)+1 C SET INDEX OF CENTER PART OF ANNOTATION, BLANK,THOUSAND,MILLION,ETC. I2 = IE/3+3 C DRAW PARTS OF ANNOTATION, USING AUTO-POSITIONING FEATURE OF SYMBOL. CALL SYMBOL(X0+BLEN*COST+D7,Y0+BLEN*SINT+D8,HT,IUNIT(1,I1),THETA, 1 NCHR(I1)) IF (I2-3) 205,210,205 205 CALL SYMBOL(AUTO,AUTO,HT,IUNIT(1,I2),THETA,NCHR(I2)) 210 CALL SYMBOL(AUTO,AUTO,HT,IEND(I3),THETA,3) GO TO 110 C DRAW DIGIT ANNOTATION OF INTEGER-POWER-OF-TEN TIC MARK. 190 CALL NUMBER(AUTO,AUTO,0.14,0.,THETA,-1) CALL NUMBER(X0+BLEN*COST+D3,Y0+BLEN*SINT+D4,0.07,FXMN+FJ,THETA,-1) GO TO 110 C IF CYCLE LENGTH IS LESS THAN 2 INCHES, GO TO NEXT TIC MARK. 100 IF (DELTA-0.5) 105,105,110 C ANNOTATE INTERMEDIATE TIC MARK. 105 CALL NUMBER(X0+BLEN*COST+D5,Y0+BLEN*SINT +D6, 10.105, FLOAT(I),THETA,-1) 110 CONTINUE C DECREMENT CYCLE COUNTER. FJ = FJ-1.0 C GO TO LOOP THRU NEXT CYCLE. GO TO 85 C TEST FOR ANNOTATING AXIS TITLE. 120 IF (NC) 125,130,125 C DRAW AXIS TITLE. 125 CALL SYMBOL(BCDX,BCDY,0.14,IBCD,THETA,NC) 130 RETURN END C.....SUBROUTINE BAR (XPAGE, YPAGE, ANGLE, HEIGHT, WIDTH, SH, IHAT, NPI) C..... C..... XPAGE, YPAGE ARE THE COORDINATES OF THE LOWER LEFT CORNER OF THE C..... BAR, IN INCHES. C.......ANGLE IS THE ANGLE AT WHICH THE BASE OF THE BAR IS DRAWN, C....... IN DEGREES. BAR IS ROTATED ABOUT (XPAGE, YPAGE). C.......HEIGHT IS THE HEIGHT OF THE MAIN BAR, IN INCHES. C.......WIDTH IS THE WIDTH OF THE BAR, IN INCHES. C.......SH IS THE HEIGHT OF THE INTERMEDIATE BAR, IN INCHES. C.......IHAT IS THE HATCHING CODE. THE INTERMEDIATE BAR IS C....... HATCHED ACCORDING TO THIS CODE. C....... C....... IF IHAT=1 DRAW BAR ONLY. C....... IF IHAT=2 HATCH FROM LEFT TO RIGHT. C....... IF IHAT=3 HATCH FROM RIGHT TO LEFT. C....... IF IHAT=4 HATCH BOTH WAYS. C.......NPI IS THE NUMBER OF LINES OF HATCHING PER INCH. C....... SUBROUTINE BAR (X,Y,TH,H,W,SH,IHAT,NPI) THETA = TH * 0.017453292 XS = SIN (THETA) XC = COS (THETA) AK = W * XC BK = W * XS CALL PLOT (X,Y,3) X1 = X - H * XS Y1 = Y + H * XC CALL PLOT (X1,Y1,2) X1 = X1 + AK Y1 = Y1 + BK CALL PLOT (X1,Y1,2) X1 = X + AK Y1 = Y + BK CALL PLOT (X1,Y1,2) CALL PLOT (X,Y,2) C SET FLAGS ACCORDING TO IHAT IF (SH)9,9,7 9 RETURN 7 IF(IHAT-1)9,10,8 8 IF(IHAT-3)11,12,13 10 K1 = 3 14 K2 = 3 GO TO 15 11 K1 = 2 GO TO 14 12 K1 = 3 16 K2 = 2 GO TO 15 13 K1 = 2 GO TO 16 C HATCH ONE 15 X2 = X - SH * XS Y2 = Y + SH * XC X3 = X2 + AK Y3 = Y2 + BK CALL PLOT (X3,Y3,K1) CALL PLOT (X2,Y2,2) CALL PLOT (X1,Y1,K2) IF (IHAT - 1) 9,9,25 25 FNPI = NPI L = W * FNPI M = SH * FNPI IF (M) 9,9,701 701 IF (L) 9,9,702 702 IF (L - M) 40,40,41 40 F = L GO TO 42 41 F = M 42 DH = SH / F DW = W / F W2 = 0.0 H1 = 0.0 IH = F - 1.0 DO 50 I = 1,IH H1 = H1 + DH H2 = SH - H1 W2 = W2 + DW W1 = W - W2 XP1 = X + W1 * XC YP1 = Y + W1 * XS CALL PLOT (XP1,YP1,3) CALL PLOT (X - H2 * XS, Y + H2 * XC,K2) CALL PLOT (X2 + W2 * XC, Y2 + W2 * XS,K1) CALL PLOT (X1 - H1 * XS, Y1 + H1 * XC,K2) CALL PLOT (XP1,YP1,K1) 50 CONTINUE GO TO 9 END C SUBROUTINE LGLIN (XARRAY,YARRAY,NV,K,JTYPE,NSY,LOGTYP) C XARRAY ARRAY CONTAINING VALUES TO BE PLOTTED AS THE ABSCISSAS, C EITHER LOGARITHMIC OR LINEAR. C YARRAY ARRAY CONTAINING VALUES TO BE PLOTTED AS THE ORDINATES, C EITHER LOGARITHMIC OR LINEAR. C XARRAY AND YARRAY MUST CONTAIN SCALING FACTORS. MINIMUM C VALUES MUST BE LOCATED AT (NV*K+1) AND DELTA VALUES MUST C BE LOCATED AT (NV*K+K+1). C NV NUMBER OF DATA POINTS TO BE PLOTTED. C K REPEAT CYCLE OF LOCATION OF VALUES IN ARRAYS. C JTYPE CONTROLS TYPE OF LINE PRODUCED. C JTYPE=0 PRODUCES A LINE PLOT ONLY. C JTYPE GREATER THAN ZERO PRODUCES A LINE PLOT WITH A C SYMBOL AT EVERY JTYPE-TH POINT THRU ARRAYS. C JTYPE LESS THAN ZERO PRODUCES ONLY SYMBOLS (NOT CONNECTED) C AT EVERY JTYPE-TH POINT THRU ARRAYS. C NSY INTEGER SPECIFYING CENTERED SYMBOL OF SYMBOL TABLE TO C BE DRAWN AT EVERY JTYPE-TH DATA POINT. C LOGTYP INTEGER SPECIFYING MODE OF PLOT, EITHER LOG-LOG C OR SEMI-LOG. C LOGTYP=0 PRODUCES A LOG-LOG PLOT. C LOGTYP=1 PRODUCES A SEMI-LOG PLOT LINEAR IN X. C LOGTYP=-1 PRODUCES A SEMI-LOG PLOT LINEAR IN Y. SUBROUTINE LGLIN (XARRA,YARRA,NV,K,JTYPE,NSY,LGTYP) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE LGLINE(XARRA,YARRA,NV,K,JTYPE,NSY,LGTYP) DIMENSION XARRA(2), YARRA(2), INTEQ(2) INTEQ(1) = NSY ETO10 = 0.4342945 LMN = NV*K+1 LDX = LMN+K NL = LMN-K C STORE SCALING FACTORS. XMIN = XARRA (LMN) DX = XARRA (LDX) YMIN = YARRA (LMN) DY = YARRA (LDX) C STORE COORDINATES OF ENDS OF LINE. X1 = XARRA (1) X2 = XARRA (NL) Y1 = YARRA (1) Y2 = YARRA (NL) C CONVERT LINEAR TO LOG, DEPENDING ON VALUE OF LOGTYP. IF (LGTYP) 10,10,20 10 XMIN = ETO10*ALOG(XMIN) X1 = ETO10*ALOG (X1) X2 = ETO10*ALOG (X2) 20 IF (LGTYP) 40,30,30 30 YMIN = ETO10*ALOG (YMIN) Y1 = ETO10*ALOG (Y1) Y2 = ETO10*ALOG (Y2) C LOCATE PEN. 40 CALL WHERE(XN,YN,Z) C FIND MAXIMUM OF COORDINATES OF END POINTS OF LINE. DF = AMAX1(ABS((X1-XMIN)/DX-XN),ABS((Y1-YMIN)/DY-YN)) DL = AMAX1(ABS((X2-XMIN)/DX-XN),ABS((Y2-YMIN)/DY-YN)) C SET CONSTANTS FOR POINT PLOT, LINE PLOT, OR LINE AND SYMBOL PLOT. C IC PEN UP-DOWN FOR PLOT. C IS PEN UP-DOWN FOR SYMBOL. C NA STEP FROM 1 TO NT. C NT WHEN NA=NT, USE SYMBOL. C NF SUBSCRIPT OF ARRAY VALUE TO BE PLOTTED. C KK STEP NF FORWARD OR BACKWARD THRU ARRAYS. C ICA,ISA VALUES OF IC AND IS AFTER FIRST POINT PLOTTED. C LSW FLAG TO SKIP PLOT CALL FOR POINT PLOT ONLY. IC = 3 IS = -1 NT = IABS(JTYPE) IF (JTYPE) 60,50,60 50 NT = 1 60 IF (DF-DL) 80,80,70 70 NF = NL NA = ((NV-1)/NT)*NT+NT-(NV-1) KK = -K GO TO 90 80 NF = 1 NA = NT KK = K 90 IF (JTYPE) 100,110,120 100 ICA = 3 ISA = -1 LSW = 1 GO TO 130 110 NA = LDX 120 ICA = 2 ISA = -2 LSW = 0 C BEGIN DO-LOOP FOR PLOTTING. 130 DO 230 I=1,NV C STORE COORDINATES. XN = XARRA (NF) YN = YARRA (NF) C CONVERT LINEAR TO LOG DEPENDING ON VALUE OF LOGTYP. IF (LGTYP)140,140,150 140 XN = ETO10*ALOG (XN) 150 IF (LGTYP) 170,160,160 160 YN = ETO10*ALOG (YN) C CALCULATE PAGE COORDINATES OF POINT. 170 XN = (XN-XMIN)/DX YN = (YN-YMIN)/DY C TEST FOR SYMBOL OR POSSIBLE PLOT CALL. IF (NA-NT) 180,190,200 C TEST FOR PLOT OR NO-PLOT. 180 IF (LSW) 210,200,210 190 CALL SYMBOL(XN,YN,0.08,INTEQ,0.0,IS) NA = 1 GO TO 220 200 CALL PLOT(XN,YN,IC) C RESET CONSTANTS. 210 NA = NA+1 220 NF = NF+KK IS = ISA 230 IC = ICA RETURN END C SUBROUTINE SCALG (VARRAY,DIST,NV,K) C VARRAY ARRAY OF DATA TO BE SCALED. MUST BE NV*K+K+1 IN LENGTH. C DIST THE DISTANCE OVER WHICH THE VALUES IN VARRAY ARE TO BE C PLOTTED, IN PAGE INCHES. C NV NUMBER OF VALUES IN VARRAY TO BE USED. C K REPEAT CYCLE OF LOCATION OF VALUES IN VARRAY. SUBROUTINE SCALG (VARRA,DIST,NV,K) C EARLIER VERSION OF THIS SUBROUTINE WAS C SUBROUTINE SCALOG(VARRA,DIST,NV,K) DIMENSION VARRA(2) C XMAX,XMIN TRIAL MINIMUM AND MAXIMUM VALUES. C T TEMP. VALUE BEING TESTED FOR MAXIMUM OR MINIMUM, C ALSO ROUNDING FACTOR. C NP SUBSCRIPT AND DO-LOOP LIMIT. ETO10 = 0.4342945 C INITIALIZE TRIAL MINIMUM AND MAXIMUM VALUES. XMAX = VARRA(1) XMIN = XMAX C CALCULATE LOCATION OF LAST POINT OF ARRAY. NP = NV*K C FIND MINIMUM AND MAXIMUM VALUES OF ARRAY. DO 10 I=1,NP,K T = VARRA(I) 5 IF (T-XMIN) 6,7,7 6 XMIN = T 7 IF (T-XMAX) 10,10,8 8 XMAX = T 10 CONTINUE C CALCULATE THE GREATEST 10**N LESS THAN OR EQUAL TO THE MINIMUM C VALUE OF THE ARRAY AND STORE IN THE ARRAY LOCATION (NV*K+1). XMIN = 10.0**(INT(ETO10*ALOG (XMIN)+100.0001)-100) NP = NP+1 VARRA (NP) = XMIN NP = NP+K C SET CONSTANT TO ROUND LOG OF MAXIMUM ARRAY VALUE UP. C DETERMINE DELTA VALUE (NUMBER OF LOG CYCLES COVERING ARRAY VALUES C DIVIDED BY THE DISTANCE OVER WHICH DATA IS TO BE PLOTTED) AND STORE C IN ARRAY LOCATION (NV*K+K+1). XMAX = INT (ETO10*ALOG (XMAX)-100.0001)+100 VARRA (NP) =(XMAX- ETO10*ALOG (XMIN))/DIST RETURN END C.....THE SHADE SUBROUTINE MAY BE USED TO SHADE A POLYGON FORMED BY C.....TWO LINES DEFINED BY TWO SETS OF POINTS. ANY NUMBER OF POINTS C.....MAY BE USED. C..... C.....CALL SHADE (XARAY1, YARAY1, XARAY2, YARAY2, DLIN, ANGLE, C..... NPTS1, INC1, NPTS2, INC2) C..... C..... XARAY1,YARAY1 ARE THE NAMES OF THE ARRAYS CONTAINING THE X AND C..... Y COORDINATES OF THE DATA POINTS TO BE PLOTTED C..... FOR LINE 1. C..... XARAY2,YARAY2 ARE THE NAMES OF THE ARRAYS CONTAINING THE X AND C..... Y COORDINATES OF THE DATA POINTS TO BE PLOTTED C..... FOR LINE 2. C..... DLIN IS THE DISTANCE BETWEEN LINES OF SHADING. C..... ANGLE IS THE ANGLE OF INCLINATION OF LINES OF SHADING, C..... IN DEGREES. C..... NPTS1 IS THE NUMBER OF DATA POINTS FORMING LINE 1. C..... INC1 IS THE INCREMENT BETWEEN ELEMENTS OF THE ARRAYS C..... (XARAY1 AND YARAY1) FORMING LINE 1. INC1 IS C..... GREATER THAN 1 IF THE VALUES TO BE PLOTTED ARE IN C..... A MIXED ARRAY. C..... NPTS2 IS THE NUMBER OF DATA POINTS FORMING LINE 2. C..... INC2 IS THE INCREMENT BETWEEN ELEMENTS OF THE ARRAYS C..... (XARAY2 AND YARAY2) FORMING LINE 2. INC2 IS C..... GREATER THAN 1 IF THE VALUES TO BE PLOTTED ARE IN C..... A MIXED OR MULTIDIMENSIONED ARRAY. C..... SUBROUTINE SHADE (X1,Y1,X2,Y2,D,TH,N1,J1,N2,J2) DIMENSION X1(2), Y1(2), X2(2), Y2(2), TS(20) R(C1,C2)=C1*C+C2*S RC(PX,PY,XM,YM,DX,DY) =R((PX-XM)/DX,(PY-YM)/DY) K1=J1 K2=J2 N3=K1*(N1-1)+1 N4=K2*(N2-1)+1 T1=TH*.0174533 C=COS(T1) S=SIN(T1) M=N3+K1 YM1=Y1(M) XM1=X1(M) M=M+K1 DY1=Y1(M) DX1=X1(M) M=N4+K2 YM2=Y2(M) XM2=X2(M) M=M+K2 DY2=Y2(M) DX2=X2(M) RYMIN=RC(Y1,X1,YM1,XM1,DY1,-DX1) RYMAX=RYMIN KK=1+K1 KJ=1+K2 DO 2 I=KK,N3,K1 T1=RC(Y1(I),X1(I),YM1,XM1,DY1,-DX1) RYMIN=AMIN1(RYMIN,T1) RYMAX=AMAX1(RYMAX,T1) 2 CONTINUE DO 9 I=1,N4,K2 T1=RC(Y2(I),X2(I),YM2,XM2,DY2,-DX2) RYMIN=AMIN1(RYMIN,T1) RYMAX=AMAX1(RYMAX,T1) 9 CONTINUE 3 M=0 IP=3 JU=-1 RXD=RC(X1(N3),Y1(N3),XM1,YM1,DX1,DY1) XD=RC(X2(N4),Y2(N4),XM2,YM2,DX2,DY2) RYD=RC(Y1(N3),X1(N3),YM1,XM1,DY1,-DX1) YD=RC(Y2(N4),X2(N4),YM2,XM2,DY2,-DX2) CALL STACK (XD,YD,RXD,RYD,RYMIN,TS,M) 10 RXD=RC(X1,Y1,XM1,YM1,DX1,DY1) XD=RC(X2,Y2,XM2,YM2,DX2,DY2) RYD=RC(Y1,X1,YM1,XM1,DY1,-DX1) YD=RC(Y2,X2,YM2,XM2,DY2,-DX2) CALL STACK (XD,YD,RXD,RYD,RYMIN,TS,M) 11 DO 5 I=KK,N3,K1 K=I-K1 RXD=RC(X1(I),Y1(I),XM1,YM1,DX1,DY1) XD=RC(X1(K),Y1(K),XM1,YM1,DX1,DY1) RYD=RC(Y1(I),X1(I),YM1,XM1,DY1,-DX1) YD=RC(Y1(K),X1(K),YM1,XM1,DY1,-DX1) CALL STACK (XD,YD,RXD,RYD,RYMIN,TS,M) 5 CONTINUE DO 8 I=KJ,N4,K2 K=I-K2 RXD=RC(X2(I),Y2(I),XM2,YM2,DX2,DY2) XD=RC(X2(K),Y2(K),XM2,YM2,DX2,DY2) RYD=RC(Y2(I),X2(I),YM2,XM2,DY2,-DX2) YD=RC(Y2(K),X2(K),YM2,XM2,DY2,-DX2) CALL STACK (XD,YD,RXD,RYD,RYMIN,TS,M) 8 CONTINUE M=M/2*2 IF(M)12,12,20 20 IF(M1)21,13,21 21 M1=0 GO TO 14 13 M1=M+1 14 DO 6 J=1,M I=IABS(M1-J) CALL PLOT (R(TS(I),-RYMIN),R(RYMIN,TS(I)),IP) IP=IP+JU 6 JU=-JU 12 RYMIN=RYMIN+D IF(RYMIN-RYMAX)3,22,22 22 RETURN END SUBROUTINE STACK (XD,YD,RXD,RYD,RYMIN,TS,M) DIMENSION TS(2) 7 XD=XD-RXD YD=YD-RYD IF(YD)18,1,18 18 RYD=RYMIN-RYD 31 TEST=RYD/YD T=TEST*XD+RXD IF(ABS(TEST-.5)-.5)16,17,1 17 RYMIN=RYMIN+.0001 RYD=RYD+.0001 GO TO 31 16 IF (M) 2,2,30 30 DO 4 J=1,M IF(TS(J)-T)4,19,19 19 A=TS(J) TS(J)=T T=A 4 CONTINUE 2 M=M+1 TS(M)=T 1 RETURN END SUBROUTINE AXIS(XPAGE,YPAGE,IBCD,NCHAR,AXLEN,ANGLE,FIRSTV,DELTAV) C..... XPAGE,YPAGE COORDINATES OF STARTING POINT OF AXIS, IN INCHES C..... IBCD AXIS TITLE. C..... NCHAR NUMBER OF CHARACTERS IN TITLE. + FOR C.C-W SIDE. C..... AXLEN FLOATING POINT AXIS LENGTH IN INCHES. C..... ANGLE ANGLE OF AXIS FROM THE X-DIRECTION, IN DEGREES. C..... FIRSTV SCALE VALUE AT THE FIRST TIC MARK. C..... DELTAV CHANGE IN SCALE BETWEEN TIC MARKS ONE INCH APART DIMENSION IBCD(2) KN=NCHAR A=1.0 IF (KN) 1,2,2 1 A=-A KN=-KN 2 EX=0.0 ADX= ABS (DELTAV) IF (ADX) 3,7,3 3 IF (ADX- 99.0) 6,4,4 4 ADX=ADX/10.0 EX=EX+1.0 GO TO 3 5 ADX=ADX*10.0 EX=EX-1.0 6 IF (ADX-0.01) 5,7,7 7 XVAL=FIRSTV*10.0**(-EX) ADX= DELTAV*10.0**(-EX) STH=ANGLE*0.0174533 CTH=COS(STH) STH=SIN(STH) DXB=-0.1 DYB=0.15*A-0.05 XN=XPAGE+DXB*CTH-DYB*STH YN=YPAGE+DYB*CTH+DXB*STH NTIC=AXLEN+1.0 NT=NTIC/2 DO 20 I=1,NTIC CALL NUMBER(XN,YN,0.105,XVAL,ANGLE,2) XVAL=XVAL+ADX XN=XN+CTH YN=YN+STH IF (NT) 20,11,20 11 Z=KN IF (EX) 12,13,12 12 Z=Z+7.0 13 DXB=-.07*Z+AXLEN*0.5 DYB=0.325*A-0.075 XT=XPAGE+DXB*CTH-DYB*STH YT=YPAGE+DYB*CTH+DXB*STH CALL SYMBOL(XT,YT,0.14,IBCD(1),ANGLE,KN) IF (EX) 14,20,14 14 Z=KN+2 XT=XT+Z*CTH*0.14 YT=YT+Z*STH*0.14 CALL SYMBOL(XT,YT,0.14,3H*10,ANGLE,3) XT=XT+(3.0*CTH-0.8*STH)*0.14 YT=YT+(3.0*STH+0.8*CTH)*0.14 CALL NUMBER(XT,YT,0.07,EX,ANGLE,-1) 20 NT=NT-1 CALL PLOT(XPAGE+AXLEN*CTH,YPAGE+AXLEN*STH,3) DXB=-0.07*A*STH DYB=+0.07*A*CTH A=NTIC-1 XN=XPAGE+A*CTH YN=YPAGE+A*STH DO 30 I=1,NTIC CALL PLOT(XN,YN,2) CALL PLOT(XN+DXB,YN+DYB,2) CALL PLOT(XN,YN,2) XN=XN-CTH YN=YN-STH 30 CONTINUE RETURN END SUBROUTINE LINE (XARRAY,YARRAY,NPTS,INC,LINTYP,INTEQ) C..... XARRAY NAME OF ARRAY CONTAINING ABSCISSA OR X VALUES. C..... YARRAY NAME OF ARRAY CONTAINING ORDINATE OR Y VALUES. C..... NPTS NUMBER OF POINTS TO BE PLOTTED. C..... INC INCREMENT OF LOCATION OF SUCCESSIVE POINTS. C..... LINTYP CONTROL TYPE OF LINE--SYMBOLS, LINE, OR COMBINATION. C..... INTEQ INTEGER EQUIVALENT OF SYMBOL TO BE USED, IF ANY. DIMENSION XARRAY(1),YARRAY(1) LMIN = NPTS*INC+1 LDX = LMIN+INC NL = LMIN-INC FIRSTX = XARRAY(LMIN) DELTAX = XARRAY(LDX) FIRSTY = YARRAY(LMIN) DELTAY = YARRAY(LDX) CALL WHERE (XN,YN,DF) DF=AMAX1(ABS((XARRAY( 1)-FIRSTX)/DELTAX-XN), 1 ABS((YARRAY( 1)-FIRSTY)/DELTAY-YN) ) DL=AMAX1(ABS((XARRAY(NL)-FIRSTX)/DELTAX-XN), 1 ABS((YARRAY(NL)-FIRSTY)/DELTAY-YN) ) IPEN = 3 ICODE = -1 NT =IABS(LINTYP) IF (LINTYP) 7,6,7 6 NT = 1 7 IF (DF-DL) 9,9,8 8 NF = NL NA = ((NPTS-1)/NT)*NT+NT-(NPTS-1) KK = -INC GO TO 10 9 NF = 1 NA = NT KK = INC 10 IF (LINTYP) 11,12,13 11 IPENA = 3 ICODEA = -1 LSW = 1 GO TO 15 12 NA=LDX 13 IPENA = 2 ICODEA = -2 LSW=0 15 DO 30 I =1,NPTS XN = (XARRAY(NF)-FIRSTX)/DELTAX YN = (YARRAY(NF)-FIRSTY)/DELTAY IF (NA-NT) 20,21,22 20 IF (LSW) 23,22,23 21 CALL SYMBOL (XN,YN,0.08,INTEQ,0.0,ICODE) NA = 1 GO TO 25 22 CALL PLOT (XN,YN,IPEN) 23 NA = NA + 1 25 NF = NF+KK ICODE = ICODEA 30 IPEN = IPENA RETURN END SUBROUTINE NUMBER (XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC) C..... XPAGE,YPAGE COORDINATES OF LOWER LEFT CORNER OF NUMBER. C..... HEIGHT HEIGHT OF PLOTTED NUMBER. C..... FPN FLOATING POINT NUMBER TO BE PLOTTED. C..... ANGLE ANGLE AT WHICH NUMBER IS PLOTTED, IN DEGREES. C..... NDEC NUMBER OF DECIMAL PLACES TO BE DRAWN. C..... THIS VERSION OF NUMBER REQUIRES THE SYMBOL VERSION WITH C..... 999. X, Y FEATURE, AND NC = 0 FEATURE. DIMENSION NUM(20) DATA MINUS/"55/,IPER/"56/,IZERO/"60/ II=0 FPV = FPN N = NDEC MAXN = 9 IF (N - MAXN) 11, 11, 10 10 N = MAXN 11 IF (N + MAXN) 12, 20, 20 12 N = -MAXN 20 IF (FPV) 21, 30, 30 21 II=II+1 NUM(II)=MINUS 30 MN = -N IF (N) 31, 32, 32 31 MN = MN - 1 32 FPV = ABS(FPV) + (0.5 * 10. ** MN) I = ALOG10(FPV) + 1.0 ILP = I IF (N + 1) 40, 41, 41 40 ILP = ILP + N + 1 41 IF (ILP) 50, 50, 51 50 II=II+1 NUM(II)=IZERO GO TO 61 51 IF (ILP+N-18) 54,54,52 52 N=-1 IF (ILP-19) 54,54,53 53 ILP=19 54 DO 60 J=1,ILP K = FPV * 10. ** (J - I) II=II+1 NUM(II)=K+IZERO FPV = FPV - (FLOAT(K) * 10. ** (I - J)) 60 CONTINUE 61 IF (N) 99, 70, 70 70 II=II+1 NUM(II)=IPER IF (N) 99, 99, 80 80 DO 90 J = 1, N K = FPV * 10. II=II+1 NUM(II)=K+IZERO 90 FPV = FPV * 10. - FLOAT(K) 99 CALL SYMBOL (XPAGE,YPAGE,HEIGHT,NUM,ANGLE,II+1000) RETURN END SUBROUTINE SCALE (ARRAY,AXLEN,NPTS,INC) C..... ARRAY NAME OF ARRAY CONTAINING VALUES TO BE SCALED. C..... AXLEN LENGTH IN INCHES OVER WHICH ARRAY IS TO BE SCALED. C..... NPTS NUMBER OF POINTS TO BE SCALED. C..... INC INCREMENT OF LOCATION OF SUCCESSIVE POINTS. DIMENSION ARRAY(1),SAVE(7) SAVE(1)=1.0 SAVE(2)=2.0 SAVE(3)=4.0 SAVE(4)=5.0 SAVE(5)=8.0 SAVE(6)=10.0 SAVE(7)=20. FAD=0.01 K=IABS(INC) N=NPTS*K Y0=ARRAY(1) YN=Y0 DO 25 I=1,N,K YS=ARRAY(I) IF (Y0-YS) 22,22,21 21 Y0=YS GO TO 25 22 IF (YS-YN) 25,25,24 24 YN=YS 25 CONTINUE FIRSTV=Y0 IF (Y0) 34,35,35 34 FAD=FAD-1.0 35 DELTAV=(YN-FIRSTV)/AXLEN IF (DELTAV) 70,70,40 40 I=ALOG10(DELTAV)+1000.0 P=10.0**(I-1000) DELTAV=DELTAV/P-0.01 DO 45 I=1,6 IS=I IF (SAVE(I)-DELTAV) 45,50,50 45 CONTINUE 50 DELTAV=SAVE(IS)*P FIRSTV=DELTAV*AINT(Y0/DELTAV+FAD) T=FIRSTV+(AXLEN+0.01)*DELTAV IF (T-YN) 55,57,57 55 FIRSTV=P*AINT(Y0/P+FAD) T=FIRSTV+(AXLEN+.01)*DELTAV IF (T-YN) 56,57,57 56 IS=IS+1 GO TO 50 57 FIRSTV=FIRSTV-AINT((AXLEN+(FIRSTV-YN)/DELTAV)/2.0)*DELTAV IF (Y0*FIRSTV) 58,58,59 58 FIRSTV=0.0 59 IF (INC) 61,61,65 61 FIRSTV=FIRSTV+AINT(AXLEN+.5)*DELTAV DELTAV=-DELTAV 65 N=N+1 ARRAY(N)=FIRSTV N=N+K ARRAY(N)=DELTAV 67 RETURN 70 DELTAV=2.0*FIRSTV DELTAV=ABS(DELTAV/AXLEN)+1. GO TO 40 END SUBROUTINE SYMBOL(XX,YY,H,IALPH,TH,NN) DIMENSION IALPH(1),JJ(2),ICHAR(1344) DIMENSION IFA(96),IFB(78),IFC(64),IFD(88),IFE(56),IFF(74), X IFG(90),IFH(80),IFI(110),IFJ(110),IFK(60),IFL(90),IFM(48), X IFN(104),IFO(96),IFP(100) EQUIVALENCE (ICHAR,IFA),(ICHAR(97),IFB),(ICHAR(175),IFC), X (ICHAR(239),IFD),(ICHAR(327),IFE),(ICHAR(383),IFF), X (ICHAR(457),IFG),(ICHAR(547),IFH),(ICHAR(627),IFI), X (ICHAR(737),IFJ),(ICHAR(847),IFK),(ICHAR(907),IFL), X (ICHAR(997),IFM),(ICHAR(1045),IFN),(ICHAR(1149),IFO), X (ICHAR(1245),IFP) C AMBERSAND IS CENT SIGN C AT IS LOGICAL NOT DATA IFA/ 1 "101,18,0,0,0,10,2,2,4,0,2,-2,0,-4,-8,0,8,0,0,-6, 1"102,24,0,0,0,12,6,0,2,-2,0,-2,-2,-2,-6,0,6,0,2,-2,0,-2,-2,-2,-6,0 2,"103,16,8,10,-2,2,-4,0,-2,-2,0,-8,2,-2,4,0,2,2, 3"104,14,0,0,0,12,6,0,2,-2,0,-8,-2,-2,-6,0, 4"105,14,8,12,-8,0,0,-6,6,0,-6,0,0,-6,8,0/ DATA IFB/ X "106,12,0,0,0,6,6,0,-6,0,0,6,8,0, 6"107,20,8,10,-2,2,-4,0,-2,-2,0,-8,2,-2,4,0,2,2,0,4,-4,0, 7"110,12,0,0,0,12,0,-6,8,0,0,6,0,-12, 8"111,12,6,0,-4,0,2,0,0,12,-2,0,4,0, 9"112,12,0,4,0,-2,2,-2,2,0,2,2,0,10/ DATA IFC/ X "113,12,0,0,0,12,0,-8,8,8,-6,-6,6,-6, 1"114,6,0,12,0,-12,8,0, 2"115,10,0,0,0,12,4,-6,4,6,0,-12, 3"116,8,0,0,0,12,8,-12,0,12, 4"117,18,2,0,-2,2,0,8,2,2,4,0,2,-2,0,-8,-2,-2,-4,0/ DATA IFD/ 5"120,14,0,0,0,12,6,0,2,-2,0,-2,-2,-2,-6,0, 6"121,24,6,0,-4,0,-2,2,0,8,2,2,4,0,2,-2,0,-8,-2,-2,9,9,-4,4,6,-4, 8"122,18,0,0,0,12,6,0,2,-2,0,-2,-2,-2,-6,0,4,0,4,-6, 9"123,24,0,2,2,-2,4,0,2,2,0,2,-2,2,-4,0,-2,2,0,2,2,2,4,0,2,-2/ DATA IFE/ 1 "124,8,4,0,0,12,-4,0,8,0, 1"125,12,0,12,0,-10,2,-2,4,0,2,2,0,10, 2"126,6,0,12,4,-12,4,12, 3"127,10,0,12,0,-12,4,6,4,-6,0,12, 4"130,10,0,0,8,12,-4,-6,-4,6,8,-12/ DATA IFF/ 5"131,10,0,12,4,-6,4,6,-4,-6,0,-6, 6"132,8,0,12,8,0,-8,-12,8,0, 7"60,18,2,0,-2,2,0,8,2,2,2,0,2,-2,0,-8,-2,-2,-2,0, 8"61,10,2,10,2,2,0,-12,-2,0,4,0, 9"62,18,0,8,0,2,2,2,2,0,2,-2,0,-2,-6,-6,0,-2,6,0/ DATA IFG/ 1"63,26,0,2,2,-2,2,0,2,2,0,2,-2,2,-2,0,2,0,2,2,0,2,-2,2,-2, 10,-2,-2, 2"64,12,0,10,0,-6,6,0,-2,0,0,8,0,-12, 3"65,20,0,2,2,-2,2,0,2,2,0,4,-2,2,-2,0,-2,-2,0,6,6,0, 4"66,24,0,4,2,2,2,0,2,-2,0,-2,-2,-2,-2,0,-2,2,0,8,2,2,2,0,2,-2/ DATA IFH/ 5"67,12,2,0,0,6,4,4,0,2,-6,0,0,-2, 6"70,34,2,0,-2,2,0,2,2,2,2,0,2,2,0,2,-2,2,-2,0,-2,-2,0,-2,2,-2,2,0, 72,-2,0,-2,-2,-2,-2,0, 8"71,24,0,2,2,-2,2,0,2,2,0,8,-2,2,-2,0,-2,-2,0,-2,2,-2,2,0,2,2, 9"40,2,0,0/ DATA IFI/ 1 "46 ,24,6,8,-2,2,-2,0,-2,-2,0,-2,2,-2,2,0,2,2,9,9,0,6, 10,0,-6,-10, 2"56,16,4,0,2,0,0,2,-2,0,0,-2,2,2,-2,0,2,-2, 3"74,6,8,10,-8,-4,8,-4, 4"50,8,6,0,-4,4,0,4,4,4, 5"53,10,0,6,8,0,-4,0,0,4,0,-8, 6 "134,4,6,0,-6,12, 7 "135,10,2,12,4,0,0,-12,-4,0,0,0, 8"41,16,4,12,0,-8,9,9,0,-4,0,0,9,9,0,0,0,0/ DATA IFJ/ A "44,28,0,4,2,-2,4,0,2,2,-2,2,-4,0,-2,2,2,2,4,0,2,-2,-2,2, 1-2,0,0,2,0,-12, 2"52,22,4,2,0,8,0,-4,-4,0,8,0,-4,0,-2,-2,4,4,-2,-2,-2,2,4,-4, 3"51,8,2,12,4,-4,0,-4,-4,-4, 4"73,16,4,8,0,0,9,9,0,0,0,0,9,9,0,-4,-2,-4, 5"100,6,0,4,8,0,0,-4, 6"55,4,0,6,8,0, 7"57,4,0,0,6,12, 8"54,6,2,0,2,4,-2,-4/ DATA IFK/ 1 "45,44,0,0,8,12,9,9,-8,-4,-1,1,0,1,1,1,1,0,1,-1,0,-1, 1-1,-1,-1,0,9,9,7,-7,-1,1,0,1,1,1,1,0,1,-1,0,-1,-1,-1,-1,0, 2"137,4,0,0,8,0, 3"76,6,0,10,8,-4,-8,-4/ DATA IFL/ 4"77,28,0,10,2,2,2,0,2,-2,0,-2,-2,-2,-2,0,0,-4,9,9,0,-2,0,0, 59,9,0,0,0,0, 6"72,22,4,4,0,0,9,9,0,0,0,0,9,9,0,4,0,0,9,9,0,0,0,0, 8"43,26,2,2,0,2,-2,0,8,0,-2,0,0,-2,0,8,0,-2,2,0,-8,0,2,0,0,2,0,-6, 9 "136,6,0,6,4,3,4,-3/ DATA IFM/ X "47,6,4,8,0,4,0,-4, 1"75,12,0,4,8,0,9,9,-8,4,0,0,8,0, 2"42,12,2,8,0,4,9,9,4,0,0,0,0,-4, 3 "133,10,6,12,-4,0,0,-12,4,0,0,0/ DATA IFN/ 1 0,18,0,0,0,6,6,0,0,-12,-12,0,0,12,6,0,9,9,0,-6, 2 1,26,0,0,0,6,3,0,3,-3,0,-6,-3,-3,-6,0,-3,3,0,6,3,3,3,0,9,9,0,-6, 3 2,14,0,0,0,6,6,-9,-12,0,6,9,9,9,0,-6, 4 3,18,0,0,9,9,0,6,0,-12,9,9,-6,6,12,0,9,9,-6,0, 5 4,18,0,0,9,9,6,6,-12,-12,9,9,12,0,-12,12,9,9,6,-6/ DATA IFO/ 1 5,16,0,0,0,6,6,-6,-6,-6,-6,6,6,6,9,9,0,-6, 2 6,16,0,0,0,6,6,-6,-12,0,6,6,9,9,0,-12,0,6, 3 7,16,0,0,9,9,-6,-6,12,12,-12,0,12,-12,9,9,-6,0, 4 8,22,0,0,9,9,-6,6,12,0,-12,-12,12,0,9,9,-2,6,-8,0,9,9,4,0, 5 9,16,0,0,6,6,9,9,-12,0,6,-6,0,-6,9,9,0,6/ DATA IFP/ 1 10,38,0,0,6,6,9,9,-3,-3,-6,0,-3,3,9,9,3,-3,0,-6,-3,-3,9,9,3,3, 2 6,0,3,-3,9,9,-3,3,0,6,9,9,-3,-3, 3 11,30,0,0,9,9,0,-6,0,12,9,9,6,-6,-12,0,9,9,0,6,12,-12,9,9,-12,0, 4 12,12,9,9,-6,-6, 5 12,12,0,0,6,6,-12,0,12,-12,-12,0,6,6, 6 13,12,0,0,9,9,0,6,0,-12,9,9,0,6/ DATA IDEC/"56/,IBLK/"40/ SCALE=H/.06 THETA=TH*.01745329 IF(ABS(XX-999.)-.1)110,100,100 100 XS=XX X=0. 110 IF(ABS(YY-999.)-.1)130,120,120 120 YS=YY Y=0. 130 N=MOD(NN,1000) IF(NN)5,5,4 4 IF(NN-1000)1,2,2 1 KCHAR=2 3 NUM=N/KCHAR NUM1=N-KCHAR*NUM IF(NUM1.NE.0)NUM=NUM+1 DO 16 KK=1,NUM NUM1=KCHAR IF(KK.EQ.NUM)NUM1=N-KCHAR*(KK-1) IBCD=IALPH(KK) JJ(1)=IBCD.AND."177 JJ(2)=IBCD/256.AND."177 SX=X SY=Y DO 15 M=1,NUM1 IPEN=3 IF(NN.LT.-1)IPEN=2 I=1 12 IF(JJ(M).EQ.ICHAR(I))GOTO 10 I=ICHAR(I+1)+I+2 IF(I.GE.1345)GOTO 13 GOTO 12 10 IF(JJ(M).EQ.IBLK)GOTO 13 N1=I+2 N2=N1+ICHAR(I+1)-2 DO 11 J=N1,N2,2 IF(ICHAR(J).EQ.9)IPEN=3 IF(ICHAR(J).EQ.9)GOTO 11 IF(JJ(M).EQ.IDEC)GOTO 18 X=X+ICHAR(J)*SCALE*.005 Y=Y+ICHAR(J+1)*SCALE*.005 18 IF(JJ(M).EQ.IDEC.AND.J.NE.N1)X=X+ICHAR(J)*.005 IF(JJ(M).EQ.IDEC.AND.J.NE.N1)Y=Y+ICHAR(J+1)*.005 IF(JJ(M).EQ.IDEC.AND.J.EQ.N1)X=X+.06*SCALE/3. IF(TH)40,50,60 50 CALL PLOT(X+XS,Y+YS,IPEN) GOTO 40 60 XP=X*COS(THETA)-Y*SIN(THETA) YP=X*SIN(THETA)+Y*COS(THETA) CALL PLOT(XP+XS,YP+YS,IPEN) 40 IPEN=2 11 CONTINUE 13 CONTINUE SX=SX+.06*SCALE X=SX Y=SY 15 CONTINUE 16 CONTINUE RETURN 5 N=1 2 KCHAR=1 GOTO 3 END SUBROUTINE FACTOR(FACT) CALL PLOT (FACT,FACT,1000) RETURN END SUBROUTINE NEWPEN C NEWPEN NULL IN PDP-11 RETURN END SUBROUTINE WHERE(XPAGE,YPAGE,RFACT) CALL PLOT(XPAGE,YPAGE,1001) CALL PLOT(RFACT,RFACT,1002) RETURN END SUBROUTINE PLOTS(IU,NAME,K) CALL ASSIGN(IU,NAME,K) XU=IU CALL PLOT(XU,XU,1003) RETURN END SUBROUTINE PLOT(XPAGE,YPAGE,IPEN) DATA IOLDX,IOLDY,IXPT,IYPT/4*0/,STEPS,STEPS1/2*200./ DATA FACT/1./ DATA IUNIT/0/ INEWP=IPEN 50 IF(INEWP-2)10,20,30 10 IF(INEWP)40,999,999 40 INEWP=-INEWP GOTO 50 30 IF(INEWP-999)20,1060,1000 20 IX=(XPAGE*STEPS+SIGN(.5,XPAGE))+IXPT IY=(YPAGE*STEPS+SIGN(.5,YPAGE))+IYPT 80 IF(INEWP-2)999,100,90 C OVERFLOW OR UNDER FLOW OF PLOT C IF ANY VALUE OF X,Y .LT.0 OR X1,X2 .GT. 16000 C OR Y1,Y2 .GT. 1599 DON'T PLOT LINE AT ALL 100 IF(IX.LT.0.OR.IY.LT.0.OR.IOLDX.LT.0.OR.IOLDY.LT.0 1 .OR.IX.GT.16000.OR.IY.GT.1599.OR.IOLDX.GT.16000 2 .OR.IOLDY.GT.1599)GOTO 90 WRITE(IUNIT)IOLDX,IOLDY,IX,IY 90 IOLDX=IX IOLDY=IY IF(IPEN)150,999,999 150 IXPT=IOLDX IYPT=IOLDY 999 RETURN 1000 IF(IPEN-1001)1010,1020,1030 1010 FACT=XPAGE STEPS=STEPS1*FACT RETURN 1020 XPAGE=FLOAT(IOLDX-IXPT)/STEPS YPAGE=FLOAT(IOLDY-IYPT)/STEPS RETURN 1030 IF(IPEN-1003)1040,1050,999 1040 XPAGE=FACT RETURN 1050 IF(IUNIT.EQ.0)GOTO 1051 IX=-1 WRITE(IUNIT)IX,IX,IX,IX CALL CLOSE(IUNIT) 1051 IUNIT=XPAGE GOTO 1070 1060 IX=-1 WRITE(IUNIT)IX,IX,IX,IX CALL CLOSE(IUNIT) IUNIT=0 1070 FACT=1. IOLDX=0 IOLDY=0 IXPT=0 IYPT=0 STEPS=STEPS1 RETURN END CALL PLOTS(2,7HSYM.DAT,7) CALL PLOT(1.,1.,-3) X=0. K=0 DO 1 I=1,16 Y=0. DO 2 J=1,8 INTEQ=J-1+K CALL SYMBOL(X,Y,.5,INTEQ,90.,-1) Y=Y+.75 2 CONTINUE X=X+.75 K=K+8 1 CONTINUE CALL PLOT(0.,0.,999) STOP END CALL PLOTS(3,8HCHAR.DAT,8) CALL SYMBOL(.25,.75,.15,38HCHARACTERS AVAILABLE IN SYMBOL ROUTINE 1,90.,38) CALL SYMBOL(.5 ,1. ,.15,37HINTERNAL EQUIVALENT TO LEFT OF SYMBOL 1,90.,37) CALL PLOT(.75,.64,-3) CALL PLOT(0.,6.72,2) X=0. K=0 DO 1 I=1,2 Y=0. CALL PLOT(X,Y,3) CALL PLOT(X+.96,Y,2) DO 2 J=1,7 INTEQ=J-1+K CALL SYMBOL(X+.48,Y+.48,.48,INTEQ,90.,-1) CALL NUMBER(X+.18,Y+.1,.12,FLOAT(INTEQ),90.,-1) CALL PLOT(X,Y+.96,3) CALL PLOT(X+.96,Y+.96,2) Y=Y+.96 2 CONTINUE X=X+.96 K=K+7 CALL PLOT(X,0.,3) CALL PLOT(X,6.72,2) 1 CONTINUE CALL PLOT(X,-.48,-3) CALL PLOT(0.,7.68,2) X=0. K=32 DO 3 I=1,8 Y=0. CALL PLOT(X,Y,3) CALL PLOT(X+.96,Y,2) DO 4 J=1,8 INTEQ=J-1+K CALL SYMBOL(X+.72,Y+.27,.48,INTEQ,90.,-1) CALL NUMBER(X+.18,Y+.1,.12,FLOAT(INTEQ),90.,-1) CALL PLOT(X,Y+.96,3) CALL PLOT(X+.96,Y+.96,2) Y=Y+.96 4 CONTINUE X=X+.96 K=K+8 CALL PLOT(X,0.,3) CALL PLOT(X,7.68,2) 3 CONTINUE CALL PLOT(0.,0.,999) STOP END REAL X(200),Y(200),SIZE,T,DT,F,DUM INTEGER NPTS,I C C INTERNAL FUNCTION C F(T)=T C C PARAMETERS C NPTS=190 DT=.1 SIZE=7. C C CALCULATE POINTS C DO 110 I=1,NPTS T=FLOAT(I-1)*DT X(I)=F(T)*COS(T) Y(I)=F(T)*SIN(T) 110 CONTINUE C C MAKE THE GRAPH C CALL PLOTS(1,10HFOR001.DAT,10) CALL FACTOR(.9) CALL PLOT(.5,.5,-3) CALL SCALE(X,SIZE,NPTS,1) CALL SCALE(Y,SIZE,NPTS,1) CALL AXIS(0.,0.,15HX = F(T)*COS(T),-15,SIZE,0.,X(NPTS+1), X X(NPTS+2)) CALL AXIS(0.,0.,15HY = F(T)*SIN(T),15,SIZE,90.,Y(NPTS+1), X Y(NPTS+2)) CALL LINE(X,Y,NPTS,1,0,0) CALL SYMBOL(.5,7.5,.42,6HSPIRAL,0.,6) CALL SYMBOL(.75,7.,.21,8HF(T) = T,0.,8) CALL PLOT(11.,0.,999) END .ROOT RES-*(CSI,PARS,OPEN,CLDEL,READIN) RES: .FCTR PLT/LB:PLOTIT:PLTDAT:ERMSG CSI: .FCTR [1,1]SYSLIB/LB:.CSI1:.CSI2 PARS: .FCTR [1,1]SYSLIB/LB:PARSE OPEN: .FCTR [1,1]SYSLIB/LB:OPFNB CLDEL: .FCTR [1,1]SYSLIB/LB:DLFNB:CLOSE READIN: .FCTR [1,1]SYSLIB/LB:READ:WAITU .END [1,50]PLT/EA,[1,30]PLT=PLT/MP TASK=...PLT PAR=PAR14K:41000:77000 UNITS=2 ASG=TI:1,SY:2 STACK=32 / .TITLE PLTDAT - PLOTTER DATA FILE .IDENT /1.1/ .NLIST TTM ;NVEC - NUMBER OF VECTORS ALLOWED NVEC==3000. ;LINESZ - NUMBER OF DOTS IN LINE LINESZ==1600. ;LINCNT - NUMBER OF BYTES/LINE LINCNT== .MCALL FDBDF$,FDRC$A,FDBK$A,FDOP$A .MCALL FSRSZ$,CSI$,CSI$SW,CSI$SV,CSI$ND .MCALL GMCR$,NMBLK$ LINSV=. ;SAVE CURRENT ADDRESS ;FILE BLOCK I/O SPECS FOR RSX11M PLTFIL::FDBDF$ ;DEFINE FDB FDRC$A FD.RWM ;BLOCK I/O FDBK$A BUFFER,512.,,,STATUS ;BLOCK DEFNS FDOP$A 2,CSIBLK+C.DSDS,DEFBLK,FO.RD ;UNIT 2 FROOM CSIBLK+DEFBLK, RO ; GET MCR COMMAND LINE DIRECTIVE GMCR:: GMCR$ ; DEFILE CSIBLK + OFFSETS CSI$ ;DEFINE OFFSETS CSIBLK::.BLKB C.SIZE ;RESERVE SPACE FOR CSIBLK ;NOW DEFINE SWITCH TABLES FOR CSI SWTAB:: CSI$SW DE,200,STWD,SET ;DELETE INPUT FILE SWITCH CSI$SW CO,100000,STWD,SET,,COTAB ;COPIES SWITCH CSI$ND ;EOL COTAB:: CSI$SV DECIMAL,REPCNT,2 CSI$ND ;EOL ;SWITCH STATUS WORD STWD:: .WORD 0 ;DEFAULT FILENAME BLOCK DEFBLK::NMBLK$ ,DAT ;INITIALIZE FSR - 0 SINCE ONLY BLOCK I/O IS USED FSRSZ$ 0 ;BUFFER - 512. BYTES (1 BLOCK) BUFFER::.BLKB 512. ;I/O STATUS - 2 WORDS STATUS::.BLKW 2 ;LOCATION FOR LOCAL BUFFER (6 WORDS) VBUFF:: .BLKW 6 ;LOCAL BUFFER POINTER LBUFF:: .WORD VBUFF ;SYSTEM BUFFER POINTER SYBUFF::.WORD BUFFER ;COUNT - FOR LOADING VBUFF BUFCNT::.WORD 6 IOSZ=.-LINSV .=LINSV ;ALLOCATE PLOT LINE ON TOP OF THE ABOVE .IF GT IOSZ-LINESZ ;SO WE DON'T DESTROY DATA .=LINSV+IOSZ-LINESZ .ENDC ;PLOT LINE LINE:: .BLKB LINESZ ;OTHER LOCATIONS ;PLACE TO SAVE MAXX XSAV:: .WORD ;PLACE TO SAVE NPTS NSAV:: .WORD ;REPEAT COUNT REPCNT::.WORD 1 ; VECCNT - NUMBER OF VECTORS REMAINING TO BE PLOTTED VECCNT::.WORD ; YCNT - NUMBER OF Y POINTS TO PLOT YCNT:: .WORD ; IPT - ARRAY OF VECTORS IPT:: .BLKW NVEC*4 ; NPTS - NUMBER OF VECTORS USED NPTS:: .WORD ; MAXX - MAX X COORDINATE MAXX:: .WORD ; ACTIVE - START OF ACTIVE VECTORS ACTVEC::.WORD IPT ;CONSTANTS ;PLOTTING ROUTINE LPS=177514 LPB=177516 ;THIS SUBROUTINE ACTS AS AN INTERFACE BETWEEN PLOTIT ;AND THE LINE PRINTER-PLOTTER LPLOT:: MOV #LINE,R4 MOV #LINCNT,R3 TSTB @#LPS BPL .-4 LOOP: CLR R2 .REPT 10 ASRB (R4)+ ROL R2 .ENDR MOV R2,@#LPB DEC R3 BNE LOOP RTS PC .END .TITLE ERMSG .IDENT /1.1/ ; ; ERROR MESSAGE ROUTINE ; ; EQUATED SYMBOLS ; S$V0==0 ;SEV 0=DIAGNOSTIC MESSAGE S$V1==1 ;SEV 1=DIAG IF TERM IN/FATAL IF NOT S$V2==2 ;SEV 2=FATAL ERROR ; ; MACRO LIBRARY CALLS ; .MCALL CLOSE$,EXIT$S,DIR$,QIO$,WTSE$S .MCALL CALL,RETURN ; ; LOCAL MACROS ; ; ERROR MESSAGE DEFINITION ; ; ERM NUM,FORMAT ; ; WHERE: ; ; NUM=ERROR NUMBER. ; FORMAT=ERROR MESSAGE FORMAT STATEMENT. ; .MACRO ERM NUM,FORMAT E$R'NUM==NUM'. ERMAX=NUM'. .PSECT ERRMSG,D $$$=. .ASCIZ "FORMAT" .PSECT ERRTAB,D .=MESSG+<2*NUM'.> .WORD $$$ .PSECT .ENDM ; ; LOCAL DATA ; .PSECT ERRMSG,D PREFX: .ASCIZ /PLT -- / ;PLT ERROR MESSAGE PREFIX .PSECT ERRTAB,D MESSG: ;REF LABEL .PSECT ; ; ERROR MESSAGES ; ERM 0,^\FILENAME REQUIRED\ ERM 1,^\WILD CARD NOT ALLOWED\ ERM 2,^\ONLY ONE INPUT FILE MAY BE SPECIFIED\ ERM 3,^\ILLEGAL FILENAME\ ERM 4,^\ILLEGAL SWITCH\ ERM 5,^\FILE NOT FOUND\ ERM 6,^\FILE HAS ILLEGAL FORMAT\ ERM 7,^\COMMAND I/O ERROR\ ERM 8,^\BAD COMMAND FORMAT\ ERM 9,^\ONLY FIRST %D. VECTORS WILL BE PLOTTED\ ERM 10,^\DELETE FAILED --- INCORRECT PERMISSION\ ERM 11,^\EMPTY FILE (NO VECTORS)\ ; ; QIO DPB FOR ERROR MESSAGE OUTPUT ; CODPB: QIO$ IO.WVB,1,1,,COSTS,,<0,0,40,0,0,0> ; ; CONSOLE OUTPUT I/O STATUS DOUBLE WORD ; COSTS: .BLKW 2 ;+ ; **-$ERMSG-ERROR MESSAGE ROUTINE ; ; THIS ROUTINE IS CALLED TO OUTPUT AN ERROR MESSAGE. THE ERROR ; NUMBER SPECIFIES AN ERROR FORMAT WHICH IS PASSED TO $EDMSG TO ; EDIT THE ERROR MESSAGE. THE RESULTANT ERROR MESSAGE IS THEN ; OUTPUT USING THE ROUTINE $PUTCO. ; ; INPUTS: ; ; R1=ERROR/SEVERITY NUMBERS. ; R2=ARGUMENT BLOCK ADDRESS. ; ; OUTPUTS: ; ; THE SPECIFIED ERROR MESSAGE IS OUTPUT AND THE INPUT FILE IS ; CLOSED AND AN EXIT IS EXECUTED. ;- $ERMSG::CLR R4 ;PICKUP ERROR NUMBER BISB R1,R4 ; MOV R1,R5 ;COPY ERROR AND SEVERITY CODES CMP #ERMAX,R4 ;ERROR CODE WITHIN RANGE? BLO 20$ ;IF LO NO ASL R4 ;CONVERT TO WORD INDEX MOV MESSG(R4),R1 ;GET ADDRESS OF FORMAT STRING BEQ 20$ ;IF EQ ERROR IS NOT DEFIEQD MOV #GMCR+2,R0 ;GET ADDRESS OF ERROR MESSAGE BUFFER MOV #PREFX,R3 ;GET ADDRESS OF PREFIX STRING 10$: MOVB (R3)+,(R0)+ ;INSERT PREFIX IN MESSAGE BUFFER BNE 10$ ;IF NE MORE TO GO DEC R0 ;BACKUP TO ZERO BYTE CALL $EDMSG ;FORMAT OUTPUT CALL $PUTLN ;OUTPUT MESSAGE SWAB R5 ;LOOK AT SEVERITY CODE TSTB R5 ;IS IT ZERO? BNE 20$ ;IF NE NO RETURN ;EXIT ON DIAGNOSTIC 20$: CLOSE$ #PLTFIL ;CLOSE INPUT FILE IF OPEN EXIT$S ;EXIT ;+ ; **-$PUTLN-OUTPUT MCR DISPLAY MESSAGE ; ; INPUTS: ; ; R0=ADDRESS OF NEXT BYTE IN OUTPUT BUFFER. ; ; OUTPUTS: ; ; THE LENGTH OF THE MESSAGE IS CALCULATED AND THEN THE MESSAGE ; IS OUTPUT. ;- $PUTLN::MOV R0,R2 ;COPY ADDRESS OF NEXT BYTE MOV #GMCR+2,R1 ;GET ADDRESS OF OUTPUT BUFFER SUB R1,R2 ;CALCULATE LENGTH OF MESSAGE ; ; SUBROUTINE TO ISSUE A MESSAGE TO DEVICE 'CO' ; ; INPUTS: ; R1=BUFFER ADDRESS ; R2=BYTE COUNT ; ; OUTPUTS: ; ; C-CLEAR: SUCCESS, MESSAGE IS PRINTED ON DEVICE 'CO' ; ; C-SET: REQUEST FAILED ; $PUTCO::MOV #,R0 ;POINT TO DPB PARAMETERS MOV R1,(R0)+ ;SET BUFFER ADDRESS MOV R2,(R0)+ ;BYTE COUNT DIR$ #CODPB ;ISSUE QIO DIRECTIVE BCS 10$ ;EXIT ON FAILURE WTSE$S #1 ;WAIT FOR I/O COMPLETION ROLB COSTS ;MOVE SIGN BIT TO 'C' 10$: RETURN ;EXIT .END