*DECK     PSYSTM
          IDENT  P.SYSTM
          SST    FL 
          SYSCOM B1 
          LIST   F
          ENTRY  P.CAD
          ENTRY  P.CFD
          ENTRY  P.CLOCK
          ENTRY  P.CLOSE
          ENTRY  P.DATE 
          ENTRY  P.DISP 
          ENTRY  P.DISPD
          ENTRY  P.END
          ENTRY  P.FCE
          ENTRY  P.FOB
          ENTRY  P.GETB 
          ENTRY  P.GETC 
          ENTRY  P.GETCH
          ENTRY  P.GETLN
          ENTRY  P.GETS 
          ENTRY  P.GLOBL
          ENTRY  P.GTO
          ENTRY  P.HALT 
          ENTRY  P.INIT 
          ENTRY  P.IOE
          ENTRY  P.ISM
          ENTRY  P.MSG
          ENTRY  P.NEW
          ENTRY  P.NEWD 
          ENTRY  P.NFN
          ENTRY  P.OPEN 
          ENTRY  P.PAGE 
          ENTRY  P.PEN
          ENTRY  P.PEX
          ENTRY  P.PUTB 
          ENTRY  P.PUTC 
          ENTRY  P.PUTCH
          ENTRY  P.PUTLN
          ENTRY  P.PUTS 
          ENTRY  P.RESET
          ENTRY  P.REWRT
          ENTRY  P.RPE
          ENTRY  P.RPF
          ENTRY  P.RWRTS
          ENTRY  P.SABRT
          ENTRY  P.SKP
          ENTRY  P.SNM
          ENTRY  P.SPE
          ENTRY  P.SRS
          ENTRY  P.SWS
          ENTRY  P.TERA 
          ENTRY  P.TIME 
          ENTRY  P.TMS
          ENTRY  P.VPE
          ENTRY  P.WWR
 PSYSTM   SPACE  4,10 
 PSYSTM   TITLE  PASCAL 6000 RUN TIME SYSTEM. 
          COMMENT PASCAL 6000 RUN TIME SYSTEM.
          COMMENT COPYRIGHT (C) UNIVERSITY OF MINNESOTA - 1978. 
 PSYSTM   SPACE  4,10 
***       PASCAL 6000 RUN TIME SYSTEM.
*         J. P. STRAIT.      77/01/20.
*         J. J. DRUMMOND.    77/01/20.
* 
*         ORIGINAL VERSION BY 
*         H. SANDMAYR        CIRCA JUNE 1974. 
*         N. WIRTH           CIRCA JUNE 1974. 
*         S. KNUDSEN         CIRCA MARCH 1976.
 PSYSTM   SPACE  4,10 
***       THE PASCAL 6000 SYSTEM. 
* 
*         THE PASCAL 6000 SYSTEM CONSISTS OF 4 MAIN PARTS:  
* 
*         1. THE PASCAL 6000 COMPILER, WRITTEN IN PASCAL 6000,
*            GENERATES RELOCATABLE OBJECT CODE FOR CDC 6000 , CYBER 70
*            AND CYBER 170 SERIES COMPUTERS.
*         2. THE PASCAL 6000 RUN TIME SYSTEM (THIS COMPASS PROGRAM) 
*            INCLUDES ALL OPERATING SYSTEM INTERFACE ROUTINES.
*         3. THE PASCAL SUPPORT ROUTINES INCLUDE HIGHER LEVEL CHARACTER 
*            INPUT/OUTPUT ROUTINES, THE POST-MORTEM DUMP ROUTINE, AND 
*            VARIOUS PROCEDURE/FUNCTION PACKAGES. 
*         4. THE COMPASS SUPPORT ROUTINES INCLUDE MEDIUM LEVEL
*            CHARACTER INPUT/OUTPUT ROUTINES, MATHEMATICAL ROUTINES,
*            AND OTHER PROCEDURES AND FUNCTIONS WHICH FOR ONE REASON OR 
*            ANOTHER ARE CODED IN ASSEMBLY LANGUAGE.
 PSYSTM   SPACE  4,10 
***       THE PASCAL 6000 RUN TIME SYSTEM.
* 
*         THE PASCAL 6000 RUN TIME SYSTEM CAN ITSELF BE SUB-DIVIDED 
*         INTO SEVERAL MAJOR GROUPS OF ROUTINES:  
* 
*         1. INITIALIZATION OF THE PASCAL 6000 SYSTEM.  THIS INVOLVES 
*            THE CREATION OF THE RUN TIME STACK AND THE RUN TIME HEAP,
*            AND ALL OTHER GLOBAL SYSTEM INFORMATION. 
*         2. TERMINATION OF THE PASCAL 6000 SYSTEM.  THIS INCLUDES BOTH 
*            NORMAL TERMINATION AT THE END OF A PROGRAM AND ERROR 
*            RECOVERY IN THE CASE OF ABNORMAL CONDITIONS OR ERROR 
*            TERMINATION. 
*         3. LOW LEVEL INPUT/OUTPUT ROUTINES REQUIRING DIRECT CALLS TO
*            THE OPERATING SYSTEM.  THESE INCLUDE OPENING AND CLOSING 
*            FILES, AND SUCH PASCAL ROUTINES AS RESET, REWRITE, GET,
*            PUT, AND OTHERS. 
*         4. THE DYNAMIC ALLOCATION ROUTINES NEW AND DISPOSE. 
*         5. OTHER PROCEDURES AND FUNCTIONS, SUCH AS DATE AND MESSAGE,
*            WHICH REQUIRE DIRECT CALLS TO THE OPERATING SYSTEM.
 PSYSTM   SPACE  4,10 
***       PASCAL REGISTER CONVENTIONS.
* 
*         UNLESS OTHERWISE NOTED, ALL ROUTINES IN THE RUN TIME SYSTEM 
*         OBSERVE THE FOLLOWING REGISTER CONVENTIONS. 
* 
*         (A0) = CURRENT LINE NUMBER IN CALLING ROUTINE (IF PMD IS ON). 
*         (B1) = 1. 
*         (B4) = ADDRESS OF THE TOP OF THE RUN TIME HEAP. 
*         (B5) = ADDRESS OF THE CURRENT ACTIVATION RECORD.
*         (B6) = ADDRESS OF THE TOP OF THE RUN TIME STACK.
 PSYSTM   SPACE  4,10 
***       SUMMARY OF EXTERNALLY CALLED ROUTINES.
* 
*         THE FOLLOWING TABLE SUMMARIZES THE EXTERNALLY CALLED
*         ROUTINES.  THESE FALL INTO ONE OF THREE CATAGORIES: 
* 
*         1. ROUTINES WHICH ARE DIRECTLY USER-CALLABLE, YET ARE KNOWN 
*            UNDER A DIFFERENT NAME, SUCH AS WRITELN (P.PUTLN).  THESE
*            CORRESPOND TO PRE-DEFINED PASCAL ROUTINES. 
*         2. ROUTINES WHOSE CALLS ARE GENERATED BY THE COMPILER ITSELF
*            TO MAINTAIN THE RUN TIME ENVIRONMENT, SUCH AS P.OPEN.
*         3. ROUTINES WHICH ARE CALLED FROM THE LIBRARY (OR BY USER-
*            WRITTEN COMPASS ROUTINES) TO MAINTAIN THE RUN TIME 
*            ENVIRONMENT, SUCH AS P.SABRT.
* 
*  ROUTINE  EXTERNAL  PASCAL
*  NAME     NAME      NAME     DESCRIPTION
*  -------  --------  -------  -----------
*  CLK      P.CLOCK   CLOCK    CP TIME IN MILLISECONDS (FUNCTION).
*  CLO      P.CLOSE            CLOSE FILE.
*  DTE      P.DATE    DATE     SYSTEM DATE. 
*  DSP      P.DISP    DISPOSE  DEALLOCATE HEAP STORAGE. 
*  TDS      P.DISPD   DISPOSE  TEST AND DEALLOCATE HEAP STORAGE.
*  END      P.END              RETURN CONTROL TO THE OPERATING SYSTEM.
*  GTB      P.GETB    GET      GET BINARY.
*  GTC      P.GETC    GET      GET CHARACTER. 
*  GCH      P.GETCH   GET      GET CHARACTER HELPER.
*  GTL      P.GETLN   READLN   GET LINE.
*  GTS      P.GETS    GETSEG   GET SEGMENT. 
*  GTO      P.GTO              GOTO EXTERNAL LABEL. 
*  HLT      P.HALT    HALT     HALT WITH A MESSAGE. 
*  PRS      P.INIT             INITIALIZE THE PASCAL RUN TIME SYSTEM. 
*  IOE      P.IOE              INPUT/OUTPUT ERROR.
*  MSG      P.MSG     MESSAGE  DISPLAY MESSAGE TO USER DAYFILE. 
*  NEW      P.NEW     NEW      ALLOCATE HEAP STORAGE. 
*  TNW      P.NEWD    NEW      ALLOCATE CHECKED HEAP STORAGE. 
*  NFN      P.NFN              CREATE NEW FILE NAME OF FORM -SCRNNNN-.
*  OPE      P.OPEN             OPEN FILE. 
*  PAG      P.PAGE    PAGE     START PAGE.
*  PEN      P.PEN              COMMON PROCEDURE ENTRY.
*  PEX      P.PEX              COMMON PROCEDURE EXIT. 
*  PTB      P.PUTB    PUT      PUT BINARY.
*  PTC      P.PUTC    PUT      PUT CHARACTER. 
*  PCH      P.PUTCH   PUT      PUT CHARACTER HELPER.
*  PTL      P.PUTLN   WRITELN  PUT LINE.
*  PTS      P.PUTS    PUTSEG   PUT SEGMENT. 
*  RST      P.RESET   RESET    REWIND FILE AND PREPARE FOR READING. 
*  RWT      P.REWRT   REWRITE  REWIND FILE AND PREPARE FOR WRITING. 
*  RWS      P.RWRTS   REWRITE  REWRITE SEGMENTED FILE WITH SKIP COUNT.
*  ABT      P.SABRT            COMMON ERROR ROUTINE.
*  TIM      P.TIME    TIME     SYSTEM TIME OF DAY.
*  VPE      P.VPE              VARIABLE PROCEDURE ENTRY.
* 
*         THE FOLLOWING ROUTINES ARE INTERNAL TO THE RUN TIME SYSTEM, 
*         BUT HAVE EXTERNAL ENTRY POINTS FOR USE BY OTHER ROUTINES. 
* 
*  CAD      P.CAD              CONVERT ADDRESS TO DISPLAY CODE. 
*  CFD      P.CFD              CONVERT INTEGER TO PASCAL 10:3 FORM. 
*  FCE      P.FCE              FIND CURRENT ENTRY POINT.
*  FOB      P.FOB              FLUSH OUTPUT BUFFER. 
*  ISM      P.ISM              ISSUE STATISTICS MESSAGE TO DAYFILE. 
*  RPE      P.RPE              RESTORE PASCAL ENVIRONMENT.
*  RPF      P.RPF              REWIND PASCAL FILE.
*  SKP      P.SKP              SKIP RECORDS.
*  SNM      P.SNM              SET NAME IN MESSAGE
*  SPE      P.SPE              SAVE PASCAL ENVIRONMENT. 
*  SRS      P.SRS              SET READ STATUS. 
*  SWS      P.SWS              SET WRITE STATUS.
*  TMS      P.TMS              TERMINATE MESSAGE STRING.
*  WWR      P.WWR              PROCESS WRITE WITHOUT REWRITE ERROR. 
 PSYSTM   SPACE  4,10 
***       EXTENDED FET (EFET) FORMAT. 
* 
*         ASSOCIATED WITH EACH PASCAL FILE IS AN EXTENDED FILE
*         ENVIRONMENT TABLE (EFET), WHICH HAS THE FOLLOWING FORMAT. 
* 
* EFET-13 BSS    1           LINE COUNTER 
* EFET-12 BSS    10D         CHARACTER BUFFER 
* EFET-2  BSS    1           END OF CHARACTER BUFFER SENTINEL 
* EFET-1  VFD    1/EOLN,1/REWRITE,58/POINTER
* EFET    VFD    9/DISP,33/,18/LRL
* EFET+1  VFD    42/LFN,18/CODE-STATUS      FET+0 
* EFET+2  VFD    42/,18/FIRST               FET+1 
* EFET+3  CON    IN                         FET+2 
* EFET+4  CON    OUT                        FET+3 
* EFET+5  VFD    42/,18/LIMIT               FET+4 
* 
* 
* LINE COUNTER   SET TO -1 UPON OPEN, DECREMENTED ON EACH 
*                WRITELN.  PRESENT ONLY FOR TEXT FILES. 
* CHAR BUFFER    PRESENT ONLY FOR TEXT FILES. 
* SENTINEL       SET TO -0 UPON OPEN.  PRESENT ONLY FOR 
*                TEXT FILES.
* EOLN           END OF LINE FLAG FOR TEXT FILES. 
* REWRITE        REWRITE FLAG FOR TEXT FILES. 
* POINTER        ADDRESS OF CURRENT BUFFER ELEMENT.  POINTS INTO
*                THE CHAR BUFFER FOR TEXT FILES, AND INTO THE I/O 
*                BUFFER FOR WORD FILES. 
* DISP           DISPOSITION CODE IN THE FOLLOWING FORMAT.
*                 1/  EOF FOR NON-SEG.FILES, EOS FOR SEG.FILES. 
*                 1/  EOF 
*                 1/  SEGMENTED FILE. 
*                 1/  REWRITE FLAG. 
*                 1/  TEXT FILE.
*                 1/  TERMINAL FILE ("/" ON PROGRAM HEADER).
*                 1/  RE-OPENED FILE. 
*                 1/  FILE ACTUALLY CONNECTED TO TERMINAL.
*                 1/  EXTERNAL FILE.
* LRL            LOGICAL RECORD LENGTH.  THIS IS THE NUMBER OF WORDS
*                IN EACH ELEMENT OF THE FILE (1 FOR CHAR FILES).
*                NOTE THAT THE BUFFER LENGTH MUST BE A MULTIPLE OF LRL
*                TO PREVENT AN ELEMENT FROM WRAPPING AROUND THE BUFFER. 
 PSYSTM   SPACE  4,10 
***       INPUT/OUTPUT CONVENTIONS. 
* 
*         A FILE MAY BE READ ONLY IF IT HAS BEEN RESET AND MAY BE 
*         WRITTEN ONLY IF IT HAS BEEN REWRITTEN.  THIS MAY BE DETERMINED
*         BY THE REWRITE FLAGS WHICH ARE SET BY SWS AND CLEARED BY SRS. 
*         WHEN A FILE IS OPENED, IF ITS NAME IS INPUT, THE FILE IS
*         INITIALIZED FOR READING, OTHERWISE IT IS INITIALIZED FOR
*         WRITING.
* 
*         INPUT AND OUTPUT FILES ARE DISTINGUISHED BY THE CIO FUNCTION
*         CODE (STATUS) IN THE LOWER 18 BITS OF THE FET FIRST WORD AS 
*         WELL AS BY THE REWRITE FLAGS.  AN INPUT FILE IS DENOTED BY A
*         READ CODE (BIT 2 IS NOT SET), AND AN OUTPUT FILE IS DENOTED 
*         BY A WRITE CODE (BIT 2 IS SET).  A WRITER CODE (24B) IS 
*         PRESENT IF EITHER 
*              1. THE FILE HAS NOT YET BEEN WRITTEN, I.E. CIO HAS NOT 
*                 YET BEEN CALLED, OR 
*              2. AN END OF RECORD HAS RECENTLY BEEN WRITTEN (BY PTS).
*         AT ANY POINT WHERE THE CODE IS IN QUESTION (SUCH AS AFTER 
*         A REWIND OR SKIP), A READ OR WRITE CODE MUST BE SET.  SRS 
*         MAY BE CALLED TO SET A READ STATUS AND FILL THE BUFFER, 
*         OR SWS MAY BE CALLED TO SET A WRITE STATUS.  WHEN AN OUTPUT 
*         FILE IS CLOSED, ITS BUFFER IS FLUSHED WITH A WRITER UNLESS
*              1. THE BUFFER IS EMPTY, AND
*              2. THE FUNCTION CODE IN THE FET IS A WRITER. 
 PSYSTM   SPACE  4,10 
***       BINARY INPUT/OUTPUT.
* 
*         BINARY INPUT/OUTPUT (THAT IS, NON-TEXT I/O), IS PERFORMED BY
*         P.GETB AND P.PUTB WHICH CORRESPOND TO THE PASCAL PROCEDURES 
*         GET AND PUT.  FOR A BINARY FILE, THE FILE VARIABLE (CALLED
*         *POINTER* IN THE EFET DESCRIPTION GIVEN ABOVE) POINTS TO THE
*         CURRENT ELEMENT OF THE FILE IN THE CIO CIRCULAR BUFFER.  IN 
*         CASE OF AN INPUT FILE, THE POINTER HAS THE SAME VALUE AS THE
*         *OUT* POINTER IN THE CIO FET (EFET+4).  IN THE CASE OF AN 
*         OUTPUT FILE, IT HAS THE SAME VALUE AS THE *IN* POINTER IN 
*         THE FET (EFET+3).  THE CURRENT ELEMENT OF THE FILE CAN
*         THEREBY BE LOCATED REGARDLESS OF WHETHER THE FILE IS
*         CURRENTLY AN INPUT OR OUTPUT FILE.
* 
*         WHEN GET OR PUT IS CALLED, THE FILE VARIABLE AND ITS
*         ASSOCIATED FET POINTER ARE ADVANCED CIRCULARLY.  IF 
*         ADVANCING THE POINTER MAKES THE BUFFER HALF EMPTY FOR AN
*         INPUT FILE OR HALF FULL FOR AN OUTPUT FILE, THEN CIO IS 
*         CALLED TO PERFORM AN INPUT OR OUTPUT FUNCTION.  IN THIS WAY,
*         THE RUN TIME SYSTEM ATTEMPTS TO KEEP INPUT BUFFERS FULL AND 
*         OUTPUT BUFFERS EMPTY TO OVERLAP EXECUTION WITH INPUT/OUTPUT 
*         ACTIVITY. 
 PSYSTM   SPACE  4,10 
***       TEXT INPUT/OUTPUT.
* 
*         TEXT FILE INPUT/OUTPUT IS PERFORMED BY THE ROUTINES P.GETC
*         AND P.PUTC WHICH CORRESPOND TO THE PASCAL PROCEDURES GET AND
*         PUT.  FOR TEXT FILES, THE FILE VARIABLE POINTS TO THE CURRENT 
*         ELEMENT OF THE FILE IN THE CHARACTER BUFFER (EFET-12 THROUGH
*         EFET-2).  THE CURRENT ELEMENT OF THE FILE CAN THEREBY BE
*         LOCATED REGARDLESS OF WHETHER THE FILE IS A TEXT OR BINARY
*         FILE. 
* 
*         THE COMPILER GENERATES INLINE CODE FOR P.GETC AND P.PUTC, 
*         AND GENERATES CALLS TO P.GETCH AND P.PUTCH TO HANDLE THE
*         EXTRA WORK OF UNPACKING AND PACKING CHARACTERS. 
* 
*         WHEN P.GETC IS CALLED (OR PERFORMED INLINE), THE FILE POINTER 
*         IS ADVANCED.  IF ADVANCING THE FILE POINTER EMPTIES THE CHAR
*         BUFFER, OR ADVANCES TO THE END OF LINE, P.GETCH IS CALLED 
*         TO HANDLE THIS SPECIAL CASE.  IF THE POINTER IS ADVANCED TO 
*         A WORD WITH ONLY THE UPPER BIT SET, THIS INDICATES THAT THE 
*         END OF LINE HAS BEEN REACHED.  IN THIS CASE, P.GETCH SETS THE 
*         *EOLN* BIT IN EFET-1, SETS THE CURRENT ELEMENT TO BLANK, AND
*         SETS THE NEXT ELEMENT TO NEGATIVE ZERO.  IF THE FILE POINTER
*         IS ADVANCED TO A NEGATIVE ZERO WORD, THIS INDICATES THAT THE
*         CHARACTER BUFFER IS EMPTY, AND P.GETCH UNPACKS A NEW WORD 
*         FROM THE CIO CIRCULAR BUFFER.  BEFORE UNPACKING, P.GETCH
*         IN TURN CALLS P.GETB TO ADVANCE TO THE NEXT 10 CHARACTER WORD 
*         OF THE FILE.
* 
*         WHEN P.PUTC IS CALLED (OR PERFORMED INLINE), THE FILE POINTER 
*         IS ADVANCED.  IF THE POINTER IS ADVANCED TO A NEGATIVE ZERO 
*         WORD, THIS INDICATES THAT THE CHARACTER BUFFER IS FULL, AND 
*         P.PUTCH IS CALLED TO PACK THE TEN CHARACTERS FROM THE 
*         CHARACTER BUFFER INTO THE CIO CIRCULAR BUFFER.  AFTER 
*         PACKING, P.PUTCH IN TURN CALLS P.PUTB TO ADVANCE THE CIO FET
*         POINTERS. 
 PSYSTM   SPACE  4,10 
***       SEGMENTED FILES.
* 
*         IN ORDER TO PROVIDE A MECHANISM FOR MANIPULATING CDC KRONOS 
*         AND SCOPE MULTI-RECORD FILES (WHICH THE COMPILER USES FOR 
*         RELOCATABLE BINARIES), THE CONCEPT OF SEGMENTED FILES WAS 
*         INTRODUCED AS AN EXTENSION INCLUDED IN PASCAL 6000.  A PASCAL 
*         SEGMENT CORRESPONDS DIRECTLY TO A KRONOS OR SCOPE LOGICAL 
*         RECORD.  A NEW RESERVED WORD *SEGMENTED* WAS ADDED TO PASCAL
*         TO INTRODUCE A SEGMENTED FILE.  THE DECLARATION OF SUCH A 
*         FILE TYPE IS AS FOLLOWS.
* 
*                TYPE SEGFILE = SEGMENTED FILE OF SOMETYPE; 
* 
*         SEVERAL PREDEFINED PROCEDURES AND FUNCTIONS WERE ADDED OR 
*         ALTERED TO PROVIDE MECHANISMS FOR MANIPULATING SEGMENTED
*         FILES.  THESE ARE SUMMARIZED IN THE FOLLOWING TABLE.
* 
*         EOS(F)         A PREDICATE WHICH IS TRUE WHEN F IS POSITIONED 
*                        AT AN END OF SEGMENT (END OF RECORD).  EOS IS
*                        VERY SIMILAR TO EOF. 
* 
*         GETSEG(F)      ADVANCES F TO THE BEGINNING OF THE NEXT
*                        SEGMENT, AND PREPARES FOR READING. 
* 
*         GETSEG(F,N)    POSITIONS F TO THE BEGINNING OF THE NTH
*                        SEGMENT COUNTING FROM THE CURRENT SEGMENT. 
*                        N > 0 ADVANCES, N = 0 POSITIONS TO THE 
*                        BEGINNING OF THE CURRENT SEGMENT, AND N < 0
*                        BACKSPACES.  GETSEG(F,1) IS THE SAME AS
*                        GETSEG(F). 
* 
*         PUTSEG(F)      MARKS THE END OF SEGMENT WHILE WRITING F.
*                        THIS IS USED WHEN THE GENERATION OF A SEGMENT
*                        SEGMENT IS COMPLETED.
* 
*         REWRITE(F,N)   INITIATES WRITING AT THE BEGINNING OF THE
*                        NTH SEGMENT COUNTING FROM THE CURRENT ONE. 
*                        POSITIONING IS THE SAME AS FOR GETSEG(F,N).
*                        REWRITE(F,1) ADVANCES ONE SEGMENT, AND SO IS 
*                        -NOT- THE SAME AS REWRITE(F) WHICH REWINDS.
*                        NOTE THAT THIS -CANNOT- BE USED TO REWRITE 
*                        IN PLACE ON A SEGMENTED FILE.  WRITING ON SUCH 
*                        A FILE RELEASES THE REMAINDER OF THE FILE. 
* 
*         THE POSITIONING ROUTINES GETSEG(F,N) AND REWRITE(F,N) ARE NOT 
*         IMPLEMENTED WITH RANDOM ACCESS I/O, BUT RATHER WITH SKIPF AND 
*         SKIPB.  SINCE KRONOS AND SCOPE ARE ORIENTED TOWARD FORWARD
*         PROCESSING OF SEQUENTIAL FILES, POSITIONING IS LESS EFFICIENT 
*         FOR N <= 0 THAN IT IS FOR N > 0.
* 
*         FOR SEGMENTED FILES, THE EFET CONTAINS BOTH AN *EOS* BIT AND
*         AN *EOF* BIT.  TO KEEP PROCESSING SIMPLE, THE BIT POSITION
*         WHICH IS USED AS THE *EOF* BIT FOR NON-SEGMENTED FILES (BIT 
*         59) IS USED AS THE *EOS* BIT FOR SEGMENTED FILES. 
* 
*         RESET(F) AND REWRITE(F) ARE HANDLED IDENTICALLY FOR NON-
*         SEGMENTED AND SEGMENTED FILES, AS A  REWIND/SET-READ  AND 
*         REWIND/SET-WRITE  RESPECTIVELY.  GETSEG(F,N) AND REWRITE(F,N) 
*         HOWEVER, ARE DONE AS A  SKIP(N)/SET-READ  AND  SKIP(N)/SET- 
*         WRITE.  THE PROCESSING DONE IN SKIP IS SUMMARIZED IN THE
*         FOLLOWING TABLE.  IN THE TABLE, EOS AND EOF REFER TO THE
*         EOS AND EOF BITS IN THE EFET, AND EOR REFERS TO THE EOR 
*         BIT IN THE FET FIRST WORD (BIT 4).  N/A MEANS NOT APPLICABLE. 
* 
* 
*                          N < 1            N = 1            N > 1
*                          -----            -----            -----
*  NOT (EOS OR EOR)        N/A              SKIPF(1)         SKIPF(N) 
*        EOS OR EOR        N/A              NO ACTION        SKIPF(N-1) 
*           NOT EOF        SKIPB(1-N)       N/A              N/A
*               EOF        SKIPB(2-N)       N/A              N/A
 PSYSTM   SPACE  4,10 
***       DYNAMIC ALLOCATION (NEW AND DISPOSE). 
* 
*         IN PASCAL 6000, THE STANDARD PROCEDURE NEW IS USED TO 
*         ALLOCATE NODES IN HEAP STORAGE.  THE STANDARD PROCEDURE 
*         DISPOSE IS USED TO RETURN NODES TO THE FREE STORAGE POOL. 
*         THE FREE STORAGE POOL CONSISTS OF TWO PARTS.
*                1. THE SPACE BETWEEN THE HEAP AND THE STACK (BETWEEN 
*                   B6 AND B4) IS CALLED THE FREEBLOCK.  THIS SPACE IS
*                   AVAILABLE FOR ALLOCATION AS EITHER STACK OR HEAP. 
*                2. THE LIST OF FREE STORAGE EMBEDDED IN THE HEAP IS
*                   CALLED THE FREELIST.  THIS SPACE IS AVAILABLE FOR 
*                   ALLOCATION ONLY AS HEAP STORAGE.
* 
*         EACH NODE IN THE FREELIST HAS A HEADER OF THE FORM
* 
*                24/, 18/SIZE, 18/NEXT
* 
*         AND IS FOLLOWED BY SIZE-1 WORDS.  NEXT POINTS TO THE NEXT 
*         BLOCK OF FREE STORAGE, AND THUS FORMS THE FREELIST.  THE
*         FREELIST IS MAINTAINED IN ORDER OF DECREASING ADDRESS, AND
*         SO NEXT=0 IS USED FOR A NIL POINTER.
* 
*         NEW ALLOCATES STORAGE BY ATTEMPTING TO FIND A NODE IN THE 
*         FREELIST WHICH IS LARGE ENOUGH.  IF ONE IS AVAILABLE, THE 
*         UNUSED STORAGE REMAINS IN FREELIST.  IF THIS FAILS, THE 
*         STORAGE IS ALLOCATED FROM THE FREEBLOCK.
* 
*         DISPOSE RETURNS STORAGE BY SORTING THE GARBAGE NODE INTO THE
*         FREELIST.  IF POSSIBLE, ADJACENT FREE NODES ARE COALESCED,
*         AND IF THE GARBAGE NODE BORDERS ON THE FREEBLOCK, THAT NODE 
*         IS ADDED TO THE FREEBLOCK.
* 
*         IF A POINTER TYPE IS DECLARED 
* 
*                (*$T-*) TYPE P = ^T
* 
*         WITH THE RUN TIME TESTS OFF, IT IS A 17 BIT ADDRESS AND 
*         POINTS TO A NODE LARGE ENOUGH TO HOLD AN ELEMENT OF TYPE
*         T.  IF IT IS DECLARED 
* 
*                (*$T+*) TYPE P = ^T
* 
*         WITH THE TESTS ON (THE DEFAULT CONDITION), IT IS A 36 BIT 
*         QUANTITY OF THE FORM
* 
*                18/KEY, 18/ADDRESS 
* 
*         WHERE ADDRESS POINTS TO THE SECOND WORD OF A NODE WHICH IS
*         ONE WORD LARGER THAN NECESSARY TO HOLD AN ELEMENT OF TYPE T.
*         THE FIRST WORD OF THIS NODE HAS THE FORM
* 
*                24/0, 18/KEY, 18/ADDRESS 
* 
*         AND FOR A POINTER REFERENCE TO BE VALID, THE HEADER WORD
*         MUST BE BIT IDENTICAL TO THE POINTER. 
* 
*         THE HEADER WORD OF A CHECKED NODE AND THE VALUE OF THE
*         POINTER ARE SET BY NEW.  A UNIQUE KEY VALUE IS USED FOR EACH
*         NODE IN DYNAMIC STORAGE.  THE HEADER WORD OF A CHECKED NODE 
*         AND THE VALUE OF THE POINTER ARE CLEARED BY DISPOSE.
* 
*         THANKS TO PROFESSOR CHARLES FISCHER OF THE UNIVERSITY OF
*         WISCONSIN FOR SUGGESTING THIS METHOD OF APPLYING RUN TIME 
*         TESTS TO POINTER REFERENCES.
 PSYSTM   SPACE  4,10 
***       ACTIVATION RECORDS. 
* 
*         EACH ACTIVATION RECORD ON THE RUN TIME STACK CONSISTS OF
*         SEVERAL MAJOR PARTS:  
* 
*         1. THE HEADER INFORMATION WHICH INCLUDES RUN TIME POINTERS
*            AND IS USED TO MAINTAIN THE STACK.  THIS HEADER IS DESIGNED
*            SO THAT THE COMMON EXIT CODE MERELY DOES THE FOLLOWING:  
*                SB6    B5
*                JP     B5+1
*            AND THE STACK IS AUTOMATICALLY UPDATED.
*         2. VAR PARAMETERS, ONE WORD VALUE PARAMETERS, AND ADDRESSES 
*            OF MULTI-WORD VALUE PARAMETERS.  EACH FORMAL PARAMETER 
*            HAS A SINGLE WORD IN THIS SECTION. 
*         3. THE VALUES OF MULTI-WORD VALUE PARAMETERS.  THESE ARE
*            COPIED INTO PLACE BY THE PROCEDURE ITSELF. 
*         4. THE FUNCTION RESULT (NOT ALLOCATED FOR PROCEDURES).
*         5. LOCAL VARIABLES. 
*         6. RE-USED TEMPORARIES (ANONYMOUS VARIABLES). 
*         7. BUFFERS FOR FILES WHICH ARE LOCAL VARIABLES.  THESE ARE
*            PUSHED ONTO THE STACK BY P.OPEN. 
*         8. DYNAMIC TEMPORARIES USED TO SAVE PARAMETERS WHICH ARE
*            ALREADY LOADED INTO REGISTERS WHEN A PROCEDURE CALL
*            CONTAINS A FUNCTION REFERENCE IN THE PARAMETER LIST. 
*            THESE ARE PUSHED AND POPPED BY THE GENERATED CODE ITSELF.
* 
*         EACH ACTIVATION RECORD IN THE RUN TIME STACK HAS THE
*         FOLLOWING FORMAT. 
* 
*         STACK 
*         ADDRESS   CONTENTS
*         -------   --------
*         B5        EQ     EP+2 
*                   VFD    30/SL
*         B5+1      SB5    DL 
*                   EQ     RA 
*         B5+PFLC   FIRST PARAMETER 
*                      ...
*         B5+PFLC+N-1  NTH PARAMETER
*                   VALUES OF MULTI-WORD VALUE PARAMETERS 
*                   FUNCTION RESULT (FOR FUNCTIONS ONLY)
*                   VARIABLES 
*                   RE-USED TEMPORARIES 
*                   VALUES OF DYNAMIC ARRAY VALUE PARAMETERS
*                   BUFFERS 
*                   DYNAMIC TEMPORARIES 
*         B6        TOP OF STACK
* 
* 
*         THE HEADER INFORMATION CONTAINS FOUR POINTERS.  BECAUSE THE 
*         MAIN ACTIVATION IS THE FIRST ONE ON THE STACK AND THE MAIN
*         PROGRAM HAS NO RETURN ADDRESS, NONE OF THESE POINTERS ARE 
*         SET IN THE MAIN ACTIVATION RECORD.  IN ADDITION, MPLC IS THE
*         STACK OFFSET RATHER THAN PFLC.  THE FIRST FOUR WORDS OF THE 
*         MAIN ACTIVATION HAVE THE FOLLOWING VALUES:  
* 
*                *<MAINVARS>* 
*                15/0,15/2,15/2,15/ SIZE OF MAIN PROGRAM ACTIVATION 
*                PROGRAM NAME 
*                *PASCAL R.V*  (R = RELEASE, V = VERSION) 
* 
* 
*         EP     ENTRYPOINT ADDRESS OF THE CURRENT PROCEDURE. 
* 
*         SL     STATIC LINK.  THIS IS THE POINTER TO THE ACTIVATION
*                OF THE ROUTINE WHICH SURROUNDS THE CURRENT ONE.  IT
*                IS USED FOR ACCESS TO GLOBAL VARIABLES.  THE STATIC
*                LINK IS NOT PRESENT FOR ROUTINES WHICH ARE NESTED
*                IMMEDIATELY INSIDE THE MAIN PROGRAM. 
* 
*         DL     DYNAMIC LINK.  THIS IS THE POINTER TO THE ACTIVATION 
*                WHICH IMMEDIATELY PRECEDES THE CURRENT ONE ON THE
*                STACK.  IT IS USED FOR POPPING THE CURRENT ACTIVATION
*                OFF OF THE STACK.
* 
*         RA     RETURN ADDRESS.  THIS THE RETURN ADDRESS FOR THE 
*                CURRENT PROCEDURE. 
 PSYSTM   SPACE  4,10 
***       PARAMETER PASSING.
* 
*         UP TO 5 PARAMETERS MAY BE PASSED IN X-REGISTERS.  THIS IS 
*         BASED ON THE VALUE OF THE X-COMPILER OPTION SETTING AT THE
*         TIME OF THE PROCEDURE OR FUNCTION DECLARATION.  IF THE X
*         OPTION WAS SET TO N, THE FIRST N PARAMETERS ARE PASSED IN 
*         REGISTERS X0 TO X(N-1) AND THE COMMON ENTRY ROUTINE *P.PEN* 
*         STORES THEM INTO MEMORY STARTING AT (B6)+PFLC.  IF THERE ARE
*         MORE THAN N PARAMETERS, THE REST ARE PASSED THROUGH MEMORY
*         STARTING AT THE LOCATION WITH ADDRESS (B6)+N+PFLC.  IF THE
*         COMPILER OPTION SETTING X0 IS USED, ALL PARAMETERS ARE PASSED 
*         THROUGH MEMORY STARTING AT (B6)+PFLC.  THE PARAMETERS ARE 
*         ALWAYS ONE WORD AND MAY BE A VALUE OR AN ADDRESS.  THE
*         FOLLOWING LIST DESCRIBES THE VARIOUS KINDS OF PARAMETERS. 
* 
*         A) FOR A VAR PARAMETER, THE ADDRESS IS ALWAYS PASSED. 
* 
*         B) FOR A VALUE PARAMETER WHICH IS LESS THAN OR EQUAL TO ONE 
*            WORD IN SIZE, THE VALUE ITSELF IS PASSED.
* 
*         C) FOR A VALUE PARAMETER WHICH IS LARGER THAN ONE WORD, THE 
*            ADDRESS OF THE ACTUAL PARAMETER IS PASSED AND THE PREAMBLE 
*            CODE OF THE CALLED PROCEDURE OR FUNCTION COPIES IT ONTO
*            THE STACK. 
* 
*         D) FOR A PROCEDURE OR FUNCTION PARAMETER, THE ENTRY-POINT 
*            ADDRESS AND STATIC LINK ARE PASSED AS
* 
*                      24/0, 18/SL, 18/EP 
* 
*            THE STATIC LINK IS A POINTER TO THE VARIABLES FOR THE
*            PROCEDURE WHICH IMMEDIATELY SURROUNDS THE ACTUAL PROCEDURE 
*            OR FUNCTION PARAMETER.  SUCH A PROCEDURE IS CALLED BY
*            LOADING THE DESCRIPTOR INTO X5 AND RETURN JUMPING TO THE 
*            PSYSTM ROUTINE *P.VPE*.
* 
*         E) FOR A CONFORMANT ARRAY PARAMETER, THE ADDRESS OF THE ARRAY 
*            AND THE ADDRESS OF THE DESCRIPTOR ARE BOTH PASSED ONLY IF
*            THE PARAMETER IS THE FIRST IN THE PARAMETER GROUP (I.E., 
*            IF IT IS THE FIRST OF A GROUP OF PARAMETERS WHICH SHARE
*            A COMMON CONFORMANT-ARRAY-SCHEMA).  IF THE PARAMETER IS
*            NOT THE FIRST PARAMETER OF THE GROUP, THEN THE ADDRESS OF
*            THE ARRAY IS PASSED.  IF THE PARAMETER IS THE FIRST IN 
*            THE PARAMETER GROUP, THE ADDRESS OF THE ARRAY AND THE
*            ADDRESS OF THE DESCRIPTOR ARE PASSED AS
* 
*                      24/0, 18/DESCRIPTOR, 18/ARRAY
* 
*            THE DESCRIPTOR CONTAINS A THREE WORD BLOCK FOR EACH
*            CONFORMANT SUBSCRIPT WHICH HAS THE FORM
* 
*                      SIZE 
*                      HIGH SUBSCRIPT 
*                      LOW SUBSCRIPT
* 
*            FOR THE FIRST SUBSCRIPT, SIZE IS THE SIZE OF THE WHOLE 
*            ARRAY.  FOR THE REST OF THE SUBSCRIPTS, SIZE IS THE SIZE 
*            OF THE SUB-ARRAYS.  THE PREAMBLE CODE OF THE CALLED
*            PROCEDURE OR FUNCTION COPIES THE DESCRIPTOR INTO THE 
*            ACTIVATION RECORD, IF IT IS THE FIRST PARAMETER OF THE 
*            PARAMETER GROUP.  IF THE CONFORMANT ARRAY PARAMETER IS 
*            A *VAR* PARAMETER, THE ADDRESS OF THE ARRAY IS RESTORED
*            TO THE PARAMETER WORD.  IF THE PARAMETER IS PASSED BY
*            VALUE, THE ARRAY IS COPIED INTO THE LOCAL ACTIVATION 
*            RECORD AND THE ADDRESS OF THE LOCAL COPY IS STORED IN
*            THE PARAMETER WORD.
 PSYSTM   SPACE  4,10 
***       PROCEDURE/FUNCTION CODE FORMAT. 
* 
*         EACH PROCEDURE AND FUNCTION GENERATED BY THE PASCAL 6000
*         COMPILER CONSISTS OF SEVERAL MAJOR PARTS: 
* 
*         1. THE HEADER INFORMATION WHICH IS USED BY THE ERROR RECOVERY 
*            ROUTINES AND BY *PASCODE*, THE PASCAL 6000 DECODER.
*         2. PREAMBLE CODE WHICH MAINTAINS THE STACK, OPENS FILES, AND
*            (IN THE CASE OF THE MAIN PROGRAM) INITIALIZES THE RUN TIME 
*            ENVIRONMENT. 
*         3. THE BODY OF THE ROUTINE ITSELF.
*         4. POSTAMBLE CODE WHICH MAINTAINS THE STACK, CLOSES FILES,
*            AND (FOR THE MAIN PROGRAM) TERMINATES EXECUTION. 
*         5. CONSTANTS USED IN THE CURRENT ROUTINE WHICH ARE TOO LARGE
*            TO BE LOADED WITH IN LINE CODE.
*         6. POST-MORTEM DUMP INFORMATION.
*         7. A ZERO WORD TO FLAG THE END OF THE POST-MORTEM DUMP
*            INFORMATION. 
* 
*         THE HEADER INFORMATION IS ALWAYS PRESENT FOR THE MAIN PROGRAM 
*         BUT IS NOT PRESENT IN PROCEDURES AND FUNCTIONS WHEN THE POST- 
*         MORTEM DUMP INFORMATION IS SUPPRESSED ( P0 ) FOR THE ENTIRE 
*         PROGRAM.  IN ADDITION, WHEN  P0  IS SET FOR THE ENTIRE
*         PROGRAM, THE ZERO WORD IS NOT GENERATED AT THE END OF EVERY 
*         MODULE.  THIS ALLOWS A SAVINGS OF THREE WORDS FOR EACH
*         PROCEDURE AND FUNCTION IN THE COMPILER ITSELF.  SUPPRESSING 
*         POST-MORTEM DUMP INFORMATION FOR SPECIFIC PROCEDURES (AS IS 
*         DONE FOR THE LIBRARY ROUTINES) ALLOWS THESE ROUTINES TO BE
*         *TRANSPARENT* AS FAR AS THE POST-MORTEM DUMP IS CONCERNED.
*         SUCH ROUTINES WILL NOT APPEAR IN THE POST-MORTEM DUMP LIST
*         UNTIL AT LEAST ONE ROUTINE WITH  P+  OR  P-  HAS BEEN LISTED. 
*         IN THIS WAY, PASCAL USERS ARE NOT CONFUSED BY THE LISTING OF
*         PASCAL LIBRARY ROUTINES IN THE POST-MORTEM DUMP.  INSTEAD,
*         THE POST-MORTEM DUMP LISTS THE LINE NUMBER OF THE REFERENCE 
*         IN THE USER PROGRAM AS THE LOCATION OF THE ERROR. 
* 
* 
*         THE MAIN PROGRAM HAS THE FOLLOWING FORM.
* 
* 
*  REL. 
*  ADDR.  CONTENTS
*  -----  --------
*  0      1/H, 1/E, 10/0, 18/PMD, 12/0, 18/OUTPUT 
*  1      PROGRAM NAME, BLANK FILLED
*  2      1/P, 1/S, 1/0, 6/0, 6/0, 15/ENTRY, 15/CONST, 15/PINFO 
*  ENTRY  PREAMBLE CODE 
*         PROGRAM BODY
*         POSTAMBLE CODE
*  CONST  CONSTANTS 
*  PINFO  POST-MORTEM DUMP INFORMATION
*         ZERO WORD 
* 
* 
*         EACH PROCEDURE AND FUNCTION HAS THE FOLLOWING FORM. 
* 
* 
*  REL. 
*  ADDR.  CONTENTS
*  -----  --------
*  0      ROUTINE NAME, BLANK FILLED
*  1      1/P, 1/S, 1/F, 6/0, 6/COUNT, 15/ENTRY, 15/CONST, 15/PINFO 
*  ENTRY  PREAMBLE CODE 
*         PROCEDURE/FUNCTION BODY 
*         POSTAMBLE CODE
*  CONST  CONSTANTS 
*  PINFO  POST-MORTEM DUMP INFORMATION
*         ZERO WORD 
* 
* 
*         H      SET IF HEADER INFORMATION WILL BE PRESENT FOR
*                PROCEDURES AND FUNCTION, I.E. PMD IS NOT ENTIRELY
*                SUPPRESSED.
*         E      SET IF EXTERNAL FILES WERE PRESENT ON THE PROGRAM
*                HEADING. 
*         PMD    ADDRESS OF THE POST-MORTEM DUMP ROUTINE IF AVAILABLE.
*         OUTPUT ADDRESS OF THE OUTPUT EFET.
*         P      SET IF  P+  (FOR THE CURRENT MODULE).
*         S      SET IF  P0  (FOR THE CURRENT MODULE).
*         F      SET IF THE MODULE IS A FUNCTION. 
*         COUNT  USED BY THE POST-MORTEM DUMP ROUTINE TO COUNT THE
*                NUMBER OF TIMES THE ROUTINE HAS BEEN LISTED. 
*                THIS FIELD IS INITIALLY ZERO.
*         ENTRY  ADDRESS OF THE ENTRY POINT, RELATIVE TO THE
*                BEGINNING OF THE MODULE. 
*         CONST  ADDRESS OF THE CONSTANTS, RELATIVE TO THE BEGINNING
*                OF THE MODULE. 
*         PINFO  ADDRESS OF THE POST-MORTEM DUMP INFORMATION (IF
*                PRESENT), RELATIVE TO THE BEGINNING OF THE BLOCK.
* 
* 
*         THE PREAMBLE CODE IN PROCEDURES AND FUNCTIONS (AS OPPOSED 
*         TO THE MAIN PROGRAM) BEGINS WITH AN ENTRY/EXIT WORD 
*         (WHICH THE CALLER RETURN JUMPS TO).  THIS IS IMMEDIATELY
*         FOLLOWED BY A CALL TO THE PROCEDURE ENTRY ROUTINE:  
* 
* RTN     SUBR
* +       RJ     =XP.PEN
* -       VFD    1/TL,11/NP,18/SIZE 
* 
* 
*         TL     SET IF THIS PROCEDURE IS TOP-LEVEL.
*         NP     NUMBER OF PARAMETERS TO BE PUSHED ON THE STACK BY THE
*                COMMON ENTRY PROCEDURE, BIASED BY 2000B AND NEGATED
*                IF NOT TOP-LEVEL.
*         SIZE   THE SIZE OF THE CURRENT ACTIVATION.
* 
*         THIS UNUSUAL FORMAT ALLOWS EXTRACTING -NP WITH AN UNPACK
*         INSTRUCTION AFTER SHIFTING THE WORD 30 BITS.
* 
*         THE PREAMBLE CODE IN THE MAIN PROGRAM BEGINS WITH CODE TO 
*         SET UP PARAMETERS FOR AND CALL THE INITIALIZATION ROUTINE:  
* 
* PGM     SX5    A0 
*         SA0    LINE 
*         SB7    PARAMS 
*         SX6    PGM
*         SX7    PGM; 
*         SB3    WSP
*         RJ     =XP.INIT 
* 
* 
*         LINE   CURRENT PROGRAM LINE NUMBER. 
*         PARAMS NUMBER OF FORMAL CONTROL STATEMENT PARAMETERS. 
*         PGM    MAIN PROGRAM ENTRY ADDRESS.
*         PGM;   MAIN PROGRAM ACTIVATION RECORD ADDRESS.
*         WSP    WORKSPACE DESIGNATION.  SEE P.INIT FOR DETAILS ON
*                THIS VALUE.
* 
*         THIS INITIALIZATION PROLOGUE IS FOLLOWED BY CODE TO OPEN
*         ALL GLOBAL FILE VARIABLES.  IT IS DURING THIS PHASE 
*         OF INITIALIZATION THAT FILE-NAME SUBSTITUTION TAKES 
*         PLACE FOR ALL EXTERNAL PASCAL FILES (THOSE ON THE 
*         PROGRAM HEADER).
* 
* 
*         THE PREAMBLE CODE IS FOLLOWED BY THE ACTUAL CODE WHICH
*         COMPRISES THE PROCEDURE, FUNCTION, OR MAIN PROGRAM. 
* 
* 
*         FOR PROCEDURES AND FUNCTIONS, THE POSTAMBLE CODE IS 
*         SIMPLY A JUMP TO THE COMMON PROCEDURE EXIT ROUTINE: 
* 
*         EQ     =XP.PEX
* 
* 
*         FOR THE MAIN PROGRAM, THE POSTAMBLE CODE CONSISTS OF
*         TWO PARTS.  THE FIRST PART CLOSES ALL GLOBAL FILE 
*         VARIABLES, RETURNING THOSE WHICH ARE INTERNAL PASCAL
*         FILES.  THE SECOND PART OF THE POSTAMBLE CODE CALLS 
*         THE PROGRAM TERMINATION ROUTINE, P.END, WHICH ISSUES
*         STATISTICS MESSAGES TO THE DAYFILE AND ENDS THE PROGRAM.
* 
* 
*         THE CONSTANTS IMMEDIATELY FOLLOW THE POSTAMBLE CODE, AND
*         CONSIST OF ALL CONSTANTS THAT CANNOT BE GENERATED EASILY
*         BY IN-LINE CODE.  THESE CONSTANTS ARE TYPICALLY CHARACTER 
*         STRINGS, FLOATING POINT NUMBERS, SETS, AND INTEGERS THAT
*         OCCUPY MORE THAN 18 BITS. 
* 
* 
*         THE POST-MORTEM DUMP INFORMATION CONSISTS OF AN ENTRY FOR 
*         EACH VARIABLE THAT WILL BE LISTED IN THE POST-MORTEM DUMP.
*         CURRENTLY, ONLY SIMPLE VARIABLES AND ALFA VARIABLES ARE 
*         LISTED IN THE POST-MORTEM DUMP, AND SO THOSE ARE THE ONLY 
*         ONES WHICH HAVE ENTRIES IN THE PMD INFORMATION.  EACH ENTRY 
*         IS TWO WORDS LONG, AND HAS THE FOLLOWING FORMAT.
* 
* 
*         VARIABLE NAME, BLANK FILLED 
*         24/, 17/VTYPE, 1/I, 18/VADDR
* 
* 
*         VTYPE  TYPE OF THE VARIABLE, USING THE PMD TYPE CODES 
*                DEFINED IN COMSPAS.
*         I      SET IF THE VARIABLE IS INDIRECTLY ADDRESSED (E.G.
*                VAR PARAMETERS). 
*         VADDR  ADDRESS OF THE VARIABLE RELATIVE TO THE CURRENT
*                STACK SEGMENT. 
 COMSPAS  SPACE  4
          LIST   X
*CALL     COMSPAS 
 SYMBOLS  SPACE  4,10 
          LIST   *
 PRESET   SPACE  4,10 
          USE    PRESET 
 SCRATCH  SET    *           SCRATCH STORAGE
          USE    *
 PSYSTM   TITLE  MACROS AND MICROS. 
**        MACROS. 
 MACROS   SPACE  4,10 
          XTEXT  COMCMAC
 ENTER    SPACE  4,10 
**        ENTER - DECLARE SYSTEM ENTRY POINT. 
* 
* SYM     ENTER  P.SYM
* 
*         DECLARES THE EXTERNAL NAME P.SYM WITH THE 
*         INTERNAL NAME SYM.
  
  
          PURGMAC ENTER 
  
          MACRO  ENTER,A,B
 A        BSS    0
 B        EQU    A
          ENDM
 ROUTINE  SPACE  4,10 
**        ROUTINE - DECLARE SYSTEM ROUTINE. 
* 
* SYM     ROUTINE P.SYM 
* 
*         DECLARES THE EXTERNAL ROUTINE P.SYM WITH THE
*         INTERNAL NAME SYM.
  
  
          PURGMAC ROUTINE 
  
          MACRO  ROUTINE,A,B
 A        SUBR
 B        EQU    A
          ENDM
 SCRATCH  SPACE  4,10 
**        SCRATCH - DECLARE SCRATCH STORAGE.
* 
* TAG     SCRATCH N 
* 
*         DECLARES N WORDS OF SCRATCH STORAGE OVERLAYED ON
*         THE PRESET CODE.
  
  
          PURGMAC SCRATCH 
  
          MACRO  SCRATCH,TAG,N
 TAG      EQU    SCRATCH
 SCRATCH  SET    SCRATCH+N
          ERRNG  PRSL-SCRATCH STORAGE EXCEEDS PRESET. 
          ENDM
 MICROS   SPACE  4,10 
**        MICROS. 
 EMSG     SPACE  4,10 
**        EMSG - ERROR DAYFILE MESSAGE OPTION.
  
  
 EMSG     MICRO  1,,*3*      ERROR MESSAGES TO USER DAYFILE 
 IMSG     SPACE  4,10 
**        IMSG - INFORMATIVE DAYFILE MESSAGE OPTION.
  
  
 IMSG     MICRO  1,,*3*      INFORMATIVE MESSAGES TO USER DAYFILE 
  
          EXT    CMM.ALF     EXTERNAL CMM.ALF MACRO 
 PSYSTM   TITLE  TABLES.
**        TABLES. 
 TGVR     SPACE  4,10 
**        TGVR - TABLE OF GLOBAL VARIABLES. 
* 
*         THIS TABLE INCLUDES RUN TIME SYSTEM VARIABLES THAT ARE
*         MAINTAINED ACROSS THE ENTIRE EXECUTION OF A PASCAL PROGRAM. 
*         IN OTHER WORDS, THEY ARE GLOBAL WITH RESPECT TO THE USER
*         PROGRAM.
  
  
 TGVR     ENTER  P.GLOBL
          LOC    0
  
 FL       BSS    1           CURRENT FIELDLENGTH
 FLIST    VFD    1/1,41/0,18/0  FREELIST
 KEY      DATA   1           KEY FOR POINTER CHECKS 
 FORT     DATA   0           FORTRAN CALL FLAG
 PTRS     BSS    1           FOR SAVING GLOBAL POINTERS (B4,5,6)
 MAIN     BSS    1           MAIN PROGRAM ENTRY POINT ADDRESS 
 MVAR     BSS    1           MAIN ACTIVATION RECORD ADDRESS 
 PMD      BSS    1           ADDRESS OF PASCPMD (UPPER 30 BITS) 
 OUTP     EQU    PMD         OUTPUT EFET ADDRESS (LOWER 30 BITS)
 MINFS    BSS    1           MINIMUM FREE WORKSPACE 
  
          LOC    *O 
 TERA     SPACE  4,10 
**        TERA - TABLE OF ERROR RECOVERY ADDRESSES. 
* 
*         THIS VECTOR IS JUMPED TO WHEN PASCAL DETECTS A RUN TIME 
*         ERROR.  A0 WILL CONTAIN THE LINE NUMBER AT THIS TIME IF 
*         P+ IS ON. 
  
  
 TERA     ENTER  P.TERA      TABLE OF ERROR RECOVERY ADDRESSES
          LOC    0
  
 ASSERR   SX0    MSGD        VALUE OUT OF RANGE 
          EQ     ABT
  
 INXERR   SX0    MSGE        INDEX OR CASE VAR OUT OF RANGE 
          EQ     ABT
  
 DIVERR   SX0    MSGF        DIVISION BY ZERO 
          EQ     ABT
  
 WSFERR   SX0    MSGG        WORKSPACE IS FULL
          EQ     ABT
  
 OVLERR   SX0    MSGN        INTEGER OVERFLOW 
          EQ     ABT
  
 PTRERR   SX0    MSGH        INCORRECT POINTER REFERENCE
          EQ     ABT
  
 MODERR   SX0    MSGAD       MOD BY NON-POSITIVE MODULO 
          EQ     ABT
  
 EOLERR   SX0    MSGAE       TRIED TO CHECK EOLN WHILE AT EOS/EOF 
          EQ     ABT
  
          LOC    *O 
 TMSG     SPACE  4,10 
**        TMSG - TABLE OF DAYFILE MESSAGES. 
* 
*         NOTE THAT THE LENGTHS OF THE MESSAGES MUST BE EVEN. 
  
  
 MSGA     DATA   C* AT LINE +++++ IN --------- //////////.* 
 MSGB     DATA   C* IN --------- //////////.* 
 MSGD     DATA   C* VALUE OUT OF RANGE.*
 MSGE     DATA   C* INDEX OR CASE EXPR OUT OF RANGE. *
 MSGF     DATA   C* DIVISION BY ZERO.*
 MSGG     DATA   C* WORKSPACE IS FULL. *
 MSGH     DATA   C* INCORRECT POINTER REFERENCE. *
 MSGI     DATA   C* TOO MANY PROGRAM PARAMETERS. *
 MSGJ     DATA   C* HALT.*
 MSGK     DATA   C* LINELIMIT EXCEEDED ON =======. *
 MSGL     DATA   C* TRIED TO READ ======= PAST EOS/EOF.*
 MSGM     DATA   C* TRIED TO WRITE ======= WITHOUT REWRITE.*
 MSGN     DATA   C* INTEGER LARGER THAN MAXINT.*
 MSGO     DATA   C* BUFFER TOO SMALL ON =======. *
 MSGP     DATA   C* XXXXXXB LOAD FL,   XXXXXXB RUN FL. *
 MSGQ     DATA   C* WORKSPACE EXCEEDS VALIDATED FL.*
 MSGR     DATA   C* PASCAL SYSTEM ERROR. *
 MSGS     DATA   C* NON-DIGIT FOUND WHILE READING =======. *
 MSGT     DATA   C* VALUE TOO LARGE WHILE READING =======. *
 MSGU     DATA   C* INTERNAL FILE LIMIT EXCEEDED.*
 MSGV     DATA   C* INCOMPATIBLE VERSION OF PASCLIB USED.*
 MSGAA    DATA   C* AAAAA.BBB CP SECS, XXXXXXB CM USED.*
 MSGAB    DATA   C* TRIED TO READ ======= WITHOUT RESET. *
 MSGAC    DATA   C* UNDEFINED VALUE TO WRITE ON =======. *
 MSGAD    DATA   C* MOD BY NON-POSITIVE MODULO.*
 MSGAE    DATA   C* TRIED TO CHECK EOLN WHILE AT EOS/EOF.*
 TIOE     SPACE  4,10 
**        TIOE - TABLE OF INPUT/OUTPUT ERRORS.
  
  
 TIOE     BSS    0
          LOC    0
  
 IOEA     CON    MSGK        LINELIMIT EXCEEDED ON XXXXXXX. 
 IOEB     CON    MSGL        TRIED TO READ XXXXXXX PAST EOS/EOF.
 IOEC     CON    MSGM        TRIED TO WRITE XXXXXXX WITHOUT REWRITE.
 IOED     CON    MSGO        BUFFER TOO SMALL ON XXXXXXX. 
 IOEE     CON    MSGS        NON-DIGIT FOUND WHILE READING XXXXXXX. 
 IOEF     CON    MSGT        VALUE TOO LARGE WHILE READING XXXXXXX. 
 IOEG     CON    MSGAB       TRIED TO READ XXXXXXX WITHOUT RESET. 
 IOEH     CON    MSGAC       UNDEFINED VALUE TO WRITE ON XXXXXXX. 
  
          LOC    *O 
 PSYSTM   TITLE  RUN TIME ROUTINES. 
 P.CLOCK  SPACE  4,12 
**        P.CLOCK - RETURN CP TIME IN MILLISECONDS. 
* 
*         ENTRY  NONE.
* 
*         EXIT   (X6) = CP TIME IN MILLISECONDS.
* 
*         USES   A - 1, 2, 6. 
*                B - NONE.
*                X - 1, 2, 3, 4, 6, 7.
* 
*         CALLS  SYS=.
* 
*         MACROS TIME.
  
  
 CLK      ROUTINE P.CLOCK    ENTRY/EXIT 
          TIME   CLKA 
          MX1    -12
          SA2    CLKA 
          MX3    -24
          BX4    -X1*X2      0 <= MILLISECONDS < 1000D
          AX2    12 
          SX6    1000D
          BX3    -X3*X2      SECONDS
          IX7    X6*X3
          NO
          IX6    X4+X7       TOTAL MILLISECONDS 
          EQ     CLKX        RETURN 
  
 CLKA     BSS    1           TEMPORARY
 P.CLOSE  SPACE  4,20 
**        P.CLOSE - CLOSE FILE. 
* 
*         IF A PASCAL INTERNAL FILE, RETURN IT, ELSE IF AN OUTPUT FILE, 
*         FLUSH THE BUFFER.  NOTE THAT THIS ROUTINE ASSUMES THAT
*         EXTERNAL FILES (THAT ARE NOT RE-OPENED INTERNAL FILES)
*         MAY NOT BE DYNAMIC, AND THAT THEY NEED NOT BE RECALLED. 
* 
*         ENTRY  (B2) <= 0 IF FILE IS A LOCAL VARIABLE, 
*                     >  0 IF FILE IS A DYNAMIC VARIABLE. 
*                (A1) =  EFET ADDRESS.
*                (X1) =  ((A1)).
* 
*         EXIT   (B2)    UNCHANGED. 
* 
*         USES   A - 1, 2, 3, 4, 5, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  CIO=, DSP, FOB, WNB=.
* 
* (NOS)   MACROS RECALL, RETURN.
  
  
 CLO1     RETURN X2,R 
 CLO2     LE     B2,B0,CLOX  IF NOT DYNAMIC 
          SA3    X2+4        LIMIT
          SA1    X2+B1       FIRST
          IX3    X3-X1
          SX1    X1          ISOLATE ADDRESS FOR DSP
          SB7    X3          BUFFER LENGTH
          RJ     DSP         DISPOSE THE BUFFER 
  
 CLO      ROUTINE P.CLOSE 
          LX1    59-51
          SX2    A1+B1
          PL     X1,CLO1     IF INTERNAL FILE 
          RJ     FOB         FLUSH OUTPUT BUFFER
          SA1    X2-1        EFET 
          NO
          LX1    59-53
          PL     X1,CLOX     IF PLAIN EXTERNAL FILE 
          RECALL X2          IF RE-OPENED 
          EQ     CLO2 
 P.DATE   SPACE  4,12 
**        P.DATE - RETURN SYSTEM DATE.
* 
*         ENTRY  (X1) = ADDRESS TO RETURN SYSTEM DATE.
* 
*         EXIT   ((X1)) = SYSTEM DATE.
* 
*         USES   A - 1, 6.
*                B - NONE.
*                X - 1, 6.
* 
*         CALLS  SYS=.
* 
*         MACROS DATE.
  
  
 DTE      ROUTINE P.DATE     ENTRY/EXIT 
          DATE   X1 
          EQ     DTEX        RETURN 
 P.DISP   SPACE  4,12 
**        P.DISP - DEALLOCATE HEAP STORAGE. 
* 
*         ENTRY  (X1) = POINTER VALUE ($T-).
*                (B7) = SIZE OF NODE TO DEALLOCATE. 
* 
*         EXIT   NODE DEALLOCATED.
* 
*         USES   X - ALL. 
*                A - 2, 3, 5, 6.
*                B - 7. 
* 
*         CALLS  ABT. 
* 
*         MACROS NONE.
  
  
*         LINK GARBAGE NODE INTO THE FREELIST.
  
 DSP6     IX7    X7-X1       SET SIZE OF GARBAGE NODE 
          SX5    X3 
          LX7    18 
          BX7    X7+X4       SET NEXT OF GARBAGE NODE 
          SA7    X1          STORE HEADER OF GARBAGE NODE 
          BX3    X3-X5
          IX6    X3+X1       SET PREVIOUS NEXT TO ADDRESS OF GARBAGE
          SA6    A3 
  
 DSP      ROUTINE P.DISP
          SA5    TGVR+FL     CURRENT FIELD LENGTH 
          SX3    B4+         END OF HEAP
          IX2    X1-X3
          SX7    X1+B7       LWA+1 OF GARBAGE NODE
          IX6    X5-X7
          BX0    X6+X2
          NG     X0,TERA+PTRERR  IF NODE IS NOT IN THE HEAP 
          LE     B7,B0,DSPX  IF SIZE <= 0 
          SA2    TGVR+FLIST  INITIATE SCAN OF FREELIST
  
*         SORT GARBAGE NODE INTO FREELIST.
  
 DSP1     SA3    A2          REMEMBER PREVIOUS NODE 
          SX4    X2 
          SA2    X2          ADVANCE TO (NEW) CURRENT NODE
          IX5    X7-X4
          NG     X5,DSP1     IF POSITION IN FREELIST NOT FOUND
  
*         CORRECT POSITION FOUND, NOW TRY TO COALESCE.
  
 DSP2     ZR     X4,DSP5     IF END OF FREELIST REACHED 
          SX0    X2          ADDRESS OF NEXT NODE 
          AX2    18          SIZE OF CURRENT NODE 
          IX5    X4+X2       LWA+1 OF CURRENT NODE
          IX2    X5-X1
          NG     X2,DSP5     IF NODES CANNOT BE COALESCED 
          IX6    X4-X1
          PL     X6,DSP3     IF POINTER <= ADDRESS OF CURRENT NODE
          SX1    X4          SET POINTER TO ADDRESS OF CURRENT NODE 
 DSP3     IX6    X7-X5
          PL     X6,DSP4     IF LWA+1 GARBAGE >= LWA+1 CURRENT
          BX7    X5          SET LWA+1 GARBAGE TO LWA+1 CURRENT 
 DSP4     SA2    X0          ADVANCE TO NEXT NODE 
          SX4    X0          ADDRESS OF (NEW) CURRENT NODE
          EQ     DSP2        GO TRY TO COALESCE MORE
  
*         TRY TO ADD GARBAGE TO FREEBLOCK.
  
 DSP5     SB7    X1          POINTER
          GT     B7,B4,DSP6  IF POINTER > END OF HEAP 
          SX5    X3 
          SB4    X7          ADD NODE TO THE FREEBLOCK
          BX6    X3-X5
          SA6    A3+         SET NEXT OF PREVIOUS NODE TO 0 
          EQ     DSPX 
 P.DISPD  SPACE  4,12 
**        P.DISPD - TEST AND DEALLOCATE HEAP STORAGE. 
* 
*         ENTRY  (X1) = EXTENDED POINTER VALUE ($T+). 
*                (B7) = SIZE-1 OF NODE TO DEALLOCATE. 
* 
*         EXIT   NODE DEALLOCATED.
* 
*         USES   X - ALL. 
*                A - 2, 3, 4, 5, 6. 
*                B - 7. 
* 
*         CALLS  ABT, DSP.
* 
*         MACROS NONE.
  
  
 TDS1     SB7    B7+B1       ACTUAL LENGTH OF NODE
          SA6    X1          ZERO FIRST WORD OF NODE
          RJ     DSP         DEALLOCATE THE NODE
  
 TDS      ROUTINE P.DISPD 
          SA2    TGVR+FL     CURRENT FIELD LENGTH 
          BX3    X1          SAVE ORIGINAL
          SX1    X1-1        ADDRESS OF ACTUAL NODE.
          IX5    X1-X2
          BX6    -X5+X1 
          NG     X6,TERA+PTRERR  IF POINTER NOT IN FIELD LENGTH 
          SA4    X1          GET KEY FROM NODE
          IX6    X4-X3
          ZR     X6,TDS1     IF KEYS MATCH
          EQ     TERA+PTRERR  INCORRECT POINTER REFERENCE 
 P.END    SPACE  4,12 
**        P.END - RETURN CONTROL TO THE OPERATING SYSTEM. 
* 
*         ENTRY  NONE.
* 
*         EXIT   TO OPERATING SYSTEM. 
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  ISM, SYS=. 
* 
*         MACROS ENDRUN.
  
  
 END      ROUTINE P.END 
          RJ     ISM         ISSUE STATISTICS MESSAGE 
          ENDRUN
 P.GETB   SPACE  4,12 
**        P.GETB - GET BINARY.
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
*                (X3) = FILE POINTER, IF NOT EOS/EOF. 
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 3, 7.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  CIO=, IOE, RCL=, SWS.
* 
*         MACROS READ, RECALL.
  
  
 GTB9     BX7    -X7+X6 
          AX0    1           (LIMIT - FIRST) / 2
          NG     X7,GTBX     IF FET BUSY OR EOR/EOF/EOI 
          SB3    X0+
          GE     B7,B3,GTBX  IF BUFFER HALF FULL
          READ   X2 
  
 GTB      ROUTINE P.GETB
          SA3    A1+4        OUT
          LX1    59-56
          SX2    A1+B1       FET
          SA4    A3+B1       LIMIT
          NG     X1,GTB8     IF FILE WAS NOT RESET
          LX1    56-59
          NG     X1,GTB7     IF READ AT EOS/EOF 
          SB3    X1          LRL
          SX7    X3+B3       OUT + LRL
          SX4    X4          LIMIT
          SA1    X2+B1       FIRST
          IX3    X7-X4       (OUT + LRL) - LIMIT
          SX6    X1          FIRST
          IX0    X4-X6       LIMIT - FIRST
          PL     X3,GTB1     IF OUT = LIMIT 
          SX6    X7          OUT + LRL
 GTB1     SA6    A3          ADVANCE OUT
          BX3    X6 
          SA6    X2-2        ADVANCE FILE POINTER 
 GTB2     SA1    X2          FET
          LX7    X1          SAVE FET 
          SA1    A3-B1       IN 
          IX6    X1-X3       IN - OUT 
          PL     X6,GTB3     IF IN >= OUT 
          IX6    X6+X0
 GTB3     SB7    X6          FULL SPACE IN BUFFER 
          LX7    59-0        COMPLETE BIT 
          SX6    X7 
          LX6    0-4         EOR BIT
          GE     B7,B3,GTB9  IF BUFFER NOT EMPTY
          SX1    X2-1        ADDRESS OF EFET
          NG     X7,GTB4     IF FET NOT BUSY
          RECALL
          EQ     GTB2        TRY AGAIN
  
 GTB4     PL     X6,GTB6     IF NOT EOR 
          MX4    2
          BX4    X4*X6       EXTRACT EOR/EOF BITS 
          MX6    -4 
          LX7    60-59+0-14  RIGHT ADJUST EOR LEVEL NUMBER
          BX6    -X6*X7      EOR LEVEL
          SB7    X6 
          EQ     B7,B1,GTB6  IF LEVEL 1 EOR (INTERACTIVE INPUT) 
          SA1    X1          EFET 
          LX1    59-57
          NG     X1,GTB5     IF SEGMENTED FILE
          LX7    X4,B1
          AX4    X7,B1
 GTB5     PL     X4,GTB6     IF NOT EOS/EOF 
          SA1    X2-1        EFET 
          BX6    X1+X4
          SA6    A1          SET EOS AND/OR EOF BITS
          EQ     GTBX        RETURN 
  
 GTB6     READ   X2          FILL THE BUFFER
          EQ     GTB2        TRY AGAIN
  
 GTB7     SX1    IOEB        READ AT EOS/EOF ON XXXXXXX.
          EQ     IOE1        ISSUE INPUT/OUTPUT ERROR 
  
 GTB8     SX1    IOEG        TRIED TO READ XXXXXXX WITHOUT RESET
          EQ     IOE1        ISSUE INPUT/OUTPUT ERROR 
 P.GETC   SPACE  4,16 
**        P.GETC - GET CHARACTER. 
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 3, 7.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  GCH. 
* 
*         MACROS NONE.
  
  
 GTC      ROUTINE P.GETC
          SA3    X1+B1       NEW CHARACTER OR END OF BUFFER 
          SX6    X1+B1       ADVANCE POINTER
          SA6    A1+         UPDATE POINTER 
          SX2    A1+2        FET ADDRESS
          PL     X3,GTCX     IF BUFFER NOT EMPTY
          SX7    GTCX        RETURN ADDRESS 
          EQ     GCH         CALL HELPER TO FILL BUFFER 
 P.GETCH  SPACE  4,12 
**        P.GETCH - GET CHARACTER HELPER. 
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (A3) = LOWER 18 BITS OF ((A1)) IF EOLN TO BE SET.
*                (X1) < 0 IF READ WITHOUT RESET ERROR.
*                (X3) = 1/1, 59/0 IF EOLN TO BE SET.
*                     = 60/-0     IF BUFFER TO BE FILLED. 
*                (X6) = ((A1)) ONLY NECESSARY IF EOLN TO BE SET.
*                (X7) = RETURN ADDRESS. 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 3, 7.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  CIO=, GTB, WNB=. 
* 
*         MACROS READ, RECALL.
  
  
 GCH8     SA1    A1+B1       EFET 
          RJ     GTB         GET NEXT WORD
          SA1    X2-1        EFET 
          SX6    X2-13       FWA CHARACTER BUFFER 
          MX0    -6 
          NG     X1,GCH7     IF EOS/EOF ENCOUNTERED 
          SA6    A1-B1       SET FILE POINTER INTO CHARACTER BUFFER 
          SA4    X3          GET CURRENT WORD 
          SB3    X6 
          ZR     X4,GCH6     IF ZERO (WILL RETURN IF -0)
 GCH9     LX4    6
          BX6    -X0*X4 
          LX4    6
          SA6    B3          STORE CHARACTER 1
          BX7    -X0*X4 
          LX4    6
          SA7    A6+B1       STORE CHARACTER 2
          BX6    -X0*X4 
          LX4    6
          SA6    A7+B1       STORE CHARACTER 3
          BX7    -X0*X4 
          LX4    6
          SA7    A6+B1       STORE CHARACTER 4
          BX6    -X0*X4 
          LX4    6
          SA6    A7+B1       STORE CHARACTER 5
          BX7    -X0*X4 
          LX4    6
          SA7    A6+B1       STORE CHARACTER 6
          BX6    -X0*X4 
          LX4    6
          SA6    A7+B1       STORE CHARACTER 7
          BX7    -X0*X4 
          LX4    6
          SA7    A6+B1       STORE CHARACTER 8
          BX6    -X0*X4 
          LX4    6
          SA6    A7+B1       STORE CHARACTER 9
          BX7    -X0*X4 
          SA7    A6+B1       STORE CHARACTER 10 
          ZR     X7,GCH1     IF POSSIBLE EOL IN THIS WORD 
 GCH10    SA1    GCHB 
          SB7    X1+         RETURN ADDRESS 
          JP     B7 
  
 GCH      ENTER  P.GETCH
          SA7    GCHB        SAVE RETURN ADDRESS
          ZR     X3,GCH8     IF CHARACTER BUFFER TO BE FILLED 
          BX6    X6+X3
          MX7    60 
          NG     X1,GCH8     IF READ WITHOUT RESET, LET GTB ISSUE ERROR 
          SA6    A1+         SET EOLN FLAG
          SX6    1R 
          SA7    A3+B1       SET END OF CHARACTER BUFFER SENTINAL 
          SA6    A3          SET CURRENT CHARACTER TO BLANK 
          EQ     GCH10
  
 GCH1     ZR     X6,GCH5     IF EOL IN THIS WORD
          RECALL X2          WAIT I/O COMPLETE
          SA3    X2+4        LIMIT
          SA4    A3-B1       OUT
          SX0    X3          LIMIT
 GCH2     SX6    X4+B1       ADVANCE OUT
          SA3    A4-1        IN 
          IX7    X0-X6       LIMIT - OUT
          NZ     X7,GCH3     IF OUT <> LIMIT
          SA1    X2+B1       FIRST
          SX6    X1          OUT BECOMES FIRST
 GCH3     IX7    X6-X3       OUT - IN 
          NZ     X7,GCH4     IF BUFFER NOT EMPTY
          SA1    X2          FET
          NO
          LX1    59-4 
          NG     X1,GCH10    IF EOR/EOF/EOI, THIS IS ZERO CHARACTER 
          READ   X2,R        FILL THE BUFFER
          EQ     GCH2        TRY AGAIN
  
 GCH4     SA1    X6          LOOK AHEAD ONE WORD
          CX3    X1 
          NZ     X3,GCH10    IF NOT ZERO WORD, THIS IS ZERO CHARACTER 
          SA1    X2-1        EFET 
          RJ     GTB         SKIP ZERO WORD 
          SX6    X2-13       FWA CHARACTER BUFFER 
          MX7    1
          NO
          SA6    X2-2        RESET FILE POINTER 
          SA7    X2-4        SET EOL FLAG 
          EQ     GCH10
  
 GCH5     SX7    B1 
          SA3    GCHA        40404040404040404040B
          IX7    X4-X7
          BX1    -X7+X4      FORM MASK FOR UPPER NON-ZERO CHARACTERS
          MX6    1
          BX3    X1*X3
          CX7    X3          NUMBER OF NONZERO CHARACTERS 
          SA6    B3+X7       SET EOL FLAG 
          EQ     GCH10
  
 GCH6     NG     X4,GCH9     IF TEN SEMI-COLONS FOOLED GCH
 GCH7     SX7    1R 
          MX1    1
          SA7    X6          SET CURRENT CHARACTER TO BLANK 
          BX6    X6+X1       SET EOLN BIT 
          MX7    60 
          SA6    A1-B1       SET FILE POINTER 
          SA7    X6+B1       SET END OF BUFFER SENTINAL 
          EQ     GCH10
  
 GCHA     DATA   40404040404040404040B
 GCHB     SCRATCH 1 
 P.GETLN  SPACE  4,12 
**        P.GETLN - GET LINE. 
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  GCH, GTB.
* 
*         MACROS NONE.
  
  
 GTL      ROUTINE P.GETLN    ENTRY/EXIT 
          NG     X1,GTL3     IF EOLN
          SB7    X1+1 
 GTL1     SA3    B7          ADVANCE TO NEXT CHARACTER
          SB7    B7+B1
          PL     X3,GTL1     IF NOT END OF CHARACTER BUFFER 
          NZ     X3,GTL3     IF EOLN FOUND
          MX5    48 
 GTL2     SA1    A1+B1       EFET 
          RJ     GTB         GET BINARY 
          SA1    X2-2        POINTER
          SA3    X1 
          BX1    -X5*X3 
          NZ     X1,GTL2     IF NOT EOLN
 GTL3     SA2    GTLX        RETURN ADDRESS 
          MX3    60          SET TO FILL CHARACTER BUFFER 
          AX2    30 
          SX7    X2          RETURN ADDRESS 
          EQ     GCH
 P.GETS   SPACE  4,14 
**        P.GETS - GET SEGMENT. 
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
*                (X2) = NUMBER OF SEGMENTS. 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 7. 
*                X - ALL. 
* 
*         CALLS  SKP, SRS.
* 
*         MACROS NONE.
  
  
 GTS      ROUTINE P.GETS
          RJ     SKP         SKIP RECORDS 
          RJ     SRS         SET READ STATUS
          EQ     GTSX        RETURN 
 P.GTO    SPACE  4,10 
***       P.GTO - GOTO EXTERNAL LABEL.
* 
*         POP ACTIVATION RECORDS FROM STACK UNTIL THE APPROPRIATE ONE 
*         IS FOUND.  THIS INCLUDES FIXING UP THE ACTIVATION POINTERS
*         FOR ALL PROCEDURES WHOSE ACTIVATIONS ARE POPPED.
* 
*         ENTRY  (B3) = ACTIVATION POINTER OF DESTINATION LABEL.
*                (B4) = TOP OF HEAP.
*                (B5) = CURRENT ACTIVATION POINTER. 
*                (B6) = TOP OF STACK. 
*                (B7) = ADDRESS OF DESTINATION LABEL. 
* 
*         EXIT   (MINFS) = UPDATED TO MINIMUM FREE WORKSPACE. 
*                (B5) = (B3)
*                (B6) = NEW TOP OF STACK. 
*                JUMPS TO (B7). 
* 
*         USES   A - 1, 2, 6, 7.
*                B - 5, 6.
*                X - 1, 2, 6, 7.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 GTO      ROUTINE P.GTO      ENTRY
          SA1    TGVR+MINFS  PREVIOUS MINIMUM FREE WORKSPACE (PMFW) 
          SX2    B4-B6       CURRENT FREE WORKSPACE (CFW) 
          IX6    X1-X2
          BX7    X6 
          AX6    60 
          BX0    X6*X7
          IX6    X2+X0       MIN(CFW,PMFW)
          SA6    TGVR+MINFS  PMFW := MIN(CFW,PMFW)
 GTO1     SA1    B5+B1       SB5 DL / EQ RA 
          SA2    B5          EQ EP+2 / SL 
          AX1    30 
          SB6    B5          POP ACTIVATION FROM STACK
          SB5    X1 
          NE     B5,B3,GTO1  IF APPROPRIATE ACTIVATION NOT FOUND
          JP     B7          EXIT TO LABEL
 P.HALT   SPACE  4,14 
**        P.HALT - HALT WITH A MESSAGE. 
* 
*         ENTRY  (A0) = LINE NUMBER IF PMD AVAILABLE. 
*                (X1) = MESSAGE ADDRESS.
*                       OR 0 FOR * HALT.*.
*                (X2) = MESSAGE LENGTH. 
* 
*         EXIT   TO ABT.
* 
*         USES   A - 1, 2, 6, 7.
*                B - 7. 
*                X - 0, 1, 2, 6, 7. 
* 
*         CALLS  ABT, TMS.
* 
*         MACROS NONE.
  
  
 HLT      ROUTINE P.HALT
          ZR     X1,HLT1     IF NO MESSAGE PARAMETER
          RJ     TMS         TERMINATE MESSAGE STRING 
          SX0    X1 
          EQ     ABT         EXIT TO COMMON ERROR ROUTINE 
  
 HLT1     SX0    MSGJ        HALT 
          EQ     ABT         EXIT TO COMMON ERROR ROUTINE 
 P.INIT   SPACE  4,24 
**        P.INIT - INITIALIZE THE PASCAL RUN TIME SYSTEM. 
* 
*         ENTRY  (LWPR) = LWA+1 LOADED. 
*                (B3) = WORK SPACE DESIGNATION.  (NOTE: FL IS THE LAST
*                       CONTROL CARD FIELD LENGTH.) 
*                MODIFIED TO USE CMM.ALF MACRO INSTEAD OF MEMORY MACRO
*                     >0 : RFL TO WSA(B3) 
*                     <0 : IF FL < (LWPR(B6) - WSA(B3)),
*                             THEN RFL TO (FL(B4) - LWPR(B6)) 
*                (B7) = NUMBER OF FORMAL CONTROL CARD PARAMETERS. 
*                (X5) = CURRENT FIELD LENGTH. 
*                (X6) = ADDRESS OF MAIN ENTRY POINT.
*                (X7) = ADDRESS OF MAIN ACTIVATION RECORD.
* 
*         EXIT   FL SET AS SPECIFIED. 
*                CONTROL CARD PARAMS CLEANED UP.
*                OUTPUT FILE MARKED NOT OPENED. 
*                (TGVR+FL) = ACTUAL FL. 
*                (B1) = 1.
*                (B4) = ACTUAL FL.
*                (B5) = ADDRESS OF MAIN ACTIVATION RECORD.
*                (B6) = (LWPR). 
* 
*         USES   ALL REGISTERS. 
* 
* (NOS)   CALLS  CAD, CPM=, MSG=, SYS=. 
* 
*         MACROS ABORT, GETFLC, MEMORY, MESSAGE.
  
  
          USE    PRESET 
  
 PRS      ROUTINE P.INIT
          SB1    1
          SA6    TGVR+MAIN   SAVE ADDRESS OF MAIN ENTRY POINT 
          SA7    TGVR+MVAR   SAVE ADDRESS OF MAIN ACTIVATION
          SA1    LWPR        LWA+1 LOADED 
          SB5    X7          ADDRESS OF MAIN ACTIVATION 
          SB6    X1          TOP OF STACK = LWA+1 LOADED
          SA2    X6-3        ADDRESS OF PMD AND OUTPUT EFET 
          BX6    X2 
          SA6    TGVR+OUTP
          MX3    -6 
          GETFLC TGVR+FL     GET FIELD LENGTH CONTROL WORD
          SA2    TGVR+FL     FETCH FIELD LENGTH CONTROL WORD
          AX2    30 
          SX0    X2 
          SX1    MSGQ        WORKSPACE EXCEEDS VALIDATED FL 
          BX0    X3*X0       LAST CONTROL-STATEMENT FL
          SB2    B6-B3       LWPR(B6) - WSA(B3) 
          PL     B3,PRS1     IF FL ALWAYS TO BE RESET 
          NG     B2,PRS7     IF CODE + WORKSPACE >= 2**17 
          IX5    X0-X5
          BX2    X5 
          AX5    59 
          BX5    X5*X2
          IX0    X0-X5       MAX(CURRENT FL, LAST CONTROL-STATEMENT FL) 
          SB4    X0+         FIELD LENGTH 
          SB3    -B3
          SX7    B4-B6       FOR <0 FLDIFF = FL(B4) - LWPR(B6)
          SA7    FLDIFF      STORE FLDIFF FOR CMM ALLOCATION
          GE     B4,B2,PRS2  IF FL IS SUFFICIENT
 PRS1     SX0    B3          FOR >0 MEMORY NEEDED FOR WSA(B3) 
          BX7    X0          SAVE ADDITIONAL FL FOR CMM ALLOCATION
          SA7    FLDIFF      STORE FLDIFF FOR CMM ALLOCATION
 PRS2     NG     X0,PRS7     IF CODE + WORKSPACE >= 2**17 
          RJ     CMMUP       ALLOCATE CMM FL VIA CMM.ALF
          SA4    TGVR+FL
          SB4    X4          ACTUAL FL
          SA4    ACTR 
          MX0    42 
          SB3    X4          NUMBER OF ACTUAL PARAMETERS
          SA4    ARGR-1      PRELOAD
          SX6    B4-B6       FREE WORKSPACE 
          SA6    TGVR+MINFS  PRESET MINIMUM FREE WORKSPACE
          SA3    TGVR+OUTP
          ZR     B7,PRS6     IF NO FILES IN PROGRAM HEADING 
          SX3    X3+
          ZR     X3,PRS3     IF NO OUTPUT FILE
          SA6    X3+         SET OUTPUT FILE NOT OPENED 
 PRS3     SX1    MSGI        TOO MANY PROGRAM PARAMETERS
          ZR     B3,PRS4     IF ALL ACTUALS PROCESSED 
          SA4    A4+B1       GET NEXT ACTUAL PARAMETER
          SB3    B3-B1       COUNT IT 
          BX7    X0*X4       STRIP THE DELIMITER
          SA7    A4          REPLACE FILE NAME
          SX2    X4-3        /=3 IN SCOPE PARAMETERS
          SX3    X4-1R/ 
          ZR     X2,PRS4     IF / (IN SCOPE PARAMETERS) 
          NZ     X3,PRS3     IF NOT / (IN KRONOS PARAMETERS)
 PRS4     SB3    A4-B1       NUMBER OF ACTUALS BEFORE / 
          BX7    X7-X7
          GT     B3,B7,PRS7  IF TOO MANY ACTUAL PARAMS
 PRS5     SB3    B3+B1
          SA7    B3+B1       ZERO THE REST OF FORMALS AND ONE MORE WORD 
          LE     B3,B7,PRS5 
 PRS6     MX0    6*6
          SA1    LWPR        LOAD FL
          SB2    X1 
          SX1    -B2         < 0 AFTER CMM INITIALIZATION 
          LX0    -6 
          SA5    MSGP 
          RJ     CAD         CONVERT ADDRESS TO DISPLAY 
          LX6    3*6
          BX2    -X0*X5      REMOVE XXXXXX
          SX1    B4          RUN FL 
          BX6    X0*X6       REMOVE BLANKS
          IX7    X6+X2       REPLACE XXXXXX WITH LOAD FL
          SA7    A5 
          RJ     CAD         CONVERT ADDRESS TO DISPLAY 
          LX0    6
          SA1    MSGP+2 
          LX6    4*6
          BX2    -X0*X1      REMOVE XXXXXX
          BX6    X0*X6       REMOVE BLANKS
          IX7    X6+X2       REPLACE XXXXXX WITH RUN FL 
          SA7    A1 
          MESSAGE MSGP,"IMSG"  XXXXXXB LOAD FL,   XXXXXXB RUN FL. 
          SB4    B4-2        ENSURE TWO WORDS AT END OF FL
          RJ     CLK         GET MILLISECOND CLOCK
          SA6    ISMA        SAVE MILLISECOND CLOCK READING 
          EQ     PRSX        RETURN 
  
 FLDIFF   BSS    1           FLDIFF = FL DIFFERENCE FOR CMM ALLOCATION
  
  
  
**        P.CMMUP - CALL CMM.ALF MACRO TO ALLOCATE CMM. 
* 
*         ENTRY  X2 = FLDIFF FOR CMM ALLOCATION VIA CMM.ALF.
*                X3 = SET ZERO FOR SIZE CODE AND GROUP ID PARAMETER.
* 
*         EXIT   X1 = FWA OF CMM ALLOCATED VIA CMM.ALF FOR FLDIFF.
* 
*         CALLS  NONE.
* 
*         MACROS CMM.ALF TO ALLOCATE CMM FOR FLDIFF.
  
  
 CMMUP    ROUTINE P.CMMUP 
          SX7    B5          SAVE B5
          SA7    SAVB57      STORE B5 
          SX7    B7          SAVE B7
          SA7    A7+B1       STORE B7 
          SA2    FLDIFF      SET FLDIFF FOR CMM ALLOCATION
          SX3    B0          SET CMM.ALF X3 PARAMETER 
          RJ     =YCMM.ALF   ALLOCATE CMM FOR FLDIFF IN X2
          SB6    X1          RESET B6 OLD LWPR = CMMFWA ALLOCATED 
          BX7    X1          X1 = CMM NEW BLOCK FWA ALLOCATED 
          SA1    FLDIFF 
          IX7    X7+X1       ADD CMM FLDIFF TO CMMFWA FOR TGVR+FL 
          SA7    TGVR+FL     STORE FLDIFF + CMMFWA IN TGVR+FL 
          SA1    SAVB57      RELOAD B5
          SB5    X1          RESET B5 
          SA1    A1+B1       RESTORE B7 
          SB7    X1          RESET B7 
          EQ     CMMUPX      RETURN 
  
 SAVB57   BSS    2           SAVE B5 AND B7 
  
  
 PRS7     MESSAGE X1,"EMSG"  ISSUE ERROR MESSAGE
          ABORT 
  
 PRSL     EQU    *
  
          USE    *
 IOE      SPACE  4,18 
**        P.IOE - INPUT/OUTPUT ERROR. 
* 
*         ISSUE AN INPUT/OUTPUT ERROR MESSAGE, INSERTING THE FILE 
*         NAME INTO THE MESSAGE.  THEN GO ABORT.
* 
*         ENTRY  (A0) = LINE NUMBER (IF PMD INFO AVAILABLE).
*                (X0) = FET-14 (IF ENTERING AT P.IOE).
*                (X1) = INDEX INTO TABLE OF INPUT/OUTPUT ERRORS.
*                (X2) = FET (IF ENTERING AT IOE1).
* 
*         EXIT   TO ABT.
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  ABT, SNM.
* 
  
  
 IOE1     SX0    X2-14       NORMALIZE CALLING SEQUENCE 
          EQ     IOE2 
  
 IOE      ROUTINE P.IOE 
 IOE2     SA2    TIOE+X1     FETCH I/O ERROR NAME 
  
*         COPY OFF ERROR MESSAGE IN CASE OF SUBSEQUENT CALLS TO SNM.
  
          SB7    4           NUMBER OF WORDS TO TRANSFER
 IOE3     SA3    X2+B7
          BX6    X3 
          SA6    IOEZ+B7
          SB7    B7-B1
          GE     B7,B0,IOE3  IF MORE TO TRANSFER
          MX6    6*7
          SA3    X0+14       GET FILE NAME
          SB7    1R=         SUBSTITUTION CHARACTER 
          BX1    X6*X3       DISCARD LOWER BITS 
          SA4    A6-B1       FWA - 1 OF MESSAGE 
          SX5    A6+         FWA OF MESSAGE 
          RJ     SNM         SET FILE NAME IN MESSAGE 
          SX0    X5          ADDRESS OF ERROR MESSAGE 
          EQ     ABT         GO ABORT 
  
 IOEZ     SCRATCH 5          TEMPORARY STORAGE FOR I/O ERROR MESSAGE
 P.MSG    SPACE  4,12 
**        P.MSG - DISPLAY MESSAGE TO USER DAYFILE.
* 
*         ENTRY  (X1) = ADDRESS OF MESSAGE. 
*                (X2) = LENGTH OF MESSAGE (IN CHARACTERS).
* 
*         EXIT   MESSAGE DISPLAYED. 
* 
*         USES   A - 1, 2, 6, 7.
*                B - 7. 
*                X - 1, 2, 6, 7.
* 
*         CALLS  MSG=, TMS. 
* 
*         MACROS MESSAGE. 
  
  
 MSG      ROUTINE P.MSG      ENTRY/EXIT 
          RJ     TMS
          MESSAGE X1,"IMSG",RCL 
          EQ     MSGX        RETURN 
 P.NEW    SPACE  4,16 
**        P.NEW - ALLOCATE HEAP STORAGE.
* 
*         ENTRY  (B7) = SIZE OF NODE TO ALLOCATE. 
* 
*         EXIT   (X6) = ADDRESS OF NODE.
*                (B7)   UNCHANGED.
* 
*         USES   X - 0, 2, 3, 5, 6, 7.
*                A - 2, 3, 5, 7.
*                B - 3, 4.
* 
*         CALLS  ABT. 
* 
*         MACROS NONE.
  
  
 NEW3     SX6    B4-B7       ADDRESS OF NEW NODE
          SB3    X6-MINFB 
          GE     B6,B3,TERA+WSFERR  IF WORKSPACE IS FULL
          SB4    X6          SHORTEN FREEBLOCK
  
*         COMPUTE NEW MINIMUM FREE WORKSPACE. 
  
          SX2    B4-B6       CURRENT FREE WORKSPACE (CFW) 
          SA3    TGVR+MINFS  PREVIOUS MINIMUM FREE WORKSPACE (PMFW) 
          IX7    X3-X2
          BX5    X7 
          AX7    60 
          BX0    X7*X5
          IX7    X2+X0       MIN(CFW,PMFW)
          SA7    A3          PMFW := MIN(CFW,PMFW)
  
 NEW      ROUTINE P.NEW 
          SA2    TGVR+FLIST  INITIATE SCAN OF FREELIST
          MX0    42 
 NEW1     SA3    A2          REMEMBER PREVIOUS NODE 
          SA2    X3          ADVANCE TO (NEW) CURRENT NODE
          SX6    A2          ADDRESS OF CURRENT NODE
          AX2    18 
          SB3    X2+         SIZE OF CURRENT NODE 
          ZR     X6,NEW3     IF END OF FREELIST REACHED 
          LT     B3,B7,NEW1  IF NODE NOT LARGE ENOUGH 
          EQ     B3,B7,NEW2  IF NODE EXACTLY THE RIGHT SIZE 
          SX5    B7          SIZE OF NEW NODE 
          SA2    A2          RELOAD HEADER OF FREE NODE 
          LX5    18 
          SB3    B3-B7
          IX7    X2-X5
          SX6    A2+B3       ADDRESS OF NEW NODE
          SA7    A2+         SHORTEN FREE NODE
          EQ     NEWX 
  
 NEW2     SA5    A2          RELOAD HEADER OF CURRENT NODE
          BX3    X0*X3
          SX5    X5 
          IX7    X3+X5       REMOVE NEW NODE FROM FREELIST
          SA7    A3 
          EQ     NEWX 
 P.NEWD   SPACE  4,14 
**        P.NEWD - ALLOCATE CHECKED HEAP STORAGE. 
* 
*         ENTRY  (B7) = SIZE-1 OF NODE TO ALLOCATE. 
* 
*         EXIT   (X6) = NEW POINTER VALUE.
*                       STORAGE ALLOCATED.
* 
*         USES   A - 2, 3, 5, 6, 7. 
*                B - 3, 4, 7. 
*                X - 0, 2, 3, 4, 5, 6, 7. 
* 
*         CALLS  NEW. 
* 
*         MACROS NONE.
  
  
 TNW      ROUTINE P.NEWD
          SB7    B7+B1       NEED ONE MORE WORD FOR THE HEADER
          MX4    -18
          RJ     NEW         ALLOCATE THE STORAGE 
          SA2    TGVR+KEY    GET THE OLD KEY
          SX3    X2+B1       FORM THE NEW KEY 
          BX7    -X4*X3      MODULUS 2**18
          SA7    A2          UPDATE THE KEY 
          SX6    X6+B1       FORM THE NEW POINTER 
          LX7    18 
          BX6    X6+X7       NEW POINTER
          SA6    X6-1        STORE THE HEADER IN THE NODE 
          EQ     TNWX        RETURN 
 P.NFN    SPACE  4,12 
**        P.NFN - GENERATE NEW FILE NAME. 
* 
*         ENTRY  NONE.
* 
*         EXIT   (X2) = NEW FILE NAME OF FORM *SCRNNNN*.
* 
*         USES   A - 1, 2, 3, 4, 6. 
*                B - 3, (RESTORES B2).
*                X - ALL. 
* 
*         CALLS  CDD=.
* 
*         MACROS NONE.
  
  
 NFN      ROUTINE P.NFN 
          SA1    NFNA        COUNTER
          SX5    B4          SAVE TOP OF HEAP POINTER 
          SX6    X1+B1       ADVANCE COUNTER
          SX4    X1-9999
          SA6    A1+
          SX0    MSGU        INTERNAL FILE LIMIT EXCEEDED 
          PL     X4,ABT      IF INTERNAL FILE LIMIT EXCEEDED
          SX0    B2          SAVE B2
          BX1    X6 
          RJ     =XCDD=      CONVERT DECIMAL DIGITS 
          MX1    1
          SB2    B2-B1
          SX2    3RSCR
          AX1    B2          CREATE MASK FOR DIGITS CONVERTED 
          SB4    X5          RESTORE TOP OF HEAP POINTER
          BX4    X1*X4       REMOVE TRAILING BLANKS 
          IX2    X2+X4       COMBINE *SCR* AND *NNNN* 
          SB2    X0          RESTORE B2 
          LX2    -3*6        LEFT ADJUST
          EQ     NFNX        RETURN 
  
 NFNA     DATA   0           FILE NAME COUNTER
 P.OPEN   SPACE  4,26 
**        P.OPEN - OPEN FILE. 
* 
*         OPEN A PASCAL FILE, SETTING UP THE EFET AND FET, AND
*         ALLOCATING BUFFER SPACE.  FOR A RE-OPEN, P.OPEN ASSUMES 
*         THAT THE FET POINTERS ARE SET AND THE FET HAS BEEN RECALLED.
*         WHEN RE-OPENING, THE SETTING OF READ STATUS OR WRITE STATUS 
*         IS LEFT UP TO THE CALLER.  OTHERWISE, *INPUT* IS SET TO READ
*         STATUS, AND ALL OTHER FILES ARE SET TO WRITE STATUS.
* 
*         ENTRY  (B2) < 0 IF FILE IS TO BE RE-OPENED. 
*                (B2) = 0 IF FILE IS A LOCAL VARIABLE,
*                     > 0 IF FILE IS A DYNAMIC VARIABLE.
*                (B3) = EFET ADDRESS. 
*                (B7) = BUFFER LENGTH.
*                (X1) = DISPOSITION CODE. 
*                (X2) = FILE NAME.
*                (X6) = LRL.
* 
*         NOTE THAT B7 IS NOT USED WHEN RE-OPENING. 
* 
*         EXIT   (B2)   UNCHANGED.
*                (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 5, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  CIO=, IOE, NEW, SRS, SWS.
* 
* (NOS)   MACROS OPEN, RETURN.
  
  
 OPE7     RETURN X2          RETURN INTERNAL FILE 
 OPE8     RJ     SWS         SET WRITE STATUS 
  
 OPE      ROUTINE P.OPEN
          MX4    59 
          LX1    0-4         RIGHT ADJUST CODED BIT 
          BX3    X1+X4       SET ALL OTHER BITS 
          LX3    1
          BX4    X3-X4       COMBINE BINARY BIT AND COMPLETE BIT
          LX1    59-8+4 
          BX7    X2+X4       SET BINARY/CODED AND COMPLETE BITS 
          IX6    X1+X6       COMBINE DISPOSITION WITH LRL 
          SA7    B3+B1       FET FIRST WORD 
          SA6    B3          EFET 
          SX1    A7+B1       FIRST
          BX4    X2          SAVE FILE NAME 
          GT     B2,B0,OPE2  IF DYNAMIC FILE
          ZR     B2,OPE1     IF NOT RE-OPENING
          SA2    X1          FIRST
          SA3    X1+3        LIMIT
          SX6    X2 
          SX7    X3 
          EQ     OPE4 
  
 OPE1     SX6    B6          BUFFER ADDRESS 
          SB3    B6+B7
          SB3    B3+MINFB 
          GE     B3,B4,TERA+WSFERR  IF WORKSPACE IS FULL
          SB6    B6+B7       PUSH BUFFER ONTO STACK 
          SA5    TGVR+MINFS  PREVIOUS MINIMUM FREE WORKSPACE (PMFW) 
          SX2    B4-B6       CURRENT FREE WORKSPACE (CFW) 
          IX7    X5-X2
          BX3    X7 
          AX7    60 
          BX0    X7*X3
          IX7    X2+X0       MIN(CFW,PMFW)
          SA7    A5          PMFW := MIN(CFW,PMFW)
          EQ     OPE3 
  
 OPE2     RJ     NEW         ALLOCATE BUFFER
 OPE3     SX7    B7          BUFFER LENGTH
          IX7    X6+X7       LIMIT
 OPE4     SX5    FETSZ-5
          SB3    X5 
          LX5    18 
          BX6    X6+X5       INSERT FET LENGTH
          SA6    X1          SET FIRST
          SX6    X6 
          SA6    A6+B1       SET IN 
          SA6    A6+B1       SET OUT
          SA7    A6+B1       SET LIMIT
          IX5    X7-X6       BUFFER LENGTH
          BX6    X6-X6
 OPE5     SB3    B3-B1       CLEAR REMAINDER OF FET 
          SA6    A7+B3
          GT     B3,B1,OPE5 
          SA3    X1-2        EFET 
          SX2    A3+B1       FET ADDRESS
          LX3    59-55
          PL     X3,OPE6     IF NOT A TEXT FILE 
          SX7    -B1
          MX6    60 
          SA7    A3-13       LINE COUNT 
          SA6    A3-2        SENTINAL 
 OPE6     LX3    55-53
          AX3    60-3 
          ZR     X3,OPE7     IF INTERNAL FILE 
          OPEN   X2,ALTERNR,R 
          SA3    X2+4        LIMIT
          NO
          AX3    18 
          SX3    X3          PRU SIZE 
          IX6    X3-X5
          SA5    =5LINPUT 
          SX1    IOED        BUFFER TOO SMALL ON XXXXXXX
          PL     X6,IOE1     IF BUFFER LENGTH < PRU SIZE
          IX7    X4-X5
          SA3    X2+B1       FETCH DEVICE TYPE FROM FET+1, BYTE 0 
          MX0    -12
          LX3    -48
          BX3    -X0*X3      DEVICE TYPE
          SX6    X3-2RTT     CHECK FOR DEVICE TYPE *TT* 
          NZ     X6,OPE6.1   IF NOT TERMINAL FILE 
          MX0    1
          SA1    X2-1        EFET 
          LX0    52-59
          BX6    X1+X0       SET TERMINAL BIT 
          SA6    A1 
 OPE6.1   NG     B2,OPEX     IF RE-OPENING FILE 
          MX0    1
          SA1    X2-1        EFET 
          NZ     X7,OPE8     IF FILE NAME <> INPUT
          LX0    57-59
          BX6    X1+X0       SET SEGMENTED BIT
          SA6    A1+
          RJ     SRS         SET READ STATUS
          EQ     OPEX        RETURN 
 P.PAGE   SPACE  4,10 
**        P.PAGE - START PAGE.
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   X - ALL. 
*                A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
* 
*         CALLS  PTC, PTL.
* 
*         MACROS NONE.
  
  
 PAG      ROUTINE P.PAGE
          SX2    X1+
          SX3    A1-11       FWA OF CHAR BUFFER 
          IX3    X3-X2       NEGATIVE IF NON-EMPTY CHAR BUFFER
          BX3    -X3*X1 
          NG     X3,PAG1     IF EMPTY CHAR BUFFER AND EOLN SET
          RJ     PTL         ELSE WRITELN 
          SA1    X2-2        UPDATE A1/X1 
 PAG1     SX6    1R1         CARRIAGE CONTROL CHARACTER 
          SA6    X1+         INTO CHAR BUFFER 
          RJ     PTC         PUT CHARACTER
          EQ     PAGX        RETURN 
 P.PEN    SPACE  4,18 
**        P.PEN - PROCEDURE ENTRY.
* 
*         ENTRY  (B4) = TOP OF RUN TIME HEAP. 
*                (B5) = OLD STACK POINTER (DYNAMIC LINK). 
*                (B6) = OLD TOP OF STACK = NEW STACK POINTER. 
*                (X0 - X4) MAY CONTAIN PROCEDURE PARAMETERS.
*                (X5) = STATIC LINK IF (X5) >= 0. 
*                (X5) = MASK REPRESENTING DIFFERENCE BETWEEN THE LEVEL
*                       OF THE CALLER AND THE CALLED IF (X5) < 0. 
* 
*         EXIT   ACTIVATION RECORD PUSHED ONTO STACK. 
*                PARAMETERS STORED ON STACK.
* 
*         USES   A - 5, 6, 7. 
*                B - 2, 3, 5, 6.
*                X - 5, 6, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 +        BX6    X4 
          NO
          SA6    B6+PFLC+4   STORE FIFTH PARAMETER
 +        BX7    X3 
          NO
          SA7    B6+PFLC+3   STORE FOURTH PARAMETER 
 +        BX6    X2 
          NO
          SA6    B6+PFLC+2   STORE THIRD PARAMETER
 +        BX7    X1 
          NO
          SA7    B6+PFLC+1   STORE SECOND PARAMETER 
 +        BX6    X0 
          NO
          SA6    B6+PFLC+0   STORE FIRST PARAMETER
  
*         PUSH STACK. 
  
 PEN3     SB5    B6+         *** PERFORM IN ONE WORD ***
          SB6    B3+         *** PERFORM IN ONE WORD ***
  
 PEN      ROUTINE P.PEN 
          BX6    X5          SAVE STATIC LINK DESCRIPTION 
          SA5    PEN         EQ EP+2 / 0
          BX7    X5          SAVE ENTRY POINT ADDRESS 
          AX5    30 
          SA5    X5-1        WORD WITH CALL TO PEN
          SB3    X5          SIZE OF ACTIVATION RECORD
          LX5    30 
          UX5,B2 X5          B2 := -NUMBER OF PARAMETERS IN X-REGISTERS 
          AX5    59 
          BX6    -X5*X6      CLEAR STATIC LINK IF TOP-LEVEL 
          SX5    X6          STATIC LINK
          PL     X6,PEN2     IF WE HAVE THE STATIC LINK 
          SA5    B5          TRACE STATIC LINK CHAIN
 PEN1     LX6    1
          SA5    X5 
          NG     X6,PEN1     IF STATIC LINK NOT REACHED YET 
 PEN2     SX6    X5          STATIC LINK
          BX6    X7+X6       EQ EP+2 / SL 
          SX7    6150B       SB5 B0+K 
          SA6    B6 
          LX6    30 
          SA5    X6-2        EQ RA / 0
          LX7    30-12       SB5 B0+0 
          SX6    B5          DL 
          BX5    X5+X7       EQ RA / SB5 B0+0 
          IX7    X5+X6       EQ RA / SB5 DL 
          LX7    30          SB5 DL / EQ RA 
          SA7    B6+B1
          SX6    B3          SIZE OF ACTIVATION RECORD
          SB3    B6+B3       TENTATIVE NEW TOP OF STACK 
          SX5    B6 
          IX7    X5+X6       TOP OF STACK + SIZE OF ACTIVATION RECORD 
          SX6    B4-MINFB    TOP OF HEAP - MINIMUM FREE SPACE 
          IX5    X6-X7
          NG     X5,TERA+WSFERR  IF STACK AND HEAP COLLIDED 
          JP     B2+PEN3     STORE PARAMETERS AND EXIT
 P.PEX    SPACE  4,10 
**        P.PEX - PROCEDURE EXIT. 
* 
*         ENTRY  (B5) = ADDRESS OF CURRENT ACTIVATION RECORD. 
* 
*         EXIT   (MINFS) = UPDATED TO MINIMUM FREE WORKSPACE. 
*                EXITS TO (B5)+1 TO POP STACK SEGMENT.
* 
*         USES   A - 1, 7.
*                B - 6. 
*                X - 0, 1, 2, 3, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 PEX      ENTER  P.PEX
          SA1    TGVR+MINFS  PREVIOUS MINIMUM FREE WORKSPACE (PMFW) 
          SX2    B4-B6       CURRENT FREE WORKSPACE (CFW) 
          IX7    X1-X2
          BX3    X7 
          AX7    60 
          BX0    X7*X3
          IX7    X2+X0       MIN(CFW,PMFW)
          SB6    B5          SET TOP OF STACK 
          SA7    A1          PMFW := MIN(CFW,PMFW)
          JP     B5+1        EXIT 
 P.PUTB   SPACE  4,12 
**        P.PUTB - PUT BINARY.
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  CIO=, RCL=, WWR. 
* 
*         MACROS RECALL, WRITE. 
  
  
 PTB      ROUTINE P.PUTB     ENTRY/EXIT 
          SB3    X1+         LRL
          SA3    A1+3        IN 
          LX1    59-56
          SX2    A1+B1       FET
          SA4    A1+5        LIMIT
          PL     X1,WWR1     IF WRITE WITHOUT REWRITE 
          SX4    X4          LIMIT
          SX6    X3+B3       IN + LRL 
          IX7    X6-X4
          SA1    X2+B1       FIRST
          SX6    X1+         FIRST
          IX0    X4-X6       LIMIT - FIRST
          PL     X7,PTB1     IF IN = LIMIT
          SX6    X3+B3       IN + LRL 
 PTB1     SA6    A3          ADVANCE IN 
          BX4    X6 
          SA6    X2-2        ADVANCE FILE POINTER 
 PTB2     SA1    A3+B1       OUT
          IX3    X1-X4       OUT - IN 
          SX6    X3-1        EMPTY SPACE IN BUFFER
          AX7    X0,B1
          PL     X6,PTB3     IF OUT >= IN 
          IX6    X0+X6
 PTB3     IX1    X7-X6
          SB7    X6 
          NG     X1,PTBX     IF BUFFER HALF EMPTY 
          SA1    X2          FET
          LX1    59-0 
          PL     X1,PTB4     IF FET BUSY
          WRITE  X2 
 PTB4     GE     B7,B3,PTBX  IF BUFFER NOT FULL 
          RECALL
          EQ     PTB2 
 P.PUTC   SPACE  4,12 
**        P.PUTC - PUT CHARACTER. 
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = ADDRESS OF THE FET. 
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  PCH. 
* 
*         MACROS NONE.
  
 PTC      ROUTINE P.PUTC
          SA3    X1+B1       LOOK AHEAD IN CHARACTER BUFFER 
          SX4    B1 
          IX6    X1+X4       ADVANCE POINTER
          SA6    A1          UPDATE POINTER 
          SX2    A1+2        FET ADDRESS
          PL     X3,PTCX     IF BUFFER NOT FULL 
          SX7    PTCX        RETURN ADDRESS 
*         EQ     PCH         FALL THROUGH TO HELPER TO EMPTY BUFFER 
 P.PUTCH  SPACE  4,14 
**        P.PUTCH - PUT CHARACTER HELPER. 
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (X1) = ((A1)). 
*                (X7) = RETURN ADDRESS. 
* 
*         EXIT   (X2) = ADDRESS OF THE FET. 
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  PTB, WWR.
* 
*         MACROS NONE.
  
  
 PCH      ENTER  P.PUTCH
          SA7    PCHA        SAVE RETURN ADDRESS
          SX2    A1+2        FET
          LX1    1
          SA4    X2-13       LOAD CHARACTER 1 
          SA3    A4+B1       LOAD CHARACTER 2 
          PL     X1,WWR1     IF WRITE WITHOUT REWRITE 
          LX4    6
          SA1    A3+B1       LOAD CHARACTER 3 
          BX7    X4+X3
          SA3    A1+B1       LOAD CHARACTER 4 
          LX7    6
          BX4    X7+X1
          SA1    A3+B1       LOAD CHARACTER 5 
          LX4    6
          BX7    X4+X3
          SA3    A1+B1       LOAD CHARACTER 6 
          LX7    6
          BX4    X7+X1
          SA1    A3+B1       LOAD CHARACTER 7 
          LX4    6
          BX7    X4+X3
          SA3    A1+B1       LOAD CHARACTER 8 
          LX7    6
          BX4    X7+X1
          SA1    A3+B1       LOAD CHARACTER 9 
          LX4    6
          BX7    X4+X3
          SA3    A1+B1       LOAD CHARACTER 10
          LX7    6
          BX1    X7+X1
          SA4    X2+2        IN 
          LX1    6
          BX7    X1+X3       PACKED WORD
          SA7    X4+         STORE WORD IN BUFFER 
          SA1    X2-1        EFET 
          RJ     PTB         PUT BINARY 
          MX6    1
          SX3    X2-13       FWA OF CHAR BUFFER.
          LX6    -1 
          SA1    PCHA 
          BX6    X3+X6       FILE POINTER WITH REWRITE SET, EOLN CLEAR. 
          SB7    X1          RETURN ADDRESS 
          SA6    X2-2 
          JP     B7 
  
 PCHA     SCRATCH 1 
 P.PUTLN  SPACE  4,12 
**        P.PUTLN - WRITELN.
* 
*         ENTRY  (A1) = EFET ADDRESS - 1. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
* (NOS)   CALLS  IOE, PTB, WWR. 
* 
* (NOS)   MACROS NONE.
* (NOSBE) MACROS WRITE. 
  
  
 PTL      ROUTINE P.PUTLN 
          SB3    X1+
          SA4    A1-11       FWA CHARACTER BUFFER 
          LX1    59-58
          SB7    60-6        INITIALIZE SHIFT COUNT 
          BX6    X6-X6       INITIALIZE PACKED WORD 
          SX2    A1+2        FET
          PL     X1,WWR1     IF WRITE WITHOUT REWRITE 
          SB3    A4-B3       CHARACTER COUNT
          SX7    B3 
          ZR     B3,PTL5     IF CHARACTER BUFFER EMPTY
          SX1    -6 
 PTL1     LX3    B7,X4       PREPARE CHARACTER
          SB3    B3+B1       ADVANCE CHARACTER COUNT
          SB7    B7+X1       ADVANCE SHIFT COUNT
          BX6    X6+X3       INSERT CHARACTER 
          SA4    A4+B1       FETCH NEXT CHARACTER 
          NG     B3,PTL1     IF MORE CHARACTERS LEFT
          LX7    59-0 
          NG     X7,PTL2     IF EVEN NUMBER OF CHARACTERS 
          SX4    1R 
          NO
          LX3    B7,X4
          SB7    B7+X1
          BX6    X6+X3       APPEND A BLANK IF ODD NUMBER 
 PTL2     NZ     X3,PTL3     IF ORD(PREVIOUS CHAR) <> 00B 
          SX4    2R 
          SB7    B7+X1
          LX3    B7,X4
          SB7    B7+X1
          BX6    X6+X3       APPEND 2 BLANKS TO PROTECT ZERO CHARACTER
 PTL3     SA3    X2+2        IN 
          SX5    B7          SAVE SHIFT COUNT 
          SA6    X3          STORE PACKED WORD IN BUFFER
          SA1    A1+B1       EFET 
          RJ     PTB         PUT BINARY 
          SA3    X2+2        IN 
          PL     X5,PTL4     IF WORD WAS NOT FULL 
          BX6    X6-X6
          SA1    X2-1        EFET 
          SA6    X3          STORE A ZERO WORD FOR END OF LINE
          RJ     PTB         PUT BINARY 
 PTL4     SA4    X2-14       LINE COUNT 
          MX3    2
          SX6    A4+B1       FWA CHARACTER BUFFER 
          SX1    IOEA        BEYOND LINELIMIT ON XXXXXXX
          SX7    B1 
          IX7    X4-X7       COUNT THE LINE 
          BX6    X6+X3       FILE POINTER WITH EOLN AND REWRITE BITS SET
          SA7    A4          UPDATE LINECOUNT 
          SA6    X2-2        UPDATE FILE POINTER
          ZR     X4,IOE1     IF BEYOND LINELIMIT
          EQ     PTLX        RETURN 
  
 PTL5     SA3    X2-4        LAST CHARACTER OF PREVIOUS WORD
          NZ     X3,PTL3     IF ORD(PREVOUS CHAR) <> 00B
          SX6    2R 
          NO
          LX6    -12         APPEND 2 BLANKS TO PROTECT ZERO CHARACTER
          EQ     PTL3 
 P.PUTS   SPACE  4,12 
**        P.PUTS - PUT SEGMENT. 
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
* (NOS)   CALLS  FOB, SWS, WWR. 
* 
*         MACROS RECALL.
  
  
 PTS      ROUTINE P.PUTS
          LX1    59-56
          SX2    A1+B1       FET ADDRESS
          PL     X1,WWR1     IF WRITE WITHOUT REWRITE 
          SX3    20B
          RECALL X2          WAIT I/O COMPLETE
          SA1    X2+
          BX6    -X3*X1      DESTROY POSSIBLE WRITER CODE 
          SA6    A1 
          RJ     FOB         FLUSH OUTPUT BUFFER
          RJ     SWS         SET WRITE STATUS 
          EQ     PTSX        RETURN 
 P.RESET  SPACE  4,12 
**        P.RESET - REWIND FILE AND PREPARE FOR READING.
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  RPF, SRS.
* 
*         MACROS NONE.
  
  
 RST      ROUTINE P.RESET 
          SX2    A1+B1       FET
          RJ     RPF         REWIND PASCAL FILE 
          NG     X0,RSTX     IF ACTUAL FILE IS INPUT OR OUTPUT
          RJ     SRS         SET READ STATUS
          EQ     RSTX        RETURN 
 P.REWRT  SPACE  4,12 
**        P.REWRT - REWIND FILE AND PREPARE FOR WRITING.
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  CIO=, RPF, SWS.
* 
*         MACROS REWIND, WRITEF.
  
  
 RWT      ROUTINE P.REWRT 
          SX2    A1+B1       FET
          RJ     RPF         REWIND PASCAL FILE 
          NG     X0,RWTX     IF ACTUAL FILE IS INPUT OR OUTPUT
          SA3    X2-1        EFET 
          LX3    59-52
          NG     X3,RWT1     IF TERMINAL FILE 
          SA1    X2+2        PREVENT FLUSH OF READ FILE 
          SX6    X1 
          SA6    A1+B1       OUT := IN
          WRITEF X2          ENSURE FILE IS EMPTY 
          REWIND X2,R        POSITION TO BEGINNING OF FILE
 RWT1     RJ     SWS         SET WRITE STATUS 
          EQ     RWTX        RETURN 
 P.RWRTS  SPACE  4,12 
**        P.RWRTS - REWRITE SEGMENTED FILE. 
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
*                (X2) = NUMBER OF SEGMENTS. 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 2, 3, 7. 
*                X - ALL. 
* 
*         CALLS  CIO=, SKP, SWS.
* 
*         MACROS SKIPB, WRITEF. 
  
  
 RWS      ROUTINE P.RWRTS 
          RJ     SKP         SKIP RECORDS 
          SA3    X2-1        EFET 
          LX3    59-52
          NG     X3,RWS1     IF TERMINAL FILE 
          SA1    X2+2        PREVENT FLUSH OF READ FILE 
          SX6    X1 
          SA6    A1+B1       OUT := IN
          WRITEF X2          ENSURE FILE IS EMPTY 
          SKIPB  X2,1,R      BACKSPACE OVER EOF 
 RWS1     RJ     SWS         SET WRITE STATUS 
          EQ     RWSX        RETURN 
 P.SABRT  SPACE  4,20 
**        P.SABRT - COMMON ERROR ROUTINE. 
* 
*         1. ISSUE 1 OR 2 ERROR MESSAGES TO THE USER DAYFILE, 
*            THEN ISSUE A MESSAGE OF THE FORM 
*                    AT LINE 1 IN PROGRAM A.
*                OR  AT LINE 99999 IN PROCEDURE PASCALCOMP. 
*                OR  AT LINE 123 IN FUNCTION SDEV.
*                OR  IN PROCEDURE ERROR.     (IF NO PMD INFORMATION)
*         2. FLUSH ALL OUTPUT BUFFERS OF FILES ON THE PROGRAM HEADING.
*         3. CALL PMD IF IT IS AVAILABLE, ELSE ISSUE THE
*            FIRST MESSAGE TO THE OUTPUT FILE.
* 
*         ENTRY  (A0) = LINE NUMBER (IF PMD INFO AVAILABLE).
*                (B5) = CURRENT A.R. POINTER (IF PMD AVAILABLE).
*                (X0) = 30/0, 30/MSG1.
*                       OR 30/MSG2, 30/MSG1.
* 
*         EXIT   TO PMD OR ABORT THE JOB. 
* 
*         USES   ALL REGISTERS. 
* 
* (NOS)   CALLS  CDD=, CPM=, FCE, FOB, MSG=, SNM, VPE(PMD), WNB=, ZFN=. 
* 
*         MACROS MESSAGE, RECALL. 
  
  
 ABT      ENTER  P.SABRT
          EQ     ABT1        THIS JUMP FOR NORMAL CASE
-         EQ     ABT10       THIS JUMP AFTER ENTERING ONCE
 ABTA     EQU    *-1
 ABT1     SA5    ABTA        PREVENT RECURSIVE CALL TO ABT
          LX5    30 
          BX6    X5 
          SA6    A5 
          BX6    X0 
          SA6    ABTB        SAVE MESSAGE ADDRESSES 
          SX1    =YP.DER
          NG     X1,ABT1.5   IF NO REPRIEVE 
          RJ     =YP.DER     DISABLE ERROR REPRIEVE 
          SA1    ABTB        RESTORE MESSAGE ADDRESSES
          BX0    X1 
 ABT1.5   BSS    0
  
          MESSAGE X0,"EMSG"  ISSUE FIRST MESSAGE TO USER DAYFILE
          SA2    X0 
          SX3    1R 
          MX4    6
          LX3    -6 
          BX6    -X4*X2 
          IX7    X6+X3
          SA7    A2          REPLACE FIRST CHARACTER WITH A BLANK 
          AX0    30 
          ZR     X0,ABT2     IF NO SECOND MESSAGE 
          MESSAGE X0,"EMSG"  ISSUE SECOND MESSAGE TO USER DAYFILE 
 ABT2     SA1    TGVR+PMD 
          PL     X1,ABT4     IF PMD ENTIRELY SUPPRESSED 
          SX0    MSGA-1      ASSUME PMD IS ON 
          RJ     FCE         FIND CURRENT ENTRYPOINT
          NG     X5,ABT3     IF PMD IS ON 
          SX0    MSGB-1      ADDRESS - 1 OF PMD OFF MESSAGE 
 ABT3     SA2    X2-2        (A2) = ADDRESS OF NAME OF MODULE 
          SB7    1R-         SUBSTITUTION CHARACTER 
          SA4    X0          FWA - 1 OF MESSAGE 
          BX5    X0          SAVE ADDRESS 
          RJ     SNM         SET MODULE TYPE IN MESSAGE 
          SA1    A2          LOAD MODULE NAME 
          RJ     =XZFN=      ZERO FILL PROGRAM/PROCEDURE/FUNCTION NAME
          SA4    X5          FWA - 1 OF MESSAGE 
          SB7    1R/         SUBSTITUTION CHARACTER 
          BX1    X6 
          RJ     SNM         SET MODULE NAME IN MESSAGE 
          SX1    A0          LINE NUMBER
          SB7    B4          SAVE HEAP POINTER
          RJ     =XCDD=      CONVERT LINE NUMBER TO DECIMAL DISPLAY CODE
          SB4    B7          RESTORE HEAP POINTER 
          MX6    1
          SB2    B2-B1       6 * NUMBER OF DIGITS CONVERTED - 1 
          AX7    X6,B2
          BX1    X7*X4       ZERO FILL LINE NUMBER
          SB7    1R+         SUBSTITUTION CHARACTER 
          SA4    X5          FWA - 1 OF MESSAGE 
          RJ     SNM         SET LINE NUMBER IN MESSAGE 
          MESSAGE X5+B1,"EMSG"  ISSUE ERROR MESSAGE 
  
*         FLUSH OUTPUT BUFFERS. 
  
 ABT4     SA1    TGVR+OUTP
          LX1    1
          R=     A5,ARGR     INITIALIZE LOWCORE FILE POINTER
          PL     X1,ABT11    IF NO EXTERNAL FILES 
          SX2    X5+         FET ADDRESS
 ABT5     ZR     X2,ABT6     IF FILE NOT OPENED 
          SA1    X2-1        EFET 
          SA3    A1-B1       EFET - 1 
          LX1    59-56       WORD FILE REWRITE (IN BIT 59)
          LX3    59-58       TEXT FILE REWRITE (IN BIT 59)
          LX4    B1,X1       TEXT FILE (IN BIT 59)
          BX3    -X4+X3 
          BX4    X1*X3
          PL     X4,ABT6     IF FILE NOT READY FOR WRITING
          RJ     FOB         FLUSH OUTPUT BUFFER
 ABT6     SA5    A5+B1       ADVANCE TO NEXT FILE POINTER 
          SX2    X5          FET ADDRESS
          NZ     X5,ABT5     IF MORE FILES LEFT 
  
*         SEE IF OUTPUT FILE IS READY FOR WRITING.
  
          SA2    TGVR+OUTP
          SX4    X2 
          SA1    X2          OUTPUT EFET (IF OUTPUT EXISTS) 
          ZR     X4,ABT11    IF NO OUTPUT FILE
          PL     X2,ABT11    IF PMD ENTIRELY SUPPRESSED 
          SA3    A1-B1       EFET - 1 
          LX1    59-56       WORD FILE REWRITE (IN BIT 59)
          LX3    59-58       TEXT FILE REWRITE (IN BIT 59)
          MX6    59 
          BX5    X1*X3
          SA6    A1-13       SET LINELIMIT(OUTPUT,-1) 
          LX2    30 
          PL     X5,ABT11    IF OUTPUT FILE NOT READY FOR WRITING 
          SB7    X2          ADDRESS OF PMD IF AVAILABLE
          SX2    X4+B1       FET ADDRESS
          RECALL X2          WAIT I/O COMPLETE
          NZ     B7,ABT8     IF PMD AVAILABLE 
  
*         CONVERT OUTPUT TO BE A FILE OF ALFA.
  
          SA1    X2-1        BINARY EFET FIRST WORD 
          MX6    1
          LX6    55-59
          BX6    -X6*X1      CLEAR CHARFILE BIT 
          SA6    A1 
          SA3    X2+2        FET IN POINTER 
          BX6    X3 
          SA6    A1-B1       SET FILE POINTER 
          SA5    ABTB        MESSAGE ADDRESS
  
*         WRITE THE MESSAGE TO OUTPUT.
  
 ABT7     SA4    X5          NEXT WORD OF MESSAGE 
          SA3    X2-2        FILE POINTER 
          BX6    X4 
          SA6    X3          PUT WORD IN BUFFER 
          SA1    A3+B1       EFET 
          RJ     PTB         ADVANCE POINTERS 
          SA3    X5 
          MX4    -12
          SX5    X5+B1       NEXT ADDRESS 
          BX4    -X4*X3 
          NZ     X4,ABT7     IF NOT END OF LINE 
          EQ     ABT9        GO ABORT 
  
*         CALL PMD. 
  
 ABT8     SB4    B4+MINFB+1  TRY TO PREVENT STACK OVERFLOW
          SA1    TGVR+MAIN
          BX6    X6-X6
          LX7    X1 
          SA6    B6+PFLC     VAR MEMORY    : MEMORYARRAY
          SA7    A6+B1           MAIN      : INTEGER
          SA1    TGVR+MVAR
          SX6    A0 
          BX7    X1 
          SA6    A7+B1           LINE      : INTEGER
          SA7    A6+B1           MVAR      : INTEGER
          SX6    B5 
          SA6    A7+B1           STACKP    : INTEGER
          SX6    X2-14
          SA6    A6+B1       VAR F         : TEXT 
          SA4    ABTB 
          SX6    B1 
          SX7    X4 
          SA7    A6+B1       VAR MSG       : MESS 
          SA6    A7+B1           ABORT     : BOOLEAN
          SX7    -B1
          SA7    A6+B1           NLEVELS   : INTEGER
          SX5    B7 
          RJ     VPE         CALL POST-MORTEM DUMP ROUTINE
 ABT9     SA2    TGVR+OUTP
          SX2    X2+1        OUTPUT FET ADDRESS 
          RJ     FOB         FLUSH THE BUFFER 
          EQ     ABT11
  
 ABT10    MESSAGE X0,"EMSG"  ISSUE ERROR MESSAGE
          MESSAGE MSGR,"EMSG"  PASCAL SYSTEM ERROR
 ABT11    ABORT 
  
 ABTB     SCRATCH 1          MESSAGE ADDRESS
  
 P.TIME   SPACE  4,12 
**        P.TIME - RETURN SYSTEM TIME.
* 
*         ENTRY  (X1) = ADDRESS TO RETURN SYSTEM TIME.
* 
*         EXIT   ((X1)) = SYSTEM TIME.
* 
*         USES   A - 1, 6.
*                X - 1, 6.
* 
*         CALLS  SYS=.
* 
*         MACROS CLOCK. 
  
  
 TIM      ROUTINE P.TIME     ENTRY/EXIT 
          CLOCK  X1 
          EQ     TIMX        RETURN 
 P.VPE    SPACE  4,10 
**        P.VPE - VARIABLE PROCEDURE ENTRY. 
* 
*         CALL A VARIABLE PROCEDURE BY DOING THE FOLLOWING: 
*                1. SIMULATE A RETURN JUMP TO THE ROUTINE.
*                2. MOVE THE STATIC LINK TO THE LOWER 18 BITS OF X5.
* 
*         ENTRY  (X5) = 42/STATIC LINK,18/ENTRY POINT 
* 
*         EXIT   TO ROUTINE ENTRY POINT + 1.
* 
*         USES   X - 5, 6, 7. 
*                A - 5, 7.
*                B - 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 VPE      ROUTINE P.VPE 
          BX6    X5 
          SB7    X5+B1       PROCEDURE ENTRY + 1
          SA5    VPE         GET RETURN ADDRESS 
          AX6    18          STATIC LINK
          BX7    X5 
          SX5    X6          STATIC LINK
          SA7    B7-B1       SIMULATE RJ TO PROCEDURE 
          JP     B7          ENTER THE PROCEDURE
 PSYSTM   TITLE  SUBROUTINES. 
 CAD      SPACE  4,12 
**        CAD - CONVERT ADDRESS TO DISPLAY. 
* 
*         ENTRY  (X1) = 18 BIT ADDRESS. 
* 
*         EXIT   (B2) = 6 * COUNT OF DIGITS CONVERTED.
*                (X2) = DISPLAY CODE LEFT JUSTIFIED, BLANK FILLED WITH
*                       LEADING ZERO SUPPRESSION. 
*                (X6) = DISPLAY CODE RIGHT JUSTIFIED, BLANK FILLED WITH 
*                       LEADING ZERO SUPPRESSION. 
* 
*         USES   A - 2. 
*                B - 2, 3, 7. 
*                X - 1, 2, 3, 4, 6, 7.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 CAD      ROUTINE P.CAD 
          SA2    CADA        =10H 
          SB3    6           (B3) = SHIFT INCREMENT 
          MX4    -3          (X4) = DIGIT MASK
          SB2    B0          CLEAR JUSTIFY COUNT
          SB7    1R0-1R      (B7) = CONVERSION COUNT
 CAD1     BX7    -X4*X1      EXTRACT DIGIT
          LX2    -6          SHIFT ASSEMBLY 
          SB2    B2+B3
          SX3    X7+B7       CONVERT DIGIT
          AX1    3           SHIFT OFF DIGIT
          IX2    X2+X3       ADD DIGIT TO ASSEMBLY
          NZ     X1,CAD1     LOOP TO ZERO DIGIT 
          LX2    -6          LEFT JUSTIFY ASSEMBLY
          LX6    X2,B2       RIGHT JUSTIFY ASSEMBLY 
          EQ     CADX        RETURN 
  
 CADA     CON    10H
 CFD      SPACE  4,16 
***       CFD - CONVERT INTEGER TO PASCAL 10:3 FORM.
* 
*         ADAPTED FROM CDC COMMON DECK *COMCCFD*. 
* 
*         ENTRY  (B1) = 1.
*                (X1) = INTEGER TO BE CONVERTED (LESS THAN 2**30).
* 
*         EXIT   (X6) = NUMBER CONVERTED TO DISPLAY CODE. 
* 
*         USES   A - 1, 2, 3, 4, 6. 
*                B - 2, 3.
*                X - ALL. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
  
 CFD      ROUTINE P.CFD 
          SA2    CFDA        =.1P48+1 
          SX7    1000 
          SA3    A2+B1       =10.0P 
          MX4    -29
          SB3    -6 
          BX6    -X4*X1      DISCARD UPPER BITS 
          SX5    6
          IX7    X6-X7
          SA4    A3+B1       (X4) = BACKGROUND
          SB2    1R0-1R      (B2) = CONVERSION
          PX1    X6          FLOAT
          PL     X7,CFD1     IF INTEGER PRESENT 
          SB2    B0 
          SA4    A4+B1       SET LEADING ZEROS
 CFD1     DX6    X2*X1       EXTRACT REMAINDER
          FX1    X2*X1
          LX4    -6 
          SB3    B3+X5       ADVANCE SHIFT COUNT
          UX7    X1          CHECK QUOTIENT 
          FX0    X3*X6       EXTRACT DIGIT
          SX6    X0+B2       CONVERT DIGIT
          IX4    X6+X4
          NZ     X7,CFD1     LOOP TO ZERO QUOTIENT
          SX3    1R.         INSERT DECIMAL POINT 
          MX2    -18         FRACTION MASK
          LX6    X4,B3       RIGHT JUSTIFY ASSEMBLY 
          BX1    -X2*X6      EXTRACT FRACTION 
          LX3    18 
          IX7    X1+X3       ADD DECIMAL POINT
          BX4    X2*X6       EXTRACT INTEGER
          LX4    6
          IX6    X4+X7       ADD INTEGER INTO RESULT
          EQ     CFDX        RETURN 
  
 CFDA     CON    0.1P48+1 
          CON    10.0P
          CON    9L 
          CON    9L     0000
 FCE      SPACE  4,18 
**        FCE - FIND CURRENT ENTRY POINT. 
* 
*         FCE FINDS THE ENTRY POINT TO THE CURRENT PROCEDURE. 
*         STACK SEGMENTS FOR ROUTINES WITH PMD SUPPRESSED 
*         ARE AUTOMATICALLY POPPED FROM THE STACK.  FCE 
*         ALSO DETERMINES IF THE CURRENT ROUTINE HAS PMD INFO.
* 
*         ENTRY  NONE.
* 
*         EXIT   (X1) = NAME OF MODULE TYPE (*PROGRAM*, *PROCEDURE* OR
*                       *FUNCTION*) LEFT JUSTIFIED, ZERO FILLED.
* 
*                (X2) = ADDRESS OF ENTRY POINT CORRESPONDING TO 
*                       THE CURRENT STACK SEGMENT.
*                (X5) < 0 IF PMD INFO IS AVAILABLE. 
*                     >= 0 IF PMD INFO IS NOT AVAILABLE.
* 
*         USES   A - 1, 2, 5. 
*                B - 2, 3, 5, 6.
*                X - 1, 2, 5, 6, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 FCE3     SA5    X2-1        LOAD MAIN PROGRAM DESCRIPTOR WORD
          SA1    =L*PROGRAM*
  
 FCE      ROUTINE P.FCE      ENTRY/EXIT 
          SA2    TGVR+MVAR   ADDRESS OF MAIN PROGRAM ACTIVATION 
          MX7    1
          LX7    -2 
          SB3    X2+
          EQ     B5,B6,FCE2  IF STACK PARTIALLY POPPED
 FCE1     SA2    TGVR+MAIN   ASSUME MAIN ROUTINE
          EQ     B5,B3,FCE3  IF CURRENT ROUTINE IS MAIN PROGRAM 
          SA1    B5 
          AX1    30 
          SA5    X1-3        PROCEDURE DESCRIPTOR WORD
          SX2    A5+1        ENTRY POINT OF CURRENT ROUTINE 
          BX6    X7*X5
          LX6    3
          SA1    X6+FCEA     LOAD MODULE NAME (PROCEDURE/FUNCTION)
          NG     X5,FCEX     IF PMD INFO AVAILABLE
          LX5    59-58
          PL     X5,FCEX     IF PMD NOT SUPPRESSED
 FCE2     SA2    B5+B1       BACK UP TO PREVIOUS STACK SEGMENT
          SB6    B5 
          LX2    30 
          SB5    X2 
          EQ     FCE1        CONTINUE 
  
 FCEA     BSS    0           TABLE OF MODULE TYPES
          DATA   L*PROCEDURE* 
          DATA   L*FUNCTION*
 FOB      SPACE  4,14 
**        FOB - FLUSH OUTPUT BUFFER.
* 
*         IF AN OUTPUT FILE, FLUSH THE BUFFER.
* 
*         ENTRY  (X2) = FET ADDRESS.
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  CIO=, PTL, WNB=. 
* 
*         MACROS RECALL, WRITER.
  
  
 FOB      ROUTINE P.FOB 
          SA1    X2          FET FIRST WORD 
          LX1    59-2 
          PL     X1,FOBX     IF INPUT FILE (READ CODE)
          SA3    A1-B1       EFET 
          SA1    A3-B1       FILE POINTER 
          LX3    59-55
          SB3    X1 
          PL     X3,FOB1     IF NOT CHARACTER FILE
          SB7    A3-12       FWA CHARACTER BUFFER 
          EQ     B3,B7,FOB1  IF CHARACTER BUFFER EMPTY
          RJ     PTL         WRITELN
 FOB1     SA3    X2+2        IN 
          RECALL X2          WAIT I/O COMPLETE
          SA1    X2          FET FIRST WORD 
          BX6    X1          COPY FIRST WORD OF FET 
          MX7    -4          MASK FOR *AT* FIELD
          LX6    0-10        POSITION *AT* FIELD
          BX7    -X7*X6      EXTRACT *AT* 
          NZ     X7,FOBX     IF *AT* SET
          SA4    A3+B1       OUT
          SX1    X1-24B      WRITER CODE
          AX1    2           GET RID OF BINARY AND COMPLETE BITS
          IX6    X3-X4
          NZ     X1,FOB2     IF NOT WRITER CODE IN FET
          ZR     X6,FOBX     IF BUFFER EMPTY
 FOB2     WRITER X2          FLUSH THE BUFFER 
          EQ     FOBX        RETURN 
 ISM      SPACE  4,10 
**        ISM - ISSUE STATISTICS MESSAGE TO DAYFILE.
* 
*         ENTRY  (ISMA) = PRESET WITH INITIAL MILLISECOND CLOCK.
* 
*         EXIT   CP/CM USED MESSAGE ISSUED TO DAYFILE.
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  CAD, CFD, CLK, MSG=. 
* 
*         MACROS MESSAGE. 
  
  
 ISM      ROUTINE P.ISM      ENTRY/EXIT 
          SA3    TGVR+FL     RUN FL 
          SA2    TGVR+MINFS  MINIMUM FREE WORKSPACE 
          SA5    MSGAA+2     CM PORTION OF MESSAGE
          SX4    MINFB
          IX6    X3-X2       COMPUTE MINIMUM CM NEEDED
          IX1    X6+X4       ENSURE GUARENTEED AMOUNT OF WORKSPACE
          RJ     CAD         CONVERT CM TO DISPLAY CODE 
          MX0    6*4
          BX6    -X0*X6      REMOVE BLANKS
          LX0    4*6         POSITION MASK
          BX5    X0*X5       REMOVE XXXXXX
          LX6    4*6         POSITION DIGITS
          BX7    X5+X6
          SA7    A5+         RESTORE WORD 
          SA5    ISMA 
          RJ     CLK         GET MILLISECOND CLOCK
          IX1    X6-X5
          RJ     CFD         CONVERT CP SECONDS TO PASCAL 10:3 FORM 
          SA6    MSGAA
          MESSAGE MSGAA,"IMSG"  * AAAAA.BBB CM SECS, XXXXXXB CM USED.*
          EQ     ISMX        RETURN 
  
 ISMA     BSS    1           INITIAL MILLISECOND CLOCK
 RPE      SPACE  4,10 
**        RPE - RESTORE PASCAL ENVIRONMENT. 
* 
*         ENTRY  (P.GLOBL+PTRS) = PASCAL STACK AND HEAP POINTERS. 
*                (P.GLOBL+FORT) = FORTRAN CALL FLAG AND LINE NUMBER.
* 
*         EXIT   FORTRAN CALL FLAG IN (P.GLOBL+FORT) CLEARED. 
*                (A0) = LINE NUMBER IN PASCAL PROGRAM AT WHICH THE
*                       FORTRAN ROUTINE WAS CALLED. 
*                (B4) = TOP OF HEAP POINTER.
*                (B5) = POINTER TO CURRENT ACTIVATION.
*                (B6) = TOP OF STACK POINTER. 
* 
*         USES   X - 4, 5, 6. 
*                A - 0, 4, 5, 6.
*                B - 4, 5, 6. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 RPE      ROUTINE P.RPE      ENTRY/EXIT 
          SA4    =XP.GLOBL+FORT 
          SA5    =XP.GLOBL+PTRS 
          SA0    X4-400000B  RESTORE LINE NUMBER
          SB6    X5          RESTORE TOP OF STACK POINTER 
          AX5    18 
          SB5    X5          RESTORE POINTER TO CURRENT ACTIVATION
          AX5    18 
          SB4    X5          RESTORE TOP OF HEAP POINTER
          BX6    X2-X2
          SA6    A4          CLEAR FORTRAN CALL FLAG
          EQ     RPEX        RETURN 
 RPF      SPACE  4,12 
**        RPF - REWIND PASCAL FILE. 
* 
*         IF THE ACTUAL FILE NAME IS NEITHER INPUT NOR OUTPUT,
*         FLUSH THE I/O BUFFER (FOR OUTPUT FILES) AND REWIND. 
* 
*         ENTRY  (X2) = FET ADDRESS.
* 
*         EXIT   (X2) = FET ADDRESS.
*                (X0) < 0 ONLY IF THE NAME IS INPUT OR OUTPUT.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 3, 7.
*                X - ALL. 
* 
*         CALLS  CIO=, FOB. 
* 
*         MACROS NONE.
  
  
 RPF      ROUTINE P.RPF 
          SA1    X2          FET
          MX0    42 
          SA3    =5LINPUT 
          BX6    X0*X1
          SA4    =6LOUTPUT
          IX3    X6-X3
          BX4    X6-X4
          ZR     X3,RPFX     IF ACTUAL FILE NAME IS INPUT 
          ZR     X4,RPFX     IF ACTUAL FILE NAME IS OUTPUT
          RJ     FOB         FLUSH OUTPUT BUFFER
          REWIND X2 
          BX0    X0-X0
          EQ     RPFX        RETURN 
 SKP      SPACE  4,14 
**        SKP - SKIP RECORDS. 
* 
*         ENTRY  (A1) = EFET ADDRESS. 
*                (X1) = ((A1)). 
*                (X2) = SKIP COUNT. 
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 4, 6, 7. 
*                B - 2, 3, 7. 
*                X - ALL. 
* 
*         CALLS  CIO=, FOB, WNB=. 
* 
*         MACROS SKIPB, SKIPF, RECALL.
  
  
 SKP1     BX5    X6*X0       EOF STATUS 
          NZ     B2,SKP2     IF NON-ZERO SKIP COUNT 
          NG     X5,SKPX     IF (ZERO SKIP COUNT) AND (EOF/EOI) 
          SX1    B1 
          SKIPB  X2,X1,R     BACK TO TOP OF SEGMENT 
          EQ     SKPX        RETURN 
  
 SKP2     SX1    B1-B2       COMPLEMENT AND ADD 1 
          LX4    X5,B1
          IX1    X1-X4       IF EOF THEN SUBTRACT 1 
          SKIPB  X2,X1,R
  
 SKP      ROUTINE P.SKP 
          SB2    X2          SKIP COUNT 
          SX2    A1+B1       FET
          RJ     FOB         FLUSH BUFFER (IF OUTPUT TYPE FILE) 
          SA3    X2-1        EFET 
          RECALL X2          WAIT I/O COMPLETE
          LX0    X3,B1       EOF STATUS 
          MX6    1
          LE     B2,B0,SKP1  IF SKIP COUNT ZERO OR NEGATIVE 
          SA4    X2          FET
          LX4    59-4 
          BX3    X4+X3       EOS OR EOR STATUS IN FET 
          BX5    X6*X3
          AX5    59-1 
          SX1    B2+X5       SUBTRACT ONE IF AT EOS OR EOR IN FET 
          ZR     X1,SKPX     RETURN IF ZERO SKIP COUNT
          SKIPF  X2,X1,R     SKIP FORWARDS
          EQ     SKPX        RETURN 
 SNM      SPACE  4,32 
***       SNM - SET NAME IN MESSAGE.
* 
*         REPLACES OCCURRENCES OF THE SUBSTITUTION CHARACTER WITHIN 
*         A MESSAGE WITH THE CHARACTERS OF THE GIVEN NAME OR NUMBER,
*         ELIMINATING ALL EXCESS OCCURRENCES OF THE SUBSTITUTION
*         CHARACTER, AND GUARANTEEING AN EOLN IN THE NEW MESSAGE. 
*         THE ORIGINAL MESSAGE MUST CONTAIN A SUFFICIENT NUMBER OF
*         SUBSTITUTION CHARACTERS (USUALLY CONSECUTIVE) TO ALLOW FOR
*         REPLACEMENT BY THE NAME OR NUMBER (UP TO 10 CHARACTERS).
*         THE MESSAGE MUST NOT CONTAIN COLONS (00B) AS THEY WILL BE 
*         INTERPRETED AS AN EOLN.  ADAPTED FROM CDC COMMON DECK 
*         *COMCSNM*.
* 
*         ENTRY  (A4) = FWA - 1 OF MESSAGE. 
*                (B1) = 1.
*                (B7) = DISPLAY CODE SUBSTITUTION CHARACTER,
*                       RIGHT JUSTIFIED, BINARY ZERO FILLED.
*                (X1) = DISPLAY CODE NAME TO BE SET IN MESSAGE, 
*                       LEFT JUSTIFIED, BINARY ZERO FILLED. 
*                (X4) = ((A4)). 
* 
*         EXIT   (B7) = UNCHANGED.
*                (X1) = UNCHANGED.
*                NAME ENTERED INTO MESSAGE IN PLACE OF SUBSTITUTION 
*                CHARACTERS.
* 
*         USES   A - 4, 7.
*                B - 2, 3.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 SNM4     SX2    B2          INSURE EVEN NUMBER OF CHARACTERS 
          LX2    -1 
          PL     X2,SNM6     IF NOT ODD NUMBER OF CHARACTERS
          SX3    1R 
          BX2    -X6*X7 
          IX2    X2-X3
          NZ     X2,SNM5     IF LAST CHARACTER NOT BLANK
          AX7    6           REMOVE TRAILING BLANK
          SB2    B2+B1
          EQ     SNM6        LEFT JUSTIFY LAST WORD OF NEW MESSAGE
  
 SNM5     LX7    6           ADD TRAILING BLANK 
          SB2    B2-1 
          BX7    X3+X7
 SNM6     SB2    B2+B2       LEFT JUSTIFY LAST WORD OF NEW MESSAGE
          BX1    X0          RESTORE X1 
          SB3    B2+B2       CALCULATE SHIFT COUNT
          MX2    -12
          SB2    B3+B2
          LX7    X7,B2
          SA7    A7+B1
          BX2    -X2*X7 
          ZR     X2,SNMX     IF END OF LINE SET 
          BX7    X7-X7       GUARANTEE END OF LINE
          SA7    A7+B1
  
 SNM      ROUTINE P.SNM      ENTRY/EXIT 
          SB2    10          INITIALIZE REGISTERS 
          BX7    X4 
          LX0    X1          SAVE X1
          SA7    A4 
          SB3    B0 
          MX6    -6 
          BX7    X7-X7
 SNM1     SB3    B3-B1       DECREMENT OLD MESSAGE WORD CHARACTER COUNT 
          SX3    B7 
          PL     B3,SNM2     IF MORE CHARACTERS IN OLD MESSAGE WORD 
          SA4    A4+1        GET NEXT WORD IN ORIGINAL MESSAGE
          SB3    9           RESET OLD MESSAGE WORD CHARACTER COUNT 
 SNM2     LX4    6           GET NEXT CHARACTER FROM ORIGINAL MESSAGE 
          BX2    -X6*X4 
          ZR     X2,SNM4     IF END OF LINE 
          IX3    X2-X3
          NZ     X3,SNM3     IF NOT SUBSTITUTION CHARACTER
          LX1    6
          ZR     X1,SNM1     IF REPLACEMENT ALREADY COMPLETED 
          BX2    -X6*X1      GET NEXT CHARACTER FROM SPECIFIED NAME 
          BX1    X6*X1
 SNM3     LX7    6           ENTER NEXT CHARACTER INTO NEW MESSAGE WORD 
          BX7    X7+X2
          SB2    B2-1        DECREMENT NEW MESSAGE WORD CHARACTER COUNT 
          GT     B2,SNM1     IF NEW MESSAGE WORD NOT FULL 
          SA7    A7+B1       SAVE NEW MESSAGE WORD
          BX7    X7-X7
          SB2    10          RESET NEW MESSAGE WORD CHARACTER COUNT 
          EQ     SNM1        CONTINUE BUILDING NEW MESSAGE
 SPE      SPACE  4,10 
**        SPE - SAVE PASCAL ENVIRONMENT.
* 
*         ENTRY  (A0) = LINE NUMBER IN PASCAL PROGRAM AT WHICH THE
*                       FORTRAN ROUTINE WAS CALLED. 
*                (B4) = TOP OF HEAP POINTER.
*                (B5) = POINTER TO CURRENT ACTIVATION.
*                (B6) = TOP OF STACK POINTER. 
* 
*         EXIT   PASCAL STACK, HEAP POINTERS SAVED IN (P.GLOBL+PTRS). 
*                FORTRAN CALL FLAG, LINE NUMBER SET IN (P.GLOBL+FORT).
* 
*         USES   X - 3, 6, 7. 
*                A - 6, 7.
*                B - NONE.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 SPE      ROUTINE P.SPE      ENTRY/EXIT 
          SX6    B4 
          SX7    B5 
          SX3    B6 
          LX6    36 
          LX7    18 
          BX3    X6+X3
          BX7    X3+X7       6/0,18/B4,18/B5,18/B6
          SX6    A0+400000B 
          SA7    =XP.GLOBL+PTRS   SAVE PASCAL STACK, HEAP POINTERS
          SA6    =XP.GLOBL+FORT   SET FORTRAN CALL FLAG, LINE NUMBER
          EQ     SPEX        RETURN 
 SRS      SPACE  4,14 
**        SRS - SET READ STATUS.
* 
*         FILL BUFFER UNLESS FILE IS A TERMINAL FILE. 
* 
*         ENTRY  (X2) = FET ADDRESS.
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 3, 7.
*                X - 0, 1, 3, 4, 6, 7.
* 
*         CALLS  GTB, GTC, WNB=.
* 
*         MACROS RECALL.
  
  
 SRS2     SX7    X2-4        END OF CHARACTER BUFFER
          SX6    1R 
          MX1    1
          SA6    X7          SET BLANK AS NEXT CHARACTER
          BX7    X1+X7       SET EOLN 
          SA7    X3          SET POINTER
 SRS3     MX3    42+2 
          SA1    X2          FET FIRST WORD 
          LX3    2
          BX6    X3*X1       REMOVE OLD FUNCTION CODE 
          SX4    10B
          IX6    X6+X4       INSERT READ CODE 
          SA6    A1 
  
 SRS      ROUTINE P.SRS 
          SA4    X2+B1       FIRST
          SX3    X4 
          RECALL X2          WAIT I/O COMPLETE
          SA1    X2          FET
          MX4    42+2 
          LX4    2
          BX6    X4*X1
          SA6    A1          CLEAR FUNCTION CODE
          SA1    A1-B1       EFET 
          BX6    X3          FIRST
          IX4    X3+X1
          SX7    X4 
          SA7    A4+B1       IN := FIRST + LRL
          SX3    64B
          SA6    A7+B1       OUT := FIRST 
          LX3    -6 
          BX6    -X3*X1      CLEAR EOS, EOF, AND REWRITE BITS 
          SA6    A1 
          LX6    59-55
          LX1    X6,B1
          PL     X6,SRS1     IF BINARY FILE 
          SX3    A1-1        ADDRESS OF POINTER 
          NG     X1,SRS2     IF TERMINAL FILE 
          SX6    X3-2        ADDRESS OF SENTINEL - 1
          SA6    X3          SET POINTER AND CLEAR EOLN 
          SA1    X3          EFET-1 
          RJ     GTC         FILL BUFFER
          EQ     SRSX        RETURN 
  
 SRS1     NG     X1,SRS3     IF TERMINAL FILE 
          SA1    A1+         EFET 
          RJ     GTB         FILL BUFFER
          EQ     SRSX        RETURN 
 SWS      SPACE  4,12 
**        SWS - SET WRITE STATUS. 
* 
*         ENTRY  (X2) = FET ADDRESS.
* 
*         EXIT   (X2) = FET ADDRESS.
* 
*         USES   A - 1, 3, 6, 7.
*                B - 7. 
*                X - 1, 3, 6, 7.
* 
*         CALLS  WNB=.
* 
*         MACROS RECALL.
  
  
 SWS      ROUTINE P.SWS 
          MX7    42+2 
          LX7    2
          RECALL X2          WAIT I/O COMPLETE
          SA3    X2          FET
          BX6    X7*X3       REMOVE OLD FUNCTION CODE 
          SX3    24B
          IX6    X6+X3       INSERT WRITER CODE 
          SA6    A3 
          SA1    X2+B1       FIRST
          SX6    X1 
          SA6    A1+B1       IN = FIRST 
          SA6    A6+B1       OUT = FIRST
          SA3    A3-B1       EFET 
          SX1    X6          FIRST
          SX7    64B
          LX7    -6 
          BX6    X7+X3       SET EOS, EOF, AND REWRITE BITS 
          SA6    A3+
          LX6    59-55
          BX3    X3-X3
          SX7    1R 
          PL     X6,SWS2     IF BINARY FILE 
          SB7    10-1 
          SA7    A3-12       CLEAR CHARACTER BUFFER 
          MX3    2
          SX1    A7          FWA CHARACTER BUFFER 
 SWS1     SA7    A7+B1
          SB7    B7-B1
          GT     B7,B0,SWS1  LOOP 
 SWS2     BX6    X1+X3       SET EOLN AND REWRITE BITS IF CHARACTER FILE
          SA6    A3-B1       SET FILE POINTER 
          EQ     SWSX        RETURN 
 TMS      SPACE  4,14 
**        TMS - TERMINATE MESSAGE STRING. 
* 
*         ENSURE END OF LINE TERMINATOR ON STRING.
* 
*         ENTRY  (X1) = ADDRESS OF PACKED STRING. 
*                (X2) = LENGTH OF STRING IN CHARACTERS. 
* 
*         EXIT   (X1) = ADDRESS OF MESSAGE IN -C- FORMAT. 
* 
*         USES   A - 1, 2, 6, 7.
*                B - 7. 
*                X - 1, 2, 6, 7.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 TMS2     ZR     X2,TMS3     IF STRING ENDED ON WORD BOUNDARY 
          LX7    X2,B1
          LX2    X7,B1
          IX7    X2+X7       MULTIPLY X2 BY 6 
          MX1    1
          SB7    X7-59
          AX1    -B7         GENERATE CHARACTER MASK
          BX6    X1*X6       REMOVE CHARACTERS
          SA2    =10H 
          BX1    -X1*X2 
          BX6    X1+X6       REPLACE REMOVED CHARACTERS WITH BLANKS 
          SA6    A6+         REPLACE LAST WORD
 TMS3     BX7    X7-X7
          SA7    A6+B1       ENSURE ZERO WORD 
          SX1    TMSA        MESSAGE ADDRESS
  
 TMS      ROUTINE P.TMS      ENTRY/EXIT 
          SA1    X1+         FIRST WORD 
          BX2    -X2
          LX6    X1 
          SX7    X2+80
          SA6    TMSA        STORE FIRST WORD 
          PL     X7,TMS1     IF 80 CHARACTERS OR LESS 
          SX2    -80
 TMS1     SX2    X2+10
          PL     X2,TMS2     IF WORD CONTAINING END OF STRING FOUND 
          SA1    A1+1        NEXT WORD
          BX6    X1 
          SA6    A6+B1
          EQ     TMS1 
  
 TMSA     SCRATCH 9 
 WWR      SPACE  4,12 
**        WWR - WRITE WITHOUT REWRITE.
* 
*         ENTRY  (X2) = FET ADDRESS.
* 
*         EXIT   TO IOE1. 
* 
*         USES   A - NONE.
*                B - NONE.
*                X - 1. 
* 
*         CALLS  IOE. 
* 
*         MACROS NONE.
  
  
 WWR      ROUTINE P.WWR 
 WWR1     SX1    IOEC        TRIED TO WRITE XXXXXXX WITHOUT REWRITE 
          EQ     IOE1        ISSUE INPUT/OUTPUT ERROR 
 PSYSTM   SPACE  4
          END 
