* XEROX SIGMA 5/7 FORTRAN IV - FORTLIB (SYSTEM)  #705361   1/27/75
*
*      F O R T R A N    S T A T E M E N T    P R O C S
*
*           A N D    D E F I N I T I O N S    O F
*
*     R E G I S T E R S    A N D    P A R A M E T E R S
*
X1       EQU      1                 INDEX 1
*
X2       EQU      2                 INDEX 2
LE       EQU      2                 LINK, ERROR
*
X3       EQU      3                 INDEX 3
BL       EQU      3                 BUFFER LOCATION
*
X4       EQU      4                 INDEX 4
ES       EQU      4                 ERROR SEVERITY
MNA      EQU      4                 MINIMUM NUMBER OF ARGUMENTS
NMD      EQU      4                 NUMBER OF MULTIPLE DUMMIES
*
X5       EQU      5                 INDEX 5
EN       EQU      5                 ENTRY NAME
MXA      EQU      5                 MAXIMUM NUMBER OF ARGUMENTS
ND       EQU      5                 NUMBER OF DUMMIES
*
X6       EQU      6                 INDEX 6
EL       EQU      6                 ENTRY LOCATION
LL       EQU      6                 LINK, LIBRARY
LR       EQU      6                 LINK, RECEIVING
*
X7       EQU      7                 INDEX 7
FP       EQU      7                 FORMAT POINTER
*
AR       EQU      8                 ACCUMULATOR, REAL
AD       EQU      8                 ACCUMULATOR, DOUBLE
AD0      EQU      8                 ACCUMULATOR, DOUBLE, 1ST WORD
AC       EQU      8                 ACCUMULATOR, COMPLEX
AC0      EQU      8                 ACCUMULATOR, COMPLEX, 1ST WORD
AK       EQU      8                 ACCUMULATOR, KOMPLEX
AK0      EQU      8                 ACCUMULATOR, KOMPLEX, 1ST WORD
*
AI       EQU      9                 ACCUMULATOR, INTEGER
AL       EQU      9                 ACCUMULATOR, LOGICAL
AD1      EQU      9                 ACCUMULATOR, DOUBLE, 2ND WORD
AC1      EQU      9                 ACCUMULATOR, COMPLEX, 2ND WORD
AK1      EQU      9                 ACCUMULATOR, KOMPLEX, 2ND WORD
*
AK2      EQU      10                ACCUMULATOR, KOMPLEX, 3RD WORD
*
AK3      EQU      11                ACCUMULATOR, KOMPLEX, 4TH WORD
*
NA       EQU      14                NUMBER OF ARGUMENTS
*
LC       EQU      15                LINK, CALLING
*
*
P        EQU      8                 PROTECTED     (FOR 9IODATA CALLS)
C        EQU      4                 CONTINUED      ''    ''      ''
E        EQU      2                 END I/O LIST   ''    ''      ''
*
E1       EQU      4                 ERROR SEVERITY - MINOR
E2       EQU      7                 ERROR SEVERITY - MAJOR
E3       EQU      15                ERROR SEVERITY - ABORT
         PAGE
*
*              CALLING AND RECEIVING SEQUENCE MNEMONICS
*
INTG     CNAME    X'01'             INTEGER
SNGL     CNAME    X'02'             REAL
DOUB     CNAME    X'04'             DOUBLE PRECISION
CMPX     CNAME    X'08'             COMPLEX
KMPX     CNAME    X'10'             KOMPLEX (DOUBLE COMPLEX)
LOGL     CNAME    X'20'             LOGICAL
EVRY     CNAME    X'3F'             EVERY TYPE PERMISSIBLE
         PROC
LF       GEN,1,7,4,3,17    AFA(1),NAME,CF(2),AF(2),AF(1)
         PEND
*
*              IMPLICIT TYPE SET TO REAL UNTIL ALTERED
*
IMPTYPE  SET      2
         PAGE                       SPO,DHO
*
*     R E A D / W R I T E    P R O C
*
*
*              INITIALIZE - NOTHING REFED YET
*
         OPEN     BCR,BCW,BIR,BIW,USA,IOD,EOL,PRT
BCR      SET      0
BCW      SET      0
BIR      SET      0
BIW      SET      0
USA      SET      0
IOD      SET      0
EOL      SET      0
PRT      SET      0
*
BCDREAD  CNAME    1
BCDWRITE CNAME    2
BINREAD  CNAME    3
BINWRITE CNAME    4
         PROC
LF       LI,AI    AF(1,1)           GET UNIT NUMBER
         DO       NAME<3            IF BCD,
            LI,FP    AF(1,2)           GET FORMAT POINTER
            DO       NAME=1            IF BCDREAD,
               BAL,LL   9BCDREAD          CALL 9BCDREAD
               DO       BCR=0             IF NOT ALREADY REFED,
                  REF      9BCDREAD          REF IT, AND
BCR               SET      1                 REMEMBER
               FIN
            ELSE                       IF BCDWRITE,
               BAL,LL   9BCDWRIT          CALL 9BCDWRIT
               DO       BCW=0             IF NOT ALREADY REFED,
                  REF      9BCDWRIT          REF IT, AND
BCW               SET      1                 REMEMBER
               FIN
            FIN
*
*
         ELSE
            DO       NAME=3            IF BINREAD,
               BAL,LL   9BINREAD          CALL 9BINREAD
               DO       BIR=0             IF NOT ALREADY REFED,
                  REF      9BINREAD          REF IT, AND
BIR               SET      1                 REMEMBER
               FIN
            ELSE                       IF BINWRITE,
               BAL,LL   9BINWRIT          CALL 9BINWRIT
               DO       BIW=0             IF NOT ALREADY REFED,
                  REF      9BINWRIT          REF IT, AND
BIW               SET      1                 REMEMBER
               FIN
            FIN
         FIN
         PEND
*
ENDIOL   CNAME
         PROC
LF       BAL,LL   9ENDIOL           CALL 9ENDIOL
         DO       EOL=0             IF NOT ALREADY REFED,
            REF      9ENDIOL           REF IT, AND
EOL         SET      1                 REMEMBER
         FIN
         PEND
READ     CNAME    1
WRITE    CNAME    2
PRINT    CNAME    3
         OPEN     JM1,J,E,C,ARG
ARG      COM,1,8,1,1,4,17     AFA(1),1**AF(2),AF(3),AF(4),0,AF(1)
         PROC
*              INITIALIZE I/O OPERATION
         DO       NAME=1                 READ
            DO       NUM(AF(1))=1
LF             BINREAD  (AF(1),0)
            ELSE
LF             BCDREAD  (AF(1),0)
            FIN
         FIN
         DO       NAME=2                 WRITE
            DO       NUM(AF(1))=1
LF             BINWRITE (AF(1),0)
            ELSE
LF             BCDWRITE (AF(1),0)
            FIN
         FIN
         DO       NAME=3                 PRINT
LF          LI,FP    AF(1)
            BAL,LL   9PRINT
            DO       PRT=0
               REF      9PRINT
PRT            SET      1
            FIN
         FIN
*
JM1      DO       NUM(AF)-1         FOR EACH ITEM,
J           SET      JM1+1
E           SET      J=NUM(AF)         E=1 IFF END OF I/O LIST
            DO       NUM(AF(J))>2      IF ARRAY,
               LI,AI    AF(J,3)           GET NUMBER OF ELEMENTS
               BAL,LL   9IOLUSA           AND CALL 9IOLUSA
               ARG      AF(J,1),AF(J,2),0,E
               DO       USA=0
                  REF      9IOLUSA
USA               SET      1
               FIN
            ELSE                       IF NOT ARRAY
C              SET      (E||1)&(NUM(AF(J+1))<3)  C=1 IFF NOT LAST ARG
               DO       J=2|(NUM(AF(J-1))>2)  IFF FIRST ARG,
                  BAL,LL   9IODATA               CALL 9IODATA
                  DO       IOD=0                 IF NOT REFED,
                     REF      9IODATA               REF IT, AND
IOD                  SET      1                     REMEMBER
                  FIN
               FIN
               DO       NUM(AF(J))=2          GENERATE ARGUMENT
                  ARG      AF(J,1),AF(J,2),C,E   WITH SPECIFIED
               ELSE                              OR
                  ARG      AF(J),IMPTYPE,C,E     IMPLICIT TYPE
               FIN
            FIN
         ELSE                       IF LIST IS EMPTY,
            ENDIOL                     END IT WITH DIRECT CALL
         FIN
*
         CLOSE    JM1,J,E,C,ARG
         CLOSE    BCR,BCW,BIR,BIW,USA,IOD,EOL,PRT
         PEND
         PAGE
*
*     R E W I N D ,    B A C K S P A C E ,    E N D F I L E
*
         OPEN     BKS,REW,ENF
BKS      SET      0
REW      SET      0
ENF      SET      0
BKSPACE  CNAME    1
REWIND   CNAME    2
ENDFILE  CNAME    3
         OPEN     J
         PROC
LF       EQU      %
J        DO       NUM(AF)           FOR EACH ARG,
            LI,AI    AF(J)             PICK UP UNIT NUMBER
            DO       NAME=1            IF BKSPACE,
               BAL,LL   9BKSPACE          CALL 9BKSPACE
               DO       BKS=0             IF NOT ALREADY REFED,
                  REF      9BKSPACE          REF IT, AND
BKS               SET     1                  REMEMBER
               FIN
            FIN
            DO       NAME=2            IF REWIND,
               BAL,LL   9REWIND           CALL 9REWIND
               DO       REW=0             IF NOT ALREADY REFED,
                  REF      9REWIND           REF IT, AND
REW               SET      1                 REMEMBER
               FIN
            FIN
            DO       NAME=3            IF ENDFILE
               BAL,LL   9ENDFILE          CALL 9ENDFILE
               DO       ENF=0             IF NOT ALREADY REFED,
                  REF      9ENDFILE          REF IT, AND
ENF               SET      1                 REMEMBER
               FIN
            FIN
         FIN
         CLOSE    J
         CLOSE    BKS,REW,ENF
         PEND
         PAGE
*
*     F O R M A T    P R O C
*
*              LIKE THE COMPILER, THIS PROC GENERATES A BRANCH
*              AROUND THE TEXT, SO FORMATS MAY BE PLACED ANYWHERE
*              IN A PROGRAM.
*
FORMAT   CNAME
         PROC
         LOCAL    NEXT
LF       B        NEXT
         TEXT     AF
NEXT     SET      %
         PEND
         PAGE
*
*     P A U S E  /  S T O P    P R O C
*
         OPEN     PAU,STO
PAU      SET      0
STO      SET      0
*
PAUSE    CNAME    1
STOP     CNAME    2
         PROC
LF       LI,AI    AF(1)
         DO       NAME=1
            BAL,LL   9PAUSE
            DO       PAU=0
               REF      9PAUSE
PAU            SET      1
            FIN
         ELSE
            BAL,LL   9STOP
            DO       STO=0
               REF      9STOP
STO            SET      1
            FIN
         FIN
         CLOSE    PAU,STO
         PEND
         PAGE
*
*     I N I T I A L    P R O C
*
         OPEN     INI
INI      SET      0
*
INITIAL  CNAME
         PROC
LF       BAL,LL   9INITIAL
         DO       INI=0
            REF      9INITIAL
INI         SET      1
         FIN
         CLOSE    INI
         PEND
         PAGE
*
*
*    C A L L    P R O C
*
CALL     CNAME                                                           0004000
         OPEN     I,ARG                                                  0005000
ARG      COM,1,8,6,17  AFA(1),1**AF(2),0,AF(1)                           0006000
         PROC                                                            0007000
LF       LI,14    NUM(AF(2))
         BAL,15   AF(1)                                                  0009000
I        DO       NUM(AF(2))                                             0010000
         DO       NUM(AF(2,I))=2                                         0011000
         ARG      AF(2,I,1),AF(2,I,2)                                    0012000
         ELSE                                                            0013000
         ARG      AF(2,I),IMPTYPE                                        0014000
         FIN                                                             0015000
         FIN                                                             0016000
         CLOSE    I,ARG                                                  0017000
         PEND                                                            0018000
*
*    C O N N E C T    P R O C
*
         OPEN     CON
CON      SET      0
CONNECT  CNAME                                                           0021000
         PROC                                                            0022000
         LOCAL    2G                                                     0023000
         DO       CON=0                                                  0032000
CON      SET      1                                                      0033000
         REF      9CONNECT,9RENTER,9REXIT                                0034000
         FIN                                                             0035000
LF       LW,9     AF(1)
         LI,8     %+3                                                    0025000
         BAL,LL   9CONNECT                                               0026000
         B        2G                                                     0027000
         BAL,LL   9RENTER                                                0028000
         CALL     AF(2),(AF(3))
         BAL,LL   9REXIT                                                 0030000
2G       EQU      %                                                      0031000
         CLOSE    CON
         PEND                                                            0035100
         END
