Retro1.org codex

DEFINE
* /---   FILE TYPE = E
* /---   BLOCK      DEFINE     00 000   81/07/13  01.10 
          IDENT  DEFINE 
          LCC    OVERLAY(1,1) 
* 
          TITLE  -DEFINE- COMMAND 
          TITLE 
* 
* 
          CST 
* 
* 
 DEFINE$  OVFILE
* 
* 
          EXT    ECSPRTY,COMPNAM,CSYMADD
          EXT    KEYTYPE,ERRORC,NXTC,COMCONT,HOLDEFN
          EXT    SEGREAD,UNSREAD,SEGFLG 
          EXT    CHARERR,BADPAR,DECERR,VARERR 
          EXT    LOGERR,FORMERR,EQERR,OCTERR
          EXT    ALFERR,INDXERR,DEFERR,SEGERR 
          EXT    COMPERR,LNGERR,LITERR,TEMPERR
          EXT    KLOCAL 
* 
* 
* /---   BLOCK      DEFINE     00 000   76/06/07  15.09 
          TITLE  READIN FOR -DEFINE- COMMAND
* 
*         -DEFREAD- 
*         READIN ROUTINE FOR -DEFINE- COMMAND 
* 
*         USE OF BUFFERS -
* 
*         *VARS*       CONTAINS SEVEN CHARACTER DEFINE
*         NAMES WITH 18 BIT GETVAR CODES LOWER IN ORDER 
*         BY FIRST CHARACTER
* 
*         *TOKBUF*     (ECS RESIDENT TABLE) 
*         CONTAINS 12 BIT TOKENS ASSOCIATED WITH NON
*         PRIMITIVE DEFINES 
**        ADTYPES REQUIRE TWO 12 BIT BYTES - THE FIRST
*         BYTE HAS THE UPPER BIT SET TO INDICATE ADTYPE 
**        UNNAMED LONG LITERALS REQUIRE A WHOLE WORD
*         FOLLOWING THEIR ADTYPES - THE FIRST BYTE OF THEIR 
*         ADTYPES HAVE THE SECOND TO THE UPPER BIT SET
**        NAMED LONG LITERALS REQUIRE A WHOLE WORD
* 
* 
* ECS DATA STRUCTURE
* 
* THE ECS DEFINE BUFFER IS PARTITIONED INTO PAIRS OF
* NAME AND TOKEN BUFFERS.  THE DEFINE SET THAT IS CURRENTLY 
* ACTIVE HAS ALL THE UNUSED SPACE IN THE DEFINE BUFFER
* LOCATED BETWEEN THE END OF ITS TOKEN BUFFER AND THE 
* BEGINNING OF ITS NAME BUFFER.  FOR EXAMPLE; 
* 
* START OF ECS DEFINE BUFFER
* TOKENS FOR DEFINE SET A 
* NAMES FOR DEFINE SET A
* TOKENS FOR DEFINE SET B 
* NAMES FOR DEFINE SET B
* TOKENS FOR DEFINE SET C 
* UNUSED SPACE
* NAMES FOR DEFINE SET C
* END OF ECS DEFINE BUFFER
* 
* WHEN ANOTHER DEFINE SET IS ACTIVATED, THE TOKEN AND 
* NAME BUFFERS ARE MOVED SO THAT THE UNUSED SPACE IS BETWEEN
* THAT DEFINE SETS TOKEN AND NAME BUFFER.  FOR EXAMPLE; 
* 
* START            START
* TOKEN A          TOKEN A
* NAME A           NAME A 
* TOKEN B          TOKEN B
* NAME B           UNUSED SPACE -DEFINE- SET B IS NOW ACTIVE
* TOKEN C          NAME B 
* UNUSED SPACE     TOKEN C
* NAME C           NAME C 
* END              END
* 
* AS A -DEFINE- COMMAND IS PROCESSED, THE STARTING LOCATION 
* OF THE NAMES DECREASES AS NAMES ARE ADDED AND THE ENDING
* LOCATION OF THE TOKENS INCREASES AS TOKENS ARE ADDED UNTIL
* THERE IS NO UNUSED SPACE, AT WHICH TIME A CONDENSE ERROR
* IS ISSUED AND NO MORE DEFINES ARE PROCESSED UNTIL ONE 
* OR MORE DEFINE SETS ARE PURGED. 
* 
* 
* NAME BUFFER 
* 
* THE NAME BUFFER CONTAINS AN ALPHABETICAL LIST OF ALL
* SYMBOLS GIVEN DEFINITIONS IN THE DEFINE SET SO FAR. 
* EACH SYMBOL IS LEFT JUSTIFIED IN A WORD, USING A MAXIMUM
* /---   BLOCK      DEFINE     00 000   76/06/07  15.09 
* OF 7 CHARACTERS.  THE BOTTOM 3 CHARACTERS CONTAIN INFO
* DESCRIBING THE FUNCTION OF THE SYMBOL, CALLED THE SYMBOLS 
* GETVAR CODE.  THIS CODE CONSISTS OF 4 BITS OF TYPE
* INFORMATION AND 14 BITS OF ADDRESS INFORMATION.  FOR ALL
* EXCEPT SIMPLE VARIABLE TYPES OR LITERAL TYPES OF LESS THAN
* 15 BITS, THE ADDRESS INFORMATION POINTS TO THE WORD IN
* THE TOKEN BUFFER WHERE A DESCRIPTION OF THE DEFINE BEGINS 
* (SEE DISCUSSION OF TOKENS BELOW).  THE ADDRESS INFORMATION
* FOR SIMPLE VARIABLES INDICATES THE NUMBER OF THE VARIABLE 
* BEING REFERENCED; FOR 14 BIT LITERALS, THE LITERAL ITSELF 
* IS THE ADDRESS. 
* 
* TOKEN BUFFER
* 
* THE TOKEN BUFFER CONTAINS COMPLEX DEFINITIONS OF SYMBOLS
* IN THE NAME TABLE.  FOR ALL EXCEPT LITERALS OF MORE THAN
* 14 BITS, THESE DEFINITIONS ARE OF THE FORM; 
* 
* <NUMBER OF ARGUMENTS> <CHARACTER STRING ANALOG> <EOL> 
* 
* FOR 60 BIT LITERALS, ALL THAT IS STORED IS THE LITERAL
* ITSELF. 
* THE NON60-BIT LITERAL ELEMENTS OF THE TOKEN BUFFER ARE
* 12 BIT OR 24 BIT BYTES, PACKED FROM HIGH TO LOW ORDER 
* BITS OF WORDS.  THE <NUMBER OF ARGUMENTS> IS ALWAYS LEFT
* JUSTIFIED SO THAT THE GETVAR CODE ASSOCIATED WITH THE 
* SYMBOL MAY POINT DIRECTLY TO THE FIRST WORD OF THE
* SYMBOLS DEFINITION.  FOR ALL EXCEPT THE ARGUMENT COUNT, 
* 12 BIT TOKENS CORRESPOND TO LEXICAL ELEMENTS OF THE 
* DEFINITION CALLED OPERATORS. INCLUDED IN THIS CATEGORY ARE
* SEPARATORS SUCH AS PARENTHESIS, COMMAS, END OF LINES, ETC.
* AS WELL AS SYSTEM DEFINED SYMBOLS (INT, ZRECS, +, -, ^O,).
* 24 BIT TOKENS ARE OF TWO TYPES; 1) ARGUMENT TOKENS, THE 
* TOP 12BIT BYTE OF WHICH HAS A UNIQUE VALUE NOT CORRESPOND-
* ING TO ANY OPERATOR, AND THE BOTTOM 12 BIT BYTE THE NUMBER
* OF THE ARGUMENT AS IT APPEARS IN THE ARGUMENT LIST;2) 
* ADTYPE TOKENS, WITH THE 2**LITSHFT BIT SET AND THE BOTTOM 18
* BITS CONTAINING A GETVAR CODE FOR A SIMPLE VARIABLE OR
* LITERAL.  60 BIT LITERALS THAT APPEAR IN THE DEFINITION OF
* A SYMBOL THAT IS NOT REDUCABLE TO A SINGLE LITERAL ITSELF,
* HAVE THE 2**LITSHFT BIT SET INDICATING THAT THE REST
* OF THE CURRENT TOKEN WORD IS IRRELEVANT, THE LITERAL
* APPEARS IN THE NEXT WORD IN THE TOKEN BUFFER AND THE NEXT 
* TOKEN WILL BE LEFT JUSTIFIED IN THE WORD AFTER THE
* LITERAL.  *** WARNING ***  IN ALL OTHER CONTEXTS, THE 
* 2**LITSHFT BIT SET IN AN ADTYPE MEANS THAT THE LONG LITERAL 
* RESIDES IN *LITS* (THE LITERAL STACK GENERATED BY *LEX* 
* AND *DEFLEX*.  *** WARNING ***
* 
* /---   BLOCK      DEFINE     00 000   80/03/27  23.09 
* WHEN THE DEFINITION OF A SYMBOL CONTAINS A PREVIOUSLY 
* DEFINED SYMBOL, THE TOKEN BUFFER REPRESENTATION OF
* THE DEFINITION CONTAINS THE TOKENS FOR THE PREVIOUSLY 
* DEFINED SYMBOL ENCLOSED BY PARENTHESIS TOKENS.
* 
* 
* EXAMPLE DEFINE SET NAME AND TOKEN BUFFERS 
* 
* DEFINE  ABC=7 
*         DEF=N1
*         VECT(X)=N(X+100)
*         LIT='7ABCDEF'7+1
*         FUNCT(X,Y)=SIN(Y+LIT-VECT(X)"DEF+'7GEHI'7)
* 
* TOKEN BUFFER (* INDICATES START OF WORD)
* *0001 0077 0015 03760000 *0002 40000144 0016 0001 
* *01020304050600000001 
* *0002 0051 0015 03760001 *0002 40040002 0003 0015 *0077 
*       0015 0015 03760000 *0016 0002 40000144 0016 *0016 
*       0013 40100001 0002 *60040011 *07051011000000000000
*       *0016 0001
* 
* NAME BUFFER 
* <NAME>  <GETVAR>
* ABC     000007
* DEF     100001
* FUNCT   200003
* LIT     040002
* VECT    200000
* 
* 
* CM NAME PAGING
* 
* A CM BUFFER IS USED DURING BINARY CHOP SEARCHES FOR 
* DEFINED  NAMES.  IN DEFINE SETS WITH NAME BUFFERS LARGER
* THAN THE CM BUFFER, THE ECS NAME BUFFER IS DIVIDED UP INTO
* PAGES THE SAME SIZE AS THE CM BUFFER.  THESE PAGES ARE
* READ INTO CM AS NEEDED FOR THE BINARY CHOP. 
* CM TABLES 
* 
* *TOKADDS* CONTAINS THE ECS LOCATIONS OF TOKEN BUFFERS 
* *NAMADDS* CONTAINS THE ECS LOCATIONS OF NAME BUFFERS
* (TOKADDS(N)) IS ALWAYS LESS THAN OR EQUAL TO (TOKADDS(N+1)) 
* (NAMADDS(N)) IS ALWAYS LESS THAN OR EQUAL TO (NAMADDS(N+1)) 
* *TOKLENS* CONTAINS THE LENGTHS OF TOKEN BUFFERS 
* *NAMLENS* CONTAINS THE LENGTH OF NAME BUFFERS 
* *SETNAMS* CONTAINS THE NAMES OF DEFINE SETS 
* 
* THERE IS AN ENTRY IN EACH TABLE WITH AN INDEX OF -1.  THESE 
* ENTRIES DESCRIBE THE NULL DEFINE SET WHICH IS OPENED WHEN 
* NO DEFINE SET IS ACTIVE.  THIS MAKES MUCH OF THE CODE MORE
* ELEGANT AND EFFICIENT BY AVOIDING SPECIAL CASES.
* 
* *PGTBL* CONTAINS THE LAST NAME OF EACH PAGE IN THE NAME 
* BUFFER.  THIS IS TO SPEED UP THE PROCESS OF FINDING 
* WHICH PAGE SHOULD BE CM RESIDENT IF THE PAGE IN ECS COULD 
* NOT CONTAIN THE NAME BEING SEARCHED FOR.
* 
* 
*         AT THE END OF CONDENSATION THE DEFINE SET NAMED 
*         *STUDENT* IS APPENDED TO THE LESSON BINARY - OTHER
*         DEFINES ARE NOT AVAIABLE IN STUDENT MODE
* 
* 
 DEFOV    OVRLAY
          SA1    OVARG1      X1 = CALL TYPE 
          SB1    X1 
          JP     B1+DEFJMP   JUMP TO DEFINE OPTION
* 
 DEFJMP   EQ     DEFNIN      BEGIN DEFINE SET 
+         EQ     PURGELU     PURGE LOCAL DEFINE SET FOR NEW 
+         EQ     ELN1        RETURN FROM SEGOV
+         EQ     PURGELD     PURGE LOCAL DEFINE SET FOR GBL 
* 
* /---   BLOCK      DEFINE     00 000   80/05/19  22.16 
 DEFNIN   CALL   SETSET      SET TO CURRENT DEFINE SET
          SX6    VARS 
          SA6    PVARS       POINTER TO DEFN NAME LIST
          SX7    -2          *UNITS* NOT ACTIVE 
          SA7    NUNITS 
          MX6    0
          SA6    UDMODE      NO INTERPRETATION OF *UNITS* 
          SA6    COMPNAM
          SA6    CSYMADD
          SA1    COMMAND
          SA2    COMCONT     SEE IF CONTINUED COMMAND 
          BX2    X1-X2
          ZR     X2,DEFRD    JUMP IF CONTINUED
* /---   BLOCK      D050       00 000   80/03/23  08.25 
* 
          SA1    LOCAL
          ZR     X1,D025     IF NOT LOCAL SET 
* 
*+         EQ     * 
+         SA1    KLOCAL      X1 = LOCAL SET NAME
          BX6    X1 
          SA6    KBLANK      LOCAL SET HANDLING LIKE BLANK
          SX6    60          NO BITS LEFT IN 0TH WORD 
          SA6    LSHIFT 
          SA6    LBYTES      LOCAL BYTE SIZE
          MX6    0           0TH WORD 
          SA6    LVARN
          SA6    MERGEL      ASSUME MERGE OPTION NOT USED 
          SX6    100000B     LOCAL TYPE IS INTEGER
          SA6    LTYPE
          SX6    1           SIGNED 
          SA6    LSIGN
          SA1    DSET        SAVE CURRENT SET NUMBER
          BX6    X1 
          SA6    GSET        GLOBAL SET NUMBER
* SAVE UNIT TAG 
          SA1    WORDPT 
          BX6    X1 
          SA6    LWRDPT 
          SA0    TAG
          SA1    ATEMPEC     X1 = ADDR OF TEMP ECS
          BX0    X1 
          WE     TAGLTH+1    WRITE OUT -UNIT- W/ARGS
          RJ     ECSPRTY
          SA0    LUNIT       SAVE -UNIT- COMMAND W/ARGS 
          RE     TAGLTH+1 
          RJ     ECSPRTY
          RJ     =XGETLINE
 D025     SA1    WORDPT      SAVE WORDPT
          BX6    X1 
          SA6    OLDPT
          CALL   GETNAME,9   GET NAME OF DEFINE SET **
          ZR     X6,DEFR0    JUMP IF NO NAME=BLANK SET
          SX7    DEFNAML     NUMBER OF NAMES TO SEARCH
          SA1    LOCAL
          IX7    X7+X1       IF LOCAL SET, INCLUDE *MERGE*
          RJ     DEFNAMS     CHECK FOR SPECIAL NAME 
          NZ     X7,D170     JUMP IF SPECIAL NAME FOUND 
* 
* 
          SB2    7
          GT     B1,B2,ERR7  ERROR IF NAME OVER 7 CHARS 
* 
          SA1    LOCAL
          NZ     X1,D100      IF LOCAL SET
* 
* 
* SPECIAL NAMES= SEGMENT(SEGFLG=1), SEGMENTV(3), UNITS(4),
* ARRAY(4), ARRAYSEG(5), ARRAYSEGV(6), COMPLEX(7),
* SEGMENTF(8), PURGE(9) 
* 
          SX0    X2-OPCOMMA  IF TERMINATOR IS COMMA 
          ZR     X0,DEFR1    JUMP , THIS IS SET NAME
 D050     SA1    LOCAL
          NZ     X1,D100     IF LOCAL SET, NO NAMED SETS
* 
          SX3    X2-EOL 
          ZR     X3,DEFR1    IF SETNAME EOL 
* 
          ZR     X3,DEFR1    JUMP IF SETNAME(EOL) 
 D100     SA1    OLDPT       THIS IS DEFINE NAME
          BX6    X1          RESET -WORDPT- 
          SA6    WORDPT 
* /---   BLOCK      D050       00 000   80/03/23  08.25 
          EQ     DEFR0       USE BLANK SET
* 
 D170     SA1    LOCAL
          ZR     X1,D171     IF NOT LOCAL SET 
* 
          SX0    X7-DEFNAML-1 
          ZR     X0,DEFL0     IF LOCAL MERGE OPTION 
* 
          EQ     D100        TREAT AS NORMAL DEFINE LINE
* 
* /---   BLOCK      D050       00 000   80/03/23  06.44 
 D171     SX0    X7-DEFNAML 
          ZR     X0,PURGE    JUMP IF PURGE OPTION 
          SX3    X2-OPCOMMA  ZERO IF ENDS WITH COMMA
** FOLLOWING IS CAUSED BY DIFF BETWEEN TREATMENT OF 
** SEGMENT AND UNITS/ARRAY/COMPLEX  * MAYBE SHOULD CHANGE 
          ZR     X3,D172     IF IT DOES, IS SPECIAL NAME
          SX0    X7-1        ZERO IF SEGMENT
          NZ     X0,D050     JUMP IF NOT, ALLOW  UNITS=V1 
          EQ     ERR8        SEGMENT MUST END WITH COMMA
 D172     SA1    KBLANK 
          BX6    X1          ASSUME BLANK SET 
          RJ     =XFINDSET
          PL     B1,DSEG1    JUMP IF SET EXISTS 
          RJ     NEWSET 
* 
 DSEG1    RJ     =XGETSET      BRING IN THE SET 
          SA1    SEGFLG 
          SX1    X1-3 
          ZR     X1,UNSREAD  JUMP IF -UNITS-
          EQ     SEGREAD     JUMP IF SEGMENT/ARRAY/COMPLEX
* 
 DEFL0    SX6    1
          SA6    MERGEL      FLAG MERGE OPTION SELECTED 
* 
 DEFR0    SA1    KBLANK      BLANK NAME  (UNNAMED SET)
          BX6    X1 
* 
 DEFR1    BX7    X2          SAVE TERMINATOR CODE 
          SA7    ENDKEY 
          RJ     =XFINDSET     SEE IF SET ALREADY EXISTS
          PL     B1,DEFR2    JUMP IF ALREADY EXISTS 
          RJ     NEWSET      INITIALIZE A NEW SET 
          RJ     =XGETSET    OPEN IT UP AND BRING IT IN 
          SA1    LOCAL
          ZR     X1,DEFL5    IF NOT LOCAL SET 
* 
          SA1    MERGEL 
          ZR     X1,DEFRD    IF NO MERGED SET, BEGIN SET
* 
          CALL   GETNAME,8
          BX7    X2          SAVE ENDKEY
          SA7    ENDKEY 
          SA3    GSET        X3 = PREVIOUS GLOBAL SET NUM 
          SB1    X3          B1 = PREVIOUS GLOBAL SET NUM 
          SA1    KPREVN      X1 = *PREVIOUS* KEYWORD
          BX1    X1-X6
          ZR     X1,DEFL10   IF PREVIOUS SET TO BE MERGED 
          SA1    KGLOBAL     X1 = *GLOBAL* KEYWORD
          BX1    X1-X6
          NZ     X1,DEFL05   IF NAME IS NOT *GLOBAL*
          PL     B2,DEFL05   IF NAME IS NOT *GLOBAL';*
          SX7    EOL         SET TERMINATING CHAR 
          SA7    ENDKEY 
          EQ     DEFL10      DO THE MERGE 
* 
 DEFL05   SX3    X2-EOL 
          ZR     X3,DEFR1A   ANOTHER SETNAME IF EOL 
* 
          SX3    X2-OPCOMMA 
          NZ     X3,ERR8     IF BAD TERMINATION 
* 
          EQ     DEFR1A 
* 
 MERGEL   DATA   0           MERGE OPTION FLAG FOR LOCAL SET
* 
 DEFL5    BSS    0
          SA1    ENDKEY 
          SX2    X1-OPCOMMA 
          NZ     X2,ENDLIN   CONTINUE IF NOT COMMA
          CALL   GETNAME,7   GET NEXT NAME
          SX3    X2-EOL 
          ZR     X3,DEFR1A   ANOTHER SET NAME IF EOL
          SX3    X2-OPCOMMA 
          NZ     X3,DEFRDA   ANOTHER DEFINE IF NOT COMMA
* /---   BLOCK      DEFR1A     00 000   75/02/11  20.31 
* 
 DEFR1A   SX7    X2          SAVE TERMINATOR
          SA7    ENDKEY 
          ZR     X6,ERR8     ERROR EXIT IF NO SET 
          RJ     =XFINDSET     SEARCH FOR OLD SET 
 DEFL10   NG     B1,ERR8     ERROR IF NO SET
          SX7    B1 
          SA7    ODSET       SAVE OLD SET NUMBER
          SA1    DSET 
          SB2    X1 
          SA1    UNTLENS+B1  *NDEFU*
          BX7    X1 
          SA7    UNTLENS+B2 
          SA2    B2+TOKADDS  (X2)=ECS ADDR OF NEW SET TOKENS
          SA1    B1+TOKADDS  (X1)=ECS ADDR OF OLD SET TOKENS
          SA3    B1+TOKLENS  (X3)=ECS LENG OF OLD SET TOKENS
          IX4    X2+X3       MUST BE LESS THAN OR EQUAL TO
          SA5    NAMADDS+B2 
          IX4    X5-X4
          NG     X4,ERR4     IF NOT ENOUGH ROOM IN BUFFER 
          BX7    X3 
          SA7    B2+TOKLENS 
          SA0    VARS        (A0)=ADDR OF MOVE BUFFER 
          SB1    VARLONG     (B1)=LENGTH OF MOVE BUFFER 
          RJ     =XMVECS       MOVE TOKENS TO NEW DEFINE SET
          SA1    ODSET
          SB1    X1 
          SA1    DSET 
          SB2    X1 
          SA2    B2+NAMADDS  (X2)=ECS ADDR OF NEW SET NAMES 
          SA1    B1+NAMADDS  (X1)=ECS ADDR OF OLD SET NAMES 
          SA3    B1+NAMLENS  (X3)=ECS LENG OF OLD SET NAMES 
          IX2    X2-X3       (X2)=NEW ADDR OF NEW SET NAMES 
          SA4    TOKADDS+B2  SEE IF ENOUGH ROOM IN BUFFER 
          SA5    TOKLENS+B2 
          IX4    X4+X5       MUST NOT BE GT NAMADDS+B2
          IX4    X2-X4
          NG     X4,ERR4     IF NOT ENOUGH ROOM 
          BX7    X2 
          SA7    B2+NAMADDS 
          BX7    X3 
          SA7    B2+NAMLENS 
          SA0    VARS        (A0)=ADDR OF MOVE BUFFER 
          SB1    VARLONG     (B1)=LENGTH OF MOVE BUFFER 
          RJ     =XMVECS       MOVE NAMES TO NEW DEFINE SET 
          SA1    DSET 
          SB1    X1 
          RJ     =XSETSET      BRING IN NEW DEFINE SET
          SA1    ENDKEY 
          EQ     ENDLIN 
* 
* /---   BLOCK      DEFR2      00 000   80/03/23  06.50 
 ODSET    BSS    1
* 
 DEFR2    RJ     =XGETSET      BRING IN THE SET 
* 
 DEFR3    SA1    ENDKEY 
          EQ     ENDLIN      SEE IF NEED NEW LINE 
* 
 DEFRD    CALL   GETNAME,9   GET NAME OF DEFINE 
*  FOLLOWING CHECKS FOR -DEFINE- ENDING IN COMMA
*  AND TRAILING BLANKS
          SX7    X2-EOL      CHECK FOR EOL TERMINATOR 
          BX7    X7+X6       AND NO NAME
          ZR     X7,ELN1     END-OF-LINE OK 
 DEFRDA   ZR     X6,ERR7     ERROR IF NO NAME 
          SA6    DEFNAME
          SX7    DEFNAML-1   DO NOT LOOK FOR *PURGE*
          RJ     DEFNAMS     CHECK FOR SPECIAL NAMES
          ZR     X7,DEFRDAB  JUMP IF NOT
          SX0    X7-3 
          NG     X0,SEGREAD  JUMP IF SEGMENT
          SX1    X2-OPCOMMA  CHECK IF TERMINATOR=COMMA
          NZ     X1,DEFRDB   IF NOT, MUST BE  UNITS=V1 ETC. 
          ZR     X0,UNSREAD  REMOTE EXIT IF UNITS 
          SX0    X7-DEFGNML-1 
          NG     X0,SEGREAD  IF ARRAY/COMPLEX 
* 
          SA1    LOCAL
          ZR     X1,DEFRDB   IF NOT LOCAL SET 
* 
*         CONDENSING LOCAL DEFINE SET ',X,Y,S';', FORM
*         X = (INTEGER,FLOATING)
*         Y = SEGMENT SIZE (INTEGER ONLY) 
*         S = SIGNED SEGMENT IF PRESENT 
* 
          SX6    100000B     X6 = PRESET N GETVAR TYPE
          SX0    X0-1 
          NG     X0,DEFL20   IF INTEGER DECLARATION 
* 
          SX6    5B            X6 = V GETVAR TYPE 
          LX6    15 
 DEFL20   SA6    TLTYPE      TEMPORARY LTYPE
          RJ     COLON       X0 = -1 IF COLON IS LAST CHAR
          NG     X0,DEFL100  IF FULL WORD DECLARATION 
* 
          RJ     SAVEO       SAVE WORDPT ETC. 
          RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE
          MX0    -XCODEAL 
          BX0    X0*X1       MUST BE SHORT LITERAL
          BX6    X1 
          SA2    OLDINX      RESTORE INX
          BX7    X2 
          SA7    INX
          ZR     X0,DEFL30   IF X6 IS SHORT LITERAL 
* 
 DEFL25   RJ     RESTO       BACK UP POINTERS TO KEYWORD AND
          SA2    WORDPT      SET X2 TO CORRECT ENDKEY 
          SA2    X2-1 
          SA2    X2+KEYTYPE 
          EQ     DEFRDB       ASSUME IT A DEFINE NAME 
* 
 DEFL30   SA6    TLBYTES     TEMPORARY LOCAL BYTE SIZE
          RJ     COLON       X0 = -1 IF COLON LAST CHAR 
          NG     X0,DEFL110  IF UNSIGNED DECLARATION
* 
          CALL   GETNAME,7   X6 = SIGN OPTION 
          ZR     X6,DEFL25   ASSUME ITS A DEFINED NAME
* 
          SA3    KSIGN       CHECK FOR SIGNED SEGMENT 
          BX3    X6-X3
* /---   BLOCK      DEFR2      00 000   80/03/23  06.50 
          ZR     X3,DEFL40   IF SIGNED DECLARATION
* 
          SA3    KS          CHECK FOR ABBREVIATED SIGN 
          BX3    X6-X3
          NZ     X3,DEFL25   IF NOT ,S ASSUME DEFINED NAME
* 
 DEFL40   RJ     COLON
          PL     X0,DEFL25  MUST END IN COLON 
* 
          SX6    1
          SA6    TLSIGN      TEMPORARY LOCAL VAR SIGN 
          EQ     DEFL120     BEGIN INTEGRITY CHECK
* 
* /---   BLOCK      DEFR2      00 000   80/03/23  06.47 
 DEFL100  SX6    60          60 BIT DECLARATION 
          SA6    TLBYTES
          SX6    1           HAS TO BE SIGNED 
          SA6    TLSIGN 
          EQ     DEFL200     SET DECLARATION PARAMETERS 
* 
 DEFL110  SX6    0           UNSIGNED 
          SA6    TLSIGN 
* 
 DEFL120  SA1    TLBYTES     CHECK BYTE SIZE
          NG     X1,BADCNT   IF BYTE SIZE LT 0
          ZR     X1,BADCNT   IF BYTE SIZE EQ 0
* 
          SX2    61 
          IX1    X1-X2
          PL     X1,BADCNT   IF BYTE SIZE GT 60 
* 
          SA2    TLTYPE 
          SX2    X2-100000B 
          ZR     X2,DEFL200  IF INTEGER, EVERYTHING OK
* 
          SX1    X1+1 
          NZ     X1,BADCNT   IF FLOATING BYTE SIZE NE 60
* 
 DEFL200  SA1    TLTYPE      TYPE OF LOCAL VAR
          BX6    X1 
          SA6    LTYPE
          SA1    TLBYTES     LENGTH OF BYTE 
          BX6    X1 
          SA6    LBYTES 
          SA1    TLSIGN      UN/SIGNED
          BX6    X1 
          SA6    LSIGN
          EQ     DEFRD       CONTINUE SINCE MORE TO COME
* 
* 
 TLTYPE   DATA   0
 TLBYTES  DATA   0
 TLSIGN   DATA   0
* /---   BLOCK      DEFR2      00 000   80/03/23  06.49 
* 
*         -COLON- 
* 
*         LOOK AT LAST TWO CHARACTER CODES TO CHECK FOR 
*         A COLON 
* 
*         ON RETURN X0 = -1 IF COLON, 0 IF NOT
* 
 COLON    EQ     *
          SX0    B0          PRESET X0 TO NOT COLON 
          SA2    WORDPT 
          SA2    X2-1 
          SX2    X2-77B      LAST CHAR - ;
          NZ     X2,COLON    IF NOT COLON 
* 
          SA2    A2-1 
          SX2    X2-70B      LAST CHAR - SHIFT
          NZ     X2,COLON    IF NOT COLON 
* 
          SX0    -1          IT WAS A COLON 
          EQ     COLON
* 
* 
*         -SAVEO- 
* 
*         SAVE ALL INFORMATION NECESSARY TO DO A COMPILE
*         LOOK AHEAD IN THE *OLD* BUFFER
* 
 SAVEO    EQ     *
          SA2    WORDPT      SAVE WORDPT
          BX6    X2 
          SA6    OWORDPT
          SA2    INX         SAVE INX 
          BX6    X2 
          SA6    OLDINX 
          SA2    LASTKEY     SAVE LASTKEY 
          BX6    X2 
          SA2    OLDLAST
          EQ     SAVEO
* 
* 
*         -RESTO- 
* 
*         RESTORE INFORMATION SAVED BEFORE LOOK AHEAD 
*         FROM *OLD* BUFFER 
* 
 RESTO    EQ     *
          SA2    OWORDPT     RESTORE WORDPT 
          BX6    X2 
          SA6    WORDPT 
          SA2    OLDINX      RESTORE INX
          BX6    X2 
          SA6    INX
          SA2    OLDLAST     RESTORE LASTKEY
          BX6    X2 
          SA6    LASTKEY
          EQ     RESTO
* 
* 
 DEFRDAB  NG     B2,BADTYP   IF ILLEGAL TYPE DECLARATION
* 
 DEFRDB   SX7    X2          SAVE TERMINATOR
          SA7    ENDKEY 
* /---   BLOCK      DEFR2      00 000   76/08/01  23.59 
          SA1    DSET        CURRENT SET NUMBER 
          NG     X1,ERR9
          MX6    0
          SA6    NARGS       CLEAR ARGUMENT COUNT 
          SA6    NADS        CLEAR ADTYPE COUNT 
          SA6    NOPS        CLEAR OPERATION COUNT
          SX3    X2-OPASIGN  OK IF ASSIGNMENT ARROW 
          ZR     X3,DNAME 
          SX3    X2-OP=      OK IF EQUAL SIGN 
          ZR     X3,DNAME 
          SX3    X2-OP(      OK IF L PAREN  (FUNCTION)
          ZR     X3,DNAME 
          SA1    LOCAL       X1 = LOCAL SET FLAG
          ZR     X1,ERR1     IF NOT PROCESSING LOCAL SET
* 
          SX3    X2-OPCOMMA  COMMA LEGAL IN LOCAL SET 
          ZR     X3,DNAME    IF COMMA 
* 
          SX3    X2-EOL      EOL LEGAL IN LOCAL SET 
          NZ     X3,ERR1     OTHERWISE, ILLEGAL CHARACTER 
* 
* 
 DNAME    CALL   SYMCHK,DEFNAME 
          SX7    -1          SET VSEEK TO NO EXPANSION
          SA7    VSKMODE
          MX6    0
          SA6    UDMODE      NO INTERPRETATION OF *UNITS* 
          SA1    DEFNAME
          BX6    X1          PUT NAME IN X6 FOR CALL
          RJ     =XVSEEK       SEE IF NAME ALREADY DEFINED
          SA1    ADTYPE 
          PL     X1,ERR6     ERROR IF DUPLICATE NAME
          SA7    DEFNLOC     STORE LOCATION TO INSERT DEFN
          RJ     =XINITLEX     SETUP FOR PROGRAM -LEX-
          SA1    ENDKEY 
          SX2    X1-OP(      CHECK TERMINATOR KEY 
          NZ     X2,DEFIN    JUMP IF NOT FUNCTION DEFINE
* 
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
* 
* 
          SA1    LOCAL
          ZR     X1,ARGDO    IF NOT LOCAL SET 
* 
          RJ     SAVEO       SAVE COMPILATION LOCATION
          RJ     =XRTOKNAM
          RJ     =XLEX       IS NEXT LEXICAL ITEM DEFINED 
          SA1    OP 
          NZ     X1,DEFL280  IF AN OPERATOR, ASSUME CONSTANT
* 
          SA1    ADTYPE 
          NG     X1,DEFL290  IF UNDEFINED, ASSUME AN ARG
* 
 DEFL280  RJ     RESTO       RESTORE TO PRE-LEX CONDITION 
          SA1    WORDPT      POINT TO LEFT PAREN
          SX6    X1-1 
          SA6    A1 
          RJ     =XCOMPILE
          SA2    OLDINX      RESTORE INX
          BX6    X2 
          SA6    INX
          MX0    -XCODEAL 
          BX0    X0*X1       X0 = GETVAR W/ZEROED ADDRESS 
          ZR     X0,DEFL300  IF A SHORT LITERAL 
* 
 DEFL290  RJ     RESTO       RESTORE COMPILATION
          SX7    -1          SET VSEEK TO NO EXPANSION
          SA7    VSKMODE
          MX6    0
          SA6    UDMODE 
          RJ     =XINITLEX
          EQ     ARGDO       CONTINUE WITH ARGUMENTS
* 
 DEFL300  BSS    0
* 
* 
*         ADD LOCAL VECTOR DEFINE 
* 
          SA2    LBYTES      X2 = BYTE SIZE 
          SX3    X2-60
          NZ     X3,DEFL500  IF HORIZONTAL SEGMENT
* 
*         FULL WORD VECTOR
* 
          SA2    LVARN        X2 = NUMBER OF LOCALS SO FAR
          IX6    X1+X2       INDEX OF LAST VAR IN THIS ARRAY
          BX7    X1          SAVE VECTOR LENGTH 
          RJ     =XLBOUND    CHECK ITS BOUNDS 
          SA6    A2          STORE NEW NUMBER OF LOCALS 
          BX6    X2          SAVE OLD NUMBER OF LOCALS
          SA6    OLVARN 
* 
*         SIMULATE ',ARRAY,XXX(YYY)=NL(ZZZ)', WHERE ',XXX', IS
*         DEFINE NAME AND ',YYY', IS THE VECTOR LENGTH
*         AND ZZZ IS THE BASE LOCATION OF THE VECTOR
* 
          SX6    X7-1        X6 = VECTOR SIZE - 1 
          SX5    1           SET ARRAY DIMENSIONS TO 1
          LX5    9
          BX7    X5+X7
          LX7    9           X7 = ARRAY WORD W/NUM WORDS
          BX7    X6+X7       NUMBER OF ROWS - 1 
          LX7    36          BY-PASS PLANES FOR 3D MATRIX 
          SA1    OLVARN      RESTORE PREVIOUS LVARN 
          SX1    X1+1        VECTOR BEGINS AT NEXT WORD 
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
          SA2    ASVARS      X2 = ADDR OF STUDENT VARS
          SA3    ALVARS      X3 = ADDR OF LOCAL VARS
          IX3    X3-X2       OFFSET TO LOCAL VARS 
          IX1    X1+X3       OFFSET TO LOCAL VECTOR 
          SA2    LTYPE       X2 = TYPE GETVAR 
          BX7    X7+X2       ADD GETVAR OF FIRST ELEMENT
          BX1    X7+X1
          RJ     =XSTUFLIT
          SA2    TOKWRD 
          RJ     =XAPTWD
          SX4    6           INDICATE AN ARRAY TYPE DEFINE
          EQ     DEFL530     TREAT LIKE SEGMENT NOW 
* 
* 
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
*         ADD LOCAL SCALAR DEFINE 
* 
 DEFL400  BSS    0
          SA1    WORDPT      SET LASTKEY FOR EOL TEST 
          SA1    X1-1 
          BX7    X1 
          SA7    LASTKEY
          SA1    LBYTES      X1 = BITS PER BYTE 
          SX2    X1-60
          NZ     X2,DEFL410  IF SEGMENTED SCALAR
* 
*         FULL WORD SCALAR
* 
          SX6    60          ALL BITS USED IN NEW WORD
          SA6    LSHIFT 
          SA2    LVARN        X2 = NUMBER OF LOCAL VARS 
          SX6    X2+1 
          RJ     =XLBOUND    CHECK BOUNDS 
          SA6    A2          NEW NUMBER OF LOCALS 
          SA1    ASVARS      ADDRESS OF STUDENT VARS
          SA3    ALVARS      ADDRESS OF LOCAL VARS
          IX6    X3+X6       ADDRESS OF LOCAL VAR 
          IX6    X6-X1       BIAS TO LOCAL VAR
          SA1    LTYPE       GETVAR TYPE CODE 
          BX4    X6+X1       X4 = NL/VL GETVAR CODE 
          EQ     ADNAM       ADD LOCAL VAR TO DEFINE TABLE
* 
*         ADD LOCAL SCALAR SEGMENT DEFINE 
* 
 DEFL410  SA2    LSHIFT      X2 = BITS USED IN CURRENT WORD 
          SA3    LSIGN       X3 = 1 IF SIGNED 
          SA4    LVARN       X4 = VARLOC OF SEGMENTF
          LX3    2           POSITION SIGN BIT
          SX3    X3+3        INDICATE SEGMENTF
          LX3    20 
          BX3    X3+X1       NUMBER OF BITS PER BYTE
          IX6    X2+X1       INCREMENT BITS USED
          SX7    X6-61       - BITS LEFT IN WORD
          NG     X7,DEFL420  IF CAN FIT IN THIS WORD
* 
          BX6    X1          BITS USED IN NEW WORD
          MX2    0           START OF NEW BYTE
          SX4    X4+1        INCREMENT LVARN
 DEFL420  SA6    A2          STORE NEW NUMBER OF BITS USED
          BX6    X4          STORE NEW LVARN
          RJ     =XLBOUND    CHECK BOUNDS ON LOCAL INDEX
          SA6    A4 
          SA1    ASVARS      ADDRESS OF STUDENT VARS
          SA4    ALVARS      ADDRESS OF LOCAL VARS
          IX6    X4+X6       ADDRESS OF LOCAL VAR 
          IX6    X6-X1       BIAS TO LOCAL VAR
          LX3    18 
          BX3    X3+X6       BIAS TO SEGMENTF 
          LX3    18 
          SX2    X2+1        BIT POSITION OF SEGMENTF 
          BX1    X2+X3
          RJ     =XSTUFLIT   STORE SEGMENT DESCIPTOR
          SA2    TOKWRD      IN ECS TOKEN BUFFER
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
          RJ     =XAPTWD
          SX4    5           X4 = TYPE CODE FOR SEGMENT 
          LX4    XCODEAL     POSITION TYPE CODE 
          SA1    TOKWRD 
          SX1    X1-1        X1 = TOKEN ADDR OF SEG LIT 
          BX4    X4+X1       X4 = COMPLETE GETVAR 
          EQ     ADNAM
* 
* 
*         ADD LOCAL VECTOR SEGMENT DEFINE 
* 
 DEFL500  EQ     NOTYET      NO SEGMENTED VECTOR LOCALS YET 
          PX3    X2          X3 = FLOAT(BYTESIZE) 
          NX3    X3 
          SA4    K60         X4 = 60.0
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
          RX3    X4/X3       X3 = 60/BYTESIZE 
          UX3    X3,B1
          LX3    X3,B1       X3 = BYTES PER WORD
          PX3    X3 
          NX3    X3 
          PX4    X1          X4 = FLOAT(BYTES)
          NX4    X4 
          RX4    X4/X3       X4 = BYTES/BYTESPERWORD
          UX4    X4,B4
          LX4    X4,B4       X4 = NUMBER OF FULL WORDS USED 
          UX3    X3,B3
          LX3    X3,B3       X3 = BYTES/WORD
          IX5    X3*X4       X3 = BYTES RESIDING IN FULL WDS
          IX5    X1-X5       X5 = BYTES IN LAST WORD
          IX7    X5*X2       X7 = BITS USED IN LAST WORD
          SA7    LSHIFT 
          BX5    X3          SAVE BYTES PER WORD
          SA3    LVARN        X3 = WORDS USED SO FAR
          ZR     X7,DEFL510  IF ALL BITS USED IN LAST WORD
* 
          SX4    X4+1        X4 = NUMBER OF WORDS INVOLVED
          EQ     DEFL520
* 
 DEFL510  IX6    X2*X5       ALL BYTES USED IN LAST WORD
          SA6    LSHIFT 
 DEFL520  IX6    X4+X3       HIGHEST VARLOC IN SEGMENT
          RJ     =XLBOUND    MAKE SURE WITHIN RANGE 
          SA6    LVARN
          SA1    LSIGN       X1 = UN/SIGNED SEGMENT 
          LX1    22 
          BX1    X1+X2       BYTE SIZE
          LX1    18 
          SA2    ASVARS      ADDRESS OF STUDENT VARS
          SA4    ALVARS      ADDRESS OF LOCAL VARS
          SX3    X3+1        VARLOC OF FIRST BYTE 
          IX4    X3+X4       ADDRESS OF LOCAL VAR 
          IX4    X4-X2       BIAS TO LOCAL VAR
          BX1    X1+X4       BIAS TO SEGMENT
          LX1    18 
          BX1    X1+X5       NUMBER OF BYTES PER WORD 
          RJ     =XSTUFLIT
          SA2    TOKWRD 
          RJ     =XAPTWD
          SX4    5           X4 = SEGMENT TYPE
 DEFL530  LX4    XCODEAL     POSITION TYPE
          SA1    TOKWRD 
          BX4    X4+X1       INCLUDE ADDRESS
          SX4    X4-1        X4 = GETVAR CODE 
          EQ     ADNAM
* 
* 
 ARGDO    CALL   LEX         GET NEXT ITEM
          SA1    OP 
          ZR     X1,GOTARG   JUMP IF ARG NOT SEPERATOR
          SX2    X1-OPDEFN
          ZR     X2,ERR6     DEFINE NAME USED AS ARGUMENT 
          SX2    X1-OP) 
          ZR     X2,ENDARGS  DONE WITH ARGS IF PAREN
          SX2    X1-OPCOMMA 
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
          NZ     X2,ERR1     ERROR IF NOT SEPERATOR 
          SX7    -1 
          SA7    LASTKEY     CLEAR LASTKEY
          EQ     ARGDO
* 
 GOTARG   SA1    ADTYPE      MUST BE UNRECOGNIZED NAME
          PL     X1,ERR12 
          SA2    NARGS       CURRENT NUMBER OF ARGUMENTS
          SX6    X2+1 
          SX0    X2-MAXARG   CHECK TOO MANY ARGS
          PL     X0,ERR5
          SA6    A2 
          SA1    AD          GET NAME OF ARGUMENT 
          BX6    X1 
          SA6    X2+ARGLIST  SAVE NAME OF ARGUMENT
* /---   BLOCK      ARGDO      00 000   77/01/26  20.37 
          EQ     ARGDO
* 
 ENDARGS  SA2    NARGS
          ZR     X2,ERR13    JUMP IF ZERO ARGUMENTS F() 
          RJ     =XLEX         GET NEXT ITEM
          SA1    OP 
          SX2    X1-OP=      LAST CODE MUST BE =
          ZR     X2,DEFIN 
          SX2    X1-OPASIGN  OR ASSIGNMENT
          NZ     X2,ERR1
* 
 DEFIN    MX6    0           RIGHT SIDE OF A DEFINITION 
          SA6    VSKMODE     RESET MODE FOR VSEEK 
          SA6    UREF        CLEAR *UNIT* ENCOUNTERED FLAG
          SA6    UDMODE      NO INTERPRETATION OF *UNITS* 
          SA1    TOKWRD 
          BX6    X1          SAVE BEGINNING ADDRESS 
          SA6    DEFLOC 
          SX6    60          INITIALIZE SHIFT COUNT 
          SA6    TOKSHF 
          MX6    0           CLEAR NEXT TOKEN WORD
          SA6    TWD
          SA6    DNVAR       CLEAR NUMBER VARIABLES 
          MX6    -1          ASSUME CONSTANT OR SIMPLE
          SA6    DCONST 
          SA1    WORDPT 
          BX6    X1          SAVE *WORDPT*
          SA6    IWORDPT
          SA2    LOCAL
          ZR     X2,DEFIN10  IF NOT PROCESSING LOCAL SET
* 
          SA1    ENDKEY      X1 = TERMINATOR/DELIMITER
          SX2    X1-OPCOMMA 
          ZR     X2,DEFL400  IF SCALAR LOCAL DEFINE 
* 
          SX2    X1-EOL 
          ZR     X2,DEFL400  IF SCALAR LOCAL DEFINE 
* 
 DEFIN10  BSS    0
          SA1    NARGS       NUMBER OF ARGS IS FIRST TOKEN
          RJ     STUFF
* /---   BLOCK      DLEX       00 000   77/02/25  03.58 
* 
*         NOW INTERPRET DEFN
* 
 DLEX     BSS    0
          SX7    1           INITIALIZE LITS POINTER
          SA7    NLITS
          RJ     =XLEX         GET NEXT OP/ADD
          SA1    OP 
          ZR     X1,ADDR     JUMP IF ADDRESS
          SX2    X1-OPCOMMA 
          ZR     X2,ENDDEF
          SX2    X1-EOL 
          ZR     X2,ENDDEF   END OF DEFINE
* 
          RJ     STUFF
          SA2    NOPS 
          SX6    X2+1        COUNT OPS
          SA6    A2 
          EQ     DLEX 
* 
*         PROCESS ADDRESS 
* 
 ADDR     SA1    NADS 
          SX6    X1+1        INCREMENT ADDRESS COUNT
          SA6    A1 
          SA1    ADTYPE 
          NG     X1,ARGLOOK  UNRECOGNIZED - CHECK ARGLIST 
          BX2    X1 
          AX2    XCODEAL     SHIFT OFF ADDRESS
          MX0    -4          MASK FOR I/F BIT AND TYPE CODE 
          BX2    -X0*X2 
          SB1    X2 
          JP     B1+*+1      JUMP BY TYPE 
* 
+         EQ     ADDR1       SHORT LITERAL
+         EQ     ADRLIT      LONG LITERAL 
+         EQ     ADDRV       STUDENT VARIABLE 
+         EQ     ADDRV       COMMON VARIABLE
+         EQ     ERR11       IMPOSSIBLE 
+         EQ     ADRSEG      SEGMENT
+         EQ     ADRARY      ARRAY
+         EQ     ERR11       IMPOSSIBLE 
* 
+         EQ     ADUNIT      UNIT 
+         EQ     ADRLIT      LONG LITERAL 
+         EQ     ADDRV       STUDENT VARIABLE 
+         EQ     ADDRV       COMMON VARIABLE
+         EQ     ERR11       IMPOSSIBLE 
+         EQ     ERR11       IMPOSSIBLE 
+         EQ     ERR11       IMPOSSIBLE 
+         EQ     ERR11       IMPOSSIBLE 
* 
* 
 ADDRV    SA2    DNVAR       INC NUMBER VARS ENCOUNTERED
          SX6    X2+1 
          SA6    A2 
* 
 ADDR1    RJ     STUFADR     *STUFF* BOTTOM 24(X1) IN TOKENS
          EQ     DLEX 
* /---   BLOCK      ADRSEG     00 000   77/02/25  04.19 
* 
*         PROCESS LONG LITERAL
* 
* SEGMENT HAS A LITERAL ASSOCIATED -- A 60-BIT WORD 
* DESCRIBING THE SEGMENTATION.  SIMILARLY, ARRAYS HAVE
* AN INFO WORD (AND BASE-BIAS OR SEGMENTED ARRAYS HAVE TWO) 
* 
 ADRARY   BSS    0
          MX6    0           MARK NOT ALL CONSTANT/SIMPLE 
          SA6    DCONST 
          EQ     ADDR1       PREVIOUSLY DEFINED 
* 
 ADRSEG   MX6    0           MARK NOT ALL CONSTANT/SIMPLE 
          SA6    DCONST 
          EQ     ADDR1       PREVIOUSLY DEFINED 
* 
 ADRLIT   BSS    0
          LX1    60-LITSHF1 
          NG     X1,IMMLIT   IF IMMEDIATE LITERAL 
* 
          LX1    LITSHF1
          EQ     ADDR1       PREVIOUSLY DEFINED 
* 
 IMMLIT   LX1    LITSHF1
          RJ     STLIT1      LITERAL IMMEDIATELY FOLLOWS ADT
          EQ     DLEX 
* 
 ADUNIT   MX6    1           MARK UNIT ENCOUNTERED
          LX6    XCODEAL
          SA6    UREF 
          MX6    0           MARK NOT ALL CONSTANTS 
          SA6    DCONST 
          EQ     ADDR1
* 
* /---   BLOCK      ARGLOOK    00 000   76/02/17  20.05 
* 
 ARGLOOK  SA1    NARGS       NUMBER OF ARGUMENTS
          SA2    AD          GET NAME TO SEARCH FOR 
          MX6    0           MARK NOT ALL CONSTANTS 
          SA6    DCONST 
* 
 ASEEK1   SX1    X1-1        DECREMENT INDEX
          NG     X1,ERR3     JUMP IF NAME NOT FOUND 
          SA3    X1+ARGLIST 
          BX6    X3-X2       SEE IF NAMES MATCH 
          NZ     X6,ASEEK1
          BX7    X1          SAVE INDEX 
          SX1    OPARG       INSERT CODE FOR ARG
          RJ     STUFF
          BX1    X7 
          RJ     STUFF       INSERT ARG NUMBER
          SA1    LASTKEY
          SX2    X1-1R(      CHECK FOR IMPLIED MULTIPLY 
          ZR     X2,ARGMULT 
          SX2    X1-KLBRACK 
          NZ     X2,DLEX
 ARGMULT  SX1    OPMULT      INSERT MULTIPLY
          RJ     STUFF
          EQ     DLEX 
* 
* /---   BLOCK      ENDDEF     00 000   76/02/24  19.36 
* 
*         FINAL PROCESSING
*         CHECK FOR PRIMITIVE DEFN
* 
 ENDDEF   SX1    EOL         INSERT AN EOL
          RJ     STUFF
          SA2    TOKWRD 
          RJ     APTWD       WRITE OUT CURRENT *TWD*
          SA1    NARGS       CHECK IF FUNCTION
          NZ     X1,ENDD50
          SA1    DCONST      CHECK IF MAY BE ALL CONSTANTS
          ZR     X1,ENDD50   OR SIMPLE VARIABLES
          SA1    DNVAR
          SX1    X1-2        CHECK IF MORE THAN ONE VARIABLE
          PL     X1,ENDD50   ENCOUNTERED
* 
          SA1    WORDPT      SAVE *WORDPT*
          BX6    X1 
          SA6    OWORDPT
          SA1    INX         SAVE *INX* 
          BX6    X1 
          SA6    OLDINX 
          SA1    IWORDPT     RE-SET *WORDPT* TO BEGIN OF
          BX6    X1          EXPRESSION 
          SA6    WORDPT 
          SA1    LASTKEY
          BX6    X1          SAVE *LASTKEY* 
          SA6    OLDLAST
          RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE     EVALUATE EXPRESSION
          SA2    OWORDPT
          BX6    X2          RESTORE *WORDPT* 
          SA6    WORDPT 
          SA2    OLDINX 
          BX6    X2          RESTORE *INX*
          SA6    INX
          SA2    OLDLAST
          BX6    X2          RESTORE *LASTKEY*
          SA6    LASTKEY
          BX4    X1          X4 = -GETVAR- CODE 
          AX1    XCODEAL     POSTION -GETVAR- CODE TYPE 
          MX0    -3 
          BX1    -X0*X1 
          SB1    X1          PICK UP CODE TYPE
          JP     B1+*+1 
* 
+         EQ     ENDD40      SHORT LITERAL
+         EQ     ENDD20      LONG LITERAL 
+         EQ     ENDD40      STUDENT VARIABLE 
+         EQ     ENDD40      COMMON VARIABLE
+         EQ     NORMAL      EXPRESSION 
+         EQ     NORMAL      UNUSED 
+         EQ     NORMAL      ARRAY
+         EQ     NORMAL      SPECIAL JUMP 
* 
* /---   BLOCK      ENDD20     00 000   76/02/19  02.45 
* 
 ENDD20   BSS    0
          SA1    DEFLOC      RE-SET TOKEN POINTER 
          BX6    X1 
          SA6    TOKWRD 
          MX0    -XCODEAL 
          BX2    -X0*X4      ISOLATE ADDRESS
          SA2    X2+INFO     LOAD LITERAL 
          BX6    X2 
          SA6    TWD
          MX6    0
          SA6    TOKSHF      INDICATE NO BITS LEFT
          BX4    X0*X4       ZERO ADDRESS 
          BX4    X4+X1       INSERT ADDR(LIT IN TOKBUFF)
          RJ     ENDDTWD
          EQ     ADNAM
* 
 ENDD40   BSS    0
          MX6    0
          SA6    TWD
          SA1    DEFLOC      RE-SET TOKEN POINTER 
          BX6    X1 
          SA6    TOKWRD 
          SX6    60          ALL BITS AVAILABLE 
          SA6    TOKSHF 
          EQ     ADNAM
* 
 ENDD50   SA1    NADS        NUMBER OF ADDRESSES
          SX1    X1-1 
          NZ     X1,NORMAL   JUMP IF NOT SIMPLE 
          SA1    NOPS        NUMBER OF OPERATIONS 
          NZ     X1,NORMAL   JUMP IF NOT SIMPLE 
          SA1    DEFLOC      ADDRESS OF DEFN
          RJ     =XSETDEF 
          RJ     =XGETDEF      NUMBER OF ARGUMENTS
          NZ     X1,NORMAL
          RJ     =XGETDEF      GET FIRST ITEM 
          MX0    42          (X0) = GETVAR MASK 
          BX4    -X0*X1      SAVE *GETVAR* CODE 
          EQ     ADNAM       ADD DEFN NAME TO TABLE 
* 
*         -ENDDTWD- 
*         ADD THE LAST TOKEN WORD TO *TOKBUF* 
* 
 ENDDTWD  EQ     *
          BX6    X4          SAVE GETVAR CODE 
          SA6    GVSAVE 
          SA2    TOKWRD 
          RJ     APTWD
          SA4    GVSAVE 
          EQ     ENDDTWD
* 
 GVSAVE   BSS    1
* /---   BLOCK      NORMAL     00 000   75/02/11  02.52 
* 
 NORMAL   SX4    4           USE CODE FOR CALC
          LX4    XCODEAL     POSITION CODE
          SA1    UREF 
          BX4    X1+X4       ATTACH *UNIT* BIT
          SA1    DEFLOC 
          BX4    X4+X1       ATTACH ADDRESS 
*          SA1    TOKWRD
*          SX6    X1+1        ADVANCE TO NEXT FREE WORD 
*          SA1    ATOKEN
*          IX5    X1+X6       ECS ADDRESS OF NEXT TWD 
*          SA2    AVAR        ECS ADDRESS OF FIRST NAME 
*          IX1    X5-X2 
*          PL     X1,ERR4     BUFFER FULL 
*          SA6    TOKWRD
* 
 ADNAM    BSS    0
          CALL   ADDNAM,DEFNAME 
* /---   BLOCK      ENDLIN     00 000   81/07/16  04.21 
          SA1    LASTKEY     CHECK IF MORE TO LINE
          SA1    X1+KEYTYPE 
          SX2    X1-OPCOMMA 
          NZ     X2,ELN1     JUMP IF NOT COMMA
          SA1    WORDPT 
          SA2    X1          SEE IF END-OF-LINE 
          ZR     X2,ELN1
          EQ     DEFRD       CONTINUE IF MORE 
* 
 ENDLIN   SX2    X1-EOL      SEE IF END OF LINE CODE
          ZR     X2,ELN1     JUMP IF END-OF-LINE
          EQ     DEFRD
* 
 ELN1     RJ     =XRTOKNAM   FOR CONDITIONAL CSTOP/CSTART 
          RJ     =XGETLINE
          SA1    COMMAND     CHECK FOR BLANK COMMAND
          SA2    COMCONT
          BX2    X1-X2       BLANK FOR CONTINUED COMMAND
          ZR     X2,DEFRD    JUMP IF CONTINUED
          SA3    LOCAL       SEE IF LOCAL SET PROCESSING
          ZR     X3,ELN5     NEXT COMMAND IF GLOBAL SET 
* 
          RJ     =XSAVETAG   SAVE THE NEXT LINES TAG
          SA0    LUNIT       RESTORE -UNIT- TAG FOR ARG 
          SA1    ATEMPEC
          BX0    X1 
          WE     TAGLTH+1 
          RJ     ECSPRTY
          SA0    TAG
          RE     TAGLTH+1 
          RJ     ECSPRTY
* 
          SA1    LWRDPT      POINT TO ARGUMENTS LIST
          BX6    X1 
          SA6    WORDPT 
          EXEC   JOINOV,14   RE-ENTER -UNIT PROCESSING
* 
 ELN5     BSS    0
          SA2    HOLDEFN
          IX2    X1-X2       CHECK FOR ANOTHER -DEFINE- 
          ZR     X2,DEFNIN
* 
          EQ     NXTC 
 NOSET    SB1    11          NO SET 
          SA2    KE1
          EQ     ERRX 
* 
 NAMERR   SB1    12          BAD NAME 
          SA2    KE2
          EQ     ERRX 
* 
 DUPNAM   SB1    13          DUPLICATE
          SA2    KE3
          EQ     ERRX 
* 
 BADVAR   SB1    14          BAD VAR
          SA2    KE4
          EQ     ERRX 
* 
 BADFORM  SB1    15          BAD FORM 
          SA2    KE5
          EQ     ERRX 
* 
 BADCNT   SB1    16          BAD COUNT
          SA2    KE6
          EQ     ERRX 
* 
 BADSIZ   SB1    17          BAD SIZE 
          SA2    KE7
          EQ     ERRX 
* 
 BADTYP1  MX6    0           RESET LOCALS FLAG
          SA6    LOCAL
 BADTYP   SB1    18          ARRAY TYPE 
          SA2    KE8
* /---   BLOCK      ENDLIN     00 000   80/03/23  08.26 
          EQ     ERRX 
* 
 LITFULL  SB1    19          MANY LITS
          SA2    KE9
          EQ     ERRX 
* 
 NAMFULL  SB1    20          MANY NAMES 
          SA2    KE10 
          EQ     ERRX 
* 
 UFULL    SB1    21          MANY UNITS 
          SA2    KE11 
          EQ     ERRX 
* 
 NOTYET   SB1    22          NOT YET IN 
          SA2    KE12 
          EQ     ERRX 
* 
* 
* 
* /---   BLOCK      ENDLIN     00 000   80/03/23  08.25 
 ERR1     EQ     CHARERR
* 
 ERR2     EQ     LITERR 
* 
 ERR3     SB1    25          UNDEFINED
          SA1    KERR3
* 
 ERRX     BX7    X1 
          SA7    CERROR1     STORE MESSAGE
 ERRXX    SX7    11          CODE FOR DEFINE ERROR
          SA7    TFORMOK
          SA3    LOCAL
          ZR     X3,=XERR    IF NOT PROCESING LOCAL SET 
* 
          SA1    DSET 
          SA1    SETNAMS+X1  X1 = NAME OF CURRENT SET 
          SA2    KLOCAL      X2 = NAME OF LOCAL SET 
          IX3    X1-X2
          ZR     X3,=XERR    IF LOCAL SET PROCESSING OK 
* 
          MX6    0           NO LOCAL SET IN EFFECT 
          SA6    A3          ZERO LOCAL FLAG
          EQ     =XERR
* 
 ERR4     SB1    26          TOO MUCH 
          SA1    KERR4
          EQ     ERRX 
* 
 ERR5     SB1    27          MANY ARGS
          SA1    KERR5
          EQ     ERRX 
* 
 ERR6     SB1    28          DUPLICATE
          SA1    KERR6
          EQ     ERRX 
* 
 ERR7     SB1    29          BAD NAME 
          SA1    KERR7
          EQ     ERRX 
* 
 ERR8     SB1    30          BAD SET
          SA1    KERR8
          EQ     ERRX 
* /---   BLOCK      ERR9       00 000   80/03/23  07.50 
* 
          LIST   X
*CALL      DEFTEXT
          LIST   *
* /---   BLOCK      ERR9       00 000   80/03/23  07.50 
* 
 ERR9     SB1    31          NO SET 
          SA1    KERR9
          EQ     ERRX 
* 
 ERR10    EQ     FORMERR
* 
 ERR11    SB1    32          SYS ERR 1
          SA1    KERR11 
          EQ     ERRX 
* 
 ERR12    SB1    33          ARG MUST BE UNRECOGNIZED NAME
          EQ     ERRXX
* 
 ERR13    SB1    34          CAN'7T HAVE ZERO ARGUMENTS F() 
          EQ     ERRXX
* 
* /---   BLOCK      PURGE/ALL  00 000   79/02/18  17.47 
* 
 PURGE    SX3    X2-EOL 
          ZR     X3,PURGALL  PURGE ALL DEFINE SETS
          CALL   GETNAME,7   GET NAME OF SET TO PURGE 
          SX3    X2-EOL      ERROR IF NOT END-OF-LINE 
          NZ     X3,ERRORC
          RJ     =XFINDSET     SEE IF SET EXISTS
          NG     B1,ERRORC
* 
          RJ     PURGSET     PURGE DSET B1
          EQ     PNXTLN 
* 
 PURGALL  BSS    0
          RJ     ALLPURG     SUBROUTINE SINCE USED ELSEWHER 
          EQ     PNXTLN 
* 
* 
*         *PURGSET* 
* 
*         PURGE DEFINE SET
*         ON ENTRY           B1 = DSET TO PURGE 
*                            DSET = CURRENTLY OPEN SET
* 
*         ON EXIT            DSET = -1 IF ACTIVE SET PURGED 
* 
 PURGSET  EQ     *
          SX6    B1          SAVE DSET TO BE PURGED 
          SA6    PSET 
          SA1    DSET        SEE IF IT IS CURRENT SET 
          SB2    X1 
          NE     B1,B2,NOCLOSE IF NOT PURGING ACTIVE DSET 
* 
          SX1    -1          NULL SET TO BE ACTIVE
 NOCLOSE  BX6    X1          SAVE ACTIVE DSET 
          SA6    ODSET
          SB1    -1          GET NULL SET 
          RJ     =XGETSET 
          SA1    PSET        B1 = SET TO PURGE
          SB1    X1 
          SA1    TOKADDS+B0  SOURCE OF MOVE 
          SA2    TOKLENS+B1 
          SA3    NAMLENS+B1 
          IX2    X2+X3
          IX2    X2+X1       DESTINATION OF MOVE
          SA3    TOKADDS+B1 
          IX3    X3-X1       LENGTH OF MOVE 
          SB4    B1          SET TO END UPDATE
          SB3    -1          SET TO BEGIN UPDATE
          RJ     =XUPDNT     UPDATE TOK/NAMADDS 
          MX6    0           NO TOKENS OR DEFNAMS 
          SA6    SETNAMS+B1 
          SA6    NAMLENS+B1 
          SA6    TOKLENS+B1 
          SA4    TOKADDS+B1 
          BX6    X4 
          SA6    NAMADDS+B1 
          SA0    VARS 
          SB1    VARLONG
          RJ     =XMVECS     DELETE ECS COPY OF DSET
          SA1    ODSET
          SB1    X1 
          RJ     =XGETSET 
          SA1    PSET        RESTORE B1 
          SB1    X1 
          EQ     PURGSET
 PSET     BSS    1
* /---   BLOCK      ALLPURG    00 000   81/07/16  04.20 
* 
 ALLPURG  EQ     *
          SB1    B0          BEGIN WITH DSET 0
 PURGLP   SA1    SETNAMS+B1  DO NOT PURGE STUDENT DEFINE SET
          SA2    KSTUD       X2 = STUDENT SET NAME
          IX1    X1-X2
          ZR     X1,NOPURG   IF STUDENT SET, DO NOT PURGE 
* 
          RJ     PURGSET
 NOPURG   BSS    0
          SB1    B1+1 
          SB2    MAXSET 
          NE     B1,B2,PURGLP IF MORE TO PURGE
          EQ     ALLPURG
* 
 PURGEL   EQ     *
          RJ     =XSETSET    SET UP LOCAL DEFINE SET PARMS. 
          SA1    KLOCAL      X1 = NAME OF LOCAL SET 
          BX6    X1 
          RJ     =XFINDSET   B1 = SET NUMBER OF SET X6
          NG     B1,LPERR    IF NO LOCAL SET
* 
          RJ     PURGSET     PURGE SET NUMBER B1
          EQ     PURGEL 
* 
 PURGELU  RJ     PURGEL 
          SA1    GSET        REACTIVATE GLOBAL DEFINE SET 
          SB1    X1 
          RJ     =XGETSET 
          EXEC   JOINOV,15   RE-ENTRY TO -UNIT- PROCESSING
* 
 PURGELD  RJ     PURGEL 
          EQ     =XDFRD10 
* 
 LPERR    EQ     "CRASH"     LOCAL SET DIDNT EXIST
* 
* 
* 
 PNXTLN   RJ     =XGETLINE
          SA1    COMMAND     CHECK FOR BLANK COMMAND
          SA2    COMCONT
          BX2    X1-X2       BLANK FOR CONTINUED COMMAND
          ZR     X2,ERRORC   ERROR IF CONTINUED 
          EQ     NXTC 
* 
* /---   BLOCK      NEWSET     00 000   75/05/29  04.20 
* 
* 
*         -NEWSET-
*         INITIALIZES A DEFINE GROUP FOR THE NAME IN X6 
*         ON RETURN B1 CONTAINS THE INDEX OF THE GROUP
* 
 NEWSET   EQ     *
          SA6    SAVEDNM     SAVE THE SET NAME
 NW1      MX6    0           0 NAME IS EMPTY SLOT 
          RJ     =XFINDSET     LOOK FOR EMPTY SLOT
          GE     B1,B0,NW2   IF EMPTY SLOT FOUND, INITIALIZE
* 
          RJ     ALLPURG     PURGE ALL BUT -STUDENT-
          EQ     NW1         THIS TIME IT WILL FIND IT
* 
 NW2      BSS    0
          SA1    SAVEDNM
          BX6    X1 
          SA6    SETNAMS+B1  STORE THE SET NAME 
          EQ     NEWSET 
* 
* /---   BLOCK      STUFF      00 000   75/02/11  03.16 
* 
* 
*         -STUFF- 
*         STORES THE 12 BIT BYTE IN LOWER X1 IN THE NEXT
*         BYTE POSITION OF *TOKBUF* 
* 
 STUFF    EQ     *
          SA2    TOKWRD      WORD COUNT 
          SA3    TOKSHF      SHIFT COUNT
          SB1    X3-12
          PL     B1,STUF1    JUMP IF DONT NEED NEW WORD 
* 
          RJ     APTWD       WRITE OUT CURRENT TOKEN WORD 
          SA3    TOKSHF 
          SB1    48          DECREMENT *TOKSHF* 
 STUF1    MX0    48          12 BIT MASK
          BX1    -X0*X1 
          SA2    TWD         LOAD CURRENT WORD
          LX1    X1,B1       POSITION NEW BYTE
          LX0    X0,B1
          BX6    X2*X0       CLEAR NEW BYTE POSITION
          BX6    X6+X1       ATTACH NEW BYTE
          SA6    A2          STORE NEW *TWD*
          SX6    B1          STORE NEW *TOKSHF* 
          SA6    A3 
          EQ     STUFF
* 
* 
*         SET THE TOP BIT OF THE FIRST 12 BIT BYTE
*         OF AN ADDRESS *ADTYPE* TO INDICATE THE
*         FOLLOWING BYTE CONTAINS FURTHER INFORMATION 
*         AND PUT BOTH BYTES IN THE TOKEN BUFFER
*         ON ENTRY (X1) = ADTYPE
* 
 STUFADR  EQ     *
          BX7    X1 
          AX1    12          STORE FIRST 12 BITS
          SX2    4000B       SET 12TH BIT OF 1ST BYTE 
          BX1    X1+X2
          RJ     STUFF
          BX1    X7          RESTORE
          RJ     STUFF       STORE 2ND 12 BITS
          BX1    X7          RESTORE
          EQ     STUFADR
* 
* /---   BLOCK      STLIT1     00 000   79/02/20  21.04 
* 
*         LITERAL IS IMMEDIATE SO IT ADDS IT TO THE 
*         TOKEN BUFFER IN THE FIRST WHOLE WORD AFTER ITS
*         ADTYPE WITH THE 22ND BIT OF THE ADTYPE SET
*         TO INDICATE IMMEDIACY TO *GETDEF* 
*         ON ENTRY (X1) = GETVAR CODE 
*         ADDRESS OF GETVAR CODE POINTS INTO *LITS* 
* 
 STLIT1   EQ     *
          SA2    TOKSHF      PREDICT ADDR OF LIT
          SA3    TOKWRD 
          SX4    X2-24
          PL     X4,NXTWD    IF LIT CAN BEGIN AT NEXT WORD
* 
          SX3    X3+1        MUST BEGIN ONE WORD AFTER THAT 
 NXTWD    SX3    X3+1        POINT TO NEXT WORD 
          MX0    -XCODEAL 
          BX2    -X0*X1      GET ADDRESS OF LIT IN *LITS* 
          SA2    LITS+X2     GET LITERAL
          BX6    X2 
          SA6    LIT
          BX1    X0*X1       ZERO OUT ADDRESS 
          BX1    X1+X3       ENTER LIT ADDR IN TOKEN BUFF 
          RJ     STUFADR     STUFF BOTH BYTES OF (X1) 
          SA1    LIT         (X1) = LITERAL 
          RJ     STUFLIT     WRITE OUT LITERAL TO TOKENS
*                            IN NEXT AVAILABLE WORD 
          EQ     STLIT1 
* /---   BLOCK      CONSTANTS  00 000   80/03/23  07.51 
*         SUBROUTINE TO CHECK LIST OF SPECIAL NAMES 
 LUPDUN   SA7    SEGFLG      SET SPECIAL DEFINE TYPE
 DEFNAMS  EQ     *           ENTER WITH MAX NO NAMES IN X7
 LUPNAM   SA3    X7+DEFNAM-1  GET SPL NAME IN X3
          IX3    X3-X6       NAME IS IN X6
          ZR     X3,LUPDUN   QUIT IF FOUND
          SX7    X7-1 
          NZ     X7,LUPNAM
          EQ     LUPDUN 
* 
*      LIST OF SPECIAL DEFINE TYPE NAMES
* 
 DEFNAM   DATA   7LSEGMENT
          DATA   8LSEGMENTV 
          DATA   5LUNITS
          DATA   5LARRAY
          DATA   8LARRAYSEG 
          DATA   9LARRAYSEGV
          DATA   7LCOMPLEX
          DATA   0LSEGMENTF 
 DEFGNML  EQU    *-DEFNAM 
          DATA   7LINTEGER
          DATA   8LFLOATING 
 DEFLNML  EQU    *-DEFNAM 
          DATA   5LPURGE     ONLY ACTIVE ON FIRST LINE
 DEFNAML  EQU    *-DEFNAM 
          DATA   5LMERGE     ONLY ACTIVE IN LOCAL SET, LN 1 
* 
 K60      DATA   60.0 
 KVERT    DATA   0LVERTICAL 
 KSIGN    DATA   0LSIGNED 
 KS       DATA   0LS
 KE1      DATA   10LNO SET
 KE2      DATA   10LBAD NAME
 KE3      DATA   10LDUPLICATE 
 KE4      DATA   10LBAD VAR 
 KE5      DATA   10LBAD FORM
 KE6      DATA   10LBAD COUNT 
 KE7      DATA   10LBAD SIZE
 KE8      DATA   10LARRAY TYPE
 KE9      DATA   10LMANY LITS 
 KE10     DATA   10LMANY NAMES
 KE11     DATA   10LMANY UNITS
 KE12     DATA   10LNOT YET IN
* 
 KPREVN   DATA   8LPREVIOUS 
 KGLOBAL  DATA   0LGLOBAL 
* 
* 
 KBLANK   DATA   10L                 BLANKS 
 KSTUD    DATA   7LSTUDENT
* 
* 
 KERR3    DATA   10LUNDEFINED 
 KERR4    DATA   10LTOO MUCH
 KERR5    DATA   10LMANY ARGS 
 KERR6    DATA   10LDUPLICATE 
 KERR7    DATA   10LBAD NAME
 KERR8    DATA   10LBAD SET 
 KERR9    DATA   10LNO SET
 KERR11   DATA   10LSYS ERR 1 
* 
* 
 SAVEDNM  BSS    1
 DEFNAME  BSS    1
 DEFLOC   BSS    1
 ENDKEY   BSS    1
 UREF     BSS    1
 DCONST   BSS    1
 DNVAR    BSS    1
 IWORDPT  BSS    1
 OWORDPT  BSS    1
 INDLIT   BSS    1
 OLDINX   BSS    1
 OLDLAST  BSS    1
 NARGS    BSS    1
 ARGLIST  BSS    MAXARG 
* 
* 
          ENDOV 
* 
* 
          OVTABLE 
* 
* 
          END    DEFINE$
* /---   BLOCK      SEGMENT    00 000   81/07/13  01.10 
          IDENT  SEGMENT
          LCC    OVERLAY(1,1) 
* 
          TITLE  SEGMENT/ARRAY/UNITS
          TITLE 
* 
* 
          CST 
* 
* 
 SEGMNT$  OVFILE
* 
* 
          EXT    CHARERR,BADPAR,DECERR,VARERR 
          EXT    LOGERR,FORMERR,EQERR,OCTERR
          EXT    ALFERR,INDXERR,DEFERR,SEGERR 
          EXT    COMPERR,LNGERR,LITERR,TEMPERR
          EXT    ECSPRTY
* 
          EXT    COMCONT,DEFREAD,NXTC 
          EXT    KEYTYPE,SEGFLG 
* 
* 
 SEGOV    OVRLAY
          SA1    OVARG1      GET OVERLAY ARGUMENT 
          SB1    X1 
          JP     B1+*+1 
* 
+         EQ     SEGRD       -SEGMENT-
+         EQ     UNSRD       -UNITS-
* 
* 
* /---   BLOCK      SEGMENT    00 000   73/00/00  00.00 
          TITLE  READ-IN FOR -SEGMENT- COMMAND
* 
* 
*         -SEGREAD- 
*         READ-IN ROUTINE FOR -SEGMENT- COMMAND 
*         ADDS THE NAME OF THE SEGMENT TO THE DEFINED 
*         NAME TABLE AND ADDS A LITERAL CONTAINING THE
*         SEGMENT INFO TO THE DEFINED TOKEN TABLE 
* 
*         FORMAT OF SEGMENT INFO WORD - 
* 
*         SIGN BIT     = 0 FOR STUDENT,   1 FOR COMMON
*         NEXT BIT     = 0 IF UNSIGNED,   1 IF SIGNED 
*         NEXT BIT     = 0 IF HORIZONTAL, 1 IF VERTICAL 
*         NEXT BIT     = 1 IF SEGMENTF
*         NEXT  2 BITS = UNUSED 
*         NEXT 18 BITS = NUMBER OF BITS PER BYTE
*         NEXT 18 BITS = BIAS TO START OF ARRAY 
*         NEXT 18 BITS = NUMBER OF BYTES PER WORD (HORIZ) 
*                        BIT POSITION OF BYTE     (VERT)
* 
* /---   BLOCK      SEGRD      00 000   76/08/02  00.06 
* 
 SEGRD    SA1    DSET        MUST HAVE DEFINE SET 
          NG     X1,NOSET 
          SA1    WORDPT 
          SA1    X1-1        BACK UP TO PREVIOUS CHARACTER
          SA2    X1+KEYTYPE 
          SX1    X2-OPCOMMA  SEE IF ENDED WITH COMMA
          NZ     X1,BADFORM 
          MX6    -1          SET MODE FOR -VSEEK- SEARCH
          SA6    VSKMODE
          CALL   GETNAME,8   GET NAME OF SEGMENT/ARRAY
          ZR     X6,NAMERR
          SA6    SEGNAM 
          SB2    B1-8        CHECK HOW MANY CHARACTERS
          NG     B2,SEG005
          SA3    KVERT
          BX3    X3-X6       CHECK FOR SEGMENT,VERTICAL 
          ZR     X3,VERTSEG 
          EQ     NAMERR      8 CHARACTER NAME NOT LEGAL 
* 
 SEG005   SA3    SEGFLG      IS 1,2 IF SEGMENT,SEGMENTV 
          SX3    X3-3 
          NG     X3,SEG008   IF SEGMENT/SEGMENTV
          SX3    X3-8+3 
          NZ     X3,ARAYDEF  IF NOT SEGMENTF
 SEG008   SX1    X2-OPCOMMA  CHECK FOR COMMA
          ZR     X1,SEG010
          SX1    X2-OP=      CHECK FOR =
          ZR     X1,SEG010
          SX1    X2-OPASIGN  CHECK FOR ASSIGNMENT 
          NZ     X1,BADFORM 
* 
 SEG010   RJ     =XVSEEK       SEE IF ALREADY DEFINED 
          SA1    ADTYPE 
          PL     X1,DUPNAM   EXIT IF DUPLICATE NAME 
          SA7    DEFNLOC     SAVE LOCATION OF DEFINITION
          CALL   SYMCHK,SEGNAM
          RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE     STARTING VARIABLE OF ARRAY 
          MX0    -XCODEAL    MASK FOR ADDRESS PORTION 
          BX6    -X0*X1 
          LX6    18          POSITION ADDRESS 
          AX1    XCODEAL     POSITION -GETVAR- CODE TYPE
          MX0    -3 
          BX1    -X0*X1      MASK OFF 3 BIT TYPE CODE 
          SX2    X1-2 
          ZR     X2,SEG100   OK IF STUDENT BANK 
          SX2    X1-3 
          NZ     X2,BADVAR   ERROR IF NOT COMMON
          MX7    1
          BX6    X6+X7       SET SIGN BIT FOR COMMON
 SEG100   SA6    SEGWORD     SAVE TYPE BIT AND ADDRESS
          SA1    SEGFLG 
          SX1    X1-1        CHECK FOR SEGMENT
          NZ     X1,VSEG20   IF SEGMENTV/F
* /---   BLOCK      SEG200     00 000   75/05/29  04.25 
* 
          RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE
          MX0    -XCODEAL 
          BX6    X0*X1       MUST BE SHORT LITERAL
          NZ     X6,BADCNT
          ZR     X1,BADCNT
          SX6    X1-60       CHECK IF BYTE TOO BIG
          PL     X6,BADCNT
          PX6    X1 
          NX6    X6          CONVERT TO FLOATING
          SA2    K60
          FX6    X2/X6       COMPUTE BYTES PER WORD 
          UX6    X6,B1
          LX6    X6,B1       BACK TO INTEGER
          LX1    18+18
          BX6    X1+X6       COMBINE BIT AND BYTE COUNTS
          SA1    SEGWORD
          BX6    X1+X6       COMBINE WITH INFO WORD 
          SA6    A1 
* 
 SEG200   SA2    LASTKEY     LOAD LAST CHARACTER
          ZR     X2,ADDLIT   JUMP IF END-OF-LINE
          SA2    X2+KEYTYPE 
          SX6    X2-OPCOMMA  CHECK FOR COMMA
          NZ     X6,BADFORM 
* 
*         CHECK FOR SIGNED SEGMENT OPTION 
* 
          CALL   GETNAME,7    GET OPTION NAME 
          ZR     X6,NAMERR
          NZ     X1,BADFORM  ERROR IF NOT END-OF-LINE 
          SA3    KSIGN       CHECK FOR SIGNED SEGMENT 
          BX3    X6-X3
          ZR     X3,SIGNSEG 
          SA3    KS          ALLOW ABBREVIATION 
          BX3    X6-X3
          NZ     X3,NAMERR   ERROR IF NOT -S- 
* 
 SIGNSEG  MX6    1
          LX6    59          POSITION FOR SECOND BIT
          SA1    SEGWORD
          BX6    X1+X6       SET SECOND BIT 
          SA6    A1 
          EQ     ADDLIT 
* 
* /---   BLOCK      VERTSEG    00 000   76/08/02  00.10 
* 
*         PROCESS SEGMENT,VERTICAL CASE 
* 
 VERTSEG  SA3    SEGFLG      CHECK TYPE FLAG
          SX3    X3-1 
          NZ     X3,NAMERR   ERROR IF NOT -SEGMENT- 
          SX1    X2-OPCOMMA 
          NZ     X1,BADFORM  ERROR IF DID NOT END WITH COMMA
          CALL   GETNAME,7   GET NAME OF SEGMENT
          ZR     X6,NAMERR
          SA6    SEGNAM 
          SX7    2
          SA7    SEGFLG      SET SEGMENTV 
          EQ     SEG008 
* 
 VSEG20   RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE   EVALUATE STARTING BIT POSITION 
          ZR     X1,BADCNT   EXIT IF BAD BIT POSITION 
          MX0    -XCODEAL 
          BX0    X0*X1       MASK ALL BUT ADDRESS PORTION 
          NZ     X0,BADCNT   EXIT IF NOT A SHORT LITERAL
          SX0    X1-61
          PL     X0,BADCNT   EXIT IF ILLEGAL BIT POSITION 
          SA2    SEGWORD
          BX6    X1+X2       MERGE BIT POSITION WITH INFO 
          SA6    A2 
* 
          RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE     EVALUATE LENGTH OF BYTE
          ZR     X1,BADCNT   EXIT IF BAD BYTE SIZE
          MX0    -XCODEAL 
          BX0    X0*X1       MASK ALL BUT ADDRESS PORTION 
          NZ     X0,BADCNT
          SX0    X1-60
          PL     X0,BADCNT   EXIT IF BAD BYTE SIZE
          SA2    SEGWORD
          SX0    X2-1        PICK UP BIT POSITION 
          IX0    X0+X1       ADD LENGTH OF BYTE 
          SX0    X0-61
          PL     X0,BADCNT   EXIT IF BYTE SIZE TOO BIG
          LX1    18+18       POSITION LENGTH OF BYTE
          BX6    X1+X2
          MX0    1
          LX0    58          POSITION VERTICAL BIT
          BX6    X0+X6
          SA1    SEGFLG      CHECK IF SEGMENTF
          SX1    X1-8 
          NZ     X1,VSEG30   IF NOT SEGMENTF
          LX0    -1 
          BX6    X0+X6
 VSEG30   SA6    A2          UPDATE SEGMENT INFO WORD 
          EQ     SEG200 
* 
* 
* /---   BLOCK      ADDLIT     00 000   81/07/16  04.20 
* 
*         ADD SEGMENT INFO WORD TO DEFINED LITERAL TABLE
*         ARRAY USES THIS IF HAS ONLY ONE LITERAL WORD
* 
 ADDLIT   BSS    0
          SA1    SEGWORD
          RJ     =XSTUFLIT   STORE SEGMENT DESCRIPTOR 
          SA2    TOKWRD      IN ECS TOKEN BUFFER
          RJ     =XAPTWD
          SA2    TOKWRD      ADDRESS OF LITERAL IN TOKENS 
          SB1    X2-1 
          SA1    SEGFLG      CHECK TYPE 
          SX1    X1-3 
          NG     X1,SEG400   JUMP IF -SEGMENT-
          ZR     X1,SEG400   IN CASE -UNITS- USES THIS LATER
          SX1    X1-8+3 
          ZR     X1,SEG400   IF SEGMENTF
* 
 SEG310   SX4    6           6=CODE FO ARRAY IN *DEFNLEX* 
          EQ     SEG410 
* 
 SEG400   SX4    5           5=SEGMENT
 SEG410   LX4    XCODEAL     POSITION TYPE
          SX1    B1 
          BX4    X4+X1       FORM GETVAR CODE 
          CALL   ADDNAM,SEGNAM
* 
 ENDSEG   EXEC   DEFOV,2     RETURN FROM SEGOV
* 
* /---   BLOCK      SEGERRS    00 000   76/06/30  02.59 
* 
 NOSET    SB1    11          NO SET 
          SA2    KE1
          EQ     ERRX 
* 
 NAMERR   SB1    12          BAD NAME 
          SA2    KE2
          EQ     ERRX 
* 
 DUPNAM   SB1    13          DUPLICATE
          SA2    KE3
          EQ     ERRX 
* 
 BADVAR   SB1    14          BAD VAR
          SA2    KE4
          EQ     ERRX 
* 
 BADFORM  SB1    15          BAD FORM 
          SA2    KE5
          EQ     ERRX 
* 
 BADCNT   SB1    16          BAD COUNT
          SA2    KE6
          EQ     ERRX 
* 
 BADSIZ   SB1    17          BAD SIZE 
          SA2    KE7
          EQ     ERRX 
* 
 BADTYP   SB1    18          ARRAY TYPE 
          SA2    KE8
          EQ     ERRX 
* 
 LITFULL  SB1    19          MANY LITS
          SA2    KE9
          EQ     ERRX 
* 
 NAMFULL  SB1    20          MANY NAMES 
          SA2    KE10 
          EQ     ERRX 
* 
 UFULL    SB1    21          MANY UNITS 
          SA2    KE11 
          EQ     ERRX 
* 
 NOTYET   SB1    22          NOT YET IN 
          SA2    KE12 
          EQ     ERRX 
* 
 ERRX     BX6    X2          PLANT ERROR MESSAGE
          SA6    CERROR1
          SX7    11          DEFINE ERROR 
          SA7    TFORMOK
          EQ     =XERR       NEW CONDENSE ERROR PROCESSING
* 
* 
 SEGNAM   BSS    1
 USNAM    EQU    SEGNAM 
* 
 SEGWORD  BSS    1
 ARAYWD   EQU    SEGWORD
 ARAYWD2  BSS    1
* 
* 
* /---   BLOCK      ADDNAM     00 000   75/02/10  20.14 
          LIST   X
*CALL      DEFTEXT
          LIST   *
* 
 ERR4     SB1    26          TOO MUCH 
          SA1    KERR4
          BX7    X1 
          SA7    CERROR1     STORE MESSAGE
          SX7    11          CODE FOR DEFINE ERROR
          SA7    TFORMOK
          EQ     =XERR
* 
 KERR4    DATA   10LTOO MUCH
* /---   BLOCK      ARAYDEF    00 000   76/07/02  01.12 
* 
* 
          TITLE  ARRAY DEFINE 
* 
*         READIN FOR -ARRAY- AND -COMPLEX-
* 
*         PERMISSABLE FORMS FOR ARRAY DEFINE... 
*         ARRAY,NAME=V1   (SCALAR ARRAY WITH ROWS=COLS=1) 
*         ARRAY,NAME(ROWS)=N1  (VECTOR WITH COLS=1) 
*         ARRAY,NAME(ROWS,COLS)=VC1  (MATRIX) 
*         ARRAY,NAME(ROW1;ROWS)=V1  (VECTOR BASE REDEFN)
*         ARRAY,NAME(ROWS,COLS;ROW1,COL1)=N1 (BASE REDEFN)
*         ARRAY,..ANY ABOVE FORM..=N1,6,S (SEGMENTED ARRAY) 
*         COMPLEX,...ANY REAL NON-SEGMENTED SPEC ABOVE OK 
* 
*         FORMAT OF ARRAY/COMPLEX INFO WORD 
* 
*         BIT 59 = 0 FOR STUDVAR, 1 FOR COMMON
*         BIT 58 = 0 FOR REAL, 1 FOR COMPLEX ARRAY
*         BIT 57 = 0 FOR BASE INDEX OF 1, =1 FOR OTHER
*         BIT 56 = 0 FOR WORD, 1 FOR SEGMENTED ARRAY
*            IF  BITS 56OR57 ON, NEXT LITWORD HAS DETAILS 
*         BITS 55,54 HAVE ARRAY DIMENSIONS, 0 IS SCALAR,
*            1 FOR VECTOR, 2 FOR MATRIX, 3-D NOT IMPLEMENTED
*         NEXT 9 BITS ARE SIZE = ROWS"COLS (MAX 511)
*         NEXT 9 BITS ARE NUMBER OF ROWS-1
*         NEXT 9 BITS ARE NUMBER OF COLS-1
*         NEXT 9 BITS ARE NUMBER OF PLANES-1 (FOR 3-D)
*         LOWER 18 BITS ARE GETVAR CODE OF FIRST ELEMENT
*         I/F BIT,3 TYPEBITS(2=STUD,3=COMM),14BITS REL ADDR 
* 
*         ARAYWD2 (2D LITWORD) FORMAT USED FOR
*                SEGMENTED AND BASE-REDEFINED ARRAYS
* 
*         BIT 59 SET IF SIGNED SEGMENT
*         BIT 58 SET IF VERTICAL SEGMENT, 0 IF HORIZONTAL 
*         NEXT 4 BITS UNUSED
*         NEXT 6 BITS ARE (BITS/BYTE) FOR SEGMENT 
*         NEXT 6 ARE (BYTES/WD)  (0-63) FOR HORIZ SEG 
*             OR ARE (BIAS TO START OF SEG) IF VERTICAL 
*         NEXT 14 ARE ROW BASE INDEX
*         NEXT 14 ARE COL BASE INDEX
*         LAST 14 ARE PLANE BASE INDEX
* 
* 
 ARAYDEF  SX7    1           INITIALIZE 
          SA7    NROW 
          SA7    NCOL 
          SA7    ROW1 
          SA7    COL1 
          MX7    0
          SA7    ARAYWD 
          SA7    ARAYWD2
          SA7    DIMEN
          BX7    X2 
          SA7    SIZ         SAVE TERMINATOR
* 
* /---   BLOCK      ARAYNAM    00 000   76/06/30  03.00 
*    DETERMINE ARRAY NAME AND ANALYZE DIMENSIONS
          RJ     =XVSEEK       SEE IF ALREADY DEFINED 
          SA1    ADTYPE 
          PL     X1,DUPNAM   ERROR IF DUPLICATE NAME
          SA7    DEFNLOC     SAVE ECS LOC TO INSERT DEFN
          CALL   SYMCHK,SEGNAM    CHECK FOR REDEFN WARNING
          SA2    SIZ         RESTORE TERMINATOR 
          SX1    X2-OP=      CHECK FOR =
          ZR     X1,ARAYLOC  IS SCALAR
          SX1    X2-OPASIGN  CHECK FOR ASSIGNMENT 
          ZR     X1,ARAYLOC  IS SCALAR
          SX7    1
          SA7    DIMEN
          SX1    X2-OP(      CHECK FOR (SIZE) IN PAREN
          NZ     X1,BADFORM 
          RJ     SIZFIL      GET 1ST SIZE FIELD 
          SA6    NROW         AND SAVE IT 
          SX3    X2-OP)      CHECK FOR ONLY ONE FIELD 
          ZR     X3,ARAYNUL  JUMP IF VECTOR 
          SX3    X2-OPCOMMA  CHECK FOR COMMA OR SEMICOLON 
          NZ     X3,BADFORM 
          SX3    X1-56B       CHECK FOR COMMA 
          ZR     X3,ARAYMAT  JUMP IF MATRIX 
          SA6    ROW1        IS VECTOR BASE IF SEMICOLON
          RJ     SIZFIL      GET ROWS 
          SA6    NROW 
          SX3    X2-OP) 
          NZ     X3,BADFORM     MUST BE ) 
          EQ     ARAYNUL     VECTOR DONE
* 
 ARAYMAT  SX6    2
          SA6    DIMEN       DIMEN=2 FOR MATRIX 
          RJ     SIZFIL      GET COLS 
          SA6    NCOL 
          SX3    X2-OP)      CHECK FOR LAST FIELD 
          ZR     X3,ARAYNUL    JUMP IF IS 
          SX3    X1-77B      TEST FOR SEMICOLON TERMINATOR
          NZ     X3,BADFORM     ERROR IF ISNT 
          SA6    COL1        REDEFINE BASE INDICES
          SA3    NROW 
          BX7    X3 
          SA7    ROW1 
          RJ     SIZFIL      GET ROWS 
          SA6    NROW 
          SX3    X1-56B      TEST FOR COMMA 
          NZ     X3,BADFORM  ERROR IF NOT 
          RJ     SIZFIL      GET COLS 
          SA6    NCOL 
          SX3    X2-OP)      CHECK IF LAST FIELD
          NZ     X3,BADFORM  ERROR IF NOT 
* 
* /---   BLOCK      ARAYNUL    00 000   76/08/02  03.34 
* 
*         CHECK FOR = OR _ FOLLOWING )
* 
 ARAYNUL  CALL   GETNAME,7   VECTOR,MATRIX ENTER HERE 
          NZ     X6,BADFORM  NEXT NAME SHOULD BE BLANK
          SX3    X2-OP= 
          ZR     X3,ARAYLOC  TERMINATOR SHOULD BE = 
          SX3    X2-OPASIGN  OR ASSIGN ARROW
          NZ     X3,BADFORM 
* 
*         GET STARTLOC AND CHECK IF IN BOUNDS 
* 
 ARAYLOC  RJ     =XRTOKNAM   MAKE READY FOR *INITDEF* 
          RJ     =XCOMPILE     GET STARTLOC ADTYPE IN X1
          BX6    X1 
          AX1    XCODEAL     POSITION CODETYPE
          MX3    -3 
          BX3    -X3*X1      GETVAR CODE TYPE 
          MX4    0           STUD/COM  BIT OFF
          SX2    X3-2        CHECK STARTING VARIABLE TYPE 
          ZR     X2,ARAYSTB  JUMP IF STUDENT BANK 
          SX2    X3-3        MUST BE COMMON 
          NZ     X2,BADVAR   ERROR IF NOT 
          MX4    1           SET COMMON BIT 
 ARAYSTB  BX6    X4+X6       MERGE IN 
          SA6    ARAYWD      SAVE IT
          SA2    LASTKEY
          ZR     X2,ARAYSTD  JUMP IF E.O.L (NOT SEGMENT)
* 
*         HANDLE SEGMENTED ARRAY ARGUMENTS
* 
          SA2    X2+KEYTYPE  GET KEYTYPE
          SX3    X2-OPCOMMA 
          NZ     X3,BADTYP   MUST BE COMMA IF SEGMENTED 
          MX0    1           SEE BELOW
**ALLOW EITHER V OR N TYPE
          SA1    DIMEN
          ZR     X1,BADTYP   ERROR IF SEGMENTED SCALAR
          LX0    57 
          BX6    X6+X0       SET SEGMENT BIT 56 ON
          LX0    3+XCODEL-XFBIT   I/F BIT OFF SINCE 
          BX6    -X0*X6      ALL SEGMENTS ARE INTEGERS
          SA6    ARAYWD      SAVE TEMPORARILY 
* 
          RJ     SIZFIL      GET 1ST SEGMENT ARGUMENT 
          ZR     X6,BADCNT   CANNOT BE ZERO 
          NG     X6,BADCNT   OR NEGATIVE
          SX3    X6-61       CHECK IF BYTE TOO BIG
          PL     X3,BADCNT
          SA6    ATEMP         SAVE TEMPORARILY 
*** 
          SA3    SEGFLG 
          SX0    X3-6 
          ZR     X0,ARAYVER  JUMP IF VERTICAL SEGMENT 
          SX0    X3-5 
          NZ     X0,BADFORM  ERROR IF NOT HORIZ SEGMENT 
          ZR     X1,ARAYSEG  IF E.O.L. SIGNBIT(X1)=0
          SX3    X2-OPCOMMA 
          NZ     X3,BADFORM  MUST BE ,SIGNED
* 
          CALL   GETNAME,7
          ZR     X6,NAMERR
          NZ     X1,BADFORM  MUST BE E.O.L. 
          MX1    1           SET SIGNBIT
          EQ     SIGNCHK
* 
 ARAYSTD  SA3    SEGFLG      IF NO TAGS AFTER LOCATION
          SX0    X3-6        IT CANNOT BE SEGMENTED ARRAY 
          ZR     X0,BADFORM 
          SX0    X3-5        CHECK BOTH SEGMENT,SEGMENTV
          ZR     X0,BADFORM 
          EQ     ARAYSIZ
* /---   BLOCK      ARAYVER    00 000   76/08/02  03.43 
* 
*         GET VERTICAL SEGMENT BYTESIZE 
* 
 ARAYVER  SX3    X2-OPCOMMA 
          NZ     X3,BADFORM   MUST BE , BETWEEN START,BYTE
          RJ     SIZFIL      GET SEGMENT BYTESIZ
          ZR     X6,BADCNT   CANT BE ZERO 
          NG     X6,BADCNT   OR NEGATIVE
          SA3    ATEMP         = STARTBIT 
          IX7    X3+X6
          SX7    X7-62
          PL     X7,BADCNT   IS .GT.61
          LX6    6
          BX6    X6+X3       BYTESIZ/STARTBIT 
          SA6    SIZ          SAVE AGAIN IN SIZ 
          BX3    X1          SAVE TERMINATOR
          MX1    1
          LX1    59          SET VERTICAL,NONSIGNED BITS
          ZR     X3,ARAYSEG  JUMP IF E.O.L. 
* 
*         CHECK FOR SIGNED OPTION 
          SX3    X2-OPCOMMA 
          NZ     X3,BADFORM  ERROR IF TERMINATOR NOT COMMA
          CALL   GETNAME,7
          ZR     X6,NAMERR
          NZ     X1,BADFORM  ERROR IF NOT E.O.L.
          MX1    2           SET SIGN,VERTICAL BITS 
 SIGNCHK  SA3    KSIGN
          BX3    X6-X3       CHECK FOR SIGNED SEGMENT 
          ZR     X3,ARAYSEG 
          SA3    KS          ALLOW ABBREVIATION 
          BX3    X6-X3
          NZ     X3,NAMERR   ERROR IF NO S AFTER COMMA
* 
* /---   BLOCK      ARAYSEG    00 000   78/02/11  00.12 
* 
*         HORIZONTALLY SEGMENTED ARRAYS 
* 
 ARAYSEG  SA2    ARAYWD2
          BX6    X1+X2       ADD SIGNED+VERT SEGMENT BITS 
* 
          SA2    SIZ         GET BACK SEGMENT SIZE
          LX1    1
****
*          EQ     NOTYET      **USE THIS TO TURN OFF VERTSEG
****
          NG     X1,ARAYVSG  JUMP IF VERTICAL SEG 
***** 
          EQ     NOTYET      **THIS TURNS OFF HORIZ SEG 
***** 
          PX7    X2 
          NX7    X7          FLOAT BITS/BYTE
          SA3    K60         =60.0
          FX7    X3/X7       COMPUTE BYTES/WORD 
          UX7    X7,B1
          LX7    X7,B1       AS INTEGER 
          LX2    6
          BX2    X7+X2       COMBINE BIT/BYTE COUNT 
 ARAYVSG  LX2    42 
          BX6    X6+X2       MERGE WITH ARAYWD2 
          SA6    ARAYWD2     AND SAVE 
* 
* 
*         CALCULATE ARRAY SIZE
* 
 ARAYSIZ  SA1    NROW        GET LAST,FIRST ROW,COL 
          SA2    NCOL 
          SA3    ROW1 
          SA4    COL1 
          IX6    X1-X3       NUMBER OF ROWS-1, COLS-1 
          IX7    X2-X4       = COLS-1 
          BX5    X6+X7       BOTH SHOULD BE POSITIVE
          NG     X5,BADSIZ
          SX1    X6+1        NUMROWS
          SX2    X7+1        NUMCOLS
          DX4    X1*X2       NUMROWS*NUMCOLS
*         IF COMPLEX MUST DOUBLE SIZE 
          SA3    SEGFLG 
          SX3    X3-7 
          SX0    0           BIT 58 OFF FOR REAL
          SA2    ARAYWD 
          NZ     X3,ARAYPAK  JUMP IF NOT COMPLEX
          IX4    X4+X4       DOUBLE SIZE
          LX2    60-XCODEL+XFBIT   CHECK I/F BIT
          PL     X2,BADTYP   ERROR IF COMPLEX INTEGER TYPE
          SX0    20B         SET REAL/COMPLEX BIT ON
***** 
          EQ     NOTYET      ***TURNS OFF COMPLEX ARRAYS*** 
***** 
* 
*         START BUILDING ARRAY INFORMATION WORD(S)
* 
* ARAYPAK  SX3    X4-ARAYLTH      MAX SIZE OF ARRAY (256) 
 ARAYPAK  SX3    ARAYLTH         MAX SIZE OF ARRAY (255)
          IX3    X4-X3
          PL     X3,BADSIZ   ERROR IF >256
          SB1    X4-1        SAVE SIZE -1 
          SA3    DIMEN       START BUILDING ARAYWD
          BX3    X0+X3       MERGE REAL/CMPLX BIT AND DIMEN 
          LX3    9
          BX3    X3+X4       MERGE THIS WITH SIZE 
          LX3    9           THEN MERGE IN
          BX6    X3+X6       NUMROWS-1, 
          LX6    9
          BX6    X7+X6       NUMCOLS-1, 
          LX6    9           N PLANES-1 = 0 FOR NOW 
          LX6    XCODEAL+4      ROOM FOR GETVAR CODE(18BITS)
          SA2    ARAYWD 
          BX6    X6+X2       MERGE SHAPE,GETVAR,COM+SEG BITS
* 
*         AT THIS POINT X6=ARAYWD, X2 HAS GETVAR, X4=SIZE 
* 
*         NOW GET START LOCATION AND CHECK LENGTH IN BOUNDS.
* 
* /---   BLOCK      ARAYCHK    00 000   82/10/06  17.19 
          MX5    -XCODEAL 
          BX7    -X5*X2      MASK OFF ADDRESS INTO X7 
          LX2    3           SEGMENT BIT AT LEFT
          PL     X2,ARAYCHK  JUMP IF NOT SEGMENTED
* 
*   REPLACE SEGMENTED ARRAY SIZE WITH NUMBER OF WORDS USED
* 
          SA1    ARAYWD2
          LX1    1
          MX2    -6 
          NG     X1,ARAYCHK  JUMP IF VERTICAL SEGMENT 
          LX1    17 
          BX1    -X2*X1      BYTES/WD 
          SX4    X4-1        SIZE-1 
          PX4    X4 
          NX4    X4          FLOAT SIZE 
          PX1    X1 
          NX1    X1          FLOAT BYTES/WD 
          FX4    X4/X1       (SIZE-1)/(BYTES/WD)
          UX4    X4,B2
          LX4    X4,B2       +1=
          SX4    X4+1        NUMBER OF WORDS USED BY SEGARAY
* 
 ARAYCHK  SX4    X4-1        SIZE-1 
          IX4    X7+X4       X4=LAST ARRAY ELEMENT INDEX
          PL     X6,ARAYSTU  JUMP IF IN STUDENT BANK
          SX1    X4-NCVRLIM-1   (LAST ELEMENT)-(LIM+1)
          PL     X1,BADSIZ   ERROR IF LAST EL NOT IN BOUNDS 
          EQ     ARAYOK 
* 
 ARAYSTU  SX2    X4-VARLIM-1   (LAST)-(LIM+1) 
          NG     X2,ARAYOK   JUMP IF ALL INSIDE STUD BANK 
          SX2    X7-VARLIM-1  COULD BE ROUTER ARRAY 
          NG     X2,BADSIZ   JUMP IF START LOC NOT ROUTER 
          SA1    ARVARS 
          SA2    ASVARS 
          IX1    X1-X2       BIAS TO ROUTER VARS
          SA2    RVARL       (X2) = NUMBER OF RVARS ALLOWED 
          IX1    X1+X2       OFFSET TO LAST ROUTER VAR
          SX1    X1+1        LIMIT FOR ROUTER VARS
          IX2    X4-X1       CHECK IF INDEX IS TOO LARGE
          NG     X2,ARAYOK   INSIDE ROUTER VAR LIMIT
          IX2    X7-X1       CHECK IF BASE WAS ROUTER VAR 
          NG     X2,BADSIZ   IF SO, INDEX WAS TOO LARGE 
* 
* AT THIS POINT, MUST BE A LOCAL VAR OR AN ERROR.  THIS 
* DEPENDS ON THE FACT THAT THE CM ADDRESSES FOR STUDENT 
* VARS, ROUTER VARS AND LOCAL VARS (WHICH UNFORTUNATELY 
* ALL HAVE THE SAME GETVAR CODE -- GRR) ASCEND IN THE 
* ABOVE ORDER.
* 
          SA1    ASVARS      ADDRESS OF STUDENT VARS
          SA3    ALVARS      ADDRESS OF LOCAL VARS
          BX0    X6          PRESERVE X6 OVER FOLLOWING 
          IX6    X1-X3       OFFSET INTO LOCAL VARS 
          IX6    X6+X4       OFFSET OF LAST ELEMENT + 1 
          RJ     =XLBOUND    CHECK IN BOUNDS (A1/X1 USED) 
          SA1    LVARN       NUMBER OF LOCALS USED SO FAR 
          IX3    X6-X1       NUMBER NEEDED - NUMBER AVAIL.
          NG     X3,LVOK     MORE THAN ENOUGH AVAILABLE 
          ZR     X3,LVOK     JUST ENOUGH AVAILABLE
          SA6    A1          MAKE NUMBER NEEDED NEW NUM USED
          BX6    X1          SAVE THE OLD NUMBER USED SO FAR
          SA6    OLVARN 
* 
* /---   BLOCK      ARAYOK     00 000   82/10/06  17.20 
 LVOK     BX6    X0          RESTORE X6 = ARAYWD
 ARAYOK   SA6    ARAYWD      SAVE ARRAY INFO WORD 
 
* 
*         ADD BASE REDEFINITION INFO TO ARAYWD2 
* 
          SA1    ARAYWD2     CONTAINS SEGMENT INFO SO FAR 
          SA2    ROW1 
          SA3    COL1 
          SX4    1           SET PLANE1=1 FOR NOW 
          BX2    -X5*X2      X5 STILL = -XCODEAL 14BIT MASK 
          BX3    -X5*X3 
          BX4    -X5*X4 
          LX2    XCODEAL
          BX2    X2+X3       ROW1,COL1
          LX2    XCODEAL
          BX2    X2+X4       ROW1,COL1,PLANE1 
          SA4    RCPCHK      SUBTRACT 1,1,1 
          IX7    X2-X4
          ZR     X7,ARAYDUN  JUMP IF NO BASE REDEFINITION 
          MX7    1
          LX7    58          POSITION FOR BIT 57
* 
 ARAYDUN  BX6    X6+X7       MERGE BASEREDEF BIT INTO ARAYWD
          SA6    ARAYWD      WHICH IS NOW COMPLETE
          BX7    X2+X1       MERGE SEGMENT + BASEREDEF INFO 
          SA7    ARAYWD2     AND SAVE IT
          MX0    2
          LX6    2
          BX6    X0*X6
          ZR     X6,ADDLIT   JUMP IF NO ARAYWD2 INFO
          SA1    ARAYWD 
          RJ     =XSTUFLIT
          SA1    ARAYWD2
          RJ     =XSTUFLIT
          SA1    TOKWRD 
          RJ     =XAPTWD
          SA1    TOKWRD      ADDRESS OF SECOND LITERAL
          SB1    X1-2       POINT TO FIRST LIT
          EQ     SEG310 
* 
*         EXIT TO ADDLITS PUTS ARAYWD INTO TOKEN TABLE
*         AND PUTS ARRAY NAME INTO DEFINED NAMES TABLE. 
*         EXIT TO SEG310 JUST DOES LATTER.
* 
* /---   BLOCK      SIZFIL     00 000   80/03/23  07.51 
* 
*         SUBROUTINE TO GET SIZE INDEX  IN X6 
*         TERMINATOR IS IN *LASTKEY* AND X1 
*         RETURN TERMINATOR KEYTYPE IN X2 
*         INDEX MUST BE + OR - 13BIT MAXIMUM
* 
* 
 SIZFIL   EQ     *
          MX7    0
          MX6    59 
          SA6    VSKMODE     SET -1...DONT EXPAND DEFINE
          SA7    SIZ         SET 0 FOR +,  -0 FOR - 
          RJ     =XINITLEX
 SIZFIL2  RJ     =XLEX         GET SIZE ELEMENT 
          SA1    ADTYPE 
          SA2    OP 
          ZR     X2,SIZFIL8  JUMP IF PURE NUMBER IN X1
          SX2    X2-OPSUB 
          ZR     X2,SIZFIL4  JUMP IF UNARY MINUS
          SX2    X2+OPSUB-OPADD 
          ZR     X2,SIZFIL2  IGNORE UNARY PLUS
          SX2    X2+OPADD-OPDEFN
          ZR     X2,SIZFIL5  JUMP IF DEFINE 
          EQ     BADFORM     NO OTHER OPS ALLOWED 
* 
 SIZFIL4  SA2    SIZ
          BX7    -X2         TOGGLE SIGN
          SA7    A2 
          EQ     SIZFIL2
* 
 SIZFIL5  MX0    -XCODEAL 
          BX6    X0*X1
          NZ     X6,BADSIZ   JUMP IF NOT SHORT LITERAL IN X1
*NOTE...NO USE TRYING LONGLITS, - NUMBERS ARE COMPILED..UGH 
* 
 SIZFIL8  SA2    SIZ
          BX6    X1-X2       COMPLEMENTS ADTYPE IF SIZ=-0 
          BX1    X6 
          AX1    59          SIGN 
          BX1    X6-X1       ABS VALUE
          AX1    13          CHECK FOR 13BIT MAXIMUM SIZE 
          NZ     X1,BADSIZ   ERROR IF GREATER 
          SA1    LASTKEY     EXIT WITH TERMINATOR IN X1 
          SA2    X1+KEYTYPE  TERM. KEYTYPE IN X2
          EQ     SIZFIL      AND INTEGER SIZE ELEMENT IN X6 
* 
* 
 NROW     BSS    1
 NCOL     BSS    1
 ROW1     BSS    1
 COL1     BSS    1
 DIMEN    BSS    1
 SIZ      BSS    1
 ATEMP    BSS    1
 RCPCHK   DATA   2000040001B
 SIGNED   VFD    42/6LSIGNED,1/1,17/0   SPECIAL GETVAR FOR
          VFD    42/1LS,1/1,17/0        COMPSYM CHECK 
* 
* /---   BLOCK      UNITS      00 000   76/07/21  20.54 
          TITLE  READ-IN FOR -UNITS- COMMAND
* 
* 
* 
*         -UNSREAD- 
*         READ-IN ROUTINE FOR -UNITS- COMMAND - ADDS TO THE 
*         DEFINED NAME TABLE AND TO THE TOTAL UNITS COUNT 
*         (DIMENSIONALITY COUNT)
* 
* 
 UNSRD    SA1    DSET        MUST HAVE DEFINE SET 
          NG     X1,NOSET 
          SA1    WORDPT 
          SA1    X1-1        BACK UP TO PREVIOUS CHARACTER
          SA2    X1+KEYTYPE 
          SX1    X2-OPCOMMA  SEE IF ENDED WITH COMMA
          NZ     X1,BADFORM 
          MX6    -1          SET MODE FOR -VSEEK- SEARCH
          SA6    VSKMODE
          SA6    ENDFLG      MARK NOT END-OF-LINE YET 
* 
 UNS100   CALL   GETNAME,7   GET NAME OF NEXT *UNIT*
          ZR     X6,NAMERR
          SA6    USNAM
          SX1    X2-OPCOMMA  CHECK FOR COMMA
          ZR     X1,UNS120
          SX1    X2-EOL      CHECK FOR END-OF-LINE
          NZ     X1,BADFORM 
          MX7    0           MARK END-OF-LINE ENCOUNTERED 
          SA7    ENDFLG 
* 
 UNS120   RJ     =XVSEEK       SEE IF ALREADY DEFINED 
          SA1    ADTYPE 
          PL     X1,DUPNAM   EXIT IF DUPLICATE NAME 
          SA7    DEFNLOC     SAVE ECS LOC TO INSERT NAME
          CALL   SYMCHK,USNAM 
          SA1    NDEFU       GET NUMBER OF *UNITS* DEFINED
          SX6    X1-NUMAX    SEE IF TOO MANY *UNITS*
          PL     X6,UFULL 
          SX6    X1+1 
          SA6    A1 
          SX4    8           8=SHORT FLOATING LITERAL 
          LX4    XCODEAL
          BX4    X4+X1       X4=GETVAR CODE 
          CALL   ADDNAM,USNAM  ADD TO DEFINE TABLES 
          SA1    ENDFLG 
          NZ     X1,UNS100   CONTINUE IF NOT END-OF-LINE
          EQ     ENDSEG 
* 
* 
 ENDFLG   BSS    1
* 
 K60      DATA   60.0 
 KVERT    DATA   0LVERTICAL 
 KSIGN    DATA   0LSIGNED 
 KS       DATA   0LS
 KE1      DATA   10LNO SET
 KE2      DATA   10LBAD NAME
 KE3      DATA   10LDUPLICATE 
 KE4      DATA   10LBAD VAR 
 KE5      DATA   10LBAD FORM
 KE6      DATA   10LBAD COUNT 
 KE7      DATA   10LBAD SIZE
 KE8      DATA   10LARRAY TYPE
 KE9      DATA   10LMANY LITS 
 KE10     DATA   10LMANY NAMES
 KE11     DATA   10LMANY UNITS
 KE12     DATA   10LNOT YET IN
* 
* 
          ENDOV 
* 
* 
          OVTABLE 
* 
* 
          END    SEGMNT$