*
*   S Y S T E M   A P % I L
*
*        THIS SYSTEM DEFINES THE IMPLEMENTATION LANGUAGE FOR THE XEROX
*           ASSEMBLY PROGRAM (AP).  IT DOES NOT CONTAIN THE DEFINITIONS
*           FOR INTERFACE WITH AN OPERATING SYSTEM.
*
*
*   E N V I R O N M E N T
*
         OPEN     BC,I,META,P#
*
         SYSTEM   SIG5              MACHINE INSTRUCTION DEFINITIONS
*
         OPEN     BIL,BOL           SOME HAVE 'EM - SOME DON'T
BIL      S:SIN,1  X'689'            BRANCH IN LIMITS (AFTER CLM W/ DBLWD
BOL      S:SIN,1  X'699'            BRANCH OUT OF LIMITS / IN MEM LO-HI)
*
META     EQU      1**128            PATCH FOR META BUG (AP OKAY)
P#       SET      S:UFV(P#)+1       1 = PASS 1, 2 = PASS 2
*
*
*   S : S
*        SELECTION (CASE) PROCEDURE
*
S:S      FNAME
         PROC
         PEND     AF(AF(1)+2)
*
*
*   A B O R T
*        PROCEDURE FOR GENERATING A CALL TO ABORT
*
*        CALL LINE:    LABEL  ABORT  PROCESS NUMBER
*
ABORT    CNAME
         PROC
LF       LI,AR    AF(1)             LOAD PROCESS NUMBER
         B        ABORT             BRANCH TO ROUTINE IN THE ROOT
         PEND
*
*
*   B C
*        SET UP BRANCH TYPE AND APPROPRIATE CONDITION MASK FOR THE
*           CONDITION KEYWORD SPECIFIED IN 'AF(2)'.
*
*           AF(1) IS 0 FOR A TRUE BRANCH TO THAT
*           CONDITION, 1 FOR A FALSE.
*
         OPEN     I
*
BC       FNAME    X'680',X'690'     BRANCH ON CONDITION
         PROC
I        SET      0
         DO       NUM(AF(2))=1
I           SET  SCOR(AF(2),GE,LE,EQ,AZ,,,,,IL,,,,,,,,L,G,NE,ANZ,,,,,OL)
            DO    I=0
I              SET SCOR(AF(2),GEZ,LEZ,EZ,FZ,,,,,,,,,,,,,LZ,GZ,NZ,FNZ)
               ERROR,3,I=0 'UNDEFINED CONDITION'
            FIN
         FIN
         PEND     S:S(AF(1)>0,NAME)||I
*
         CLOSE    I
*
*
*  B F Z   &   B F N Z
*        BRANCH IF FIELD ZERO, AND BRANCH IF FIELD NON-ZERO
*
*        FORM OF TYPICAL REFERENCE LINE:
*          BFZ,R,C    MASK,*ADDRESS,INDEX
*          WHERE   R IS THE REGISTER CONTAINING THE FIELD TO TEST.
*                  C IS NON-ZERO IF THE CONDITION CODE HAS BEEN CHANGED
*                  ADDRESS IS THE BRANCH ADDRESS IF CONDITION IS MET.
*
*        COMPARE IS NOT EXECUTED IF THE MASK IS X'80000000', UNLESS
*          C IS NON-ZERO.  E.G.,  BFNZ,R,1  X'80000000',ADDRESS
*          WILL GENERATE THE COMPARE.
*
         OPEN     I
*
BFZ      CNAME    X'68'             BRANCH IF FIELD ZERO
BFNZ     CNAME    X'69'             BRANCH IF FIELD NON-ZERO
         PROC
         BOUND    4
LF       RES      0
I        DO       (AF(1)~=X'80000000')|(CF(3)~=0)
            CV,CF(2) AF(1)
         FIN
         DO       AFA(2)&(AF(3)=0)&(S:UFV(AF(2))<=7)
            GEN,8,4,3,17   NAME,I*3+1,AF(2),0
          ELSE
            GEN,1,7,4,3,17   AFA(2),NAME,I*3+1,AF(3),AF(2)
         FIN
         PEND
*
         CLOSE    I
*
*
*   C A L L   P R O C E D U R E
*        GENERATE A 'BAL' USING THE STANDARD LINK REGISTER
*
CALL     COM,1,7,4,20   AFA,X'6A',RL,WA(AF(1))
*
*
         OPEN     I,IAL,IAN,INL,IN1,IN2
*
*  E X I T   P R O C E D U R E
*        GENERATE A RETURN BRANCH FROM A SUBROUTINE.
*
*        FORM OF A REFERENCE LINE:
*        LBL   EXIT,COND   REG
*          WHERE: COND IS ANZ,AZ,EQ,EZ,G,GE,GEZ,GZ,IL,L,LE,LEZ,LZ,
*                     NE,NZ, OR OL.
*                 REG IS THE REGISTER CONTAINING THE RETURN ADDRESS
*                     (DEFAULT IS 'RL' IF REG IS NOT SPECIFIED)
*
*              'COND' MAY ALSO BE FZ OR FNZ (A LA BFZ/BFNZ PROCS), IN
*              WHICH CASE THE 'EXIT' CALL IS OF THE FORM:
*
*                 EXIT,COND MASK,R,C
*
EXIT     CNAME
         PROC
         DO       (INL-META)>0
            DISP  INL**8+X'0FEFFF00'
         FIN
         DO       SCOR(CF(2),FZ,FNZ)=0
            BOUND 4
I           SET   S:S(NUM(AF)=1,RL,AF)
LF          GEN,1,11,3,17 I>7,BC(0,CF(2)),I*(I<8),I*(I>7)
          ELSE
            DO    SCOR(CF(2),FZ)
LF             BFZ,AF(2),AF(3)   AF(1),*RL
             ELSE
LF             BFNZ,AF(2),AF(3)  AF(1),*RL
            FIN
         FIN
         PEND
*
*
*   I F  /  E L S  /  F I
*
*        THESE PROCEDURES DEFINE THE STANDARD IF-THEN/ELSE COMPOUNDS.
*           THE CLAUSES MAY BE NESTED; IT IS ONLY REQUIRED THAT 'FI'
*           STATICALLY BALANCE THE ASSOCIATED 'IF'.  'ELS', AS USUAL,
*           IS OPTIONAL, AND IS PAIRED WITH THE LAST UN-FI'ED 'IF'.
*
*           'ELSF' & 'THEF' ARE ALSO DEFINED.  A SEPARATE 'FI' IS NOT
*           REQUIRED TO TERMINATE (NEXT 'ELSF', 'ELS', OR 'FI').
*
*           WHERE 'IF P ... THEF Q' CAN BE CONSIDERED TO BE
*           FUNCTIONALLY EQUIVALENT TO 'IF P AND Q', THE FUNCTIONAL
*           EQUIVALENT OF 'IF P OR Q' IS NOT EASILY IMPLEMENTED IN
*           THE SAME STYLE.  IT IS AVAILABLE, HOWEVER, BY APPENDING
*           A TRAILING 'OR' KEYWORD TO ANY 'IF', 'ELSF', OR 'THEF'
*           ('IF P,OR ... IF Q').
*
*        USE:
*           IF,COND  (VAL(,R))
*              BLOCK1
*            ELS
*              BLOCK2
*           FI
*
*           WHERE 'COND' IS ANY ACCEPTED BY BC.  IF CONDITION IS TRUE,
*              BLOCK1 IS EXECUTED, ELSE IT IS SKIPPED. IF CONDITION IS
*              NOT TRUE, BLOCK2 IS EXECUTED, IF IT APPEARS.
*
*              THE OPTIONAL 'VAL,R' IMPLIES THAT A 'CV,R  VAL' IS
*              TO BE EXECUTED PRIOR TO THE TEST.  IF 'R' IS OMITTED,
*              THE 'R' FROM THE LAST SUCH 'IF' WILL BE USED.
*
*              'COND' MAY ALSO BE FZ OR FNZ (A LA BFZ/BFNZ PROCS), IN
*              WHICH CASE THE 'IF' CALL IS OF THE FORM:
*
*                 IF,COND  MASK,R
*
*   PRELUDE:
*
         OPEN     %ELS%,%ELSF%,%IF%,%NORM%,%OR%
         OPEN     :IF,:FI,:SC,:TY
         OPEN     #ELS,#IF
         OPEN     BT,CT,DR,ENL,NXTIN,OE,SE
*
*        FIXED INDICES FOR IAN
*
:TY      EQU      1                 TYPE CODE
:SC      EQU      2                 SUCCESS ADDRESS
:IF      EQU      3                 INITIAL FAIL ADDRESS (FOR 'IF')
:FI      EQU      4                 'FI' OR SECOND FAIL ADDRESS
*
*        TYPE CODES (FOR 'IAN(INL,:TY)')
*
%NORM%   EQU      0                 NO CONTROL SEQUENCE IN EFFECT
%IF%     EQU      1                 'IF' HIT - NEED 'ELSF','ELS','FI'
%ELSF%   EQU      2                 'ELSF' HIT - NEED 'ELS' OR 'FI'
%ELS%    EQU      3                 'ELS' HIT - ONLY 'FI' LEGAL
%OR%     EQU      X'80'             'OR'-CHAIN CURRENT
*
*        ERROR MESSAGES
*
OE       EQU      '''OR''-GROUP MUST TERMINATE ON ''IF'''
SE       EQU      'CONTROL SEQUENCE ERROR'
*
*        CONTROL LISTS AND INDICES
*
DR       SET      -1                DEFAULT REGISTER FOR CHAINED 'IF'S'
ENL      SET      :SC               ELS-NESTING LEVEL
IAL      SET      S:S(P#,,,S:UFV(IAL)) KEEP ONLY PASS 1 ADDRS IN LIST.
IAN      SET      %NORM%            INDICES TO IAL
INL      SET      0+META            IF-NESTING LEVEL
IN1      SET      1                 INDEX #1 IN IF-ADDRESS-LIST
IN2      SET      1                 INDEX #2 IN IF-ADDRESS-LIST
*
************************************************************************
*                                                                      *
*        THE IAN LIST IS ARRANGED IN THE FOLLOWING FASHION AT ANY ONE  *
*           'INL' LEVEL (WITH EACH ELEMENT HOLDING AN INDEX TO THE     *
*           'IAL' LIST, WHICH IS JUST A RUNNING ADDRESS TABLE):        *
*                                                                      *
*           IAN(INL,1) - TYPE CODE FOR CURRENT ENVIRONMENT.  USED FOR  *
*                        ERROR CHECKING AND REPORTING.                 *
*           IAN(INL,2) - 'SUCCESS' BRANCH ADDRESS.  USED TEMPORARILY   *
*                        DURING AN 'OR' GROUP - SATISFIED BY FIRST     *
*                        NON-'OR' COMMAND.                             *
*           IAN(INL,3) - 'FAIL' BRANCH ADDRESS(1).  INITIALLY,         *
*                        WHERE A PLAIN 'IF' SHOULD BRANCH IF THE       *
*                        CONDITION IS NOT SATISFIED.                   *
*           IAN(INL,4) - 'FAIL' BRANCH ADDRESS(2), WHICH IS ALWAYS     *
*                        THE ADDRESS OF THE TERMINAL 'FI' FOR A GROUP  *
*                        WHICH CONTAINS 'ELS' OR 'ELSF'.               *
*           IAN(INL,5) - SUBSEQUENT 'FAIL' BRANCH ADDRESSES.  THESE    *
*               .        ARE CREATED AS 'ELSF'S PILE UP WITHIN A       *
*               .        SINGLE GROUP, RATHER THAN GOING UP TO A       *
*           IAN(INL,N)   NEW 'INL' LEVEL FOR THE 'ELSF'S 'IF'.         *
*                                                                      *
************************************************************************
*
IF       CNAME    0
#IF      CNAME    1
THEF     CNAME    2
*
         OPEN     DSA
*
DSA      SET      0                 DEFINE SUCCESS ADDRESS
*
         PROC
         BOUND    4
LF       RES      0
BT       SET      1                 DEFAULT BRANCH IS 'FALSE'
CT       SET      IAN(INL+((INL-META)=0),:TY)&~%OR%  TYPE (W/O 'OR')
DR       SET      S:S(NUM(AF(2))=1,DR,AF(2))
         DO       (IAN(INL+((INL-META)=0),:TY)&%OR%)>0 DOIF IN OR-CHAIN
            GOTO,NAME+SCOR(AF(NUM(AF)|1),OR)*3 PEND,#2,#3,PEND,#5
#0           BOUND 1                IF IN 'OR'-CHAIN
DSA            SET 1                DEFINE SUCCESS ADDRESS
IAN(INL,:TY)   SET %IF%             CLEAR %OR% - SET %IF% MODE
               GOTO ESAC
#2           BOUND 1                THEF IN 'OR'-CHAIN
IAL(IAN(INL,:SC)) SET WA(%)         DEFINE SUCCESS ADDRESS
               GOTO EXIT1
#3           BOUND 1                IF ..,OR IN 'OR'-CHAIN
BT             SET 0                GENERATE TRUE BRANCH
IAN(INL,:TY)   SET %IF%|%OR%        SET %IF% MODE UNDER 'OR'-CHAIN
               GOTO ESAC
#5           BOUND 1                THEF ..,OR IN 'OR'-CHAIN
IAL(IAN(INL,:SC)) SET WA(%)         DEFINE SUCCESS ADDRESS
IAN(INL,:SC)   SET NXTIN
EXIT1        ERROR,3 OE
               GOTO,(CT~=%IF%)&(CT~=%ELSF%) EXIT0
ESAC        BOUND 1                 END CASE
          ELSE                      NOT IN 'OR'-CHAIN
            GOTO,NAME+SCOR(AF(NUM(AF)|1),OR)*3 #1,#2,#3,#4,#5
#0           BOUND 1                IF
ENL            SET :SC            (FI WILL RE-CALCULATE)
               DISP (INL-META)**8+X'001F0000'
INL            SET INL+1          BUMP NESTING LEVEL
IAN(INL,:TY)   SET %IF%             SET %IF% MODE
               GOTO EXIT2
#1           BOUND 1                #IF (INTERNAL IF)
IAN(INL,:TY)   SET %ELSF%           SET %ELSF% MODE
               GOTO EXIT2
#2           BOUND 1              THEF
               GOTO,(CT~=%IF%)&(CT~=%ELSF%) EXIT0
                  DISP (INL-META)**8+X'00AEFF00' (READ THEF AS 'AND-IF')
                  GOTO ESAC
#3           BOUND 1                IF ..,OR
ENL            SET :SC              (FI WILL RE-CALCULATE)
               DISP (INL-META)**8+X'001F0000'
INL            SET INL+1            BUMP NESTING LEVEL
IAN(INL,:TY)   SET %IF%|%OR%        SET 'IF' MODE IN 'OR'-CHAIN
               GOTO EXIT3
#4           BOUND 1                #IF ..,OR
IAN(INL,:TY)   SET %ELSF%|%OR%      SET 'ELSF' MODE IN 'OR'-CHAIN
               GOTO EXIT3
#5           BOUND 1                THEF ..,OR
               GOTO,(CT~=%IF%)&(CT~=%ELSF%) EXIT0
BT                SET 0             GENERATE 'TRUE' BRANCH
IAN(INL,:SC)      SET NXTIN         RESERVE NEW 'SUCCESS' ADDRESS
IAN(INL,:TY)      SET IAN(INL,:TY)|%OR% SET START OF 'OR'-CHAIN
                  DISP (INL-META)**8+X'00AEFF00' (READ THEF AS 'AND-IF')
                  GOTO ESAC
EXIT3       BOUND 1
BT            SET 0                 GENERATE 'TRUE' BRANCH
IAN(INL,:SC)   SET NXTIN            RESERVE NEW 'SUCCESS' ADDRESS
EXIT2        BOUND 1
ENL            SET ENL+1
EXIT1        BOUND 1
IAN(INL,ENL)   SET NXTIN          SAVE INDICES AT THIS LEVEL
ESAC        BOUND 1
         FIN
I        SET      S:S(BT,IAN(INL,:SC),IAN(INL,ENL))  SET BRANCH ADDRESS
         DO       (SCOR(CF(2),FZ,FNZ)>0)|(NUM(AF)>1)|(SCOR(AF(1),OR,)=0)
            CV,DR AF(1)
         FIN
         GEN,12,20 BC(BT,CF(2)),IAL(I)  BRANCH ON APPROPRIATE CONDITION
         DO       DSA               DOIF AT END OF 'OR'-CHAIN
IAL(IAN(INL,:SC)) SET WA(%)
DSA         SET   0
         FIN
         GOTO     PEND
EXIT0    ERROR,3  SE
PEND     PEND
*
         CLOSE    DSA
*
ELS      CNAME    1
#ELS     CNAME    0
         PROC
         BOUND    4
CT       SET      IAN(INL,:TY)&~%OR%  CURRENT TYPE (W/O 'OR' FLAG)
         DO       (CT=%IF%)|(CT=%ELSF%)
IAL(IAN(INL,ENL)) SET WA(%)+1       LAST 'IF' FAIL GOES TO AFTER BRANCH
ENL         SET   ENL+1
IAN(INL,ENL) SET  NXTIN             SAVE NEW INDICES AT THIS LEVEL
            DO    NAME(1)
               DISP (INL-META)**8+X'000DFF00'
IAN(INL,:TY)   SET %ELS%
            FIN
LF          GEN,12,20 X'680',IAL(IAN(INL,:FI))
          ELSE
            ERROR,3 SE
         FIN
         PEND
*
FI       CNAME
         PROC
CT       SET      IAN(INL,:TY)&~%OR%  CURRENT TYPE (W/O 'OR' FLAG)
         DO       (INL-META)>0
IAL(IAN(INL,ENL)) SET WA(%)         HERE FROM LAST 'IF', 'ELS', OR 'ELSF'
            DO    ENL>:FI           'ELSF' ONLY
IAL(IAN(INL,:FI)) SET WA(%)         'ELSF' ONLY
            FIN
IAN(INL)    SET
INL         SET   INL-1
            DO    (INL-META)>0
ENL            SET NUM(IAN(INL))
             ELSE
ENL            SET :SC
            FIN
            DISP  (INL-META)**8+X'00F10000'
          ELSE
INL         SET   0+META
            ERROR,3 SE
         FIN
         PEND
*
ELSF     CNAME
         PROC
CT       SET      IAN(INL,:TY)      CURRENT TYPE (WITH 'OR' FLAG)
         DO       (CT=%IF%)|(CT=%ELSF%)
            DISP  (INL-META)**8+X'00EEFF00'
            #ELS
            #IF,CF(2) AF
          ELSE
            ERROR,3 S:S((CT&%OR%)>0,SE,OE)
         FIN
         PEND
*
NXTIN    CNAME                      HELPER PROCEDURE
NXTIN    FNAME                      NEXT IAL INDICES
         PROC
IN1         SET   IN1+(IN2>=255)
IN2         SET   S:S(IN2>=255,IN2+1,2)
         PEND     IN1,IN2
*
         CLOSE    BT,CT,DR,ENL,NXTIN,OE,SE
         CLOSE    #ELS,#IF
         CLOSE    %ELS%,%ELSF%,%IF%,%NORM%,%OR%
         CLOSE    :IF,:FI,:SC,:TY
         CLOSE    I,IAL,IAN,INL,IN1,IN2
*
*
*  LOAD,COMPARE, AND ADD A VALUE.
*    THE VALUE MUST BE DEFINED BY A PRIOR 'EQU' OR 'SET'
*    THE PROC GENERATES AN IMMEDIATE OR LITERAL ADDRESS
*
LV       CNAME    X'22'             LOAD VALUE
CV       CNAME    X'21'             COMPARE VALUE
AV       CNAME    X'20'             ADD VALUE
         PROC
         DO  ((AF(1)&X'FFF80000')=0)|((AF(1)&X'FFF80000')=X'FFF80000')
LF          GEN,8,4,20 NAME,CF(2),AF(1)&X'FFFFF'
          ELSE
LF          GEN,8,4,3,17 NAME+X'10',CF(2),0,=AF(1)
         FIN
         PEND
*
*   PROCEDURE FOR LOADING NEXT ENCODED TEXT ITEM
*
*        NXTENC[,REG]   [INDEX[,NOINC]]
*
NXTENC   CNAME
         PROC
I        SET      S:S(NUM(AF(1))>0,XW,AF(1)) DEFAULT INDEX TO XW
LF       LH,S:S(NUM(CF)>1,XT,CF(2)) *XWBASE,I DEFAULT REG TO XT
         DO       SCOR(AF(2),NOINC)=0   DON'T GENERATE THE ADD IMMEDIATE
            AI,I  1                       IF 'NOINC' SPECIFIED IN AF(2)
         FIN
         PEND
*
*
*   PROCEDURE FOR GENERATING SINGLE LENGTH LOCICAL SHIFTS
*
*        SHIFT,R  FROM,TO
*
SHIFT    CNAME
         PROC
         DO       AF(1)~=AF(2)      DON'T GENERATE A SHIFT OF ZERO
            DO    AF(1)-AF(2)>16    IF SHIFT IS MORE THAN 16 LEFT,
LF             SCS,CF(2) AF(1)-AF(2)-32 GENERATE A RIGHT CIRCULAR INSTEAD
             ELSE
               DO AF(2)-AF(1)>16    IF SHIFT IS MORE THAN 16 RIGHT.
LF                SCS,CF(2) 32-AF(2)+AF(1) GENERATE A LEFT CIRCULAR INSTEAD
                ELSE
LF                SLS,CF(2) AF(1)-AF(2) GENERATE A LOGICAL SHIFT OF 16 OR
               FIN                    LESS
            FIN
         FIN
         PEND
*
*   PROCEDURE FOR GENERATING INTEGER DATA IN SPECIAL INTEGER FORMAT
*
SPECINT  CNAME
         PROC
         BOUND    4
LF       GEN,1,1,1,1,2,2,2,22    1,1,0,0,3,0,0,AF(1)
         PEND
*
*   COM FOR GENERATING EXPRESSION CONTROL TABLE ITEMS OF SPECIAL
*     INTEGER TYPE
*
SPIECT   COM,7,1,7,17  X'24',CF(2),0,AF(1)
*
*        BYTE AND HALF PROC
*          GENERATES A BYTE OR HALFWORD TO BE USED IN A BRANCH TABLE
*
*          THE FIRST ENTRY IN THE TABLE MUST HAVE THE TABLE BASE
*          ADDRESS AS THE CF(2) ENTRY.  ALL OTHER REFERENCES MUST NOT
*          USE CF(2).  A  BOUND 4  SHOULD FOLLOW THE LAST REFERENCE.
*
*        REFERENCE ONE:  BYTE,BASE   BRANCH%LOCATION%1
*          REFERENCE N:  BYTE        BRANCH%LOCATION%N
*
         OPEN     TABLE%BASE
*
BYTE     CNAME    8
HALF     CNAME    16
         PROC
         DO1      NUM(CF)=2
TABLE%BASE  SET   S:UFV(CF(2))
LF       GEN,NAME AF(1)-S:S(S:UFV(AF(1))=0,TABLE%BASE)
         PEND
*
         CLOSE    TABLE%BASE
*
         CLOSE    BC,I,META,P#
*
         END                        SYSTEM AP%IL