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)
compilerource
-
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 ???
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
] On Behalf Of kerravon86> -----Original Message----- > From: hercules-390@yahoogroups.com > [mailto:hercules-390@yahoogroups.com
, "Dave Wade" wrote:> 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
> > > > 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
> Subscribe: hercules-390-subscribe@yahoogroups.com
> Unsubscribe: hercules-390-unsubscribe@yahoogroups.com
> List owner: hercules-390-owner@yahoogroups.com
http://groups.yahoo.com/group/hercules-390>> > Files and archives at: > 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 ???
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:
________________________________
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:
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> Which version of ctci-w32 will work with > Winpcap 4.1.1 ??? > > The version on fishes web page is 3.2.1.160 ??
-
rhtatum
compilerource
%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)
Who is online
Users browsing this forum: No registered users and 1 guest