*DECK     COMPRTN 
          IDENT  COMPRTN
          SYSCOM B1 
          LIST   F
          ENTRY  BMSG 
          ENTRY  CLOSEB 
          ENTRY  CLOSET 
          ENTRY  CSLOC
          ENTRY  FIND 
          ENTRY  LOADGO 
          ENTRY  MASK 
          ENTRY  MERGE
          ENTRY  NEXTCH 
          ENTRY  NEXTCHS
          ENTRY  PORTION
          ENTRY  RELEASE
          ENTRY  ROTATE 
 COMPRTN  SPACE  4,10 
 COMPRTN  TITLE  COMPRTN - PASCAL 6000 COMPILER ROUTINES. 
          COMMENT PASCAL 6000 COMPILER ROUTINES.
          COMMENT COPYRIGHT (C) UNIVERSITY OF MINNESOTA - 1978. 
 COMPRTN  SPACE  4,10 
***       COMPRTN - PASCAL 6000 COMPILER ROUTINES.
*         J. J. DRUMMOND.    77/09/10.
*         J. P. STRAIT.      78/03/28.
 COMPRTN  SPACE  4,10 
**        ASSEMBLY CONSTANTS. 
  
  
*CALL     COMSPAS 
 BMSG     SPACE  4,12 
***       BMSG - ISSUE COMPILER *B* DISPLAY MESSAGE.
* 
*         PROCEDURE BMSG( NAME : ALFA ); EXTERN;
* 
*         ENTRY  (B1) = 1.
*                (X0) = PROCEDURE NAME. 
* 
*         EXIT   COMPILER MESSAGE ISSUED TO *B* DISPLAY.
* 
*         USES   A - 1, 6.
*                B - NONE.
*                X - 1, 6.
* 
*         CALLS  MSG=.
* 
*         MACROS MESSAGE. 
  
  
 BMSG     PS                 ENTRY/EXIT 
          BX6    X0          PROCEDURE NAME 
          SA6    BMSA+1      STORE PROCEDURE NAME 
          MESSAGE A6-B1,1    ISSUE *B* DISPLAY MESSAGE
          EQ     BMSG        RETURN 
  
 BMSA     DATA   10HCOMPILING 
          BSS    1           PROCEDURE NAME 
          CON    0           MESSAGE TERMINATOR 
 CLOSE    SPACE  4,10 
***       CLOSE - CLOSE PASCAL FILE.
* 
*         PROCEDURE CLOSEB( VAR F : LGOFILE ); EXTERN;
*         PROCEDURE CLOSET( VAR F : TEXT    ); EXTERN;
* 
*         ENTRY  (B1) = 1.
*                (X0) = EFET - 1 (FOR CLOSEB),
*                     = EFET - 13 (FOR CLOSET). 
* 
*         EXIT   FILE CLOSED. 
*                FILE RETURNED IF AN INTERNAL FILE. 
* 
*         USES   A - 1, 2, 3, 4, 5, 6, 7. 
*                B - 2, 3, 7. 
*                X - ALL. 
* 
*         CALLS  P.CLOSE
* 
*         MACROS NONE.
  
  
 CLOSEB   PS                 ENTRY/EXIT 
          SA1    X0+B1       EFET 
          SB2    -B1         SET CLOSE NON-DYNAMIC FILE 
          RJ     =XP.CLOSE   CLOSE THE FILE 
          EQ     CLOSEB      RETURN 
  
  
 CLOSET   PS                 ENTRY/EXIT 
          SA1    X0+13       EFET 
          SB2    -1          SET CLOSE NON-DYNAMIC FILE 
          RJ     =XP.CLOSE   CLOSE THE FILE 
          EQ     CLOSET      RETURN 
 CSLOC    SPACE  4,10 
**        CSLOC - RETURN CONTROL STATEMENT LOCATION.
* 
*         TYPE PCSIMAGE = ^CSIMAGE; 
*         PROCEDURE CSLOC(VAR CS : PCSIMAGE); EXTERN; 
* 
*         ENTRY  (B1) = 1.
*                (X0) = ADDRESS OF VARIABLE TO RECEIVE LOCATION.
* 
*         EXIT   ((X0)) = CONTROL STATEMENT LOCATION. 
* 
*         USES   X - 6. 
*                A - 6. 
*                B - NONE.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 CSLOC    PS                 ENTRY/EXIT 
          SX6    CCDR        CONTROL STATEMENT LOCATION 
          SA6    X0+
          EQ     CSLOC       RETURN 
 ELR      SPACE  4,10 
**        ELR - EXECUTE LOADER REQUEST. 
* 
*         ENTRY  ENTER WITH A JUMP NOT A RETURN JUMP. 
*                (X0) = ADDRESS OF *LDV* PARAMETER BLOCK. 
*                (X0) = 0 FOR RELOCATABLE AUTOLOAD. 
* 
*         EXIT   TO LOADED MODULE.
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  SYS=.
* 
* (NOS)   MACROS SYSTEM.
  
  
 ELR      BSS    0
          SYSTEM LDV,R,X0    LOAD BINARY
  
          PS                 ABORT IF LOAD NOT SUCCESSFUL 
 FIND     SPACE  4,10 
***       FIND - FIND NAMED RECORD ON NAMED FILE. 
* 
*         FIND SEARCHES FOR A NAMED FILE.  IF THE FILE NAME PASSED TO 
*         FIND IS ALL BLANKS, THEN THE DEFAULT NAME (*PASCLIB* FOR
*         KRONOS AND NOS, *PSRCLIB* FOR SCOPE AND NOS/BE) IS USED.  THE 
*         FILE SEARCH IS DONE IN THE FOLLOWING ORDER. 
*                1. LOCAL FILES.
*                2. SYSTEM LIBRARY FILES FOR KRONOS AND NOS, PERMANENT
*                   FILES ON *ID=PASCAL* FOR SCOPE AND NOS/BE.
*         IF THE FILE IS LOCATED SUCCESSFULLY, FIND THEN SEARCHES 
*         THAT FILE FOR A NAMED TEXT RECORD.  A *ULIB* RECORD MAY 
*         APPEAR AT THE BEGINNING OF THE FILE, AND WILL BE IGNORED. 
*         THE FILE IS SEARCHED SEQUENTIALLY, AND IS DETERMINED
*         TO BE UNSUCCESSFUL IF ANY ONE OF THE FOLLOWING IS REACHED:  
*                1) AN EMPTY RECORD,
*                2) AN EOF OR EOI,
*                3) A PREFIX TABLE (INDICATING A NON-TEXT RECORD).
*         THE FILE ARGUMENT *MUST* BE A TEXT FILE.  THE OLD FILE IS 
*         RETURNED IF IT IS AN INTERNAL FILE, AND THEN THE NEW FILE IS
*         MADE TO BE A SEGMENTED, TERMINAL TEXT FILE.  IF THE FILE
*         ALREADY EXISTS (BEFORE CALLING FIND) IT IS FLAGGED AS AN
*         EXTERNAL FILE, BUT IF IT MUST BE ASSIGNED FROM THE SYSTEM, IT 
*         IS FLAGGED AS AN INTERNAL FILE.  UPON SUCCESSFUL RETURN, THE
*         RECORD NAME HAS BEEN SKIPPED, AND THE FILE POINTER REFERENCES 
*         THE FIRST CHARACTER OF THE NEXT WORD.  IF THE SEARCH IS 
*         UNSUCCESSFUL, THE FILE WILL BE POSITIONED AT EOS/EOF. 
* 
*         FIND SHOULD BE DECLARED AS FOLLOWS: 
* 
*         TYPE STEXT = SEGMENTED FILE OF CHAR;
*         PROCEDURE FIND(VAR F : STEXT; FNAME,RNAME : ALFA); EXTERN;
 FIND     SPACE  4,10 
**        FIND - FIND A NAMED RECORD ON A NAMED FILE. 
* 
*         ENTRY  (X0) = ADDRESS OF FILE: FET-14.
*                (X1) = FILE NAME.
*                (X1) = '          ' FOR DEFAULT FILE NAME. 
*                (X2) = RECORD NAME.
*                (B1) = 1.
* 
*         EXIT   IF SUCCESS, FILE POSITIONED TO REQUESTED RECORD, 
*                ELSE FILE POSITIONED AT EOS/EOF. 
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  CIO=, P.CLOSE, P.GETB, P.GETCH, P.GETS, LFM=, ZFN=.
* 
* (NOS)   MACROS ASSIGN, RECALL.
  
  
 FIND     PS                 ENTRY/EXIT 
          BX6    X2 
          SB2    B0          DO NOT DISPOSE BUFFER
          SA6    FNDB        SAVE RECORD NAME 
          RJ     =XZFN=      ZERO FILL FILE NAME
          SA1    =0LPASCLIB  DEFAULT FILE NAME
          BX3    X3-X3
          IX4    X3-X6
          BX5    X4+X6
          BX1    -X5*X1 
          IX6    X6+X1       FILE NAME OR DEFAULT 
          SA6    FNDA        SAVE FILE NAME 
          SA1    FNDB 
          RJ     =XZFN=      ZERO FILL RECORD NAME
          SA6    FNDB        SAVE RECORD NAME 
          SA1    X0+13       EFET 
          RJ     =XP.CLOSE   CONDITIONALLY RETURN THE OLD FILE
          RECALL X2          WAIT I/O COMPLETE
          SA1    FNDA        FILE NAME
          SX7    B1 
          SA7    X2+6        PRESET RANDOM REQUEST
          IX6    X1+X7
          SA6    X2          SET FILE NAME INTO FET 
          SX4    11B
          SA1    X2+B1
          LX4    44 
          BX6    X1+X4       SET RANDOM ACCESS AND ERROR PROCESSING 
          SA6    A1 
  
*         LOCATE FILE.
  
          ASSIGN X2,L        FIND FILE
          SA1    X2 
          SX6    B1 
          SX3    X1 
          AX3    10          STATUS RETURN
          SX4    X3-9 
          SX0    135B        DISP: SEG, TEXT, TERM, RE-OPEN, EXT
          NZ     X4,FND1     IF NOT FOUND AS LOCAL FILE 
          SA6    X2+6        SET RANDOM REQUEST TO FIRST SECTOR 
          EQ     FND2 
  
 FND1     SX4    X3-5 
          SX0    134B        DISP: SEG, TEXT, TERM, RE-OPEN 
          ZR     X4,FND7     IF NOT FOUND AS SYSTEM FILE
  
*         RESET POINTERS AND DISPOSITION TO OPEN THE FILE.
  
 FND2     SA1    X2+1        FIRST
          SX6    X1+B1
          SX7    X1 
          SA6    A1+B1       RESET IN 
          SA7    A6+B1       RESET OUT
          SA1    X2-1        EFET 
          MX6    9
          LX0    -9          POSITION NEW DISPOSITION 
          BX1    -X6*X1      CLEAR OLD DISPOSITION
          BX6    X1+X0       SET NEW DISPOSITION
          SA6    A1          EFET 
  
*         SKIP OPTIONAL *ULIB* RECORD.
  
          BX1    X6          EFET 
          RJ     =XP.GETB    GET FIRST WORD OF FILE 
          SA1    X2-1        EFET 
          NG     X1,FND7     IF EOS/EOF ENCOUNTERED 
          SA1    X3          FIRST WORD OF FILE 
          LX1    18 
          SX6    X1-770000B 
          NZ     X6,FND6     IF NO PREFIX TABLE 
          LX1    6
          SB2    X1          SIZE OF PREFIX TABLE 
 FND3     ZR     B2,FND4     IF FINISHED SKIPPING PREFIX TABLE
          SA1    X2-1        RELOAD EFET
          SB2    B2-B1       COUNT THIS WORD
          RJ     =XP.GETB    ADVANCE TO NEXT WORD 
          SA1    X2-1        EFET 
          NG     X1,FND7     IF EOS/EOF ENCOUNTERED 
          EQ     FND3 
  
 FND4     SA1    X2-1        RELOAD EFET
          RJ     =XP.GETB    GET FIRST WORD OF RECORD 
          SA1    X2-1        EFET 
          NG     X1,FND7     IF EOS/EOF ENCOUNTERED 
          SA1    X3          FIRST WORD 
          LX1    18 
          SX6    X1-760000B 
          NZ     X6,FND7     IF NOT *ULIB* RECORD 
  
*         LOCATE RECORD.
  
 FND5     SA1    X2-1        RELOAD EFET
          SX2    1           SKIP COUNT 
          RJ     =XP.GETS    GET SEGMENT
          SA1    X2-1        RELOAD EFET
          RJ     =XP.GETB    GET FIRST WORD OF RECORD 
          SA1    X2-1        EFET 
          NG     X1,FND7     IF EOS/EOF ENCOUNTERED 
          SA1    X3          FIRST WORD OF RECORD 
          LX1    18 
          SX6    X1-770000B 
          ZR     X6,FND7     IF PREFIX TABLE (IMPLYING NON-TEXT)
 FND6     LX1    -18
          SX0    X2          SAVE FET ADDRESS 
          RJ     =XZFN=      ZERO FILL RECORD NAME
          SX2    X0          RESTORE FET ADDRESS
          SA1    FNDB        TARGET RECORD NAME 
          BX3    X1-X6
          NZ     X3,FND5     IF NO MATCH
  
*         DEFINE FILE POINTER AS FIRST CHARACTER OF SECOND WORD.
  
          SA1    X0-2        EFET-1 
          MX3    60          REQUEST TO FILL CHARACTER BUFFER 
          SX7    FIND        RETURN ADDRESS FOR P.GETCH 
          EQ     =XP.GETCH   FILL CHARACTER BUFFER
  
*         SIGNAL FAILURE. 
  
 FND7     SA1    X2-1        EFET 
          MX6    2
          BX6    X1+X6       SET EOS/EOF BITS 
          SA6    A1          FLAG FAILURE 
          EQ     FIND        RETURN 
  
  
 FNDA     BSS    1           FILE NAME
 FNDB     BSS    1           RECORD NAME
 LOADGO   SPACE  4,10 
***       LOADGO - PERFORM AUTOMATIC LOAD AND GO. 
* 
*         PROCEDURE LOADGO(VAR LGO : FILE); 
* 
*         ENTRY  (B1) = 1.
*                (X0) = EFET - 1. 
* 
*         EXIT   FILE LOADED. 
* 
*         USES   A - 1, 6.
*                X - 1, 2, 6. 
* 
*         CALLS  CPM=, P.ISM, SYS=. 
* 
* (NOS)   MACROS EREXIT.
  
  
 LOADGO   PS                 ENTRY/EXIT 
          SA1    X0+2        FILE NAME
          MX2    42 
          BX6    X2*X1
          SA6    PGNR        SET PROGRAM NAME / CLEAR ARGUMENT COUNT
          RJ     =XP.ISM     ISSUE STATISTICS MESSAGE TO DAYFILE
          SX1    =YP.DER
          NG     X1,LGO1     IF NO REPRIEVE 
          RJ     =YP.DER     DISABLE ERROR REPRIEVE 
 LGO1     SX0    B0 
          EQ     ELR         EXECUTE LOADER REQUEST 
 MASK     SPACE  4,10 
***       MASK - GENERATE MASK FUNCTION.
* 
*         TYPE BITRANGE = 0..59;
*         FUNCTION MASK(COUNT : BITRANGE) : INTEGER;
* 
*         ENTRY  (B1) = 1.
*                (X0) = SHIFT COUNT.
* 
*         EXIT   (X6) = MASK (MAY BE NEGATIVE ZERO).
* 
*         USES   A - NONE.
*                B - 2, 7.
*                X - 0, 6.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 MASK     PS                 ENTRY/EXIT 
          SB2    X0-1 
          SX6    B0+
          NG     B2,MASK     IF ZERO MASK 
          MX0    1
          AX6    B2,X0       GENERATE MASK
          EQ     MASK        RETURN 
 MERGE    SPACE  4,10 
***       MERGE - LOGICALLY MERGE TWO WORDS.
* 
*         FUNCTION MERGE(A,B : VALU) : INTEGER; 
* 
*         ENTRY  (B1) = 1.
*                (X0) = FIRST VALUE.
*                (X1) = SECOND VALUE. 
* 
*         EXIT   (X6) = (X0) OR (X1). 
* 
*         USES   X - NONE.
*                A - NONE.
*                B - NONE.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 MERGE    PS                 ENTRY/EXIT 
          BX6    X0+X1
          EQ     MERGE       RETURN 
 NEXTCH   SPACE  4,10 
***       NEXTCH - GET NEXT SOURCE CHARACTER, CROSSING INPUT LINES
*         WHEN NECESSARY. 
* 
*         PROCEDURE NEXTCH; 
* 
*         ENTRY  (B1) = 1.
* 
*         EXIT   (CH) = NEXT CHARACTER. 
*                (CHCNT) UPDATED. 
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  BEGINLI, ENDLINE.
* 
*         MACROS NONE.
  
  
 NCH1     SA5    X2+         LINE[CHCNT]
          SX4    1R 
          IX7    X1-X6
          SA6    A2          CHCNT := CHCHT + 1 
          IX0    X5-X4       CH - ' ' 
          AX7    59 
 NCHC     BX1    X7*X0
          IX6    X5-X1       ' ' OR CH
          SA6    0           CH 
  
 NEXTCH   PS                 ENTRY/EXIT 
 NCHA     SA1    0           SOURCELENGTH 
          SA2    0           CHCNT
          IX3    X1-X2
          SX6    X2+B1
          PL     X3,NCH1     IF CHCNT <= SOURCELENGTH 
          RJ     =XENDLINE   PROCESS END OF SOURCE LINE 
          RJ     =XBEGINLI   READ NEXT SOURCE LINE
 NCHB     SA1    0           SOURCELENGTH 
          SA2    0           CHCNT
          SX6    X2+1 
          EQ     NCH1 
 NEXTCHS  SPACE  4,10 
***       NEXTCHS - NEXTCH SETUP ROUTINE. 
* 
*         CONST MAXLINELEN = 120; 
*         TYPE LINEBUFFER = ARRAY[1..MAXLINELEN] OF CHAR; 
*         PROCEDURE NEXTCHSETUP( VAR LINE : LINEBUFFER; 
*           VAR CH: CHAR; VAR CHCNT,SOURCELENGTH: INTEGER); EXTERN; 
* 
*         ENTRY  (B1) = 1.
*                (X0) = ADDRESS OF LINE.
*                (X1) = ADDRESS OF CH.
*                (X2) = ADDRESS OF CHCNT. 
*                (X3) = ADDRESS OF SOURCELENGTH.
* 
*         EXIT   CODE IN NEXTCH MODIFIED WITH REQUIRED ADDRESSES. 
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 NEXTCHS  PS                 ENTRY/EXIT 
          SA4    NCHA 
          LX3    30 
          BX2    X2+X3       MERGE ADDRESSES
          LX0    30 
          BX6    X4+X2
          SA6    A4+
          SA5    NCH1 
          SA6    NCHB 
          BX7    X5+X0       MERGE ADDRESS
          SA4    NCHC 
          SA7    A5 
          BX6    X1+X4       MERGE ADDRESS
          SA6    A4 
          EQ     NEXTCHS     RETURN 
 PORTION  SPACE  4,10 
***       PORTION - EXTRACT PORTION OF WORD.
* 
*         TYPE BITRANGE = 0..59;  (* BIT 59 IS MOST SIGNIFICANT BIT *)
*         FUNCTION PORTION(WORD : INTEGER; SB,EB : BITRANGE) : INTEGER; 
* 
*         ENTRY  (B1) = 1.
*                (X0) = WORD CONTAINING FIELD TO BE EXTRACTED.
*                (X1) = STARTING BIT POSITION.
*                (X2) = ENDING BIT POSITION.
* 
*         EXIT   (X6) = RIGHT JUSTIFIED FIELD FROM SB TO EB INCLUSIVELY.
* 
*         USES   A - NONE.
*                B - 2, 3, 7. 
*                X - 0, 3, 6. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 PORTION  PS                 ENTRY/EXIT 
          IX3    X1-X2       FIELD WIDTH - 1
          MX6    1
          SB2    X3 
          SB3    X3+B1       FIELD WIDTH
          AX6    B2          MASK 
          SB2    X2          LOW ORDER BIT POSITION 
          LX6    B3          POSITION MASK
          AX0    B2          POSITION WORD
          BX6    X6*X0       EXTRACT FIELD
          EQ     PORTION     RETURN 
 ROTATE   SPACE  4,10 
***       ROTATE - ROTATE WORD ROUTINE. 
* 
*         TYPE BR = -59..59;
*         FUNCTION ROTATE(WORD : INTEGER; COUNT : BR) : INTEGER;
* 
*         ENTRY  (B1) = 1.
*                (X0) = WORD TO BE ROTATED. 
*                (X1) = SHIFT COUNT.
* 
*          EXIT   (X6) = WORD SHIFTED CIRCULARLY BY COUNT.
* 
*         USES   A - NONE.
*                B - 2, 7.
*                X - 1, 2, 3, 6, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 ROTATE   PS                 ENTRY/EXIT 
          PL     X1,ROT1     IF POSITIVE ROTATION 
          SX1    X1+60
 ROT1     SB2    X1          SET SHIFT COUNT
          LX6    B2,X0       ROTATE WORD
          EQ     ROTATE      RETURN 
 RELEASE  SPACE  4,10 
***       RELEASE - RETURN HEAP-STORAGE SEGMENT.
* 
*         TYPE MARKER = ^ MARKREC;
*              MARKREC = RECORD END;
*         PROCEDURE RELEASE(MARK: MARKER);
* 
*         ENTRY  (B1) = 1.
*                (X0) = HEAP-STORAGE SEGMENT ORIGIN ADDRESS.
*                (B4) = TOP OF HEAP ADDRESS.
* 
*         EXIT   (B4) = TOP OF HEAP AFTER RETURNING SEGMENT.
* 
*         USES   X - NONE.
*                A - NONE.
*                B - NONE.
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
  
  
 RELEASE  PS                 ENTRY/EXIT 
          SB4    X0 
          EQ     RELEASE     RETURN 
 COMPRTN  SPACE  4,10 
          END 
