compilerource

Post Reply
rhtatum

Re: What is the Telpar OS?

Post by rhtatum » Mon Jan 11, 2010 2:58 am

Source for Mike's version of PL360???MONITOR 10/14/75 VERSION 05 (PREVIOUS: MONITOR 10/14/75 VERSION 04) $NOCLOSE BEGIN COMMENT SYSTEM/360 SUPERVISOR TELPAR, INC. 4300 SIGMA ROAD DALLAS, TEXAS (214) 233-6631 WRITTEN BY MICHAEL GREEN; GLOBAL 65 PROCEDURE LEVEL0(R1); BEGIN COMMENT INTERRUPT LEVEL PROCESSING ROUTINES; GLOBAL 64 BASE R2; COMMENT STORAGE FOR LEVEL0; INTEGER YEAR,DAY,SECOND, COMMENT TIME OF DAY AND DATE; JOBTIME, COMMENT JOB PROCESSING TIME IN SECONDS; MAXTIME, COMMENT MAXIMUM NO OF SECONDS FOR JOB; USERMEMORY, COMMENT START OF USER MEMORY AREA; ENDMEMORY, COMMENT ADDRESS OF LAST BYTE IN MEMORY; ENDJOBCOUNT, COMMENT JOB CONTROL END JOB SEMAPHORE; OPERATORCOUNT, COMMENT SEMAPHORE FOR OPERATOR COMMAND PROGRAM; FIRSTPCB, COMMENT POINTER TO START OF PROCESS QUEUE; LASTPCB, COMMENT POINTER TO LAST PCB IN PROCESS QUEUE; FREEPCB, COMMENT POINTER TO AVAILABLE PCB LIST; CURRENTPCB, COMMENT POINTER TO CURRENT PCB; NUMBEROFPCBS=16, COMMENT NUMBER OF PROCESS CONTROL BLOCKS; PCBSIZE=216, COMMENT SIZE OF PROCESS CONTROL BLOCK (BYTES); LOCKOUTCOUNT, COMMENT NUMBER OF PROCESSES LOCKED OUT IN CANCEL; MAXPCBNO; COMMENT NUMBER OF LAST PROCESS STARTED; BYTE PROTECTION, COMMENT MACHINE HAS STORAGE PROTECT; FLOATINGPOINT, COMMENT MACHINE HAS FLOATING POINT; CANCELFLAG; COMMENT ANY CANCEL REQUESTED; INTEGER TIMER SYN 80; COMMENT INTERVAL TIMER LOCATION; INTEGER ENDSUPERVISOR SYN 76; COMMENT SET BY IPL ROUTINE; INTEGER CONSOLEADDRESS SYN 76; COMMENT SET AFTER IPL ON ATTENTION; ARRAY 2 INTEGER SAVEPSW SYN 704; COMMENT INITIAL PSW SAVE AREA; ARRAY 4 INTEGER SAVEREGS SYN 712; COMMENT INITIAL REGISTER SAVE; LONG REAL RINGBELLCCW=#0B00000020000001L; COMMENT CONSOLE BELL; COMMENT DEFINITION OF FIELDS IN PROCESS CONTROL BLOCK; BYTE STATUS SYN 0; COMMENT STATUS OF PROCESS: 0 - READY FOR EXECUTION, 1 - WAITING FOR SEMAPHORE CHANGE, 2 - WAITING FOR I/O COMPLETION, 3 - WAITING FOR I/O DEVICE, 4 - WAITING FOR CANCEL RECOVERY, 5 - WAITING FOR TIME INTERVAL, 6 - WAITING FOR PROGRAM CHECK RECOVERY, 128 - 134 - PROCESS WITH STATUS 0 - 6 STOPPED ON CANCEL; INTEGER LINK SYN 0, COMMENT LINK TO NEXT PCB; SEMAPHORE SYN 4, COMMENT ADDRESS OF SEMAPHORE WAITED FOR; INTERVAL SYN 4, COMMENT SECONDS REMAINING IN WAIT INTERVAL; CANCELCODE SYN 4, COMMENT CODE TO IDENTIFY CANCEL, SEE JOB SEQ; IODEVICE SYN 4; COMMENT ADDRESS OF I/O DEVICE INVOLVED IN WAIT; ARRAY 2 INTEGER CSW SYN 8; COMMENT SAVED CHANNEL STATUS WORD; ARRAY 10 INTEGER CCWS SYN 16; COMMENT ROOM FOR 5 CHANNEL COMMANDS; ARRAY 2 INTEGER PSWSUSPEND SYN 56; COMMENT PROCESS SUSPENDED PSW; ARRAY 16 INTEGER REGSUSPEND SYN 64; COMMENT PROCESS SUSPENDED REG; ARRAY 2 INTEGER PSWSVC SYN 128; COMMENT SVC SAVED PSW; ARRAY 8 INTEGER REGSVC SYN 136; COMMENT SVC SAVED REGISTERS 15-6; ARRAY 5 BYTE DISKRECORDID SYN 168; COMMENT DISK RECORD ID FIELD; BYTE SVCGOING SYN 173; COMMENT - #FF INDICATES SVC IN PROGRESS; SHORT INTEGER IOSTATUS SYN 174; COMMENT I/O DEVICE SENSE BYTES; ARRAY 8 BYTE DISKCOUNTID SYN 176; COMMENT DISK COUNT FIELD; INTEGER PRGCHKMASK SYN 184, COMMENT PROCESS ALLOWED PROGRAM CHKS; IOTIMEOUT SYN 188; COMMENT USED FOR TIMED I/O; ARRAY 3 INTEGER LEVEL1WORK SYN 192; COMMENT WORK AREA FOR LEVEL1; INTEGER PCBNUMBER SYN 204; COMMENT NUMBER IDENTIFIES PROCESS; ARRAY 6 BYTE DISKSEEKADR SYN 208; COMMENT BBCCHH SEEK ADDRESS; SHORT INTEGER LEVEL1MOREWK SYN 214; BYTE SVCLOCKOUT SYN PRGCHKMASK(2), COMMENT INDICATES SVC LOCKED; SVCCANCEL SYN PRGCHKMASK(3); COMMENT 1 - CANCEL, 2 - STOP; EXTERNAL 67 PROCEDURE PROCESSSVC(R1); NULL; COMMENT SVC 16 AND UP; EXTERNAL 69 PROCEDURE LEVEL1(R1); NULL; COMMENT STARTED HERE; FUNCTION LPSW(8,#8200); PROCEDURE SUSPEND(R1); BEGIN COMMENT IF THERE IS A CURRENTLY ACTIVE PROCESS, SAVE ITS PSW AND REGISTER CONTENTS AND PLACE ITS PCB AT THE END OF THE PCB QUEUE; R0:=R1; R1:=CURRENTPCB; IF R1 ~= 0 THEN BEGIN COMMENT PROCESS ACTIVE; STM(R3,R14,REGSUSPEND(R1+12)); COMMENT SAVE REGISTERS; LM(R3,R6,SAVEREGS); STM(R4,R6,REGSUSPEND(R1)); REGSUSPEND(R1+60):=R3; COMMENT NOW SAVE PSW; LM(R3,R4,SAVEPSW); STM(R3,R4,PSWSUSPEND(R1)); R3:=LASTPCB; R4:=FIRSTPCB; LASTPCB:=R1; IF R4 = 0 THEN FIRSTPCB:=R1 ELSE BEGIN IC(R5,STATUS(R3)); LINK(R3):=R1; STC(R5,STATUS(R3)); END; R5:=0; LINK(R1):=R5; CURRENTPCB:=R5; COMMENT STATUS IS 0 AND NO CURRENT PROCESS; END; R1:=R0; COMMENT RESTORE RETURN ADDRESS; END; PROCEDURE SETUP(R1); BEGIN COMMENT IF CURRENTPCB POINTS TO A PCB, SET UP THAT PROCESS FOR RESUMPTION; R3:=CURRENTPCB; IF R3 ~= 0 THEN BEGIN LM(R5,R7,REGSUSPEND(R3)); R4:=REGSUSPEND(R3+60); STM(R4,R7,SAVEREGS); COMMENT RESTORE REGISTER CONTENTS; LM(R4,R5,PSWSUSPEND(R3)); STM(R4,R5,SAVEPSW); LM(R3,R14,REGSUSPEND(R3+12)); COMMENT AND PSW; END; END; PROCEDURE MAKECURRENT(R7); BEGIN COMMENT REMOVE PCB FROM QUEUE AND MAKE IT THE CURRENT PCB. R3 = @PCB TO BE REMOVED, R4 = @PREVIOUS PCB OR 0 IF R3 = @FIRST PCB; R5:=LINK(R3) AND #FFFFFF; IF R4 = 0 THEN FIRSTPCB:=R5 ELSE BEGIN IC(R6,STATUS(R4)); LINK(R4):=R5; STC(R6,STATUS(R4)); END; IF R5 = 0 THEN LASTPCB:=R4; CURRENTPCB:=R3; END; PROCEDURE FINDREADY(R1); BEGIN COMMENT FIND FIRST READY PCB AND MAKE CURRENT. IF NONE ARE READY, SET UP FOR WAIT STATE; BYTE FOUNDREADY; R3:=FIRSTPCB; R4:=0; RESET(FOUNDREADY); WHILE ~FOUNDREADY AND R3 ~= 0 DO BEGIN COMMENT SEARCH; CLI(0,STATUS(R3)); IF = THEN BEGIN COMMENT FOUND ONE; SET(FOUNDREADY); MAKECURRENT; END ELSE BEGIN COMMENT TRY NEXT; R4:=R3; R3:=LINK(R3) AND #FFFFFF; END; END; IF ~FOUNDREADY THEN BEGIN COMMENT SET UP FOR WAIT; R3:=#FF070000; R4:=0; STM(R3,R4,SAVEPSW); END; END; PROCEDURE FINDWAITING(R1); BEGIN COMMENT FIND PCB FOR FIRST PROCESS WAITING FOR A SEMAPHORE AND MAKE IT THE CURRENT PCB. R0 = @SEMAPHORE. IF NONE ARE WAITING FOR THE SEMAPHORE, SET CONDITION CODE TO ~= ELSE SET TO =; BYTE FOUNDWAITING; R3:=FIRSTPCB; R4:=0; RESET(FOUNDWAITING); WHILE ~FOUNDWAITING AND R3 ~= 0 DO BEGIN COMMENT SEARCH; CLI(1,STATUS(R3)); IF = AND R0 = SEMAPHORE(R3) THEN BEGIN SET(FOUNDWAITING); MAKECURRENT; COMMENT FOUND ONE; END ELSE BEGIN COMMENT TRY NEXT PCB; R4:=R3; R3:=LINK(R3) AND #FFFFFF; END; END; TEST(FOUNDWAITING); COMMENT SET CONDITION CODE); END; PROCEDURE CANCELKILL(R8); BEGIN COMMENT KILL USER PROCESSES FOR CANCEL AND PROGRAM CHECK; FUNCTION HIO(8,#9E00); R0:=#3FFFFFFF; MAXTIME:=R0; R1:=FIRSTPCB; WHILE R1 ~= 0 DO BEGIN IF SVCGOING(R1) THEN TM(#01,PSWSVC(R1+1)) ELSE TM(#01,PSWSUSPEND(R1+1)); IF OVERFLOW THEN BEGIN COMMENT GOT USER PROCESS; IF SVCLOCKOUT(R1) THEN BEGIN COMMENT SVC LOCKED OUT; CLI(1,SVCCANCEL(R1)); IF ~= THEN BEGIN R0:=LOCKOUTCOUNT+1; LOCKOUTCOUNT:=R0; END; MVI(1,SVCCANCEL(R1)); COMMENT MARK AS BEING CANCELLED; CLI(1,STATUS(R1)); IF = THEN BEGIN COMMENT P WAIT; R3:=SEMAPHORE(R1); R0:=B3+1; B3:=R0; MVI(0,STATUS(R1)); OI(#10,PSWSUSPEND(R1+4)); END; END ELSE BEGIN COMMENT NOT LOCKED OUT, KILL IT; OI(#80,STATUS(R1)); CLI(#82,STATUS(R1)); IF = THEN BEGIN COMMENT KILL I/O; R3:=IODEVICE(R1); HIO(B3); END; END; END; R1:=LINK(R1) AND #FFFFFF; COMMENT TRY NEXT PCB; END; SET(CANCELFLAG); COMMENT MARK JOB CANCELLED; R0:=LOCKOUTCOUNT; IF R0 = 0 THEN BEGIN COMMENT START JOB CNTRL; R0:=@ENDJOBCOUNT; FINDWAITING; IF ~= THEN FINDREADY; END ELSE FINDREADY; END; GLOBAL 66 PROCEDURE IOSTUFF(R1); BEGIN COMMENT ROUTINE TO HANDLE ALL I/O INITIATION AND INTERRUPT PROCESSING. THE CURRENT PROCESS HAS ALREADY BEEN SUSPENDED. R8 = @PCB, R9 = 1 FOR DOIO, 2 FOR I/O INTERRUPT, R10 = I/O DEVICE ADDRESS. ON ERROR OR NORMAL TERMINATION (DEVICE END), SET CONDITION CODE AS FOLLOWS: = - NORMAL END, < - UNIT CHECK, > - UNIT EXCEPTION (ONLY), OVERFLOW - DEVICE NOT OPERATIVE; LONG REAL SENSECCW=#0400000020000002L, COMMENT SENSE COMMAND; WAITPSW=#0002000000000003L; COMMENT CHANNEL CHECK WAIT; ARRAY 2 INTEGER IOCSW SYN 64, OLDPRG SYN 40, NEWPRG SYN 104; INTEGER CAW SYN 72, SENSEADDRESS SYN SENSECCW; BYTE FOUNDIOWAIT, FOUNDDEVWAIT; FUNCTION SIO(8,#9C00), TIO(8,#9D00), HIO(8,#9E00); PROCEDURE PUTATHEAD(R12); BEGIN COMMENT PUT CURRENT PCB AT HEAD OF QUEUE; R1:=CURRENTPCB; R0:=FIRSTPCB; LINK(R1):=R0; FIRSTPCB:=R1; R0:=LASTPCB; IF R0 = 0 THEN LASTPCB:=R1; R0:=0; CURRENTPCB:=R0; END; PROCEDURE CHECKCONSOLE(R11); BEGIN COMMENT CHECK FOR CONSOLE ATTENTION; TM(#80,IOCSW(4)); IF OVERFLOW THEN BEGIN COMMENT GOT IT; TM(#01,IOCSW(4)); IF = THEN BEGIN COMMENT UNLESS UNIT EXCEPTION TOO; CONSOLEADDRESS:=R10; COMMENT FOUND CONSOLE ADDRESS; R0:=@OPERATORCOUNT; FINDWAITING; IF = THEN PUTATHEAD; COMMENT MAKE FIRST; END; END; END; PROCEDURE FINDCHANWAIT(R11); BEGIN COMMENT FIND PROCESS WAITING FOR CHANNEL OR ANY READY PROCESS IF NONE WAITING FOR CHANNEL; BYTE FOUNDCHANWAIT; R8:=FIRSTPCB; RESET(FOUNDCHANWAIT); R10:=R10 AND #F00; WHILE ~FOUNDCHANWAIT AND R8 ~= 0 DO BEGIN COMMENT SEARCH; R0:=IODEVICE(R8) AND #F00; CLI(3,STATUS(R8)); IF = AND R0 = R10 THEN BEGIN R9:=1; R10:=IODEVICE(R8); SET(FOUNDCHANWAIT); COMMENT FOUND ONE, SET UP TO START I/O NOW; END ELSE R8:=LINK(R8) AND #FFFFFF; COMMENT TRY NEXT PCB; END; IF ~FOUNDCHANWAIT THEN BEGIN COMMENT NONE WAITING; FINDREADY; R9:=0; END; END; WHILE R9>0 DO CASE R9 OF BEGIN COMMENT AROUND AND AROUND WE GO; BEGIN COMMENT START I/O OPERATION; R0:=0; R1:=0; STM(R0,R1,IOCSW); COMMENT CLEAR STUFF; IOSTATUS(R8):=R0; STM(R0,R1,CSW(R8)); R0:=@CCWS(R8); CAW:=R0; COMMENT CCW ADDRESS; COMMENT SET PROTECTION KEY IF ANY; IC(R0,PSWSUSPEND(R8+1)); R0:=R0 AND #F0; STC(R0,CAW); SIO(B10); IF = THEN BEGIN COMMENT STARTED I/O; MVI(2,STATUS(R8)); FINDREADY; R9:=0; COMMENT FIND SOMETHING TO DO; END ELSE IF > THEN BEGIN COMMENT CHANNEL BUSY; MVI(3,STATUS(R8)); FINDREADY; R9:=0; COMMENT FIND SOMETHING TO DO; END ELSE IF OVERFLOW THEN BEGIN COMMENT NOT OPERATIVE; OI(#30,PSWSUSPEND(R8+4)); FINDREADY; R9:=0; COMMENT SET RETURN CODE AND FIND SOMETHING TO DO; END ELSE BEGIN COMMENT CSW STORED, ANALYZE IT; TM(#10,IOCSW(4)); IF = THEN BEGIN COMMENT START ERROR; R4:=0; R3:=FIRSTPCB; WHILE R3 ~= R8 DO BEGIN COMMENT MOVE PCB; R4:=R3; R3:=LINK(R3) AND #FFFFFF; END; MAKECURRENT; PUTATHEAD; SET(FOUNDIOWAIT); R9:=3; END ELSE BEGIN COMMENT DEVICE OR CONTROL BUSY; MVI(3,STATUS(R8)); R0:=IOCSW(4) AND #AFFF0000; IF R0 = 0 THEN BEGIN COMMENT FIND SOMETHING TO DO; FINDREADY; R9:=0; END ELSE BEGIN COMMENT PENDING INTERRUPT, ANALYZE; NI(#AF,IOCSW(4)); R9:=2; END; END; END; END; BEGIN COMMENT FIND PROCESS ASSOCIATED WITH INTERRUPT; R3:=FIRSTPCB; R4:=0; RESET(FOUNDIOWAIT); WHILE ~FOUNDIOWAIT AND R3 ~= 0 DO BEGIN COMMENT SEARCH; CLI(2,STATUS(R3)); IF = AND R10 = IODEVICE(R3) THEN BEGIN MAKECURRENT; PUTATHEAD; SET(FOUNDIOWAIT); R8:=R3; COMMENT FOUND IT; END ELSE BEGIN COMMENT TRY NEXT PCB; R4:=R3; R3:=LINK(R3) AND #FFFFFF; END; END; R9:=3; COMMENT NOW ANALYZE CHANNEL STATUS; END; BEGIN COMMENT ANALYZE CHANNEL STATUS; IF FOUNDIOWAIT THEN BEGIN COMMENT SAVE CSW; R0:=IOCSW OR CSW(R8); CSW(R8):=R0; R0:=IOCSW(4) OR CSW(R8+4); CSW(R8+4):=R0; END; TM(#0F,IOCSW(5)); IF = THEN BEGIN COMMENT NO CHANNEL CHK; TM(#30,IOCSW(5)); IF = THEN BEGIN COMMENT NO PRG CHKS; TM(#02,IOCSW(4)); IF = THEN BEGIN COMMENT NO UNIT CHECK; TM(#01,IOCSW(4)); COMMENT UNIT EXCEPTION; IF OVERFLOW AND FOUNDIOWAIT THEN OI(#20,PSWSUSPEND(R8+4)); TM(#04,IOCSW(4)); IF = THEN BEGIN COMMENT NO DEVICE END; TM(#50,IOCSW(4)); COMMENT TAPE & DISK ONLY; IF OVERFLOW AND FOUNDIOWAIT THEN BEGIN NI(#CF,PSWSUSPEND(R8+4)); OI(#10,PSWSUSPEND(R8+4)); MVI(0,STATUS(R8)); END; CHECKCONSOLE; FINDCHANWAIT; COMMENT ASSUME CHANNEL END, NO HARM IF NOT; END ELSE BEGIN COMMENT DEVICE END, RESTART PCB; IF FOUNDIOWAIT THEN MVI(0,STATUS(R8)); CHECKCONSOLE; TM(#28,IOCSW(4)); IF = THEN BEGIN COMMENT JUST DEVICE END; R8:=FIRSTPCB; RESET(FOUNDDEVWAIT); COMMENT SEARCH FOR PROCESS WAITING FOR DEVICE; WHILE ~FOUNDDEVWAIT AND R8 ~= 0 DO BEGIN CLI(3,STATUS(R8)); IF = AND R10 = IODEVICE(R8) THEN BEGIN COMMENT FOUND ONE; R9:=1; SET(FOUNDDEVWAIT); END ELSE R8:=LINK(R8) AND #FFFFFF; COMMENT TRY NEXT PCB; END; IF ~FOUNDDEVWAIT THEN BEGIN FINDREADY; R9:=0; END; END ELSE FINDCHANWAIT; COMMENT KEEP CHANNEL AND CONTROL BUSY; END; END ELSE BEGIN COMMENT UNIT CHECK; IF FOUNDIOWAIT THEN BEGIN COMMENT GET I/O STATUS BYTES; R0:=@IOSTATUS(R8); SENSEADDRESS:=R0; MVI(4,SENSECCW); R0:=@SENSECCW; CAW:=R0; SIO(B10); WHILE ~= DO SIO(B10); TIO(B10); WHILE > DO TIO(B10); COMMENT SET UNIT CHECK CONDITION CODE; OI(#10,PSWSUSPEND(R8+4)); END; FINDCHANWAIT; COMMENT CHANNEL WAS FREE; END; END ELSE BEGIN COMMENT I/O INCORRECT LENGTH, PROGRAM OR PROTECTION CHECK; IF FOUNDIOWAIT THEN BEGIN COMMENT SIMULATE PRG CHK; R4:=0; R3:=FIRSTPCB; WHILE R3 ~= R8 DO BEGIN R4:=R3; R3:=LINK(R3) AND #FFFFFF; END; MAKECURRENT; SETUP; LM(R0,R1,SAVEPSW); R0:=R0 AND #FFFF0000; STM(R0,R1,OLDPRG); LM(R15,R2,SAVEREGS); LPSW(NEWPRG); END ELSE FINDCHANWAIT; COMMENT ELSE IGNORE IT; END; END ELSE BEGIN COMMENT CHANNEL CHECK; R0:=@RINGBELLCCW; CAW:=R0; R1:=CONSOLEADDRESS; HIO(B1); SIO(B1); WHILE > DO SIO(B1); LPSW(WAITPSW); COMMENT TRY TO RING BELL AND QUIT; END; END; END; SETUP; LM(R15,R2,SAVEREGS); LPSW(SAVEPSW); COMMENT DONE WITH I/O, GO DO SOMETHING; END; PROCEDURE EXTERNALINTERRUPT(R3); BEGIN COMMENT SET UP AND HANDLE EXTERNAL INTERRUPTS; ARRAY 2 INTEGER OLDEXT SYN 24, IOCSW SYN 64; ARRAY 2 INTEGER OLDSVC SYN 32, NEWSVC SYN 96; INTEGER SAVEPCB; BYTE ENDINTERVAL; FUNCTION HIO(8,#9E00); PROCEDURE MAKENEWPSW(R1); BEGIN COMMENT SET NEW PSW TO TRANSFER TO POINT OF CALL; ARRAY 2 INTEGER NEWEXT SYN 88; FUNCTION RETURN(0,#07F3); R0:=#00040000; R1:=R1 AND #FFFFFF; STM(R0,R1,NEWEXT); RETURN; END; MAKENEWPSW; COMMENT SAVE REGISTERS AND PSW; STM(R15,R2,SAVEREGS); LM(R0,R1,OLDEXT); STM(R0,R1,SAVEPSW); R2 := REFTABLE(256); R15 := REFTABKE(260); R0 := R0 AND #80; IF R0 ^= 0 THEN BEGIN COMMENT TIMER INTERRUPT; R0 := 76800; TIMER := R0; COMMENT RESET TIMER TI 1 SECOND; R0 := SECOND + 1; SECOND := R0; IF R0 > 86400 THEN BEGIN COMMENT ADJUST DATE AT MIDNIGHT; R0 := 0; SECOND := R0; R0:= DAY + 1; DAY := R0; R1 := YEAR AND 3; IF R0 > 366 THEN COMMENT DONT FORGET LEAP YEAR; IF R0 = 367 OR R1 ^= 0 THEN BEGIN R0 := 1; DAY := R0; R0 := YEAR + 1; YEAR := R0; END; END; R0 := JOBTIME + 1; JOBTIME := R0; COMMENT KEEP JOB INTERVAL TIMER; R1 := FIRSTPCB; RESET(ENDINTERVAL); COMMENT WAITING PROCESSES; WHILE R1 ^= 0 DO BEGIN COMENT SEARCH FOR THEM; CLI(5,STATUS(R1)); IF = THEN BEGIN COMMENT FOUND ONE; *********************************************************************** * This block just marks where the tape was bad. Been repaired-11/2000 * - Ronald H. Tatum * ALAN WEAVER - 01/07/97 * * * * * * BLOCK 21 (OUT OF 192) WAS INVALID ON 800 BPI SOURCE TAPE. * * * * * * * *********************************************************************** ??????????????????????????????????????????????????????????????????????? R0:=INTERVAL(R1)-1; INTERVAL(R1):=R0; IF R0 <= 0 THEN BEGIN COMMENT END OF WAIT; MVI(0,STATUS(R1)); IF ~ENDINTERVAL THEN SAVEPCB:=R1; COMMENT MARK FIRST; SET(ENDINTERVAL); END; END; CLI(2,STATUS(R1)); IF = THEN BEGIN COMMENT CHECK TIMEOUT; R0:=IOTIMEOUT(R1)-1; IOTIMEOUT(R1):=R0; IF R0 < 0 THEN BEGIN COMMENT TIME LIMIT EXCEEDED; R0:=R1; R1:=IODEVICE(R1); HIO(B1); R1:=R0; IF < THEN BEGIN COMMENT CSW STORED, UPDATE; R0:=IOCSW(4) AND #FF0000 OR CSW(R1+4); CSW(R1+4):=R0; END; END; END; R1:=LINK(R1) AND #FFFFFF; COMMENT TO NEXT PCB; END; IF ENDINTERVAL THEN BEGIN COMMENT FOUND FINISHED PROCESS; SUSPEND; R3:=FIRSTPCB; R4:=0; WHILE R3 ~= SAVEPCB DO BEGIN COMMENT SET UP FOR RESTART; R4:=R3; R3:=LINK(R3) AND #FFFFFF; END; MAKECURRENT; SETUP; END; R0:=JOBTIME; IF R0 > MAXTIME THEN BEGIN COMMENT CANCEL JOB; LM(R0,R1,SAVEPSW); R0:=R0 AND #FFFF0000 OR #100; STM(R0,R1,OLDSVC); LM(R15,R2,SAVEREGS); LPSW(NEWSVC); COMMENT FAKE CANCEL CALL; END; END; LM(R15,R2,SAVEREGS); LPSW(SAVEPSW); COMMENT RESTART PROCESS; END; PROCEDURE SUPERVISORCALL(R3); BEGIN COMMENT SET UP AND HANDLE SUPERVISOR CALLS; ARRAY 2 INTEGER OLDSVC SYN 32; FUNCTION HIO(8,#9E00); PROCEDURE MAKENEWPSW(R1); BEGIN COMMENT SET NEW PSW TO TRANSFER TO POINT OF CALL; ARRAY 2 INTEGER NEWSVC SYN 96; FUNCTION RETURN(0,#07F3); R0:=#00040000; R1:=R1 AND #FFFFFF; STM(R0,R1,NEWSVC); RETURN; END; PROCEDURE CHECKR0(R1); BEGIN COMMENT IF PROBLEM PROGRAM CALL, CHECK ADDRESS IN R1 FOR VALIDITY; BYTE ADDRESSOK; SET(ADDRESSOK); TM(#01,SAVEPSW(1)); IF OVERFLOW THEN BEGIN COMMENT OK, CHECK ADDRESS; R0:=SAVEREGS(4) AND 3; IF R0 ~= 0 THEN RESET(ADDRESSOK) ELSE BEGIN R0:=SAVEREGS(4); IF R0 > ENDMEMORY OR R0 < USERMEMORY THEN RESET(ADDRESSOK); END; END; TEST(ADDRESSOK); COMMENT SET CONDITION CODE; END; MAKENEWPSW; COMMENT SAVE REGISTERS AND PSW; STM(R15,R2,SAVEREGS); LM(R0,R1,OLDSVC); STM(R0,R1,SAVEPSW); R2:=REFTABLE(256); R15:=REFTABLE(260); CLI(0,SAVEPSW(2)); IF = THEN NI(#CF,SAVEPSW(4)); R0:=R0 AND #FF; IF R0 >= 16 THEN BEGIN COMMENT LEVEL 1 SUPERVISOR CALLS; R1:=CURRENTPCB; STM(R3,R6,REGSVC(R1+16)); R4:=R1; LM(R0,R3,SAVEREGS); STM(R0,R3,REGSVC(R4)); LM(R0,R1,SAVEPSW); STM(R0,R1,PSWSVC(R4)); SET(SVCGOING(R4)); COMMENT REGISTERS AND PSW SAVED FOR SVC; R0:=#FF040000; R1:=REFTABLE(268); STM(R0,R1,SAVEPSW); SAVEREGS:=R1; COMMENT GO PROCESSSVC; END ELSE BEGIN COMMENT LEVEL 0 SUPERVISOR CALLS; R1:=CURRENTPCB; IF R1 ~= 0 THEN BEGIN COMMENT SET UP FOR POSS. CANCEL; MVC(3,CANCELCODE(R1),1); IF R0 ~= 0 THEN MVI(2,CANCELCODE(R1+3)); CLI(0,SAVEPSW(2)); IF ~= THEN MVI(3,CANCELCODE(R1+3)); END; R1:=R0+1; WHILE R1 > 0 DO CASE R1 OF BEGIN COMMENT DO SVC; BEGIN COMMENT CANCEL JOB; R1:=CURRENTPCB; IF R1 ~= 0 THEN BEGIN SUSPEND; R1:=LASTPCB; R0:=CANCELCODE(R1); TM(#01,PSWSUSPEND(R1+1)); IF = AND R0 = 1 THEN R0:=REGSUSPEND(R1); CANCELCODE(R1):=R0; IF SVCGOING(R1) THEN TM(#01,PSWSVC(R1+1)) ELSE TM(#01,PSWSUSPEND(R1+1)); IF OVERFLOW AND ~SVCLOCKOUT(R1) THEN MVI(4,STATUS(R1)); COMMENT TAKEN CARE OF ACTIVE USER PROCESS; END; CANCELKILL; SETUP; R1:=0; END; BEGIN COMMENT START PROCESS; R1:=FREEPCB; IF R1 = 0 THEN BEGIN COMMENT NO FREE PCB, INDICATE AND RETURN; R0:=SAVEREGS(8) AND #CFFFFFFF OR #10000000; SAVEPSW(4):=R0; COMMENT USE ADDRESS IN R1; SAVEREGS(4):=R1; R1:=0; END ELSE BEGIN SUSPEND; R3:=LASTPCB; R1:=FREEPCB; R0:=LINK(R1) AND #FFFFFF; FREEPCB:=R0; COMMENT COPY PCB CONTENTS INTO NEW PCB; FOR R4:=8 STEP 4 UNTIL PCBSIZE DO BEGIN R5:=R4-4; R0:=B3(R5); B1(R5):=R0; END; R0:=REGSUSPEND(R3+4); PSWSUSPEND(R3+4):=R0; COMMENT OLD PROCESS RETURNS TO ADDRESS IN R1; R0:=MAXPCBNO+1; MAXPCBNO:=R0; PCBNUMBER(R1):=R0; REGSUSPEND(R3):=R0; NI(#CF,PSWSUSPEND(R3+4)); REGSUSPEND(R1):=R0; COMMENT LET BOTH KNOW NUMBER; CURRENTPCB:=R1; SETUP; R1:=0; END; END; BEGIN COMMENT STOP PROCESS; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN BEGIN R1:=CURRENTPCB; R0:=0; COMMENT COUNT USER PCBS; WHILE R1~=0 DO BEGIN IF SVCGOING(R1) THEN TM(#01,PSWSVC(R1+1)) ELSE TM(#01,PSWSUSPEND(R1+1)); IF OVERFLOW THEN R0:=R0+1; R1:=LINK(R1) AND #FFFFFF; COMMENT TRY NEXT PCB; END; END ELSE R0:=1; COMMENT FORCE OK IF SYSTEM CALL; IF R0 = 0 THEN R1:=1 ELSE BEGIN R1:=CURRENTPCB; R0:=FREEPCB; COMMENT NOW STOP IT; COMMENT RETURN PCB TO FREE LIST; LINK(R1):=R0; FREEPCB:=R1; R0:=0; CURRENTPCB:=R0; FINDREADY; SETUP; R1:=0; END; END; BEGIN COMMENT P OPERATION - WAIT ON SEMAPHORE; CHECKR0; IF ~= THEN R1:=1 ELSE BEGIN R1:=CURRENTPCB; CLI(0,SVCCANCEL(R1)); IF ~= THEN OI(#10,SAVEPSW(4)) ELSE BEGIN COMMENT IF IN STOP OR CANCEL, SKIP P; R1:=SAVEREGS(4); R0:=B1-1; B1:=R0; COMMENT DECREMENT SEMAPHORE; IF R0 < 0 THEN BEGIN COMMENT WAIT FOR V; SUSPEND; R1:=LASTPCB; MVI(1,STATUS(R1)); R0:=REGSUSPEND(R1) AND #FFFFFF; SEMAPHORE(R1):=R0; FINDREADY; SETUP; END; END; R1:=0; END; END; BEGIN COMMENT V OPERATION - RELEASE PROCESS ON SEMAPHORE; CHECKR0; IF ~= THEN R1:=1 ELSE BEGIN R1:=SAVEREGS(4); R0:=B1+1; B1:=R0; COMMENT INCREMENT SEMAPHORE; IF R0 <= 0 THEN BEGIN COMMENT FIND FIRST WAITING; SUSPEND; R1:=LASTPCB; R0:=REGSUSPEND(R1) AND #FFFFFF; FINDWAITING; IF ~= THEN FINDREADY; SETUP; END; R1:=0; END; END; BEGIN COMMENT DOIO OPERATION; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN SUSPEND; R8:=LASTPCB; R10:=REGSUSPEND(R8); COMMENT ONLY SUPERVISOR CAN CALL; IODEVICE(R8):=R10; R0:=#3FFFFFFF; IOTIMEOUT(R8):=R0; R9:=1; IOSTUFF; COMMENT LET IOSTUFF DO DIRTY WORK; END; END; BEGIN COMMENT WAIT FOR TIME INTERVAL; SUSPEND; R1:=LASTPCB; R0:=REGSUSPEND(R1); INTERVAL(R1):=R0; IF R0 > 0 THEN MVI(5,STATUS(R1)); FINDREADY; SETUP; R1:=0; END; BEGIN COMMENT RETURN FROM LEVEL 1 SUPERVISOR CALL; R1:=CURRENTPCB; COMMENT CHECK IN LEVEL 1 SVC; IF SVCGOING(R1) THEN BEGIN R4:=R1; LM(R0,R3,REGSVC(R4)); STM(R0,R3,SAVEREGS); LM(R0,R1,PSWSVC(R4)); STM(R0,R1,SAVEPSW); R1:=R4; LM(R3,R6,REGSVC(R1+16)); RESET(SVCGOING(R1)); R1:=0; COMMENT RESTORED STUFF; END ELSE R1:=1; COMMENT NOT IN LEVEL 1 SVC; END; BEGIN COMMENT STOP SPECIFIED PROCESS; INTEGER SAVENEXT, SAVELAST; BYTE FOUNDIT, USERMODE; RESET(USERMODE); COMMENT USER CAN STOP USER PROCESSES; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN SET(USERMODE); R1:=FIRSTPCB; RESET(FOUNDIT); R0:=0; SAVELAST:=R0; R0:=SAVEREGS(4); WHILE ~FOUNDIT AND R1 ~= 0 DO IF R0 = PCBNUMBER(R1) THEN SET(FOUNDIT) ELSE BEGIN SAVELAST:=R1; R1:=LINK(R1) AND #FFFFFF; END; IF FOUNDIT THEN BEGIN COMMENT FOUND PROCESS; IF SVCGOING(R1) THEN TM(#01,PSWSVC(R1+1)) ELSE TM(#01,PSWSUSPEND(R1+1)); IF = AND USERMODE THEN R1:=1 ELSE BEGIN IF SVCLOCKOUT(R1) THEN BEGIN OI(#10,SAVEPSW(4)); CLI(0,SVCCANCEL(R1)); IF = THEN MVI(2,SVCCANCEL(R1)); END ELSE BEGIN R0:=LINK(R1) AND #FFFFFF; SAVENEXT:=R0; R0:=FREEPCB; CLI(2,STATUS(R1)); IF = THEN BEGIN LINK(R1):=R0; FREEPCB:=R1; COMMENT HALT ANY I/O; R1:=IODEVICE(R1); HIO(B1); END ELSE BEGIN LINK(R1):=R0; FREEPCB:=R1; END; R1:=SAVELAST; IF R1 ~= 0 THEN BEGIN R0:=STATUS(R1) SHLL 24 OR SAVENEXT; LINK(R1):=R0; END ELSE BEGIN R0:=SAVENEXT; FIRSTPCB:=R0; END; R0:=SAVENEXT; IF R0 = 0 THEN LASTPCB:=R1; END; R1:=0; END; END ELSE BEGIN OI(#20,SAVEPSW(4)); R1:=0; END; END; BEGIN COMMENT FIND FIRST CANCELLED PROCESS; BYTE FOUNDIT; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN COMMENT MUST BE SUPERVISOR; R1:=FIRSTPCB; RESET(FOUNDIT); WHILE ~FOUNDIT AND R1 ~= 0 DO BEGIN TM(#80,STATUS(R1)); IF OVERFLOW THEN SET(FOUNDIT) ELSE R1:=LINK(R1) AND #FFFFFF; END; SAVEREGS(8):=R1; R1:=0; IF ~FOUNDIT THEN OI(#10,SAVEPSW(4)); END; END; BEGIN COMMENT RETURN TO JOB CONTROL; R0:=0; R1:=FIRSTPCB; WHILE R1 ~= 0 DO BEGIN COMMENT LAST USER PROCESS?; IF SVCGOING(R1) THEN TM(#01,PSWSVC(R1+1)) ELSE TM(#01,PSWSUSPEND(R1+1)); IF OVERFLOW THEN R0:=R0+1; R1:=LINK(R1) AND #FFFFFF; END; IF R0 > 0 THEN R1:=1 ELSE BEGIN R1:=CURRENTPCB; R0:=FREEPCB; LINK(R1):=R0; FREEPCB:=R1; R0:=0; CURRENTPCB:=R0; R0:=@ENDJOBCOUNT; FINDWAITING; IF ~= THEN R1:=1 ELSE BEGIN SETUP; R1:=0; END; END; END; BEGIN COMMENT DOIO OPERATION WITH TIMEOUT; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN SUSPEND; R8:=LASTPCB; R10:=REGSUSPEND(R8); COMMENT ONLY SUPERVISOR CAN CALL; IODEVICE(R8):=R10; R0:=REGSUSPEND(R8+4); IOTIMEOUT(R8):=R0; R9:=1; IOSTUFF; COMMENT LET IOSTUFF DO DIRTY WORK; END; END; BEGIN COMMENT SET PROTECTION KEY FOR PROCESSSVC; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN R1:=CURRENTPCB; R0:=PSWSVC(R1) AND #00F00000 OR SAVEPSW; SAVEPSW:=R0; R1:=0; END; END; BEGIN COMMENT RESET PROTECTION KEY FOR PROCESSSVC; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN NI(#0F,SAVEPSW(1)); R1:=0; END; END; BEGIN COMMENT ENTER SVC ROUTINE LOCKOUT MODE; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN R1:=CURRENTPCB; IF SVCLOCKOUT(R1) THEN R1:=1 ELSE BEGIN SET(SVCLOCKOUT(R1)); R1:=0; END; END; END; BEGIN COMMENT LEAVE SVC ROUTINE LOCKOUT MODE; TM(#01,SAVEPSW(1)); IF OVERFLOW THEN R1:=1 ELSE BEGIN R1:=CURRENTPCB; IF ~SVCLOCKOUT(R1) THEN R1:=1 ELSE BEGIN RESET(SVCLOCKOUT(R1)); CLI(0,SVCCANCEL(R1)); IF = THEN R1:=0 ELSE BEGIN CLI(2,SVCCANCEL(R1)); COMMENT STOP OR CANCEL; IF = THEN R1:=3 ELSE BEGIN SUSPEND; R1:=LASTPCB; OI(#80,STATUS(R1)); R0:=LOCKOUTCOUNT-1; LOCKOUTCOUNT:=R0; IF R0 = 0 THEN BEGIN COMMENT START JOBCTL; R0:=@ENDJOBCOUNT; FINDWAITING; IF ~= THEN FINDREADY; END ELSE FINDREADY; SETUP; R1:=0; END; END; END; END; END; END; END; LM(R15,R2,SAVEREGS); LPSW(SAVEPSW); COMMENT RESTART PROCESS; END; PROCEDURE PROGRAMCHECK(R3); BEGIN COMMENT SET UP AND HANDLE PROGRAM CHECKS; ARRAY 2 INTEGER OLDPRG SYN 40; LONG REAL WAIT1PSW=#0002000000000001L, WAIT2PSW=#0002000000000002L; INTEGER CAW SYN 72; FUNCTION SIO(8,#9C00), HIO(8,#9E00), SRL(9,#8800); PROCEDURE MAKENEWPSW(R1); BEGIN COMMENT SET NEW PSW TO TRANSFER TO POINT OF CALL; ARRAY 2 INTEGER NEWPRG SYN 104; FUNCTION RETURN(0,#07F3); R0:=#00040000; R1:=R1 AND #FFFFFF; STM(R0,R1,NEWPRG); RETURN; END; MAKENEWPSW; COMMENT SAVE REGISTERS AND PSW; STM(R15,R2,SAVEREGS); LM(R0,R1,OLDPRG); STM(R0,R1,SAVEPSW); R2:=REFTABLE(256); R15:=REFTABLE(260); R1:=CURRENTPCB; IF R1 ~= 0 THEN BEGIN COMMENT ACTIVE PROCESS; R1:=R0 AND #F; R0:=#80000000; SRL(R0,B1); R1:=CURRENTPCB; R0:=R0 AND PRGCHKMASK(R1); IF R0 ~= 0 THEN BEGIN COMMENT ALLOWABLE PROGRAM CHECK; OI(#30,SAVEPSW(4)); COMMENT SET OVERFLOW; LM(R15,R2,SAVEREGS); LPSW(SAVEPSW); COMMENT RETURN; END; SUSPEND; R1:=LASTPCB; IF ~SVCLOCKOUT(R1) THEN MVI(6,STATUS(R1)) ELSE OI(#30,PSWSUSPEND(R1+4)); IF SVCGOING(R1) THEN TM(#01,PSWSVC(R1+1)) ELSE TM(#01,PSWSUSPEND(R1+1)); IF = THEN BEGIN COMMENT SUPERVISOR PROCESS LEVEL; R0:=@RINGBELLCCW; CAW:=R0; R1:=CONSOLEADDRESS; HIO(B1); SIO(B1); WHILE > DO SIO(B1); LPSW(WAIT1PSW); COMMENT RING BELL AND QUIT; END; CANCELKILL; SETUP; LM(R15,R2,SAVEREGS); LPSW(SAVEPSW); END ELSE BEGIN COMMENT SUPERVISOR INTERRUPT LEVEL; R0:=@RINGBELLCCW; CAW:=R0; R1:=CONSOLEADDRESS; HIO(B1); SIO(B1); WHILE > DO SIO(B1); LPSW(WAIT2PSW); COMMENT RING BELL AND QUIT; END; END; PROCEDURE MACHINECHECK(R3); BEGIN COMMENT SET UP AND HANDLE MACHINE CHECKS; LONG REAL WAITPSW=#0002000000FFFFFFL; INTEGER CAW SYN 72; FUNCTION SIO(8,#9C00), HIO(8,#9E00); PROCEDURE MAKENEWPSW(R1); BEGIN COMMENT SET NEW PSW TO TRANSFER TO POINT OF CALL; ARRAY 2 INTEGER NEWMCH SYN 112; FUNCTION RETURN(0,#07F3); R0:=0; R1:=R1 AND #FFFFFF; STM(R0,R1,NEWMCH); RETURN; END; MAKENEWPSW; COMMENT TRY TO RING BELL AND WAIT FOREVER; R2:=REFTABLE(256); R15:=REFTABLE(260); R0:=@RINGBELLCCW; CAW:=R0; R1:=CONSOLEADDRESS; HIO(B1); SIO(B1); WHILE > DO SIO(B1); LPSW(WAITPSW); END; PROCEDURE IOINTERRUPT(R3); BEGIN COMMENT SET UP AND HANDLE I/O INTERRUPTS; ARRAY 2 INTEGER OLDIO SYN 56; PROCEDURE MAKENEWPSW(R1); BEGIN COMMENT SET NEW PSW TO TRANSFER TO POINT OF CALL; ARRAY 2 INTEGER NEWIO SYN 120; FUNCTION RETURN(0,#07F3); R0:=#00040000; R1:=R1 AND #FFFFFF; STM(R0,R1,NEWIO); RETURN; END; MAKENEWPSW; COMMENT SAVE REGISTERS AND PSW; STM(R15,R2,SAVEREGS); LM(R0,R1,OLDIO); STM(R0,R1,SAVEPSW); R2:=REFTABLE(256); R15:=REFTABLE(260); SUSPEND; R8:=0; R9:=2; R10:=SAVEPSW AND #FFF; IOSTUFF; COMMENT LET IOSTUFF DO THE DIRTY WORK; END; ARRAY 432 LONG REAL PCBTABLE; COMMENT ACTUAL PCB STORAGE. USE (NUMBEROFPCBS*PCBSIZE)/8 AS ARRAY SIZE; COMMENT INITIALIZE ALL VARIABLES AND TABLES; R0:=0; YEAR:=R0; DAY:=R0; SECOND:=R0; JOBTIME:=R0; ENDJOBCOUNT:=R0; OPERATORCOUNT:=R0; MAXPCBNO:=R0; FIRSTPCB:=R0; LASTPCB:=R0; LOCKOUTCOUNT:=R0; RESET(CANCELFLAG); R0:=#3FFFFFFF; MAXTIME:=R0; R0:=ENDSUPERVISOR+7 AND _8; USERMEMORY:=R0; COMMENT SET BY IPL; R0:=#FFFFFF; ENDMEMORY:=R0; COMMENT ASSUME BIG MEMORY AT FIRST; R6:=@PCBTABLE; FREEPCB:=R6; COMMENT SET UP FREE PCB LIST; FOR R4:=2 STEP 1 UNTIL NUMBEROFPCBS DO BEGIN IF R4=NUMBEROFPCBS THEN R7:=0 ELSE R7:=R6+PCBSIZE; LINK(R6):=R7; R6:=R6+PCBSIZE; END; CURRENTPCB:=R6; COMMENT LEAVE ONE PCB FOR INITIALIZATION PROCESS; R5:=R6+PCBSIZE-4; R0:=0; FOR R7:=R6 STEP 4 UNTIL R5 DO B7:=R0; COMMENT INITIALIZE PCB; COMMENT SET UP TO START PROCEDURE LEVEL1 AS FIRST PROCESS; R0:=REFTABLE(276); REGSUSPEND(R6+60):=R0; PSWSUSPEND(R6+4):=R0; R0:=#FF040000; PSWSUSPEND(R6):=R0; BEGIN COMMENT NOW FIND MEMORY SIZE; PROCEDURE SIZE(R1); BEGIN COMMENT CLEAR MEMORY UNTIL PROGRAM CHECK OCCURS; ARRAY 2 INTEGER NEWPRG SYN 104; FUNCTION XC(13,#D700); R0:=0; STM(R0,R1,NEWPRG); COMMENT RETURN WHEN DONE; FOR R3:=USERMEMORY+255 AND _256 STEP 256 UNTIL #FFFF00 DO XC(255,B3,B3); END; SIZE; R3:=R3-1; ENDMEMORY:=R3; COMMENT NOW KNOW SIZE; END; BEGIN COMMENT SET UP STORAGE PROTECTION IF IT EXISTS; PROCEDURE PROTECT(R1); BEGIN COMMENT PROGRAM CHECK INDICATES NO PROTECTION; ARRAY 2 INTEGER NEWPRG SYN 104; FUNCTION SSK(1,#0800); R0:=0; STM(R0,R1,NEWPRG); COMMENT RETURN WHEN DONE; FOR R3:=ENDMEMORY AND _2048 STEP _2048 UNTIL 0 DO SSK(R0,R3); SET(PROTECTION); END; RESET(PROTECTION); PROTECT; END; BEGIN COMMENT SEE IF MACHINE HAS FLOATING POINT; PROCEDURE CHECKFLOAT(R1); BEGIN COMMENT PROGRAM CHECK INDICATES NO FLOATING POINT; ARRAY 2 INTEGER NEWPRG SYN 104; FUNCTION LTDR(0,#2200); R0:=0; STM(R0,R1,NEWPRG); COMMENT RETURN WHEN DONE; LTDR; SET(FLOATINGPOINT); END; RESET(FLOATINGPOINT); CHECKFLOAT; END; R0:=0; CONSOLEADDRESS:=R0; COMMENT NO CONSOLE YET; COMMENT NOW INITIALIZE INTERRUPT HANDLING ROUTINES; EXTERNALINTERRUPT; SUPERVISORCALL; PROGRAMCHECK; MACHINECHECK; IOINTERRUPT; R0:=76800; TIMER:=R0; COMMENT START UP ONE SECOND TIMER; SETUP; LM(R15,R2,SAVEREGS); LPSW(SAVEPSW); COMMENT AND AWAY WE GO; END; $PAGE GLOBAL 67 PROCEDURE PROCESSSVC(R1); BEGIN COMMENT LEVEL1 SUPERVISOR CALL ROUTINES; ARRAY 27 LONG REAL PCB SYN B6; COMMENT SEE LEVEL0 FOR DETAILS; ARRAY 2 INTEGER CSW SYN PCB(8), PSW SYN PCB(128); ARRAY 10 INTEGER CCWS SYN PCB(16); ARRAY 8 INTEGER REGS SYN PCB(136); ARRAY 5 BYTE DISKRECORDID SYN PCB(168); ARRAY 2 BYTE SENSE SYN PCB(174); ARRAY 8 BYTE DISKCOUNTID SYN PCB(176); BYTE PRGCHKMASK SYN PCB(185); INTEGER TIMEOUT SYN PCB(188); ARRAY 3 INTEGER WORK SYN PCB(192); ARRAY 6 BYTE DISKSEEKADR SYN PCB(208); ARRAY 2 BYTE SCRATCH SYN PCB(214); EXTERNAL 68 BASE R5; COMMENT SEE LEVEL1 FOR DETAILS; ARRAY 64 INTEGER SEGLENGTHTBL, CONSOLETRT, OVERLAYADR; ARRAY 16 SHORT INTEGER OVERLAYSEG; INTEGER OVERLAYDEV, OVERLAYLOCK; ARRAY 3 INTEGER OVERLAYWORK; ARRAY 10 INTEGER RETRANSLATE; ARRAY 4 INTEGER HEXTBL SYN RETRANSLATE; ARRAY 2 INTEGER FREEDUMPLIM, SEGDUMPMASK; ARRAY 8 INTEGER LOGUNITTBL, LOGUNITSAVE, TAPEDRIVES; ARRAY 32 INTEGER DISKDRIVES; ARRAY 4 SHORT INTEGER TRKPERCYL, PADDIV, TRKCAP, RECPAD, PADMUL, DISKTYPE, LOCKOUT, LOCKLIM, FIRSTTRK, OTHERTRK; ARRAY 12 SHORT INTEGER MONTHS; INTEGER ERRMSGLOCK; ARRAY 26 BYTE ERRMSG; ARRAY 8 BYTE ERRANS; INTEGER ASKJOB; ARRAY 9 BYTE IOERRTXT; ARRAY 8 BYTE SAMEMSG; ARRAY 7 BYTE CANCELRPY; ARRAY 6 BYTE RETRYRPY; ARRAY 16 BYTE ELAPSED; ARRAY 11 BYTE ASKRPYMSG; COMMENT ASSIGN TABLE LAYOUT; SHORT INTEGER DRIVENO SYN 0; BYTE PROTECTED SYN 2, JOBREAD SYN 3, JOBWRITE SYN 4, JOBASSIGNED SYN 5, EXTENTCNT SYN 6, DISKUNIT SYN 7, TAPEMODE SYN EXTENTCNT; INTEGER ASSIGNLOCK SYN 8; ARRAY 8 BYTE ASSIGNNAME SYN 12, AREANAME SYN 20; ARRAY 32 SHORT INTEGER EXTENTS SYN 28; SHORT INTEGER STARTTRACK SYN EXTENTS, NOTRACKS SYN EXTENTS(2); BYTE SHARED SYN 92; COMMENT DISK DRIVE TABLE LAYOUT; SHORT INTEGER DISKADDRESS SYN DISKDRIVES, DISKDRIVETYPE SYN DISKDRIVES(2); INTEGER VTOCLOCK SYN DISKDRIVES(4); ARRAY 8 BYTE DISKLABEL SYN DISKDRIVES(8); COMMENT TAPE DRIVE TABLE LAYOUT; SHORT INTEGER TAPEADDRESS SYN TAPEDRIVES, TAPEDRIVETYPE SYN TAPEDRIVES(2); PROCEDURE OPENLINE(R3); BEGIN COMMENT MAKE PRINT BUFFER AVAILABLE; EXTERNAL 72 BASE R4; COMMENT SEE LEVEL1 BUFFERING PROCESS; INTEGER EMPTY, FULL, PTR, STARTB, ENDB, WTRLOCK, LINENO; SVCLOCK; R0:=@WTRLOCK; P; IF ~= THEN SVCUNLOCK; R0:=@EMPTY; P; IF ~= THEN BEGIN R0:=@WTRLOCK; V; SVCUNLOCK; END; R2:=PTR; END; PROCEDURE CLOSELINE(R3); BEGIN COMMENT FINISH UP PRINT BUFFER HANDLING; EXTERNAL 72 BASE R4; COMMENT SEE LEVEL1 BUFFERING PROCESS; INTEGER EMPTY, FULL, PTR, STARTB, ENDB, WTRLOCK, LINENO, ADDRESS, GETPTR, NOBUFF; BYTE JOBSTART; R2:=PTR; MVI(3,B2); R0:=LINENO-1; IF R0 < 0 THEN BEGIN COMMENT NEW PAGE; R0:=59; MVI(#8B,B2); END; IF JOBSTART THEN BEGIN RESET(JOBSTART); NI(#FC,B2); END; LINENO:=R0; R2:=R2+133; IF R2 = ENDB THEN R2:=STARTB; PTR:=R2; R2:=LINENO; R0:=@FULL; V; R0:=@WTRLOCK; V; SVCUNLOCK; END; PROCEDURE WRITECONSOLE(R3); BEGIN COMMENT WRITE MESSAGE ON CONSOLE; INTEGER CONSOLE SYN 76; R0:=R0 OR #09000000; CCWS:=R0; R1:=R1 OR #20000000; CCWS(4):=R1; R2:=0; WHILE R2 = 0 DO BEGIN R0:=CONSOLE; IF R0 = 0 THEN BEGIN R0:=1; WAIT; END ELSE BEGIN DOIO; IF = THEN R2:=1 ELSE BEGIN IF OVERFLOW THEN BEGIN R0:=1; WAIT; END ELSE BEGIN MVC(7,CCWS(8),CCWS); R0:=#0B000000; R1:=#20000001; STM(R0,R1,CCWS); R0:=CONSOLE; DOIO; MVC(7,CCWS,CCWS(8)); R0:=5; WAIT; COMMENT BELL WAS RUNG, WAIT FOR FIX; END; END; END; END; END; PROCEDURE READCONSOLE(R3); BEGIN COMMENT READ FROM CONSOLE; BYTE USERCALL SYN CCWS(32); INTEGER CONSOLE SYN 76; SHORT INTEGER RESLENGTH SYN CSW(6); FUNCTION LIT(2,#4100); PROCEDURE RINGBELL(R1); BEGIN MVC(15,CCWS(16),CCWS); R0:=#0B000000; CCWS:=R0; R0:=#20000001; CCWS(4):=R0; R0:=CONSOLE; DOIO; MVC(15,CCWS,CCWS(16)); END; IF R1 < #1000 THEN BEGIN COMMENT FAKE REQUEST MESSAGE; R1:=R1 OR #B0000; R2:=@ASKRPYMSG; END; R2:=R2 OR #09000000; CCWS:=R2; R2:=R0 AND #FFFFFF OR #0A000000; CCWS(8):=R2; CCWS(32):=R0; R0:=R1 SHRL 16 OR #60000000; CCWS(4):=R0; R1:=R1 AND #FFFF OR #20000000; CCWS(12):=R1; R2:=0; WHILE R2 = 0 DO BEGIN R0:=CONSOLE; IF R0 = 0 THEN BEGIN R0:=1; WAIT; END ELSE BEGIN R1:=120; IF USERCALL THEN SETKEY; TIMEDDOIO; IF = THEN BEGIN RESETKEY; R0:=TIMEOUT; IF R0 < 0 THEN RINGBELL ELSE BEGIN R2:=1; R1:=CCWS(12) AND #FFFF-RESLENGTH; END; END ELSE IF OVERFLOW THEN BEGIN RESETKEY; R0:=1; WAIT; END ELSE IF < THEN BEGIN RESETKEY; R2:=TIMEOUT; RINGBELL; IF R2 >= 0 THEN BEGIN R0:=5; WAIT; END; R2:=0; END; END; END; END; PROCEDURE IOERREDIT(R3); BEGIN COMMENT SETUP FOR I/O ERROR MESSAGE; SVCLOCK; R0:=@ERRMSGLOCK; P; IF ~= THEN SVCUNLOCK; R0:=DRIVENO(R1); IF DISKUNIT(R1) THEN BEGIN COMMENT DISK OR TAPE; MVI("D",ERRMSG); R2:=R0 SHLL 4; R2:=@DISKADDRESS(R2); END ELSE BEGIN MVI("T",ERRMSG); R2:=R0 SHLL 2; R2:=@TAPEADDRESS(R2); END; R0:=R0+1; ERRMSG(2):=R0; TR(0,ERRMSG(2),HEXTBL); UNPK(3,2,ERRMSG(4),B2); TR(2,ERRMSG(4),HEXTBL(_240)); MVI(" ",ERRMSG(1)); MVI(" ",ERRMSG(3)); UNPK(4,2,ERRMSG(16),CSW(4)); TR(3,ERRMSG(16),HEXTBL(_240)); UNPK(4,2,ERRMSG(21),SENSE); TR(3,ERRMSG(21),HEXTBL(_240)); MVI(" ",ERRMSG(20)); MVC(8,ERRMSG(7)," I/O ERR "); MVC(7,ERRANS," "); R0:=@ERRANS; R1:=#190007; R2:=@ERRMSG; END; PROCEDURE IOERRDONE(R3); BEGIN COMMENT FINISH I/O ERROR MESSAGE HANDLING; R1:=@ERRANS(R1); MVI(21,B1); TR(7,ERRANS,CONSOLETRT); R1:=0; CLC(6,ERRANS,CANCELRPY); IF = THEN R1:=1; COMMENT REPLY WAS "CANCEL"; CLC(5,ERRANS,RETRYRPY); IF = THEN R1:=2; COMMENT REPLY WAS "RETRY"; IF R1 > 0 THEN BEGIN COMMENT PROPER REPLY; R0:=@ERRMSGLOCK; V; SVCUNLOCK; END ELSE BEGIN R0:=@ERRANS; R1:=#190007; R2:=@ERRMSG; MVI("*",ERRMSG(7)); MVC(7,ERRANS," "); END; END; PROCEDURE IOCANCEL(R1); BEGIN COMMENT RETURN TO SYSTEM OR CANCEL USER; TM(#01,PSW(1)); IF = THEN BEGIN OI(#30,PSW(4)); SVCEXIT; END ELSE BEGIN R0:=5; CANCEL; END; END; GLOBAL 74 PROCEDURE TAPEIO(R4); BEGIN COMMENT INITIATE TAPE I/O AND HANDLE ERRORS; SHORT INTEGER LENGTH SYN WORK(4), RESLENGTH SYN CSW(6); INTEGER ASSIGNPT SYN WORK(8), IOADDR SYN WORK; BYTE ERRCNT SYN WORK(6), BSADDED SYN WORK(7), OP SYN IOADDR, IONOTDONE SYN ASSIGNPT; R0:=R0 AND #FFFFFF; IOADDR:=R0; OP:=R2; LENGTH:=R1; R0:=0; ERRCNT:=R0; RESET(BSADDED); IF R1 > #7FFF OR R1 <= 0 THEN BEGIN R0:=2; CANCEL; END; IF R2 = #01 AND R1 < 18 THEN BEGIN R0:=2; CANCEL; END; IF R2 = #02 AND R1 < 12 THEN BEGIN R0:=2; CANCEL; END; R1:=REGS(12); TM(#01,PSW(1)); IF OVERFLOW OR R1 <= 8 THEN BEGIN COMMENT FURTHER CHECKS; IF R1 > 8 OR R1 <= 0 THEN BEGIN R0:=2; CANCEL; END; R1:=R1 SHLL 2; R1:=LOGUNITTBL(R1-4); IF R1 = 0 THEN BEGIN R0:=6; CANCEL; END; END; ASSIGNPT:=R1; SET(IONOTDONE); IF DISKUNIT(R1) THEN BEGIN R0:=7; CANCEL; END; IF R2 = #1F OR R2 = #01 THEN BEGIN IF PROTECTED(R1) THEN BEGIN R0:=8; CANCEL; END ELSE SET(JOBWRITE(R1)); END ELSE RESET(JOBWRITE(R1)); WHILE IONOTDONE DO BEGIN COMMENT BUILD CCWS; R0:=IOADDR; R1:=LENGTH OR #20000000; IF BSADDED THEN BEGIN STM(R0,R1,CCWS(16)); R0:=#27000000; R1:=#60000001; END; STM(R0,R1,CCWS(8)); R1:=ASSIGNPT; R2:=DRIVENO(R1) SHLL 2; R0:=TAPEMODE(R1) SHLL 24; R1:=#60000001; STM(R0,R1,CCWS); R0:=TAPEADDRESS(R2); SETKEY; DOIO; R1:=ASSIGNPT; IF = THEN BEGIN COMMENT OK; RESETKEY; CLI(#02,OP); IF = THEN BEGIN R0:=LENGTH-RESLENGTH; REGS(8):=R0; END; RESET(IONOTDONE); END ELSE IF > THEN BEGIN COMMENT END TAPE OR END FILE; RESETKEY; CLI(#02,OP); IF = THEN BEGIN R0:=0; REGS(8):=R0; END; OI(#10,PSW(4)); RESET(IONOTDONE); END ELSE IF OVERFLOW THEN BEGIN RESETKEY; IOERREDIT; MVC(6,ERRMSG(8),"NOT OPR"); R0:=@ERRMSG; R1:=15; WRITECONSOLE; R0:=@ERRMSGLOCK; V; SVCUNLOCK; IOCANCEL; END ELSE BEGIN RESETKEY; TM(#40,SENSE); IF OVERFLOW THEN BEGIN TM(#40,CSW(4)); IF = OR R0 ~= #0F THEN BEGIN IOERREDIT; MVC(6,ERRMSG(8),"NOT RDY"); WHILE R1 > 2 DO BEGIN R1:=#F0007; READCONSOLE; IOERRDONE; END; IF R1 = 1 THEN IOCANCEL; END ELSE RESET(IONOTDONE); COMMENT END OF UNLOAD; END ELSE BEGIN TM(#08,SENSE); IF OVERFLOW THEN BEGIN COMMENT DATA ERROR, RETRY; SET(BSADDED); R0:=ERRCNT+1; IF R0 > 20 THEN BEGIN IOERREDIT; WHILE R1 > 2 DO BEGIN READCONSOLE; IOERRDONE; END; IF R1 = 1 THEN IOCANCEL; R0:=0; END; ERRCNT:=R0; END ELSE BEGIN COMMENT SOME OTHER ERROR; TM(#50,CSW(4)); IF OVERFLOW THEN BEGIN IF BSADDED THEN BEGIN COMMENT WHERE CU BUSY; R0:=CSW AND #FFFFFF; R1:=@CCWS(16); IF R0 ~= R1 THEN RESET(BSADDED); END; END ELSE BEGIN COMMENT NOT CONTROL UNIT BUSY; IOERREDIT; WHILE R1 > 2 DO BEGIN READCONSOLE; IOERRDONE; END; IF R1 = 1 THEN IOCANCEL; TM(#20,SENSE); IF OVERFLOW THEN BEGIN TM(#04,CSW(4)); IF OVERFLOW THEN BEGIN R0:=OP; IF R0 = #01 OR R0 = #1F THEN SET(BSADDED); END; END; END; END; END; END; END; END; GLOBAL 75 PROCEDURE DISKIO(R4); BEGIN COMMENT INITIATE DISK I/O AND HANDLE ERRORS; SHORT INTEGER LENGTH SYN WORK(4), RESLENGTH SYN CSW(6), CYLINDER SYN DISKRECORDID, HEAD SYN DISKRECORDID(2); INTEGER ASSIGNPT SYN WORK(8), IOADDR SYN WORK; BYTE OP SYN IOADDR, ERRCNT SYN WORK(6), FORMAT SYN WORK(7), OVERLAYSW SYN SCRATCH, IONOTDONE SYN ASSIGNPT, RECORD SYN DISKRECORDID(4); FUNCTION DISKEXIT(0,#07F4); IOADDR:=R0; OP:=R2; LENGTH:=R1; R0:=0; ERRCNT:=R0; IF R1 <= 0 OR R1 > #7FFF THEN BEGIN R0:=2; CANCEL; END; IF R2 = #1D OR R2 = 0 THEN SET(FORMAT) ELSE RESET(FORMAT); MVI(0,DISKCOUNTID(5)); IF OVERLAYSW THEN BEGIN R1:=OVERLAYDEV; IF R1 = 0 THEN BEGIN R0:=2; CANCEL; END; END ELSE BEGIN R1:=REGS(12); TM(#01,PSW(1)); IF OVERFLOW OR R1 <= 8 THEN BEGIN IF R1 > 8 OR R1 <= 0 THEN BEGIN R0:=2; CANCEL; END; R1:=R1 SHLL 2; R1:=LOGUNITTBL(R1-4); IF R1 = 0 THEN BEGIN R0:=6; CANCEL; END; END; END; ASSIGNPT:=R1; MVI(#FF,IONOTDONE); IF ~DISKUNIT(R1) THEN BEGIN R0:=7; CANCEL; END; R0:=R3 AND #FF; R3:=R3 SHRA 8; IF R0 = 0 OR R3 < 0 THEN BEGIN R0:=2; CANCEL; END; RECORD:=R0; SVCLOCK; R0:=@ASSIGNLOCK(R1); P; IF ~= THEN SVCUNLOCK; R0:=EXTENTCNT(R1); R2:=1; WHILE R0 > 0 AND R3 >= NOTRACKS(R1) DO BEGIN R3:=R3-NOTRACKS(R1); R0:=R0-1; R1:=R1+4; END; IF R0 > 0 THEN BEGIN R3:=R3+STARTTRACK(R1); R2:=0; END; R1:=ASSIGNPT; R0:=@ASSIGNLOCK(R1); V; SVCUNLOCK; IF R2 ~= 0 THEN BEGIN OI(#20,PSW(4)); DISKEXIT; END; R1:=DRIVENO(R1) SHLL 4; R1:=DISKDRIVETYPE(R1) SHLL 1; R0:=TRKPERCYL(R1-2); R3:=R3/R0; CYLINDER:=R3; HEAD:=R2; MVC(4,DISKCOUNTID,DISKRECORDID); MVC(3,DISKSEEKADR(2),DISKRECORDID); MVC(1,DISKSEEKADR,0S); IF FORMAT THEN BEGIN R0:=RECORD-1; RECORD:=R0; END; R1:=ASSIGNPT; CLI(#05,OP); IF = OR FORMAT THEN BEGIN IF PROTECTED(R1) THEN BEGIN R0:=8; CANCEL; END ELSE SET(JOBWRITE(R1)); END ELSE SET(JOBREAD(R1)); R0:=IONOTDONE; WHILE R0 > 0 DO BEGIN IF R0 = #FF THEN BEGIN MVC(1,DISKCOUNTID(6),LENGTH); R0:=@DISKSEEKADR OR #07000000; R1:=#60000006; STM(R0,R1,CCWS); R0:=@DISKRECORDID OR #31000000; R1:=#60000005; STM(R0,R1,CCWS(8)); R0:=@CCWS(8) OR #08000000; CCWS(16):=R0; R0:=IOADDR; R1:=LENGTH OR #20000000; IF FORMAT THEN BEGIN STM(R0,R1,CCWS(32)); MVI(#1D,CCWS(32)); R0:=@DISKCOUNTID OR #1D000000; R1:=#A0000008; END; STM(R0,R1,CCWS(24)); CLI(0,OP); IF = THEN BEGIN MVI(#20,CCWS(28)); MVI(0,DISKCOUNTID(7)); END; END ELSE MVI(#FF,IONOTDONE); R1:=ASSIGNPT; R2:=DRIVENO(R1) SHLL 4; R0:=DISKADDRESS(R2); IF ~OVERLAYSW THEN SETKEY; DOIO; IF = THEN BEGIN COMMENT I/O OK; RESETKEY; MVI(0,IONOTDONE); R0:=OP; IF R0 ~= 0 AND R0 ~= #1D THEN BEGIN R0:=LENGTH-RESLENGTH; IF ~OVERLAYSW THEN REGS(8):=R0; END; END ELSE IF > THEN BEGIN COMMENT END FILE FOUND; RESETKEY; MVI(0,IONOTDONE); R0:=0; IF ~OVERLAYSW THEN REGS(8):=R0; OI(#10,PSW(4)); END ELSE IF OVERFLOW THEN BEGIN COMMENT NOT OPERATIVE; RESETKEY; IOERREDIT; MVC(6,ERRMSG(8),"NOT OPR"); R0:=@ERRMSG; R1:=15; WRITECONSOLE; R0:=@ERRMSGLOCK; V; SVCUNLOCK; IOCANCEL; END ELSE BEGIN COMMENT ALL OTHER ERRORS; RESETKEY; TM(#40,SENSE); IF OVERFLOW THEN BEGIN IOERREDIT; MVC(6,ERRMSG(8),"NOT RDY"); WHILE R1 > 2 DO BEGIN R1:=#F0007; READCONSOLE; IOERRDONE; END; IF R1 = 1 THEN IOCANCEL; END ELSE BEGIN TM(#40,SENSE(1)); IF OVERFLOW THEN BEGIN CLI(#11,CCWS(24)); IF ~= THEN BEGIN OI(#10,PSW(4)); MVI(#11,CCWS(24)); MVI(#20,CCWS(28)); MVI(#0F,IONOTDONE); R0:=LENGTH-RESLENGTH; REGS(8):=R0; MVC(1,DISKCOUNTID(6),0S); COMMENT ERASE REST OF TRACK; END ELSE MVI(0,IONOTDONE); COMMENT TRY ONCE; END ELSE BEGIN TM(#08,SENSE(1)); IF OVERFLOW THEN BEGIN TM(#02,SENSE(1)); IF = THEN BEGIN OI(#20,PSW(4)); MVI(0,IONOTDONE); END; END; CLI(0,IONOTDONE); IF ~= THEN BEGIN TM(#02,SENSE); IF OVERFLOW THEN BEGIN R2:=@CCWS(16) OR #16000000; CCWS(8):=R2; R2:=#20000004; CCWS(12):=R2; DOIO; COMMENT READ ALTERNATE TRACK ADDRESS; IF = THEN MVC(3,DISKSEEKADR(2),CCWS(16)) ELSE BEGIN R0:=ERRCNT+1; ERRCNT:=R0; END; END ELSE BEGIN TM(#50,CSW(4)); COMMENT 2 CHAN - BUSY; IF = OR ~= THEN BEGIN R0:=ERRCNT+1; ERRCNT:=R0; END; END; R0:=ERRCNT; IF R0 > 10 THEN BEGIN IOERREDIT; WHILE R1 > 2 DO BEGIN READCONSOLE; IOERRDONE; END; IF R1 = 1 THEN IOCANCEL; R0:=0; ERRCNT:=R0; END; END; END; END; END; R0:=IONOTDONE; END; END; BEGIN COMMENT GET POINTER TO CURRENT PCB; EXTERNAL 64 BASE R4; INTEGER YEAR, DAY, SECOND, JOBTIME, MAXTIME, USERMEMORY, ENDMEMORY, ENDJOBCOUNT, OPERATORCOUNT, FIRSTPCB, LASTPCB, FREEPCB, CURRENTPCB; R6:=CURRENTPCB; END; R1:=PSW AND #FF-15; IF R1 <= 35 THEN CASE R1 OF BEGIN BEGIN COMMENT READ A CARD; EXTERNAL 70 BASE R4; COMMENT SEE LEVEL1 BUFFERING PROCESS; INTEGER FULL, EMPTY, PTR, STARTB, ENDB, RDRLOCK, ADDR, WPTR, NOBUFF; BYTE ACTIVE, EOF, CTRLCARD, EOFFOUND, READCTRL; PROCEDURE ADVANCE(R3); BEGIN COMMENT MOVE TO NEXT BUFFER; R0:=@EMPTY; V; R1:=R1+80; IF R1 = ENDB THEN R1:=STARTB; PTR:=R1; END; R2:=REGS(4); SVCLOCK; R0:=@RDRLOCK; P; IF ~= THEN SVCUNLOCK; IF CTRLCARD THEN BEGIN COMMENT HAVE CONTROL CARD; R1:=PTR; CLC(4,B1,"%EOF "); IF = THEN OI(#20,PSW(4)) ELSE OI(#10,PSW(4)); IF READCTRL THEN BEGIN COMMENT ALLOWED TO READ IT; MVC(79,B2,B1); ADVANCE; RESET(CTRLCARD); RESET(EOFFOUND); END ELSE BEGIN COMMENT NOT ALLOWED, FORCE UP TO 2 EOFS; IF EOFFOUND THEN BEGIN R0:=@RDRLOCK; V; SVCUNLOCK; R0:=9; CANCEL; END; SET(EOFFOUND); SETKEY; MVC(4,B2,"%EOF "); MVC(74,B2(5),B2(4)); RESETKEY; END; END ELSE BEGIN COMMENT GET A CARD; R0:=@FULL; P; IF ~= THEN BEGIN R0:=@RDRLOCK; V; SVCUNLOCK; END; R1:=PTR; IF READCTRL THEN BEGIN COMMENT CAN READ ANYTHNG; CLI("%",B1); IF = THEN BEGIN CLC(4,B1,"%EOF "); IF = THEN OI(#20,PSW(4)) ELSE OI(#10,PSW(4)); END; MVC(79,B2,B1); ADVANCE; END ELSE BEGIN COMMENT CAN'T READ CONTROL CARDS; CLI("%",B1); IF = THEN BEGIN SETKEY; MVC(4,B2,"%EOF "); CLC(4,B1,"%EOF "); IF = THEN MVC(74,B2(5),B1(5)) ELSE MVC(74,B2(5),B2(4)); RESETKEY; CLC(4,B1,"%EOF "); IF = THEN BEGIN OI(#20,PSW(4)); ADVANCE; END ELSE BEGIN OI(#10,PSW(4)); SET(CTRLCARD); END; END ELSE BEGIN SETKEY; MVC(79,B2,B1); RESETKEY; ADVANCE; END; END; END; R0:=@RDRLOCK; V; SVCUNLOCK; END; BEGIN COMMENT PUNCH A CARD; EXTERNAL 71 BASE R4; COMMENT SEE LEVEL1 BUFFERING PROCESS; INTEGER EMPTY, FULL, PTR, STARTB, ENDB, PCHLOCK, ADDR, WPTR, NOBUFF; BYTE JOBSTART, JOBFLUSH, ACTIVE, JOBPUNCH; R2:=REGS(4); SVCLOCK; R0:=@PCHLOCK; P; IF ~= THEN SVCUNLOCK; R0:=@EMPTY; P; IF ~= THEN BEGIN R0:=@PCHLOCK; V; SVCUNLOCK; END; R1:=PTR; MVC(79,B1(1),B2); IF ~JOBSTART THEN RESET(B1) ELSE BEGIN RESET(JOBSTART); SET(B1); END; R1:=R1+81; IF R1 = ENDB THEN R1:=STARTB; PTR:=R1; SET(JOBPUNCH); COMMENT USER PUNCHED AT LEAST ONE CARD; R0:=@FULL; V; R0:=@PCHLOCK; V; SVCUNLOCK; END; BEGIN COMMENT SET LINENO SO NEXT LINE ON NEW PAGE; EXTERNAL 72 BASE R4; COMMENT SEE LEVEL1 FOR DETAILS; INTEGER EMPTY, FULL, PTR, STARTB, ENDB, WTRLOCK, LINENO; SVCLOCK; R0:=@WTRLOCK; P; IF ~= THEN SVCUNLOCK; R0:=0; LINENO:=R0; R0:=@WTRLOCK; V; SVCUNLOCK; END; BEGIN COMMENT LINK TO PRINT ROUTINES; OPENLINE; R1:=REGS(4); MVC(131,B2(1),B1); CLOSELINE; IF R2 = 0 THEN OI(#10,PSW(4)); END; BEGIN COMMENT LINK TO READCONSOLE; R0:=REGS(8); R1:=R0 AND #FFFF; R0:=R0 SHRL 16; IF R0 > 128 OR R1 > 128 OR R1 = 0 THEN BEGIN R0:=2; CANCEL; END; LM(R0,R2,REGS(4)); R0:=R0 OR #FF000000; R2:=R2 AND #FFFFFF; READCONSOLE; REGS(8):=R1; END; BEGIN COMMENT LINK TO WRITECONSOLE; LM(R0,R1,REGS(4)); R0:=R0 AND #FFFFFF; IF R1 > 128 OR R1 <= 0 THEN BEGIN R0:=2; CANCEL; END; WRITECONSOLE; END; BEGIN COMMENT READ TAPE; LM(R0,R1,REGS(4)); R2:=#02; TAPEIO; END; BEGIN COMMENT WRITE TAPE; LM(R0,R1,REGS(4)); R2:=#01; TAPEIO; END; BEGIN COMMENT MARK TAPE; R0:=0; R1:=1; R2:=#1F; TAPEIO; END; BEGIN COMMENT REWIND TAPE; R0:=0; R1:=1; R2:=#07; TAPEIO; END; BEGIN COMMENT FORWARD SPACE RECORD; R0:=0; R1:=1; R2:=#37; TAPEIO; END; BEGIN COMMENT FORWARD SPACE FILE; R0:=0; R1:=1; R2:=#3F; TAPEIO; END; BEGIN COMMENT BACK SPACE RECORD; R0:=0; R1:=1; R2:=#27; TAPEIO; END; BEGIN COMMENT BACK SPACE FILE; R0:=0; R1:=1; R2:=#2F; TAPEIO; END; BEGIN COMMENT READ DISK; BYTE OVERLAYSW SYN SCRATCH; L (Message over 64 KB, truncated)

Steve And Grace Bovy
Posts: 1
Joined: Sun Feb 02, 2020 3:10 pm

Re: FW: [turnkey-mvs] Hercules svn version Dec 31 2009 or later ???

Post by Steve And Grace Bovy » Mon Jan 11, 2010 3:26 am

That did the trick !!! Thanks ________________________________ From: hercules-390@yahoogroups.com [mailto:hercules-390@yahoogroups.com] On Behalf Of Dave Wade Sent: Sunday, January 10, 2010 8:05 AM To: hercules-390@yahoogroups.com Subject: RE: [hercules-390] Re: FW: [turnkey-mvs] Hercules svn version Dec 31 2009 or later ???? Got it now. Thanks http://tinyurl.com/nnzjyn http://tinyurl.com/nnzjyn> Dave G4UGM
> -----Original Message----- > From: hercules-390@yahoogroups.com > [mailto:hercules-390@yahoogroups.com
] On Behalf Of kerravon86
> Sent: 10 January 2010 15:22 > To: hercules-390@yahoogroups.com > Subject: [hercules-390] Re: FW: [turnkey-mvs] Hercules svn > version Dec 31 2009 or later ???? > > > --- In hercules-390@yahoogroups.com
, "Dave Wade" wrote:
> > > > Any one any idea why this happens.... > > Sounds like the normal problem of needing to install > the new Visual C++ redistributable. > > I think Fish gave a link here about 2 months ago. > > BFN. Paul. > > > > > > ------------------------------------ > > Community email addresses: > Post message: hercules-390@yahoogroups.com
> > Files and archives at: > http://groups.yahoo.com/group/hercules-390
http://groups.yahoo.com/group/hercules-390>
> > Get the latest version of Hercules from: > http://www.hercules-390.org http://www.hercules-390.org> > > Yahoo! Groups Links > > >

Steve And Grace Bovy
Posts: 1
Joined: Sun Feb 02, 2020 3:10 pm

Re: winpcap 4.1.1 and ctci-w32 ???

Post by Steve And Grace Bovy » Mon Jan 11, 2010 3:29 am

Thanks for all your efforts Fish. I do appreciate it :) ________________________________ From: hercules-390@yahoogroups.com [mailto:hercules-390@yahoogroups.com] On Behalf Of Fish Sent: Sunday, January 10, 2010 3:57 PM To: hercules-390@yahoogroups.com Subject: RE: [hercules-390] winpcap 4.1.1 and ctci-w32 ??? Steve And Grace Bovy wrote:
> Which version of ctci-w32 will work with > Winpcap 4.1.1 ??? > > The version on fishes web page is 3.2.1.160 ??
Yes. -- "Fish" (David B. Trout) - fish@... Fight Spam! Join CAUCE! http://www.cauce.org/ http://www.cauce.org/> > 7 reasons why HTML email is a bad thing http://www.georgedillon.com/web/html_email_is_evil.shtml http://www.georgedillon.com/web/html_email_is_evil.shtml> PGP key fingerprints: DH/DSS: 9F9B BAB0 BA7F C458 1A89 FE26 48F5 D7F4 C4EE 3E2A RSA: 6B37 7110 7201 9917 9B0D 99E3 55DB 5D58 FADE 4A52

rhtatum

compilerource

Post by rhtatum » Mon Jan 11, 2010 4:30 am

%PL360 $GOTO 0001 BEGIN COMMENT PL360 ASSEMBLER -- JAN 71 -- MIKE GREEN -- TELPAR, INC; 0002 ARRAY 21 INTEGER DUMIPL=(#00020000,#00FFFFFF,07000000,#20000001, 0003 16(" "),0); 0004 ARRAY 9 INTEGER DSAVE; BYTE ASKED; 0005 ARRAY 25 BYTE EXTENDMSG="EXTEND XXXXXXXX OR CANCEL"; 0006 BYTE LISTFLAG; COMMENT USED TO INDICATE LISTING; 0007 BYTE RUNFLAG; COMMENT USED TO INDICATE RUN OUTPUT; 0008 BYTE LISTOLDSEQ,INTAPEFLAG,OUTTAPEFLAG, EXITFLAG,FIRSTCARD, 0009 FIRSTPROG, PROGFLAG; 0010 BYTE SKIPFLAG; COMMENT USED TO SKIP DATA FILL; 0011 BYTE FLAG; COMMENT USED IN SYNTACTIC ANALYSIS; 0012 BYTE EOF; COMMENT INPUT END-OF-FILE FLAG; 0013 BYTE SIGN, EXPOSIGN; COMMENT SIGN FLAGS FOR NUMBER CONVERSION; 0014 BYTE COMPLEMENT; COMMENT FLAG FOR FUNCTION TYPE 14; 0015 BYTE DUMMYSEG; COMMENT USED TO INDICATE DUMMY INSTEAD OF SEGMENT; 0016 BYTE OVLFLAG; 0017 BYTE NOTOVF,SPECNE; 0018 BYTE GOTOFLAG; 0019 BYTE PAGECTL, TAPEPRINT, PRINTOPEN; 0020 SHORT INTEGER N1,N2,N3,N4; COMMENT NAME AND LABEL POINTERS; 0021 SHORT INTEGER BLOCK; COMMENT CURRENT BLOCK LEVEL; 0022 SHORT INTEGER PSTYPE; COMMENT INDICATES TYPE OF CURRENT SEG PROC; 0023 SHORT INTEGER FILLTYPE; COMMENT USED IN DATA FILL; 0024 SHORT INTEGER PROCBR,PROCLK; COMMENT USED FOR BRANCH AROUND PROC; 0025 SHORT INTEGER CSEGNO; COMMENT CURRENT SEGMENT NUMBER; 0026 SHORT INTEGER SFG, SEGNO; COMMENT CURRENT SEGMENT LEVEL AND NUMBER; 0027 SHORT INTEGER DBREG; COMMENT CURRENT DATA BASE REGISTER; 0028 SHORT INTEGER DSEG; COMMENT CURRENT DATA SEGMENT LEVEL; 0029 SHORT INTEGER LITX; COMMENT LITERAL INDEX; 0030 SHORT INTEGER SYMTYPE; BYTE TYPEFLAG SYN SYMTYPE(1); 0031 SHORT INTEGER COUNT, PROGTAPE=3,INTAPE=1,OUTTAPE=2; 0032 SHORT INTEGER TEN=10; 0033 SHORT INTEGER ERRCOUNT, ERRLIMIT=100; COMMENT ERROR COUNT AND TRAP; 0034 SHORT INTEGER ENDCHAIN=_1; 0035 SHORT INTEGER MAXHASH=78; 0036 INTEGER OVLNO; 0037 ARRAY 64 INTEGER STRINGV; COMMENT VALUE OF CURRENT STRING; 0038 ARRAY 5 SHORT INTEGER LENHASH=(0,16,32,48,64); 0039 ARRAY 40 SHORT INTEGER HASHCHAIN=40(_1); 0040 ARRAY 47 BYTE ALPHASH=(2(0),3(2),11(4),4(6),3(8),2(10), 0041 10(12),12(14)); 0042 INTEGER I; COMMENT STACK INDEX; 0043 INTEGER LC; COMMENT LOCATION COUNTER FOR TARGET PROGRAM; 0044 INTEGER DC,DC1; COMMENT DATA COUNTERS; 0045 INTEGER FUNC0,FUNC1,FUNC2; 0046 INTEGER STACKBASE,NAMEBASE,LITBASE,LABELBASE,DATABASE,PRTBASE; 0047 INTEGER NAMEPOINTER, PROGBASE, DATASTART, DATASTOP, CHAIN, PROGCHAIN; 0048 INTEGER PTAG=#F000, COMMENT USED TO PUT IN PROGRAM BASE REGISTER; 0049 PRTADR=#0180, COMMENT PROGRAM REFERENCE TABLE ADDRESS; 0050 STARTADR=#E000, COMMENT START OF MAIN DATA SEGMENT; 0051 DCMAX; COMMENT MAXIMUM FILL ADDRESS FOR DATA; 0052 ARRAY 6 INTEGER DCTBL,DSEGTBL,DBLTBL,DBTYPETBL; 0053 INTEGER OUTCHAIN, DISKADR, TRECLEN=1600, INBASE, OUTBASE; 0054 INTEGER SAVERETURN; COMMENT USED TO HOLD RETURN REGISTER FOR MAIN; 0055 LONG REAL CONWORK; COMMENT USED TO CONVERT TO DECIMAL; 0056 LONG REAL FCON1=#4E00000000000000, FCON2=#4700000000000000, 0057 FTEN =#41A0000000000000, FONE =#4110000000000000; 0058 INTEGER FCON1LOW SYN FCON1(4)); 0059 INTEGER REGISTER XR SYN R5; COMMENT ERROR ROUTINE PARAMETER REG; 0060 FUNCTION XC(5,#D700); COMMENT DEFINE XOR FUNCTION; 0061 FUNCTION LTR(1,#1200); COMMENT DEFINE LOAD AND TEST FUNCTION; 0062 FUNCTION SETZONE(8,#96F0); COMMENT DEFINE FUNCTION TO SET ZONE; 0063 ARRAY 32 BYTE TYPETABLE= 0064 (0,1,0,0,0,1,0,0,0,0,1,0,0,0,1,1); 0065 ARRAY 8 BYTE LENGTH =(1,2,3,2,0); 0066 ARRAY 8 BYTE ALENGTH =(1,3,7,3,0); 0067 ARRAY 28 BYTE CONST =("PROGRAM SEGMENT","LEVEL","LENGTH"); 0068 ARRAY 12 BYTE CONST1 =("DATA SEGMENT"); 0069 ARRAY 16 BYTE TRTABLE =("0123456789ABCDEF"); 0070 SHORT INTEGER FS=140,FT2=172,FT3=180,FT4=194,FT5=222,FT6=232, 0071 FT7=234,FT8=240,FT9=248; COMMENT VALUE OF FIRST SYMBOL IN 0072 EACH LENGTH AND TYPE OF TERMINAL SYMBOL; 0073 SHORT INTEGER NUMBERSYMBOL=136,IDENTSYMBOL=134,STRNGSYMBOL=138, 0074 ENDFILE=168,ASSIGNSYMBOL=170,SEMICOLON=140,BLOCKHEAD=128, 0075 BLOCKBODY=130,CASESEQ=32,BEGINSYMBOL=224,ENDSYMBOL=184; 0076 ARRAY 4 SHORT INTEGER WORD2= 0077 ("DO","IF","OF","OR"); 0078 ARRAY 7 INTEGER WORD3= 0079 ("ABS ","AND ","END ","FOR ","NEG ","SYN ","XOR "); 0080 ARRAY 14 INTEGER WORD4= 0081 ("BASE","BYTE","CASE","ELSE","GOTO","LONG","NULL", 0082 "REAL","SHLA","SHLL","SHRA","SHRL","STEP","THEN"); 0083 ARRAY 10 INTEGER WORD5= 0084 ("ARRAY ","BEGIN ","SHORT ","UNTIL ","WHILE "); 0085 ARRAY 2 INTEGER WORD6= 0086 ("GLOBAL "); 0087 ARRAY 6 INTEGER WORD7= 0088 ("INTEGER ","LOGICAL ","SEGMENT "); 0089 ARRAY 8 INTEGER WORD8= 0090 ("EXTERNAL","FUNCTION","OVERFLOW","REGISTER"); 0091 ARRAY 6 INTEGER WORD9= 0092 ("CHARACTER ","PROCEDURE "); 0093 ARRAY 126 SHORT INTEGER F= 0094 (0,8,9,3,9,8,3,3,5(5),3,3,5,1,2,3(5),4,2,3,2,2,3,1,2,1,1,3(2),1, 0095 7,6,4,1,3,4,9,6,1,3,6,9,5,3,5,3,3,5,3,6,8,6,9,5,3,1,2,1,7,7,1,1, 0096 10,9,8,11,7,7,10,3(9),10,9,3(7),10,5,1,5,7,1,4,10,7,10,3,1,3(7), 0097 5,8,5,7,6,10,3,8,4(7),5,7,5,11,10,5,10,5,8,8,9,5,7,5,6,8,7); 0098 ARRAY 126 SHORT INTEGER G= 0099 (0,5,6,4,4,5,3(6),5,3(3),5(4),8,3,3(2),1,3,4,3,4,4(1),3,2,1,9,8, 0100 1,3(2),21(8),7,1,4,4,1,6,5,5,1,7,7,5(9),3,4,4,10,3,5,1,8,4,4,8,4, 0101 7,4,1,4,6,10,4,8,10,4,2,4,10,4,10,4(4),3,4,8,4,10,2,4,8,10,10, 0102 3(8),3,7,10,8); 0103 ARRAY 126 SHORT INTEGER MTB= 0104 (0,1,78,88,93,103,114,120,132,143,144,145,146,147,206,217,238, 0105 250,260,265,271,276,297,303,304,309,319,320,327,328,329,330,331, 0106 336,341,342,354,366,367,373,384,389,399,405,411,421,427,433,439, 0107 445,451,457,467,483,493,500,512,518,524,530,536,542,548,549,550, 0108 561,578,579,601,611,616,617,627,637,642,652,662,672,677,678,683, 0109 688,689,690,696,697,698,703,730,731,736,741,746,747,756,766,767, 0110 772,773,778,786,787,793,799,804,809,814,819,824,829,830,831,838, 0111 843,849,865,870,876,881,886,891,897,902,907,908,913); 0112 0113 COMMENT ALLOCATION FOR THE COMPILER TABLES AND ARRAYS IS DONE 0114 AT RUN TIME USING AVAILABLE CORE SPACE. THE LITERAL TABLE 0115 HAS A MAXIMUM LENGTH OF #3000 BYTES, DATA INITIALIZATION 0116 SECTION A MAXIMUM LENGTH OF #8000 BYTES. THE MAXIMUM LENGTH 0117 OF THE OTHER VARIABLES IS GIVEN BELOW; 0118 ARRAY 512 INTEGER V SYN 0; COMMENT TRANSLATION STACK; 0119 SHORT INTEGER S SYN V(12), T SYN V(14); 0120 INTEGER V1 SYN V(16); 0121 ARRAY #800 SHORT INTEGER LABEL SYN 0; COMMENT LABEL TABLE' 0122 SHORT INTEGER LABELADR SYN LABEL(10); 0123 ARRAY #1800 SHORT INTEGER TYPE SYN 0; 0124 ARRAY 2 SHORT INTEGER ADR SYN TYPE(2); 0125 SHORT INTEGER LINK SYN TYPE(6); 0126 BYTE NAME SYN TYPE(8); COMMENT NAME IS 2,4,6,8, OR 10 BYTES LONG; 0127 ARRAY #4000 SHORT INTEGER PROGRAM SYN MEM(R9); 0128 COMMENT R9 IS USED AS A STACK POINTER BY PROGRAM SO 0129 THAT R9 ALWAYS POINTS TO THE FIRST BYTE OF THE CURRENT 0130 PROGRAM SEGMENT BEING ASSEMBLED; 0131 0132 ARRAY 8 BYTE RIGHTPART; COMMENT USED IN SYNTACTIC ANALYSIS; 0133 ARRAY 3 SHORT INTEGER COMPARE=(#D500,@RIGHTPART,@B3(1)); 0134 SHORT INTEGER NOMORERULES=255; COMMENT END OF RIGHTPART RULES; 0135 ARRAY 20 INTEGER CBUF-20(" "); 0136 ARRAY 21 INTEGER PBUF=(20(" "),0); 0137 ARRAY 21 INTEGER CHAINBUF; 0138 ARRAY 37 SHORT INTEGER PRECL SYN PBUF(6); COMENT LENGTH FIELDS; 0139 ARRAY 33 INTEGER BLANK=" "; 0140 ARRAY 33 INTEGER WBUFLONG; 0141 ARRAY 132 BYTE WBUF SYN WBUFLONG; 0142 ARRAY 2 LONG REAL VALUEF; COMMENT VALUE OF CURRENT SYMBOL; 0143 INTEGER VALUE SYN VALUEF; 0144 SHORT INTEGER IVALUE SYN VALUEF; 0145 ARRAY 16 INTEGER ZERO; 0146 ARRAY 3 SHORT INTEGER NAMECOMP=(#D500,@B1,@NAME(R4)), 0147 NAMEMOVE=(#D200,@NAME(R4),@B1); 0148 ARRAY 3 SHORT INTEGER COMSCAN=(#DD00,@B1,@B10), 0149 TRTSCAN=(#DD00,@B1,@B10(256)); COMMENT USE THE TWO SCAN 0150 TABLES POINTED TO BY R10; 0151 ARRAY 16 INTEGER LINETABLE=0; COMMENT FOR BEGIN-END PAIRING; 0152 INTEGER BLOCKLEVEL, LINENO, INLINE, OUTMAX; 0153 0154 PROCEDURE REWIND(R13); 0155 BEGIN COMMENT REWIND TAPE OR FAKE FOR DISK; 0156 FUNCTION REWINDX(0,#0A19); 0157 STM(R0,R3,DSAVE); GETUNITTYPE; IF = THEN REWINDX ELSE BEGIN 0158 R3:=1; SETTRACK; LM(R0,R3,DSAVE); 0159 END; 0160 END; 0161 0162 PROCEDURE READTAPE(R13); 0163 BEGIN COMMENT READ TAPE OR INTERPRET FOR DISK; 0164 FUNCTION READTAPEX(0,#0A16), LTR(1,#1200); 0165 BYTE SAVEEOF; RESET SAVEEOF; 0166 STM(R0,R3,DSAVE); GETUNITTYPE; IF = THEN READTAPEX ELSE BEGIN 0167 LM(R0,R1,DSAVE); DSAVE(16):=R1; WHILE R1 > 0 DO BEGIN 0168 READDISK; IF > THEN BEGIN 0169 R3:=R3 AND _256+257; READDISK; IF > THEN CANCEL; 0170 END; 0171 IF < THEN R1:=_1 ELSE BEGIN 0172 R0:=R0+R1; R1:=NEG R1+DSAVE(16); DSAVE(16):=R1; 0173 R3:=R3+1; SET(SAVEEOF); 0174 END; 0175 END; 0176 IF ¬SAVEEOF THEN R3:=R3+1; SETTRACK; 0177 LM(R0,R3,DSAVE); R1:=R1-DSAVE(16); TEST(SAVEEOF); 0178 END; 0179 END; 0180 0181 PROCEDURE EXTENDDISK(R4); 0182 BEGIN COMMENT ASK FOR MORE DISK; 0183 IF ASKED THEN BEGIN 0184 R5:=R5+1; IF R5 > 120 THEN BEGIN 0185 RINGBELL; R5:=0; 0186 END ELSE BEGIN 0187 R0:=1; WAIT; 0188 END; 0189 END ELSE BEGIN 0190 SET(ASKED); R0:=@EXTENDMSG(7); GETASSIGN; R5:=0; 0191 R0:=@EXTENDMSG; R1:=25; WRITETYPE; R0:=10; WAIT; 0192 END; 0193 END; 0194 0195 PROCEDURE MARKTAPE(R13); 0196 BEGIN COMMENT MARK TAPE OR DISK; 0197 FUNCTION MARKTAPEX(0,#0A18); 0198 STM(R0,R3,DSAVE); GETUNITTYPE; IF = THEN MARKTAPEX ELSE BEGIN 0199 STM(R4,R5,DSAVE(16)); RESET(ASKED); 0200 X: MARKDISK; IF < THEN BEGIN 0201 R3:=R3 AND _256+257; MARKDISK; 0202 END; 0203 IF > THEN BEGIN 0204 EXTENDDISK; GOTO X; 0205 END; 0206 DISKADR:=R3; R3:=R3+1; SETTRACK; LM(R0,R5,DSAVE); 0207 END; 0208 END; 0209 0210 PROCEDURE WRITETAPE(R13); 0211 BEGIN COMMENT WRITE TAPE OR INTERPRET FOR DISK; 0212 FUNCTION WRITETAPEX(0,#0A17); 0213 STM(R0,R3,DSAVE); GETUNITTYPE; IF = THEN WRITETAPEX ELSE BEGIN 0214 STM(R4,R5,DSAVE(16)); R0:=R0 AND #FFFF; DSAVE(24):=R0; 0215 LM(R0,R1,DSAVE); 0216 WHILE R1 > DSAVE(24) DO BEGIN 0217 R1:=R1-DSAVE(24); STM(R0,R1,DSAVE(28)); RESET(ASKED); 0218 R4:=R3 AND #FF; IF R4 > 1 THEN R3:=R3 AND _256+257; 0219 X: R1:=DSAVE(24); FORMATDISK; IF > THEN BEGIN 0220 EXTENDDISK; R0:=DSAVE(28); GOTO X; 0221 END; 0222 R3:=R3+256; R0:=R0+DSAVE(24); R1:=DSAVE(32); 0223 END; 0224 STM(R0,R1,DSAVE(28)); RESET(ASKED); 0225 Y: FORMATDISK; IF < THEN BEGIN 0226 R3:=R3 AND _256+257; R1:=DSAVE(32); FORMATDISK; 0227 END; 0228 IF > THEN BEGIN 0229 EXTENDDISK; LM(R0,R1,DSAVE(28)); GOTO Y; 0230 END; 0231 DISKADR:=R3; R3:=R3+1; SETTRACK; LM(R0,R5,DSAVE); 0232 END; 0233 END; 0234 0235 PROCEDURE ERROREXIT(R4); GOTO EXIT; COMMENT EXIT FROM COMPILATION; 0236 COMMENT SHOULD THERE BE AN "END" ON THIS PROCEDURE STMT???; 0237 PROCEDURE CHAINDISK(R13); 0238 BEGIN COMMENT CHAIN HEADERS FOR DISK; 0239 STM(R0,R3,DSAVE); GETUNITTYPE; IF < THEN BEGIN 0240 R3:=CHAIN; IF R3 ~= 0 THEN BEGIN 0241 R0:=@CHAINFUFF; R1:=84; READDISK; IF ~= THEN CANCEL; 0242 MVC(3,CHAINBUFF(80),DISKADR); 0243 R1:=84; WRITEDISK; IF ~= THEN CANCEL; 0244 END; 0245 MVC(3,CHAIN,DISKADR); 0246 END; 0247 LM(R0,R3,DSAVE); 0248 END; 0249 0250 PROCEDURE FSPTM(R13); 0251 BEGIN COMMENT FORWARD SPACE FILE; 0252 FUNCTION FSPTMX(0,#0A1B); 0253 STM(R0,R3,DSAVE); GETUNITTYPE; IF = THEN FSPTMX ELSE BEGIN 0254 R0:=CHAIN; IF R0 ~= 0 THEN R3:=R0 ELSE BEGIN 0255 R0:=@DSAVE(16); R1:=8; READDISK; 0256 WHILE >= DO BEGIN 0257 IF > THEN BEGIN 0258 R3:=R3 AND _256+257; READDISK; IF > THEN CANCEL; 0259 END ELSE BEGIN 0260 R3:=R3+1; R1:=8; READDISK; 0261 END; 0262 END; 0263 R3:=R3+1; 0264 END; 0265 SETTRACK; 0266 END; 0267 LM(R0,R3,DSAVE); 0268 END; 0269 0270 PROCEDURE PAGE(R13); 0271 BEGIN COMMENT PRINTER OR TAPE/DISK; 0272 FUNCTION PAGEX(0,#0A12); 0273 IF TAPEPRINT THEN MVI("1",PAGECTL) ELSE PAGEX; 0274 END; 0275 0276 PROCEDURE WRITE(R13); 0277 BEGIN COMMENT PRINTER OR TAPE/DISK; 0278 FUNCTION WRITEX(0,#0A13); 0279 ARRAY 4 INTEGER SAVE; 0280 ARRAY 133 BYTE BUFFER; 0281 IF TAPEPRINT THEN BEGIN 0282 STM(R0,R2,SAVE); SAVE(12):=R13; 0283 R1:=R0; MVC(131,BUFFER(1),BB1); MVC(0,BUFFER,PAGECTL); 0284 MVI(" ",PAGECTL); R0:=@BUFFER; R1:=133; R2:=8; WRITETAPE; 0285 LM(R0,R2,SAVE); R13:=SAVE(12); 0286 END ELSE WRITEX; 0287 END; 0288 0289 SEGMENT PROCEDURE INPUTCARD(R3); 0290 BEGIN COMMENT READS NEXT SOURCE RECORD; 0291 ARRAY 5 INTEGER SAVE; ARRAY 80 BYTE CCARD; 0292 INTEGER GOAL, INPTR, OUTPTR, INMAX, DELETE; 0293 BYTE INNAME, OUTNAME,PROGNAME, LOOKING, TEMP, TAPERECORD; 0294 PROCEDURE GETRECORD(R7); 0295 BEGIN COMMENT GET NEXT TAPE RECORD; 0296 R1:=INPTR; IF R1 = INMAX THEN BEGIN 0297 R0:=INBASE; R1:=TRECLEN; R2:=INTAPE; READTAPE; 0298 IF ~= THEN SET(EOF) ELSE BEGIN 0299 R1:=R1+R0; INMAX:=R1; R1:=R0; 0300 END; 0301 END; 0302 IF ~EOF THEN BEGIN 0303 MVC(79,CBUF,B1); R1:=R1+80; INPTR:=R1; 0304 R0:=INLINE+1; INLINE:=R0; SET(LISTOLDSEQ); 0305 END; 0306 END; 0307 PROCEDURE PUTRECORD(R7); 0308 BEGIN COMMENT PUT NEXT TAPE RECORD; 0309 IF EOF THEN BEGIN COMMENT CLOSE FILE; 0310 R0:=OUTBASE; R1:=OUTPTR-R0; R2:=OUTTAPE; 0311 IF OUTNAME THEN BEGIN 0312 IF R1 > 0 THEN WRITETAPE; MARKTAPE; 0313 END; 0314 END ELSE BEGIN 0315 R1:=OUTPTR; IF R1 = OUTMAX THEN BEGIN 0316 R0:=OUTBASE; R1:=TRECLEN; R2:=OUTTAPE; 0317 IF OUTNAME THEN WRITETAPE; R1:=R0; 0318 END; 0319 MVC(79,B1,CBUF); R1:=R1+80; OUTPTR:=R1; 0320 R0:=LINENO+1; LINENO:=R0; 0321 END; 0322 END; 0323 PROCEDURE GETNUMBER(R7); 0324 BEGIN COMMENT SCAN CARD FOR NUMBER, COL R6; 0325 ARRAY 80 BYTE CHAR SYN CBUF(R6); 0326 R0:=CHAR; 0327 WHILE R0 = " " AND R6 < 80 DO BEGIN 0328 R6:=R6+1; R0:=CHAR; 0329 END; 0330 IF R6 = 80 THEN R0:="?"; R1:=0; 0331 WHILE R0 >= "0" AND R0 <="9" AND R6 < 80 DO BEGIN 0332 R1:=R1*10s-#F0+R0; R6:=R6+1; R0:=CHAR; 0333 END; 0334 IF R0 ~= " " AND R0 ~= "," THEN R0:="?";COMMENT MADE IT COMMA; 0335 IF R6 = 80 THEN R0:="?"; R6:=R6+1; 0336 END; 0337 PROCEDURE COPYSOURCE(R7); 0338 BEGIN COMMENT COPY SOURCE TO END FILE; 0339 R0:=INBASE; R1:=TRECLEN; R2:=INTAPE; READTAPE; 0340 WHILE = DO BEGIN 0341 R2:=OUTTAPE; WRITETAPE; R1:=TRECLEN; R2:=INTAPE; READTAPE; 0342 END; 0343 R2:=OUTTAPE; MARKTAPE; 0344 END; 0345 STM(R3,R7,SAVE); 0346 IF FIRSTPROG THEN BEGIN COMMENT DIFFERENT SOURCE FOR CONTROL CARD; 0347 EXTERNAL 78 BASE R7; 0348 ARRAY 80 BYTE BEGINCARD, EXECUTECARD; 0349 MVC(79,CCARD,EXECUTECARD); RESET(FIRSTPROG); 0350 END; 0351 WHILE FIRSTCARD DO BEGIN COMMENT SET UP FOR COMPILATION; 0352 RESET(INNAME); RESET(OUTNAME); RESET(PROGNAME); RESET(TEMP); 0353 R0:=OUTBASE; OUTPTR:=R0; INPTR:=R0; INMAX:=R0; 0354 CLC(7,CCARD(20)," "); IF ~= THEN SET(INNAME); 0355 CLC(7,CCARD(30)," "); IF ~= THEN SET(OUTNAME); 0356 CLC(7,CCARD(40)," "); IF ~= THEN SET(PROGNAME); 0357 IF ~INNAME AND ~OUTNAME AND ~PROGNAME THEN BEGIN 0358 MVC(7,CCARD(40),"********"); SET(PROGNAME); 0359 END; 0360 IF INNAME AND ~OUTNAME AND ~PROGNAME THEN SET(TEMP); 0361 IF INNAME AND ~INTAPEFLAG THEN BEGIN 0362 R2:=INTAPE; REWIND; SET(INTAPEFLAG); 0363 END; 0364 IF OUTNAME OR TEMP THEN IF ~OUTTAPEFLAG THEN BEGIN 0365 R2:=OUTTAPE; REWIND; R0:=0; OUTCHAIN:=R0; SET(OUTTAPEFLAG); 0366 END; 0367 IF PROGNAME AND ~PROGFLAG THEN BEGIN 0368 R2:=PROGTAPE; REWIND; R0:=@DUMIPL; R1:=84; WRITETAPE; 0369 MVC(3,PROGCHAIN,DISKADR); MARKTAPE; SET(PROGFLAG); 0370 END; 0371 IF INNAME THEN BEGIN COMMENT FIND SOURCE; 0372 SET(LOOKING); WHILE LOOKING DO BEGIN 0373 XC(3,CHAINBUFF(80),CHAINBUFF(80)); 0374 R0:=@CHAINBUFF; R1:=84; R2:=INTAPE; READTAPE; 0375 IF ~= THEN BEGIN COMMENT OOPS, END OF FILE; 0376 MVC(131,WBUF,BLANK); MVC(11,WBUF,"**CAN'T FIND"); 0377 MVC(7,WBUF(13),CCARD(20)); R0:=@WBUF; WRITE; 0378 REWIND; RESET(INTAPEFLAG); SET(EXITFLAG); SET(EOF); 0379 ERROREXIT; 0380 END; 0381 MVC(3,CHAIN,CHAINBUFF(80)); CLC(7,CHAINBUFF,CCARD(20)); 0382 IF = THEN RESET(LOOKING) ELSE COMMENT SHOULD COPY MAYBE; 0383 IF ~OUTNAME AND PROGNAME THEN FSPTM ELSE BEGIN 0384 MVC(131,WBUF,BLANK); MVC(7,WBUF,"**COPIED"); 0385 MVC(79,WBUF(12),CHAINBUFF); R0:=@WBUF; WRITE; 0386 MVC(131,WBUF,BLANK); WRITE; 0387 XC(3,CHAINBUFF(80),CHAINBUFF(80)); 0388 R0:=@CHAINBUFF; R1:=84; R2:=OUTTAPE; WRITETAPE; 0389 MVC(3,CHAIN,OUTCHAIN); CHAINDISK; 0390 MVC(3,OUTCHAIN,CHAIN); COPYSOURCE; 0391 END; 0392 END; 0393 MVC(131,WBUF,BLANK); MVC(79,WBUF(12),CHAINBUFF); 0394 END; 0395 IF OUTNAME THEN BEGIN COMMENT MAKE NEW HEADER; 0396 MVC(79,CHAINBUFF,BLANK); XC(3,CHAINBUFF(80),CHAINBUFF(80)); 0397 MVC(7,CHAINBUFF,CCARD(30)); R0:=@CHAINBUFF(10); GETDATE; 0398 MVC(9,CHAINBUFF(20),"VERSION 01"); 0399 IF INAME THEN BEGIN COMMENT SHOW UPDATE; 0400 CLC(7,CCARD(20),CCARD(30)); IF = AND PROGNAME THEN BEGIN 0401 CLC(1,WBUF(40)," "); IF ~= THEN BEGIN 0402 PACK(7,1,CONWORK,WBUF(40)); CVB(R0,CONWORK); 0403 R0:=R0+1; CVD(R0,CONWORK); 0404 UNPK(1,7,CHAINBUFF(28),CONWORK); 0405 SETZONE(CHAINBUFF(29)); 0406 END ELSE MVC(1,CHAINBUFF(28),"01"); 0407 END; 0408 CLC(7,CCARD(20),CCARD(30)); IF ~= OR PROGNAME THEN BEGIN 0409 MVC(9,CHAINUFF(32),"(PREVIOUS:"); 0410 MVC(29,CHAINBUFF(43),WBUF(12)); 0411 MVI(")",CHAINBUFF(73)); MVC(79,WBUF(12),CHAINBUFF); 0412 END; 0413 END ELSE BEGIN 0414 MVC(131,WBUF,BLANK); MVC(79,WBUF(12),CHAINBUFF); 0415 END; 0416 R0:=@CHAINBUFF; R1:=84; R2:=OUTTAPE; WRITETAPE; 0417 MVC(3,CHAIN,OUTCHAIN); CHAINDISK; MVC(3,OUTCHAIN,CHAIN); 0418 IF PROGNAME THEN BEGIN 0419 MVC(9,WBUF,"**COMPILED"); CLC(7,CCARD(30),CCARD(40)); 0420 IF ~= THEN BEGIN 0421 CLI("(",WBUF(44)); 0422 IF = THEN R1:=@WBUF(88) ELSE R1:=@WBUF(44); 0423 MVC(7,B1,"(OBJECT:"); MVC(7,B1(9),CCARD(40)); 0424 MVI(")",B1(17)); 0425 END; 0426 END ELSE IF INNAME THEN MVC(7,WBUF,"**COPIED") ELSE 0427 MVC(8,WBUF,"**CREATED"); 0428 R0:=@WBUF; WRITE; 0429 END; 0430 IF PROGNAME THEN BEGIN COMMENT MAKE PROGRAM HEADER; 0431 MVC(79,CHAINBUFF,BLANK); XC(3,CHAINBUFF(80),CHAINBUFF(80)); 0432 MVC(7,CHAINBUFF,CCARD(40)); R0:=@CHAINBUFF(10); GETDATE; 0433 IF INNAME OR OUTNAME THEN BEGIN 0434 MVC(7,CHAINBUFF(20),"(SOURCE:"); 0435 MVC(29,CHAINBUFF(29),WBUF(121)); MVI(")",CHAINBUFF(59)); 0436 END; 0437 IF ~OUTNAME THEN BEGIN 0438 MVC(131,WBUF,BLANK); MVC(9,WBUF,"**COMPILED"); 0439 MVC(79,WBUF(12),CHAINBUFF); R0:=@WBUF; WRITE; 0440 END; 0441 MVC(7,CHAINBUFF(1),CCARD(40)); MVI(" ",CHAINBUFF); 0442 R0:=@CHAINBUFF; R1:=84; R2:=PROGTAPE; WRITETAPE; 0443 MVC(3,CHAIN,PROGCHAIN); CHAINDISK; MVC(3,PROGCHAIN,CHAIN); 0444 END; 0445 IF INNAME AND ~OUTNAME AND ~PROGNAME THEN BEGIN COMMENT DELETE; 0446 MVC(8,WBUF,"**DELETED"); R0:=@WBUF; WRITE; 0447 R2:=INTAPE; FSPTM; SET(TEMP); 0448 END ELSE 0449 IF INNAME AND OUTNAME AND ~PROGNAME THEN BEGIN 0450 COPYSOURCE; SET(TEMP); 0451 END ELSE 0452 IF ~INNAME AND OUTNAME AND ~PROGNAME THEN BEGIN COMMENT CREATE; 0453 R0:=@CBUF; READ; IF ~= THEN BEGIN 0454 IF < THEN SET(EXITFLAG); SET(EOF); MVC(131,WBUF,BLANK); 0455 MVC(16,WBUF,"**NO SOURCE CARDS"); R0:=@WBUF; WRITE; 0456 END; 0457 WHILE ~EOF DO BEGIN 0458 PUTRECORD; R0:=@CBUF; READ; 0459 IF ~= THEN BEGIN 0460 IF < THEN SET(EXITFLAG); SET(EOF); 0461 END; 0462 END; 0463 PUTRECORD; RESET(EOF); R0:=0; LINENO:=R0; 0464 MVC(79,CCARD,CBUF); RESET(TEMP); 0465 END ELSE RESET(FIRSTCARD); 0466 IF FIRSTCARD AND TEMP THEN BEGIN COMMENT GET CONTROL CARD; 0467 R0:=@CCARD; READ; IF = THEN BEGIN 0468 MVC(131,WBUF,BLANK); 0469 MVC(21,WBUF,"**CONTROL CARD MISSING"); 0470 R0:=@WBUF; WRITE; SET(EXITFLAG); SET(EOF); 0471 END ELSE IF < THEN BEGIN 0472 SET(EXITFLAG); SET(EOF); 0473 END; 0474 END; 0475 MVC(131,WBUF,BLANK); R0:=@WBUF; WRITE; 0476 IF EXITFLAG THEN ERROREXIT; RESET(TEMP); RESET(TAPERECORD); 0477 CLC(5,CCARD(50),"NOLIST"); 0478 IF = AND ~FIRSTCARD THEN RESET(LISTFLAG); 0479 MVI("1",PAGECTL); CLC(7,CCARD(50),"FILELIST"); 0480 IF = AND ~FIRSTCARD THEN BEGIN 0481 SET(TAPEPRINT); IF ~PRINTOPEN THEN BEGIN 0482 SET(PRINTOPEN); R2:=8; REWIND; 0483 END; 0484 END; 0485 END; 0486 IF ~INNAME THEN BEGIN COMMENT JUST CARD INPUT; 0487 R0:=@CBUF; READ; IF ~= THEN BEGIN 0488 IF < THEN SET(EXITFLAG); SET(EOF); MVC(79,CCARD,CBUF); 0489 END; 0490 PUTRECORD; RESET(LISTOLDSEQ); 0491 END ELSE BEGIN COMMENT FINEST KIND UPDATE STUFF; 0492 SET(LOOKING); WHILE LOOKING DO BEGIN 0493 IF ~TAPERECORD THEN BEGIN COMMENT GET A CARD; 0494 R0:=@CBUF; READ; IF ~= THEN BEGIN 0495 IF < THEN SET(EXITFLAG); MVC(79,CCARD,CBUF); 0496 SET(TEMP); SET(TAPERECORD); 0497 END ELSE BEGIN COMMENT WHAT FLAVOR CARD IS IT; 0498 CLC(1,CBUF,"$$"); IF = THEN BEGIN COMMENT UPDATE; 0499 R6:=2; GETNUMBER; IF R0 = " " THEN BEGIN 0500 GOAL:=R1; R1:=_1; DELETE:=R1; 0501 END ELSE IF R0 = "," THEN BEGIN 0502 GOAL:=R1; GETNUMBER; DELETE:=R1; 0503 END; 0504 IF R0 = "?" THEN BEGIN 0505 MVC(131,WBUF,BLANK); R0:=@WBUF; WRITE; 0506 MVC(28,WBUF,"**UPDATE CARD FORMAT ERROR --"); 0507 MVC(79,WBUF(30),CBUF); WRITE; 0508 MVC(131,WBUF,BLANK); WRITE; 0509 END ELSE BEGIN 0510 R1:=DELETE; IF R1 >=0 AND R1 < GOAL THEN BEGIN 0511 MVC(131,WBUF,BLANK); R0:=@WBUF; WRITE; 0512 MVC(22,WBUF,"**UPDATE SEQ1 > SEQ2 --"); 0513 MVC(79,WBUF(24),CBUF); WRITE; 0514 MVC(131,WBUF,BLANK); WRITE; 0515 END ELSE BEGIN 0516 R1:=INLINE; IF R1 >= GOAL THEN BEGIN 0517 MVC(131,WBUF,BLANK); R0:=@WBUF; WRITE; 0518 MVC(25,WBUF,"**UPDATE SEQ1 <= LINENO --"); 0519 MVC(79,WBUF(27),CBUF); WRITE; 0520 MVC(131,WBUF,BLANK); WRITE; 0521 END ELSE SET(TAPERECORD); 0522 END; 0523 END; 0524 END ELSE BEGIN 0525 PUTRECORD; RESET(LOOKING); RESET(LISTOLDSEQ); 0526 END; 0527 END; 0528 END ELSE BEGIN COMMENT PLAY GAMES WITH TAPE; 0529 IF TEMP THEN BEGIN COMMENT NO MORE UPDATES; 0530 GETRECORD; PUTRECORD; RESET(LOOKING); 0531 END ELSE BEGIN 0532 GETRECORD; IF EOF THEN BEGIN COMMENT OOPS AGAIN; 0533 MVC(131,WBUF,BLANK); R0:=@WBUF; WRITE; 0534 MVC(29,WBUF,"**UPDATE SEQ1 XXXX NOT IN FILE"); 0535 R0:=GOAL; CVD(R0,CONWORK); 0536 UNPK(3,7,WBUF(14),CONWORK ; SETZONE(WBUF(17)); 0537 WRITE; MVC(131,WBUF,BLANK); WRITE; 0538 RESET(LOOKING); PUTRECORD; 0539 END ELSE BEGIN 0540 R1:=GOAL; IF R1 > INLINE THEN BEGIN 0541 PUTRECORD; RESET(LOOKING); 0542 END ELSE BEGIN COMMENT DO WE DELETE STUFF; 0543 R1:=DELETE; IF R1 = _1 THEN BEGIN 0544 PUTRECORD; RESET(LOOKING); RESET(TAPERECORD); 0545 END ELSE BEGIN 0546 WHILE R1 > INLINE DO BEGIN 0547 GETRECORD; IF EOF THEN BEGIN 0548 MVC(131,WBUF,BLANK); R0:=@WBUF; WRITE; 0549 MVC(29,WBUF, 0550 "**UPDATE SEQ2 NOT IN FILE"); 0551 R0:=DELETE; CVD(R0,CONWORK); 0552 UNPK(3,7,WBUF(14),CONWORK); 0553 SETZONE(WBUF(17)); WRITE; 0554 MVC(131,WBUF,BLANK); WRITE; 0555 PUTRECORD; RESET(LOOKING); R1:=INLINE; 0556 END ELSE R1:=DELETE; 0557 END; 0558 RESET(TAPERECORD); 0559 END; 0560 END; 0561 END; 0562 END; 0563 END; 0564 END; 0565 END; 0566 LM(R3,R7,SAVE); 0567 END; 0568 0569 PROCEDURE OUTPUTCARD(R1); 0570 BEGIN INTEGER SAVER1; SAVER1:=R1; 0571 R0:=CSEGNO; CVD(R0,CONWORK); UNPK(1,7,WBUF,CONWORK); 0572 UNPK(4,4,WBUF(3).LC); TR(3,WBUF(3),TRTABLE(_240)); 0573 SETZONE(WBUF(1)); MVI(" ",WBUF(7)); R1:=DSEG; R0:=DSEGTBL(R1) ; 0574 CVD(R0,CONWORK); UNPK(1,7,WBUF(10),CONWORK); SETZONE(WBUF(11)); 0575 UNPK(4,4,WBUF(13),DC); TR(3,WBUF(13),TRTABLE(_240)); 0576 MVI(" ",WBUF(17)); R0:=LINENO; CVD(R0,CONWORK); 0577 UNPK(3,7,WBUF(28),CONWORK); SETZONE(WBUF(31)); 0578 IF LISTOLDSEQ THEN BEGIN 0579 R0:=INLINE; CVD(R0,CONWORK); UNPK(3,7,WBUF(21),CONWORK); 0580 SETZONE(WBUF(24)); 0581 END ELSE MVC(3,WBUF(21),BLANK); 0582 MVC(79,WBUF(35),CBUF); R1:=BLOCKLEVEL SHLL 2; R0:=LINETABLE(R1) ; 0583 CVD(R0,CONWORK); UNPK(3,7,WBUF(124),CONWORK); SETZONE(WBUF(127)); 0584 R0:=BLOCKLEVEL; CVD(R0,CONWORK); UNPK(1,7,WBUF(120),CONWORK); 0585 SETZONE(WBUF(121)); R0:=@WBUF; WRITE; R1:=SAVER1; 0586 END; 0587 PROCEDURE ERROR(R4); 0588 BEGIN ARRAY 8 BYTE ERRMESS =("ERROR NO"); 0589 ARRAY 464 BYTE ERRORCODE= 0590 ("00 SYNTAX ","01 VAR ASS TYPES","02 FOR PARAMETER", 0591 "03 REG ASS TYPES","04 BIN OP TYPES ","05 SHIFT OP " 0592 "06 COMPARE TYPES","07 REG TYPE OR #","08 UNDEFINED ID ", 0593 "09 MULT LAB DEF ","10 EXC INI VALUE","11 NOT INDEXABLE", 0594 "12 DATA OVERFLOW","13 NO OF ARGS ","14 ILLEGAL CHAR ", 0595 "15 MULTIPLE ID ","16 PROGRAM OFLOW","17 INITIAL OFLOW", 0596 "18 ADDRESS OFLOW","19 NUMBER OFLOW ","20 MISSING . ", 0597 "21 STRING LENGTH","22 AND/OR MIX ","23 FUNC DEF NO. ", 0598 "24 ILLEGAL PARAM","25 NUMBER ","26 SYN MIX ", 0599 "27 ILLEGAL GOTO ","28 ILLEGAL LABEL"); 0600 ARRAY 3 INTEGER ERRSAVE; STM(R0,R2,ERRSAVE); 0601 IF ~LISTFLAG AND ~EOF THEN OUTPUTCARD; MVC(131,WBUF,BLANK); 0602 R2:= XR SHLL 4; R1 := @ERRORCODE(R2); MVC(15,WBUF(1),B1); 0603 MVC(7,WBUF(2),ERRMESS); R1:=@WBUF(R6+35); MVI("|",B1); 0604 MVI("*",WBUF(108)); MVC(9,WBUF(109),WBUF(108)); 0605 R0 := @WBUF; WRITE; MVC(131,WBUF,BLANK); 0606 R0 := ERRORCOUNT+1; ERRCOUNT := R0; 0607 IF R0 > ERRLIMIT AND XR ~= 20 THEN 0608 BEGIN MVC(38,WBUF,"*** ANALYSIS TERMINATED BY ERROR COUNT "); 0609 R0 := @WBUF; WRITE; MVC(38,WBUF,BLANK); WRITE; 0610 L: INPUTCARD; IF ~ EOF THEN 0611 BEGIN IF LISTFLAG THEN OUTPUTCARD; GOTO L; 0612 END; GOTO EXIT; 0613 END; 0614 LM(R0,R2,ERRSAVE); RESET (RUNFLAG); 0615 END; 0616 PROCEDURE LABELERROR(R3); COMMENT PRINTS OUT UNDEFINED LABELS; 0617 BEGIN ARRAY 9 BYTE LABELCODE = ("UNDEF LAB"); 0618 INTEGER TEMP, SAVE; MVC(131,WBUF,BLANK); SAVE:=R0; 0619 R2:= R1 + LABELBASE; MVC(9,WBUF(8),LABEL(R2)); 0620 MVC(8,WBUF(19),LABELCODE); RESET(RUNFLAG); 0621 R0 := CSEGNO; CVD(R0,CONWORK); 0622 UNPK(1,7,WBUF,CONWORK); SETZONE(WBUF(1)); 0623 MVI("*",WBUF(108)); MVC(15,WBUF(109),WBUF(108)); 0624 R2 := LABELADR(R2) AND #7FFF; WHILE R2 ~= ENDCHAIN DO 0625 BEGIN TEMP := R2; UNPK(4,4,WBUF(3),TEMP); MVI(" " ),WBUF(7)); 0626 TR(3,WBUF(3),TRTABLE(_240)); R0 := @WBUF; WRITE; 0627 R2 := PROGRAM(R2+2); R0:= ERRCOUNT + 1; ERRCOUNT := R0; 0628 END; 0629 MVC(131,WBUF,BLANK); R0 := SAVE; 0630 END; 0631 PROCEDURE EDIT (R8); 0632 BEGIN R1 := LC; PROGRAM(R1) := R0; R1 := R1+2; LC := R1; 0633 END; 0634 PROCEDURE EMIT (R8); 0635 BEGIN R0 := R0 SHLL 4 OR R1 SHLL 4 OR R2 SHLL 4 OR R3; 0636 R1 := LC; PROGRAM(R1) := R0; R1 := R1+2; LC := R1; 0637 END; 0638 PROCEDURE EMYT (R8); 0639 BEGIN R0 := R0 SHLL 4 OR R1 SHLL 4 OR R2 SHLL 20 OR R3; 0640 R1 := LC; PROGRAM(R1+2) := R0; R0 := R0 SHRL 16; 0641 PROGRAM(R1) := R0; R1 := R1+4; LC := R1; 0642 END; 0643 PROCEDURE EMYTBRANCH(R8); 0644 BEGIN R0 := R0 OR #4700; R1 := LC; PROGRAM(R1) := R0; 0645 V(R7) := R1; R1 := R1 + 4; LC := R1; 0646 END; 0647 PROCEDURE ANDTORCHAIN(R4); 0648 BEGIN INTEGER ANDCHAIN SYN MEM(R3), ORCHAIN SYN MEM(R3+4); 0649 R1 := ANDCHAIN; R2 := PROGRAM(R1+2); ANDCHAIN := R2; 0650 R2 := PROGRAM(R1) XOR #F0; PROGRAM(R1) := R2; 0651 R2 := ORCHAIN; PROGRAM(R1+2) := R2; ORCHAIN := R1; 0652 END; 0653 PROCEDURE CHAINFIXUP(R4); 0654 WHILE R1 ~= ENDCHAIN DO 0655 BEGIN R2 := PROGRAM(R1+2); PROGRAM(R1+2) := R0; R1 := R2; 0656 END; 0657 PROCEDURE ENTERBRANCH(R8); 0658 BEGIN COMMENT R1 = ADDRESS OF START OF BRANCH CHAIN, 0659 R2 = LABEL ID; 0660 R5 := N4 + LABELBASE; 0661 FOR R4 := N3 + LABELBASE STEP _12 UNTIL R5 DO 0662 BEGIN CLC(9,B2,LABEL(R4)); IF = THEN 0663 BEGIN R3 := LABELADR(R4) AND #7FFF; IF R3 = LABELADR(R4) THEN 0664 BEGIN R3 := R3 + PTAG; WHILE R1 ~= ENDCHAIN DO 0665 BEGIN R0 := PROGRAM(R1+2); PROGRAM(R1+2) :=R3; 0666 R1 := R0; 0667 END; 0668 END ELSE 0669 BEGIN R0 := R1 OR #8000; LABELADR(R4) := R0; 0670 R0 := ENDCHAIN; 0671 WHILE R0 ~= PROGRAM(R1+2) DO R1 := PROGRAM(R1+2); 0672 PROGRAM(R1+2) := R3; 0673 END; 0674 GOTO L; 0675 END; 0676 END; 0677 R4 := N3 + 12; N3 := R4; R4 := R4 + LABELBASE; 0678 MVC(9,LABEL(R4),B2); R1 := R1 OR #8000; LABELADR(R4) := R1; 0679 L: END; 0680 PROCEDURE ENTERNAME(R8); 0681 BEGIN R5 := 0; IC(R5,B1); IC(R5,ALPHASH(R5-193)); 0682 R3 := R3 + 1 AND #E; 0683 R5 := R5 + LENHASH(R3-2); R3 := R3 - 1; R4 := HASHCHAIN(R5); 0684 WHILE R4 >= N2 DO 0685 BEGIN R4 := R4 + NAMEBASE; EX(R3,NAMECOMP); IF = THEN 0686 BEGIN XR := 15; ERROR; R4 := N1 + NAMEBASE; GOTO X; 0687 END; R4 := LINK(R4); 0688 END; 0689 R4 := N1 + NAMEBASE; EX(R3,NAMEMOVE); TYPE(R4) := R2; 0690 ADR(R4+2) := R0; R0 := R0 SHRL 16; ADR(R4) := R0; 0691 R0 := HASHCHAIN(R5); LINK(R4) := R0; 0692 R0 := N1; HASHCHAIN(R5) := R0; R0 := R0 + R3 +9; N1 := R0; 0693 X: END; 0694 PROCEDURE EMITLIT (R4); COMMENT USED BY FOR STATEMENT; 0695 BEGIN INTEGER TEMP; TEMP := R5; R0 := 5; R3 := 0; EMIT; 0696 R1 := LITX; R3 := R1 + LITBASE; R1 := R1 + 8; LITX := R1; 0697 MVI(2,B3); MVI(3,B3(1)); MVC(1,B3(2),LC(2)); 0698 MVC(3,B3(4),TEMP); R0 := LC + 2; LC := R0; 0699 END; 0700 PROCEDURE MAKELITERAL(R4); 0701 BEGIN COMMENT R0 = TYPE, R1 = LENGTH, R2 = FIXUP ADDRESS, 0702 R3 = ADDRESS OF FIRST BYTE IF NOT SHORT INTEGER TYPE 1 0703 OR ADDRESS - 2 IF SHORT INTEGER; 0704 ARRAY 3 SHORT INTEGER MOVER1=(#D200,@B2(4),@B3(2)), 0705 MOVER2=(#D200,@B2(4),@B3); 0706 SHORT INTEGER ADDRESS; ADDRESS := R2; 0707 R2 := LITX + LITBASE; STC(R0,B2); STC(R1,B2(1)); 0708 MVC(1,B2(2),ADDRESS); CLI(1,B2); IF = THEN 0709 EX(R1,MOVER1 )ELSE EX(R1,MOVER2); 0710 R2 := @B2(R1+5) - LITBASE; LITX := R2; 0711 END; 0712 PROCEDURE HEX(R6); 0713 BEGIN ARRAY 2 INTEGER TEMP; 0714 TEMP( 4):= R1; UNPK(4,2,TEMP,TEMP(6)); 0715 TR(3,TEMP,TRTABLE(_240)); R0 := TEMP; 0716 END; 0717 PROCEDURE CLEARDATA(R8); COMMENT ZERO THE DATA AREA; 0718 BEGIN R1 := DATABASE; R2 := DCMAX - 1 + R1; 0719 IF R1 <= R2 THEN MVI(0,B1); 0720 FOR R1 := R1 STEP 256 UNTIL R2 DO MVC(255,B1(1),B1); 0721 END; 0722 0723 SEGMENT PROCEDURE ARGUMENT(R8); 0724 BEGIN R0 := V(R7); SRDL(R0,4); V(R7) := R0; R1 := R1 SHRL 28; 0725 R0 := V1(R7); R3 := T(R7+16); 0726 IF R1 = 0 THEN BEGIN XR := 13; ERROR; END ELSE 0727 CASE R1 OF BEGIN 0728 BEGIN COMMENT PAR 1 -- REGISTER -- BITS 8-11; 0729 IF R2 ~= 4 THEN BEGIN XR := 24; ERROR; END; 0730 R0 := R0 AND #F SHLL 4 OR FUNC0; FUNC0 := R0; 0731 END; 0732 BEGIN COMMENT PAR 2 -- NUMBER -- BITS 8-11; 0733 IF R2 = 2 THEN IF R3 < 2 THEN IF R0 < 16 THEN 0734 IF R0 >= 0 THEN GOTO X; XR := 24; ERROR; 0735 X: R0 := R0 AND #F SHLL 4 OR FUNC0; FUNC0 := R0; 0736 END; 0737 BEGIN COMMENT PAR 3 -- REGISTER -- BITS 12-15; 0738 IF R2 ~= 4 THEN BEGIN XR := 24; ERROR; END; 0739 R0 := R0 AND #F OR FUNC0; FUNC0 := R0; 0740 END; 0741 BEGIN COMMENT PAR 4 -- NUMBER -- BITS 12-15; 0742 IF R2 = 2 THEN IF R3 < 2 THEN IF R0 < 16 THEN 0743 IF R0 >= 0 THEN GOTO X; XR := 24; ERROR; 0744 X: R0 := R0 AND #F OR FUNC0; FUNC0 := R0; 0745 END; 0746 BEGIN COMMENT PAR 5 -- NUMBER STRING VARIABLE -- BITS 8-15; 0747 CASE R2 OF BEGIN 0748 BEGIN IF R0 > 255 THEN BEGIN XR := 24; ERROR; END; 0749 END; 0750 BEGIN IF R3 < 2 THEN IF R0 < 256 THEN 0751 IF R0 >= 0 THEN GOTO X; XR := 24; ERROR; 0752 X: END; 0753 BEGIN IF R0 ~= 1 THEN BEGIN XR:= 21; ERROR; END; 0754 IC(R0,STRINGV); 0755 END; 0756 BEGIN XR := 24; ERROR; 0757 END; 0758 END; STC(R0,FUNC0(3)); 0759 END; 0760 BEGIN COMMENT PAR 6 -- NUMBER STRING VARIABLE -- BITS 12-31; 0761 CASE R2 OF BEGIN 0762 NULL; 0763 BEGIN IF R3 < 2 THEN IF R0 < 4096 THEN 0764 IF R0 >= 0 THEN GOTO X; XR := 24; ERROR; 0765 X: END; 0766 BEGIN IF R0 ~= 1 THEN BEGIN XR := 21; ERROR; END; 0767 IC(R0,STRINGV); 0768 END; 0769 BEGIN XR := 24; ERROR; 0770 END; 0771 END; FUNC1 := R0; R0 := R0 SHRL 16 AND # F OR FUNC0; 0772 FUNC0 := R0; 0773 END; 0774 BEGIN COMMENT PAR 7 -- LITERAL VARIABLE -- BITS 12-31; 0775 CASE R2 OF BEGIN 0776 NULL; 0777 BEGIN IC(R2,LENGTH(R3)); R1 := 1 SHLL R2 - 1; 0778 R0 := R2; R2 := LC + 2; R3 := @V1(R7); 0779 MAKELITERAL; 0780 END; 0781 BEGIN R1 := R0 - 1; R0 := 0; R2 := LC + 2; 0782 R3 := @STRINGV; MAKELITERAL; 0783 END; 0784 BEGIN XR := 24; ERROR; 0785 END; 0786 END; FUNC1 := R0; R0 := R0 SHRL 16 AND #F OR FUNC0; 0787 FUNC0 := R0; 0788 END; 0789 BEGIN COMMENT PAR 8 -- VARIABLE -- BITS 12-31; 0790 IF R2 ~= 1 THEN BEGIN XR := 24; ERROR; END; FUNC1 := R0; 0791 R0 := R0 SHRL 16 AND #F OR FUNC0; FUNC0 := R0; 0792 END; 0793 BEGIN COMMENT PAR 9 -- NUMBER VARIABLE -- BITS 16-31; 0794 CASE R2 OF BEGIN 0795 IF R0 > #FFFF THEN BEGIN XR := 11; ERROR; END; 0796 BEGIN IF R3 < 2 THEN IF R0 < 4096 THEN 0797 IF R0 >= 0 THEN GOTO X; XR:=24; ERROR; 0798 X: END; 0799 BEGIN XR := 24; ERROR; 0800 END; 0801 BEGIN XR := 24; ERROR; 0802 END; 0803 END; FUNC1 := R0; 0804 END; 0805 BEGIN COMMENT PAR 10 -- LITERAL VARIABLE -- BITS 16-31; 0806 CASE R2 OF BEGIN 0807 IF R0 > #FFFF THEN BEGIN XR := 11; ERROR; END; 0808 BEGIN IC(R2,LENGTH(R3)); R1 := 1 SHLL R2 - 11; 0809 R0 := R2; R2 := LC + 2; R3 := @V1(R7); 0810 MAKELITERAL; 0811 END; 0812 BEGIN R1 := R0 - 1; R0 := 0; R2 := LC + 2; 0813 R3 := @STRINGV; MAKELITERAL; 0814 END; 0815 BEGIN XR := 24; ERROR; 0816 END; 0817 END; FUNC1 := R0; 0818 END; 0819 BEGIN PAR 11 -- VARIABLE -- BITS 16-31; 0820 IF R2 ~= 1 THEN BEGIN XR := 24; ERROR; END ELSE 0821 IF R0 > #FFFF THEN BEGIN XR := 11; ERROR; END; 0822 FUNC1 := R0; 0823 END; 0824 BEGIN COMMENT PAR 12 -- LITERAL VARIABLE -- BITS 32-47; 0825 CASE R2 OF BEGIN 0826 IF R0 > #FFFF THEN BEGIN XR := 11; ERROR; END; 0827 BEGIN IC(R2,LENGTH(R3)); R1 := 1 SHLL R2 -1; 0828 R0 := R2; R2 := LC + 4; R3 := @V1(R7); 0829 MAKELITERAL; 0830 END; 0831 BEGIN R1 := R0 - 1; R0 := 0; R2 := LC + 4; 0832 R3 := @STRINGV; MAKELITERAL; 0833 END; 0834 BEGIN XR := 24; ERROR; 0835 END; 0836 END; FUNC2 := R0; 0837 END; 0838 END ; 0839 END ; 0840 0841 PROCEDURE ALLOCATELITERALS(R8); 0842 BEGIN COMMENT R4 := LC IS A PARAMETER; 0843 ARRAY 3 INTEGER TEMP; INTEGER LITEND; 0844 ARRAY 3 SHORT INTEGER COMPARE=(#D500,#5004,#6004), 0845 MOVER=(#D200,#5000,#6004); SHORT INTEGER ADDRESS; 0846 PROCEDURE ALLTYPE(R8); 0847 BEGIN COMMENT R0 = LENGTH AND R4 = LC ARE PARAMETERS -- 0848 R7 = START OF LITERALS -- LITEND = END OF LITERALS; 0849 R6 := R7; WHILE R6 < LITEND DO (Message over 64 KB, truncated)

Post Reply

Who is online

Users browsing this forum: No registered users and 0 guests