/*

          ****  PAS80  ****

          SEQUENTIAL PASCAL

     VIRTUAL MACHINE IMPLEMENTATION

         FOR THE INTEL 8080A


       VM01-00      19-JAN-77

         THOMAS A. ROLANDER

*/

PAS80:

DO;

DECLARE
	ST(16000) BYTE,
	ST$ADR(8000) ADDRESS AT (.ST),
	VMI(17920) BYTE,
	VMI$ADR(8960) ADDRESS AT (.VMI),

	HEAD(18) ADDRESS,
	HEAPTO	ADDRESS AT (.HEAD+2 ),
	LINE	ADDRESS AT (.HEAD+4 ),
	RESULT	ADDRESS AT (.HEAD+6 ),
	JOB	    ADDRESS AT (.HEAD+8 ),
	CONT	ADDRESS AT (.HEAD+10),
	OPCODE	ADDRESS AT (.HEAD+12),
	ARG1	ADDRESS AT (.HEAD+14),
	ARG2	ADDRESS AT (.HEAD+16),
	ARG3	ADDRESS AT (.HEAD+18),
	ARG4	ADDRESS AT (.HEAD+20),
	OPLINE	ADDRESS AT (.HEAD+22),
	CONST	ADDRESS AT (.HEAD+24),

	TERMINATED BYTE AT (.RESULT),

	S ADDRESS,
	(STS BASED S) ADDRESS,
	(S$BYT BASED S) BYTE,
	Q ADDRESS,
	(STQ BASED Q) ADDRESS,
	(Q$BYT BASED Q) BYTE,
	G ADDRESS,
	(STG BASED G) ADDRESS,
	(G$BYT BASED G) BYTE,
	B ADDRESS,
	(STB BASED B) ADDRESS,
	(B$BYT BASED B) BYTE,
	Y ADDRESS,
	(STY BASED Y) ADDRESS,
	(Y$BYT BASED Y) BYTE,
	X ADDRESS,
	(STX BASED X) ADDRESS,
	(X$BYT BASED X) BYTE,
	W ADDRESS,
	(STW BASED W) ADDRESS,
	(W$BYT BASED W) BYTE,

	(I,J,TEMP,CH) BYTE,
	SEQCODE$FILE(12) BYTE,
	CSL(80) BYTE,
	CSL$ADR(40) ADDRESS AT (.CSL),
	CSL$PTR BYTE,
	FILE$OPEN(5) BYTE,
	NXT$BLK(5) ADDRESS,
	FILE$AFTNPTR(5) ADDRESS,
	(READ$FILE,WRITE$FILE) ADDRESS,
	(READ$COUNT,WRITE$COUNT) ADDRESS,
	(READ$PTR,WRITE$PTR) BYTE,
	READ$BUFFER(256) BYTE,
	WRITE$BUFFER(256) BYTE,
	(COUNT,STATUS,SEQ$CODE) ADDRESS,
	MORE$JOBS BYTE,
	RUNNING$PASCAL BYTE,
	BOOLTYPE LITERALLY '1',
	IDTYPE LITERALLY '3',
	CR LITERALLY '0DH',
	LF LITERALLY '0AH',
	CRLF LITERALLY 'CR,LF',
	TRUE LITERALLY '0FFH',
	FALSE LITERALLY '00H',
	TITLE(*) BYTE INITIAL ('PAS80  VM01-00'),
	ARGLIST(36) ADDRESS INITIAL (	BOOLTYPE,0,0,0,0,0,0,0,0,
					IDTYPE,'                ',
					IDTYPE,'                ',
					IDTYPE,'                '),
	TEXT(*) BYTE INITIAL (	'TERMINATED      ',
				'OVERFLOW        ',
				'POINTERERROR    ',
				'RANGERROR       ',
				'VARIANTERROR    ',
				'HEAPLIMIT       ',
				'STACKLIMIT      ',
				'CODELIMIT       ',
				'TIMELIMIT       ',
				'CALLERROR       ',
				'PROCERROR       ',
				'LOADERROR       ',
				'OPENERROR       ',
				'FILENAMERROR    '),
	OVERFLOW     LITERALLY '1',
	POINTERERROR LITERALLY '2',
	RANGERROR    LITERALLY '3',
	VARIANTERROR LITERALLY '4',
	HEAPLIMIT    LITERALLY '5',
	STACKLIMIT   LITERALLY '6',
	CODELIMIT    LITERALLY '7',
	TIMELIMIT    LITERALLY '8',
	CALLERROR    LITERALLY '9',
	PROCERROR    LITERALLY '10',
	LOADERROR    LITERALLY '11',
	OPENERROR    LITERALLY '12',
	FILENAMERROR LITERALLY '13',

	TEN$TABLE(5) ADDRESS INITIAL (10000,1000,100,10,1);

$INCLUDE (:F1:ISISIO.PLM)


MESSAGE: PROCEDURE (STRING$ADR,COUNT);
   DECLARE
	STRING$ADR ADDRESS,
	(COUNT,I) BYTE,
	(STRING BASED STRING$ADR) (1) BYTE;

   DO I = 0 TO COUNT-1;
      CALL CO(STRING(I));
   END;
END MESSAGE;


PRINT$ADR: PROCEDURE (VAL);
   DECLARE
	VAL ADDRESS,
	(I,BCD) BYTE;

   DO I = 0 TO 4;
      BCD = 0;
      DO WHILE VAL >= TEN$TABLE(I);
         VAL = VAL - TEN$TABLE(I);
         BCD = BCD + 1;
      END;
      CALL CO (BCD+'0');
   END;
END PRINT$ADR;


SKIP$BLANKS: PROCEDURE;
   DO WHILE CSL(CSL$PTR) = ' ';
      CSL$PTR=CSL$PTR+1;
   END;
END SKIP$BLANKS;

SKIP$CHAR: PROCEDURE (CHAR);
   DECLARE CHAR BYTE;

   CALL SKIP$BLANKS;
   IF CSL(CSL$PTR) <> CHAR THEN
      RESULT = FILENAMERROR;
   ELSE
      CSL$PTR=CSL$PTR+1;
END SKIP$CHAR;

FILE$CHAR: PROCEDURE BYTE;
   CH=CSL(CSL$PTR);
   RETURN CH <> ' ' AND CH <> ',' AND CH <> ')'
                    AND CH <> '(' AND CH <> CR;
END FILE$CHAR;

COLLECT$FILE$NAME: PROCEDURE (NAME$PTR);
   DECLARE NAME$PTR ADDRESS,
           NAME BASED NAME$PTR(1) BYTE,
           I BYTE;

   CALL SKIP$BLANKS;
   I=0;
   DO WHILE FILE$CHAR;
      NAME(I)=CH; I=I+1;
      IF I = 16 THEN
         I = 15;
      CSL$PTR=CSL$PTR+1;
   END;
   NAME(I)=LF;
END COLLECT$FILE$NAME;

COLLECT$COMMAND: PROCEDURE;
   CSL$PTR=0;
   CALL COLLECT$FILE$NAME(.SEQCODE$FILE);
   CALL SKIP$CHAR('(');
   CALL COLLECT$FILE$NAME(.ARGLIST(10));
   CALL SKIP$CHAR(',');
   CALL COLLECT$FILE$NAME(.ARGLIST(19));
   CALL SKIP$CHAR(',');
   CALL COLLECT$FILE$NAME(.ARGLIST(28));
   CALL SKIP$CHAR(')');
END COLLECT$COMMAND;

SETUP: PROCEDURE;
   DO I = 0 TO 17;
      HEAD(I) = 0;
   END;

   DO I = 0 TO 4;
      FILE$OPEN(I)=FALSE;
   END;

   S=.ST$ADR(7999)+2;
   W=.CSL+12;
   DO I = 0 TO 5;
      S=S-2; W=W-2; STS=STW;
   END;
   W=S; S=S-2; STS=W;
   S=S-2; STS=.ARGLIST;
   S=S-2; STS=.VMI+VMI$ADR(1)+8;
   S=S-2;

   Q = .VMI(8);

   HEAPTO = .ST;


END SETUP;


LOAD: PROCEDURE (NAME);
   DECLARE NAME ADDRESS;

   CALL OPEN (.SEQ$CODE,NAME,1,0,.STATUS);
   IF STATUS = 0 THEN
      CALL READ (SEQ$CODE,.VMI,2,.COUNT,.STATUS);
   IF STATUS = 0 THEN
      CALL READ (SEQ$CODE,.VMI(2),(VMI$ADR(0)-2),.COUNT,.STATUS);
   IF STATUS = 0 THEN
      CALL CLOSE (SEQ$CODE,.STATUS);

END LOAD;


EXECUT: PROCEDURE;

   DECLARE
	NEXT$INSTR BYTE;

   MORE$JOBS=TRUE;

   DO WHILE MORE$JOBS;

   RESULT = 0;


   DO WHILE TERMINATED = FALSE;

      NEXT$INSTR = SHR(Q$BYT,1); Q=Q+2;

      DO CASE NEXT$INSTR;

         /* CASE 0 (0000)  PROCERROR */
         DO;
            RESULT = PROCERROR;
         END;

         /* CASE 1 (0002)  CONSTADDR */
         DO;
            S=S-2; W=G+10; STS=STW;
            STS=STS+STQ; Q=Q+2;
         END;

         /* CASE 2 (0004)  LOCALADDR */
         DO;
            S=S-2; STS = B;
            STS=STS+STQ; Q=Q+2;
         END;

         /* CASE 3 (0006)  GLOBALADDR */
         DO;
            S=S-2; STS=G;
            STS=STS+STQ; Q=Q+2;
         END;

         /* CASE 4 (0008)  PUSHCONST */
         DO;
            S=S-2; STS=STQ; Q=Q+2;
         END;

         /* CASE 5 (000A)  PUSHLOCAL */
         DO;
            W=B;
            W=W+STQ; Q=Q+2;
            S=S-2; STS=STW;
         END;

         /* CASE 6 (000C)  PUSHGLOBAL */
         DO;
            W=G;
            W=W+STQ; Q=Q+2;
            S=S-2; STS=STW;
         END;

         /* CASE 7 (000E)  PUSHIND */
         DO;
            W=STS; STS=STW;
         END;

         /* CASE 8 (0010)  PUSHBYTE */
         DO;
            W=STS;
            STS=W$BYT;
         END;
   
         /* CASE 9 (0012)  PUSHREAL */
         DO;
            W=STS; S=S+2;
            W=W+8;
            DO I = 0 TO 3;
               W=W-2; S=S-2; STS=STW;
            END;
         END;
   
         /* CASE 10 (0014)  PUSHSET */
         DO;
            W=STS; S=S+2;
            W=W+16;
            DO I = 0 TO 7;
               W=W-2; S=S-2; STS=STW;
            END;
         END;
   
         /* CASE 11 (0016)  FIELD */
         DO;
            STS=STS+STQ; Q=Q+2;
         END;
   
         /* CASE 12 (0018)  INDEX */
         DO;
            X=STS; S=S+2;
            X=X-STQ; Q=Q+2;
            IF X > STQ THEN
               RESULT = RANGERROR;
            Q=Q+2;
            X=X*STQ; Q=Q+2;
            STS=STS+X;
         END;
   
         /* CASE 13 (001A)  POINTER */
         DO;
            IF STS = 0 THEN
               RESULT = POINTERERROR;
         END;
   
         /* CASE 14 (001C)  VARIANT */
         DO;
            W=1;
            X=STS;
            X=X+STQ; Q=Q+2;
            Y=STX;
            DO WHILE Y <> 0;
               W=W*2;
               Y=Y-1;
            END;
            IF (W AND STQ) <> W THEN
               RESULT = VARIANTERROR;
            Q=Q+2;
         END;
   
         /* CASE 15 (001E)  RANGE */
         DO;
            IF STS < STQ THEN
               RESULT = RANGERROR;
            Q=Q+2;
            IF STS > STQ THEN
               RESULT = RANGERROR;
            Q=Q+2;
         END;
   
         /* CASE 16 (0020)  COPYBYTE */
         DO;
            DECLARE TEMP BYTE;
            TEMP=STS; S=S+2;
            W=STS; S=S+2;
            W$BYT=TEMP;
         END;
   
         /* CASE 17 (0022)  COPYWORD */
         DO;
            W=STS; S=S+2;
            X=STS; S=S+2;
            STX=W;
         END;
   
         /* CASE 18 (0024)  COPYREAL */
         DO;
            X=S+8;
            W=STX;
            DO I = 0 TO 3;
               STW=STS; W=W+2; S=S+2;
            END;
            S=S+2;
         END;
   
         /* CASE 19 (0026)  COPYSET */
         DO;
            X=S+16;
            W=STX;
            DO I = 0 TO 7;
               STW=STS; W=W+2; S=S+2;
            END;
            S=S+2;
         END;
   
         /* CASE 20 (0028)  COPYTAG */
         DO;
            W=STS; S=S+2;
            X=STS;
            STX=W;
            W=STQ; Q=Q+2;
            X=STS; S=S+2;
            X=X+2;
            DO WHILE W <> 0;
               STX=0; X=X+2;
               W=W-1;
            END;
         END;
   
         /* CASE 21 (002A)  COPYSTRUC */
         DO;
            W=STQ; Q=Q+2;
            X=STS; S=S+2;
            Y=STS; S=S+2;
            DO WHILE W <> 0;
               STY=STX; Y=Y+2; X=X+2;
               W=W-1;
            END;
         END;
   
         /* CASE 22 (002C)  NEW */
         DO;
            X=B;
            X=X-HEAPTO;
            IF X < STQ THEN
               RESULT = HEAPLIMIT;
            Q=Q+2;
            W=STS;
            STW=HEAPTO; S=S+2;
            HEAPTO=HEAPTO+STQ; Q=Q+2;
         END;
   
         /* CASE 23 (002E)  NEWINT */
         DO;
            X=B;
            X=X-HEAPTO;
            IF X < STQ THEN
               RESULT = HEAPLIMIT;
            Q=Q+2;
            W=STS;
            STW=HEAPTO; S=S+2;
            W=STQ; Q=Q+2;
            HEAPTO=HEAPTO+W;
            W=W/2;
            X=HEAPTO;
            DO WHILE W <> 0;
               X=X-2; STX=0;
               W=W-1;
            END;
         END;
   
         /* CASE 24 (0030)  NOT */
         DO;
            STS= -STS +1;
         END;
   
         /* CASE 25 (0032)  ANDWORD */
         DO;
            W=STS; S=S+2;
            STS=(STS AND W);
         END;
   
         /* CASE 26 (0034)  ANDSET */
         DO;
            DO I = 0 TO 7;
               W=S+16;
               STW=(STW AND STS); S=S+2;
            END;
         END;
   
         /* CASE 27 (0036)  ORWORD */
         DO;
            W=STS; S=S+2;
            STS=(STS OR W);
         END;
   
         /* CASE 28 (0038)  ORSET */
         DO;
            DO I = 0 TO 7;
               W=S+16;
               STW=(STW OR STS); S=S+2;
            END;
         END;
   
         /* CASE 29 (003A)  NEGWORD */
         DO;
            STS= -STS;
         END;
   
         /* CASE 30 (003C)  NEGREAL */
         DO;
            STS= -STS;
         END;
   
         /* CASE 31 (003E)  ADDWORD */
         DO;
            W=STS; S=S+2;
            STS=STS+W;
         END;
   
         /* CASE 32 (0040)  ADDREAL */
         DO;
            W=STS;
            S=S+8;
            STS=STS+W;
         END;
   
         /* CASE 33 (0042)  SUBWORD */
         DO;
            W=STS; S=S+2;
            STS=STS-W;
         END;
   
         /* CASE 34 (0044)  SUBREAL */
         DO;
            W=STS;
            S=S+8;
            STS=STS-W;
         END;
   
         /* CASE 35 (0046)  SUBSET */
         DO;
            DO I = 0 TO 7;
               STS= NOT STS;
               W=S+16;
               STW=(STW AND STS); S=S+2;
            END;
         END;
   
         /* CASE 36 (0048)  MULWORD */
         DO;
            W=STS; S=S+2;
            X=STS;
            STS=STS*W;
            Y=STS;
            IF (((W OR X) AND 8000H) = 0) AND ((Y AND 8000H) = 8000H) THEN
               RESULT = OVERFLOW;
            IF ((W AND X AND 8000H) = 8000H) AND ((Y AND 8000H) = 0) THEN
               RESULT = OVERFLOW;
         END;
   
         /* CASE 37 (004A)  MULREAL */
         DO;
            W=STS;
            S=S+8;
            STS=STS*W;
         END;
   
         /* CASE 38 (004C)  DIVWORD */
         DO;
            W=STS; S=S+2;
            STS=STS/W;
         END;
   
         /* CASE 39 (004E)  DIVREAL */
         DO;
            W=STS;
            S=S+8;
            STS=STS/W;
         END;
   
         /* CASE 40 (0050)  MODWORD */
         DO;
            W=STS; S=S+2;
            STS=STS MOD W;
         END;
   
         /* CASE 41 (0052)  BUILDSET */
         DO;
            W=STS; S=S+2;
            IF W > 127 THEN
               RESULT = RANGERROR;
            TEMP=W;
            TEMP=TEMP AND 07H;
            W=W/8;
            W=W+S;
            I=1;
            DO WHILE TEMP <> 0;
               I=I*2;
               TEMP=TEMP-1;
            END;
            W$BYT=W$BYT OR I;
         END;
   
         /* CASE 42 (0054)  INSET */
         DO;
            W=S+16;
            W=STW;
            IF W > 127 THEN
               RESULT = RANGERROR;
            TEMP=W;
            TEMP=TEMP AND 07H;
            W=W/8;
            W=W+S;
            I=W$BYT;
            DO WHILE TEMP <> 0;
               I=I/2;
               TEMP=TEMP-1;
            END;
            I=I AND 01H;
            S=S+16;
            STS=I;
         END;
   
         /* CASE 43 (0056)  LSWORD */
         DO;
            W=STS; S=S+2;
            IF W+8000H > 8000H+STS THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 44 (0058)  EQWORD */
         DO;
            W=STS; S=S+2;
            IF W = STS THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 45 (005A)  GRWORD */
         DO;
            W=STS; S=S+2;
            IF W+8000H < 8000H+STS THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 46 (005C)  NLWORD */
         DO;
            W=STS; S=S+2;
            IF W+8000H > 8000H+STS THEN
               STS=0;
            ELSE
               STS=1;
         END;
   
         /* CASE 47 (005E)  NEWORD */
         DO;
            W=STS; S=S+2;
            IF W <> STS THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 48 (0060)  NGWORD */
         DO;
            W=STS; S=S+2;
            IF STS+8000H > 8000H+W THEN
               STS=0;
            ELSE
               STS=1;
         END;
   
         /* CASE 49 (0062)  LSREAL */
         DO;
            W=STS;
            S=S+8;
            X=STS;
            S=S+6;
            IF W+8000H > 8000H+X THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 50 (0064)  EQREAL */
         DO;
            W=STS;
            S=S+8;
            X=STS;
            S=S+6;
            IF W = X THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 51 (0066)  GRREAL */
         DO;
            W=STS;
            S=S+8;
            X=STS;
            S=S+6;
            IF W+8000H < 8000H+X THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 52 (0068)  NLREAL */
         DO;
            W=STS;
            S=S+8;
            X=STS;
            S=S+6;
            IF W+8000H > 8000H+X THEN
               STS=0;
            ELSE
               STS=1;
         END;
   
         /* CASE 53 (006A)  NEREAL */
         DO;
            W=STS;
            S=S+8;
            X=STS;
            S=S+6;
            IF X <> W THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 54 (006C)  NGREAL */
         DO;
            W=STS;
            S=S+8;
            X=STS;
            S=S+6;
            IF X+8000H > 8000H+W THEN
               STS=0;
            ELSE
               STS=1;
         END;
   
         /* CASE 55 (006E)  EQSET */
         DO;
            TEMP=1;
            W=S;
            I=8;
            DO WHILE I <> 0;
               X=W+16;
               IF STW <> STX THEN
               DO;
                  TEMP=0;
                  I=0;
               END;
               ELSE
               DO;
                  W=W+2;
                  I=I-1;
               END;
            END;
            S=S+30;
            STS=TEMP;
         END;
   
         /* CASE 56 (0070)  NLSET */
         DO;
            TEMP=1;
            W=S;
            DO I = 0 TO 7;
               X=W+16;
               IF (( NOT STX) AND STW) <> 0 THEN
                  TEMP=0;
               W=W+2;
            END;
            S=S+30;
            STS=TEMP;
         END;
   
         /* CASE 57 (0072)  NESET */
         DO;
            TEMP=0;
            W=S;
            I=8;
            DO WHILE I <> 0;
               X=W+16;
               IF STX <> STW THEN
               DO;
                  TEMP=1;
                  I=0;
               END;
               ELSE
               DO;
                  W=W+2;
                  I=I-1;
               END;
            END;
            S=S+30;
            STS=TEMP;
         END;
   
         /* CASE 58 (0074)  NGSET */
         DO;
            TEMP=1;
            W=S;
            DO I = 0 TO 7;
               X=W+16;
               IF (( NOT STW) AND STX) <> 0 THEN
                  TEMP=0;
               W=W+2;
            END;
            S=S+30;
            STS=TEMP;
         END;
   
         /* CASE 59 (0076)  LSSTRUCT */
         DO;
            W=STQ; Q=Q+2;
            W=W+W;
            X=STS-1; S=S+2;
            Y=STS-1;
            STS=0;
            DO WHILE W <> 0;
               X=X+1; Y=Y+1;
               IF Y$BYT <> X$BYT THEN
                  W=0;
               ELSE
                  W=W-1;
            END;
            IF Y$BYT < X$BYT THEN
               STS=1;
         END;
   
         /* CASE 60 (0078)  EQSTRUCT */
         DO;
            W=STQ; Q=Q+2;
            X=STS; S=S+2;
            Y=STS;
            STS=1;
            DO WHILE W <> 0;
               IF STY <> STX THEN
               DO;
                  STS=0;
                  W=0;
               END;
               ELSE
               DO;
                  X=X+2; Y=Y+2;
                  W=W-1;
               END;
            END;
         END;
   
         /* CASE 61 (007A)  GRSTRUCT */
         DO;
            W=STQ; Q=Q+2;
            W=W+W;
            X=STS-1; S=S+2;
            Y=STS-1;
            STS=0;
            DO WHILE W <> 0;
               X=X+1; Y=Y+1;
               IF Y$BYT <> X$BYT THEN
                  W=0;
               ELSE
                  W=W-1;
            END;
            IF Y$BYT+80H > 80H+X$BYT THEN
               STS=1;
         END;
   
         /* CASE 62 (007C)  NLSTRUCT */
         DO;
            W=STQ; Q=Q+2;
            W=W+W;
            X=STS-1; S=S+2;
            Y=STS-1;
            STS=0;
            DO WHILE W <> 0;
               X=X+1; Y=Y+1;
               IF Y$BYT <> X$BYT THEN
                  W=0;
               ELSE
                  W=W-1;
            END;
            IF Y$BYT+80H >= 80H+X$BYT THEN
               STS=1;
         END;
   
         /* CASE 63 (007E)  NESTRUCT */
         DO;
            W=STQ; Q=Q+2;
            X=STS; S=S+2;
            Y=STS;
            STS=0;
            DO WHILE W <> 0;
               IF STY <> STX THEN
               DO;
                  STS=1;
                  W=0;
               END;
               ELSE
               DO;
                  X=X+2; Y=Y+2;
                  W=W-1;
               END;
            END;
         END;
   
         /* CASE 64 (0080)  NGSTRUCT */
         DO;
            W=STQ; Q=Q+2;
            W=W+W;
            X=STS-1; S=S+2;
            Y=STS-1;
            STS=0;
            DO WHILE W <> 0;
               X=X+1; Y=Y+1;
               IF Y$BYT <> X$BYT THEN
                  W=0;
               ELSE
                  W=W-1;
            END;
            IF Y$BYT+80H <= 80H+X$BYT THEN
               STS=1;
         END;
   
         /* CASE 65 (0082)  FUNCVALUE */
         DO;
            TEMP=STQ; Q=Q+2;
            TEMP=SHR(TEMP,3);
            DO CASE TEMP;

               /*** CASE "0" ***/
               DO;
                  S=S-2; STS=0;
               END;

               /*** CASE "8" ***/
               DO;
                  S=S-8;
               END;

               /*** CASE "16" ***/
               DO;
                  W=STS;
                  STS=0;
                  S=S-2; STS=W;
               END;

               /*** CASE "24" ***/
               DO;
                  W=STS;
                  S=S-8;
                  STS=W;
               END;

            END; /*** END OF FUNCVALUE CASES ***/
         END;
   
         /* CASE 66 (0084)  JMP */
         DO;
            Q = STQ+Q;
         END;
   
         /* CASE 67 (0086)  FALSEJUMP */
         DO;
            IF STS = 0 THEN
               Q=Q+STQ;
            ELSE
               Q=Q+2;
            S=S+2;
         END;
   
         /* CASE 68 (0088)  CASEJUMP */
         DO;
            W=STS; S=S+2;
            W=W-STQ; Q=Q+2;
            IF W > STQ THEN
               RESULT = RANGERROR;
            Q=Q+2;
            W=W+W;
            Q=Q+W;
            Q=STQ+Q;
         END;
   
         /* CASE 69 (008A)  INITVAR */
         DO;
            W=STQ; Q=Q+2;
            X=S;
            DO WHILE W <> 0;
               STX=0; X=X+2;
               W=W-1;
            END;
         END;
   
         /* CASE 70 (008C)  CALL */
         DO;
            W=Q;
            W=W+STQ; Q=Q+2;
            S=S-2; STS=Q;
            Q=W;
         END;
   
         /* CASE 71 (008E)  CALLSYS */
         DO;
            DECLARE SYS$INSTR BYTE;
   
            SYS$INSTR = SHR(Q$BYT,1); Q=Q+2;

         DO CASE SYS$INSTR;
   
               /** CASE 0 (0000)  READ **/
               DO;
                  DECLARE NOT$GOT$NXT BYTE,
                          EOM LITERALLY '25';
                  W=STS; S=S+2;
                  NOT$GOT$NXT=TRUE;
                  DO WHILE NOT$GOT$NXT;
                     IF READ$COUNT = 0 THEN
                     DO;
                        CALL READ (READ$FILE,.READ$BUFFER,256,.READ$COUNT,.STATUS);
                        READ$PTR=0;
                        IF (STATUS <> 0) OR (READ$COUNT = 0) THEN
                           READ$BUFFER(0)=EOM;
                     END;
                     STW=(READ$BUFFER(READ$PTR) AND 007FH);
                     IF STW <> CR THEN
                        NOT$GOT$NXT=FALSE;
                     READ$PTR=READ$PTR+1;
                     READ$COUNT=READ$COUNT-1;
                  END;
               END;
   
               /** CASE 1 (0002)  WRITE **/
               DO;
                  TEMP=STS; S=S+2;
                  IF TEMP = LF THEN
                  DO;
                     WRITE$BUFFER(WRITE$PTR)=CR;
                     WRITE$PTR=WRITE$PTR+1;
                     WRITE$BUFFER(WRITE$PTR)=LF;
                     WRITE$PTR=WRITE$PTR+1;
                     CALL WRITE (WRITE$FILE,.WRITE$BUFFER,WRITE$PTR,.STATUS);
                     WRITE$PTR=0;
                  END;
                  ELSE
                  DO;
                     WRITE$BUFFER(WRITE$PTR)=TEMP;
                     WRITE$PTR=WRITE$PTR+1;
                  END;
               END;
   
               /** CASE 2 (0004)  OPEN **/
               DO;
                  W=STS; S=S+2;
                  X=STS; S=S+2;
                  Y=STS; S=S+2;
                  CALL OPEN (.FILE$AFTNPTR(Y),X,3,0,.STATUS);
                  IF STATUS = 0 THEN
                  DO;
                     FILE$OPEN(Y)=TRUE;
                     NXT$BLK(Y)=1;
                     STW=1;
                  END;
                  ELSE
                     STW=0;
               END;
   
               /** CASE 3 (0006)  CLOSE **/
               DO;
                  W=STS; S=S+2;
                  FILE$OPEN(W)=FALSE;
                  CALL CLOSE (FILE$AFTNPTR(W),.STATUS);
               END;
   
               /** CASE 4 (0008)  GET **/
               DO;
                  W=STS; S=S+2;
                  X=STS; S=S+2;
                  Y=STS; S=S+2;
                  IF X <> NXT$BLK(Y) THEN
                  DO;
                     NXT$BLK(Y)=X;
                     X=(X-1)*4;
                     CALL SEEK (FILE$AFTNPTR(Y),2,.X,.(0,0),.STATUS);
                  END;
                  CALL READ (FILE$AFTNPTR(Y),W,512,.COUNT,.STATUS);
                  NXT$BLK(Y)=NXT$BLK(Y)+1;
               END;
   
               /** CASE 5 (000A)  PUT **/
               DO;
                  W=STS; S=S+2;
                  X=STS; S=S+2;
                  Y=STS; S=S+2;
                  IF X <> NXT$BLK(Y) THEN
                  DO;
                     NXT$BLK(Y)=X;
                     X=(X-1)*4;
                     CALL SEEK (FILE$AFTNPTR(Y),2,.X,.(0,0),.STATUS);
                  END;
                  CALL WRITE (FILE$AFTNPTR(Y),W,512,.STATUS);
                  NXT$BLK(Y)=NXT$BLK(Y)+1;
               END;
   
               /** CASE 6 (000C)  LENGTH **/
               DO;
                  S=S+2;
                  STS=256;
               END;
   
               /** CASE 7 (000E)  MARK **/
               DO;
                  W=STS; S=S+2;
                  STW=HEAPTO;
               END;
   
               /** CASE 8 (0010)  RELEASE **/
               DO;
                  HEAPTO=STS; S=S+2;
               END;
   
               /** CASE 9 (0012)  IDENTIFY **/
               DO;
                  W=STS; S=S+2;
                  DO WHILE W$BYT <> LF;
                     CALL CO (W$BYT);
                     W=W+1;
                  END;
                  CALL CO (CR);
                  CALL CO (LF);
               END;
   
               /** CASE 10 (0014)  ACCEPT **/
               DO;
                  TEMP=(CI AND 7FH);
                  CALL CO(TEMP);
                  W=STS; S=S+2;
                  STW=TEMP;
               END;
   
               /** CASE 11 (0016)  DISPLAY **/
               DO;
                  TEMP = STS;
                  CALL CO(TEMP);
                  S = S+2;
                  IF TEMP = LF THEN
                     CALL CO(CR);
               END;
   
               /** CASE 12 (0018)  READPAGE **/
               DO;
                  RESULT = PROCERROR;
               END;
   
               /** CASE 13 (001A)  WRITEPAGE **/
               DO;
                  RESULT = PROCERROR;
               END;
      
               /** CASE 14 (001C)  READLINE **/
               DO;
                  RESULT = PROCERROR;
               END;
   
               /** CASE 15 (001E)  WRITELINE **/
               DO;
                  RESULT = PROCERROR;
               END;
   
               /** CASE 16 (0020)  READARG **/
               DO;
                  W=STS; S=S+2;
                  W=W+2; STW=1;
                  TEMP=STS; S=S+2;
                  DO CASE TEMP;

                      /*** INP ***/
                      CALL CLOSE (READ$FILE,.STATUS);

                      /*** OUT ***/
                      CALL CLOSE (WRITE$FILE,.STATUS);

                  END;
               END;
      
               /** CASE 17 (0022)  WRITEARG **/
               DO;
                  W=STS+2; S=S+2;
                  TEMP=STS; S=S+2;
                  DO CASE TEMP;

                     /*** INP ***/
                     DO;
                        CALL OPEN (.READ$FILE,W,1,0,.STATUS);
                        READ$COUNT=0;
                     END;

                     /*** OUT ***/
                     DO;
                        CALL OPEN (.WRITEFILE,W,2,0,.STATUS);
                        WRITE$PTR=0;
                     END;

                  END;
                  IF STATUS <> 0 THEN
                     RESULT = OPENERROR;
               END;
   
               /** CASE 18 (0024)  LOOKUP **/
               DO;
                  W=STS; S=S+2;
                  STW=1;
                  W=STS; S=S+2;
                  STW=3; W=W+2;
                  STW=1; W=W+2;
                  STW=0; W=W+2;
                  S=S+2;
               END;
   
               /** CASE 19 (0026)  IOTRANSFER **/
               DO;
                  RESULT = PROCERROR;
               END;
   
               /** CASE 20 (0028)  IOMOVE **/
               DO;
                  RESULT = PROCERROR;
               END;
   
               /** CASE 21 (002A)  TASK **/
               DO;
                  STS=1;
               END;
   
               /** CASE 22 (002C)  RUN **/
               DO;
                  W=S+6;
                  CALL LOAD (STW);
                  IF STATUS = 0 THEN
                  DO;
                     S=S-2; STS=STW;
                     W=W-2; S=S-2; STS=STW;
                     S=S-2; STS=.VMI+VMI$ADR(1)+8;
                     S=S-2; STS=Q;
                     Q=.VMI(8);
                  END;
                  ELSE
                     RESULT = LOADERROR;
               END;
   
            END;  /** END OF SYS$INSTR CASES **/
   
         END;
   
   
         /* CASE 72 (0090)  ENTER */
         DO;
            X=S;
            X=X-HEAPTO;
            IF X < STQ THEN
               RESULT = STACKLIMIT;
            Q=Q+2;
            S=S-2; STS=G;
            S=S-2; STS=B;
            S=S-2;
            STS=S;
            STS=STS+STQ; Q=Q+2;
            S=S-2; STS=STQ; Q=Q+2;
            B=S;
            S=S-STQ; Q=Q+2;
         END;
   
         /* CASE 73 (0092)  EXIT */
         DO;
            S=B;
            S=S+2;
            W=STS; S=S+2;
            B=STS; S=S+2;
            G=STS; S=S+2;
            Q=STS; S=S+2;
            S=W;
         END;
   
         /* CASE 74 (0094)  ENTERPROG */
         DO;
            JOB=JOB+1;
            S=S-2; STS=G;
            S=S-2; STS=B;
            S=S-2;
            STS=S;
            STS=STS+0AH; Q=Q+2; /* ACCOMODATES PRG'S W/WO ARGLIST */
            S=S-2; STS=STQ; Q=Q+2;
            B=S;
            G=B;
            X=S;
            X=X-HEAPTO;
            IF X < STQ THEN
               RESULT = STACKLIMIT;
            Q=Q+2;
            S=S-STQ; Q=Q+2;
         END;
   
         /* CASE 75 (0096)  EXITPROG */
         DO;
            TERMINATED=TRUE;
         END;
   
         /* CASE 76 (0098)  BEGINCLASS */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 77 (009A)  ENDCLASS */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 78 (009C)  ENTERCLASS */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 79 (009E)  EXITCLASS */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 80 (00A0)  BEGINMON */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 81 (00A2)  ENDMON */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 82 (00A4)  ENTERMON */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 83 (00A6)  EXITMON */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 84 (00A8)  BEGINPROC */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 85 (00AA)  ENDPROC */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 86 (00AC)  ENTTERPROC */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 87 (00AE)   EXITPROC */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 88 (00B0)  POP */
         DO;
            S=S+STQ; Q=Q+2;
         END;
   
         /* CASE 89 (00B2)  NEWLINE */
         DO;
            STB=STQ; Q=Q+2;
         END;
   
         /* CASE 90 (00B4)  INCWORD */
         DO;
            W=STS; S=S+2;
            STW=STW+1;
         END;
   
         /* CASE 91 (00B6)  DECRWORD */
         DO;
            W=STS; S=S+2;
            STW=STW-1;
         END;
   
         /* CASE 92 (00B8)  INITCLASS */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 93 (00BA)  INITMON */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 94 (00BC)  INITPROC */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 95 (00BE)  PUSHLABEL */
         DO;
            S=S-2; STS=Q;
            STS=STS+STQ; Q=Q+2;
         END;
   
         /* CASE 96 (00C0)  CALLPROG */
         DO;
            W=Q;
            Q=STS;
            Q=Q+2;
            STS=STQ; Q=Q+2;
            Q=Q+4;
            STS=STS+Q;
            S=S-2; STS=W;
         END;
   
         /* CASE 97 (00C2)  TRUNCREAL */
         DO;
            W=STS;
            S=S+6;
            STS=W;
         END;
   
         /* CASE 98 (00C4)  ABSWORD */
         DO;
            IF (STS AND 8000H) = 8000H THEN
               STS=-STS;
         END;
   
         /* CASE 99 (00C6)  ABSREAL */
         DO;
            IF (STS AND 8000H) = 8000H THEN
               STS= -STS;
         END;
   
         /* CASE 100 (00C8)  SUCCWORD */
         DO;
            STS=STS+1;
         END;
   
         /* CASE 101 (00CA)  PREVWORD */
         DO;
            STS=STS-1;
         END;
   
         /* CASE 102 (00CE)  CONVWORD */
         DO;
            W=STS;
            S=S-6;
            STS=W;
         END;
   
         /* CASE 103 (00D0)  EMPTY */
         DO;
            IF STS = 0 THEN
               STS=1;
            ELSE
               STS=0;
         END;
   
         /* CASE 104 (00D2)  ATTRIB */
         DO;
            W=STS;
            W=W+W;
            X=.HEAD+W;
            STS=STX;
         END;
   
         /* CASE 105 (00D4)  REALTIME */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 106 (00D6)  DELAY */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 107 (00D8)  CONTINUE */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 108 (00DA)  IO */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 109 (00DC)  START */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 110 (00DE)  STOP */
         DO;
            RESULT = PROCERROR;
         END;
   
         /* CASE 111 (00E0)  SETHEAP */
         DO;
            HEAPTO=STS; S=S+2;
         END;
   
         /* CASE 112 (00E2)  WAIT */
         DO;
            RESULT = PROCERROR;
         END;
   
      END;  /* END OF NEXT$INSTR CASES */
   
   
   END;  /* END OF WHILE BLOCK */

   IF TERMINATED = TRUE THEN
      RESULT = 0;
   LINE=STB;
   B=G;
   S=B;
   S=S+2;
   W=STS; S=S+2;
   B=STS; S=S+2;
   G=STS; S=S+2;
   Q=STS; S=S+2;
   S=W;
   JOB=JOB-1;
   IF JOB = 0 THEN
      MORE$JOBS=FALSE;
   ELSE
   DO;
      S=S+4;
      W=STS; STW=RESULT; S=S+2;
      W=STS; STW=LINE; S=S+2;
      S=S+4;
      W=G+2; W=STW; W=W+2;
      CALL LOAD (STW);
      IF STATUS <> 0 THEN
      DO;
         RESULT = LOADERROR;
         MORE$JOBS = FALSE;
      END;
   END;



   END; /* MORE$JOBS */

DO I = 0 TO 4;
   IF FILE$OPEN(I) = TRUE THEN
   DO;
      CALL CLOSE(FILE$AFTNPTR(I),.STATUS);
      FILE$OPEN(I)=FALSE;
   END;
END;
END EXECUT;


/**************************************************************/


RUNNING$PASCAL = TRUE;

CALL MESSAGE (.TITLE,LENGTH(TITLE));
CALL READ (1,.CSL,80,.COUNT,.STATUS);

DO WHILE RUNNING$PASCAL;

   CALL MESSAGE (.(CRLF,'*'),3);
   CALL READ (1,.CSL,80,.COUNT,.STATUS);

   IF CSL(0) <> '!' THEN
   DO;
      CALL COLLECT$COMMAND;
      CALL LOAD(.SEQCODE$FILE);
      IF STATUS = 0 THEN
      DO;
         CALL SETUP;
         CALL EXECUT;
      END;
      ELSE
         RESULT = LOADERROR;
      CALL MESSAGE(.(CR,LF),2);
      CALL MESSAGE(.TEXT(RESULT*16),16);
      CALL MESSAGE(.(' AT LINE '),9);
      CALL PRINT$ADR(LINE);
   END;
   ELSE
      RUNNING$PASCAL = FALSE;

END;

CALL EXIT;


END;