*DECK     FUN 
          IDENT  FUN
  
*         ***** FRAG 5 NOTE *****  FUN USES THE OLD P2. FORMATS FROM GEN
*         AND MUST BE CONVERTED TO TP./PB. WHEN GEN/QCGC/QSKEL/ETC CUTS 
*         OVER TO THE NEW WORLD.
          SPACE  4,7
  
 FUN      SECT   ((QCG)    EXTERNAL PROCEDURE INVOCATION.)
 FUN      SPACE  4
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN FEC
          EXT    NCM,ROUTNAM,SCT
  
*         IN FSNAP
          EXT    DMT= 
  
*         IN FTN
          EXT    CO.ARGF,CO.SNAP
  
*         IN GEN
          EXT    CURSK,EIS.PNX,ENT.SUB,NULLOP,SUB.RET 
  
*         IN PUC
          EXT    BN=APL,ECB,ECS,GCL,N.ST,N.TABLE,S=CL,S=CON,S=FAR,S=FAS 
          EXT    S=FMC,S=FVS,S=LMC,S=MMC,S=ST,T=APL,T=CAC,T=CLW,T=IOA 
          EXT    T=PAR,T=SAP,T.API,T.APL,T.CAC,T.CLW,T.CON,T.FPI,T.IOA
          EXT    T.IOI,T.OUS,T.PAR,T.SAP,T.SYM,WO.CS,WO.DOOT
  
*         IN QCGC 
          EXT    POS,REG=G,TRACE,UUC,WIN
  
*         IN QSKEL
          EXT    V=SUBST,W=APSTR,W=CAPST,W=CIA0S,W=CIS0S,W=IAPD1,W=IAPD2
          EXT    W=IAPS1,W=IAPS2,W=IPLG0,W=IPLUG,W=LUA,W=SUA
  
*         IN REG
          EXT    CDS,CIA,CRJ,CWI,DIT,GST,RUT,STS
  
*         IN UTILITY
          EXT    MVE= 
          SPACE  4,8
          LIST   -X          FOLLOWING COMDECKS ARE LISTED IN QCGC
*CALL     COMAQCG            QCG MACRO DEFINITIONS. 
*CALL     COMSQCG            QCG STRUCTURE DEFINITIONS. 
*CALL     COMSQRF            QCG REGISTER ASSOCIATES. 
                             DEFINS IS LISTED IN QSKEL
*CALL     DEFINS             DEFINE MACHINE OPCODES 
          LIST   *
          TITLE  (O=)  PROCESSORS CALLED BY SKELETONS.
*         TEMPORARY EQUATES TO GET LOAD CLEANED UP. 
  
 IO       EQU    1
 USER     EQU    0
 O=FAP    SPACE  4,10 
**        O=FAP - FIRST FUNCTION APLIST PROCESSOR 
*         THIS ONLY EXITS TO FLAG THE FIRST APL OF
*         CHARACTER FUNCTION SO THAT A TEMP *VALUE.*
*         CAN BE ALLOCATED. 
* 
*         ENTRY - (OR.1OP) = P2 WORD FOR ROUTINE
  
  
 O=FAP    BSSENT 0
          MX6    0
          SA6    APLEN       FOR O=IAP
          =A1    B4+OR.OPR   GET OPERATOR 
          MX0    -OP.MODEL   SET MODE MASK
          LX1    -OP.MODEP   POSITION MODE
          BX6    -X0*X1      EXTRACT MODE 
          SB2    X6-M.CHAR
          NZ     B2,NULLOP   IF MODE NOT CHARACTER
          SB5    T.API
          SB6    T.SAP
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
          =A1    B4+OR.1OP   GET FUNCTION OPERAND 
          BX6    X1 
          ADDWD  T.SAP
          SA1    APLEN
          =X7    X1+1 
          SA7    A1          INCREMENT APLIST LENGTH
          SB4    B4+Z=TURP
          EQ     EIS.PNX
 O=FUN    SPACE  4,8
**        O=FUN - RETURN JUMP TO CALL-BY-NAME FUNCTION. 
* 
*         ENTRY  (1OP) = ROUTINE TAG. 
*                (B4) _ TURPLE BEING PROCESSED. 
*                ARGUMENTS HAVE BEEN SET UP BY PRECEEDING *O=ARG* 
*                            TURPLES -- 
*                (APLEN) SET-UP BY *O=ARG*. 
*                (T.APL) SET-UP BY *O=ARG*. 
* 
*         EXIT   TO *EIS.PNX*.
*                (B4) ADVANCED
*         CALLS  PEJ, TRF.
* 
*         NOTE   ALSO CONTAINS PROCESSING USED BY *O=BEF*.
  
  
 O=LIBF   BSSENT 0           ENTRY FOR LIBRARY FUNCTIONS (CALL-BY-REF)
          SX6    1           FLAG NO ZERO-TERM
          EQ     O=FUN10
  
 O=FUN    BSSENT 0           ENTRY... 
          SA2    CO.ARGF
          BX6    X2 
  
 O=FUN10  SA6    FUNA 
          SA2    FAF
          SB5    T.API
          SB6    T.SAP
          NZ     X2,O=FUN15  IF APLIST ENCOUNTERED (NOT F() ) 
          NZ     X6,O=FUN15  IF NO TERMINATOR NEEDED
          RJ     IAS         SET UP APLIST
  
 O=FUN15  =A1    B4+OR.1OP
          =X7    0
          BX6    X1 
          SA7    FAF         SET FIRST APLIST WORD FLAG 
          SA6    ROUTNAM
          SA1    B4+OR.OPR
          MX7    -OP.MODEL
          LX1    -OP.MODEP
          BX7    -X7*X1 
          SX7    X7-M.CHAR
          NZ     X7,O=FUN1   IF NOT CHAR
          RJ     DCF         DEFINE CHARACTER FUNCTION
  
 O=FUN1   SA1    FUNA        ZERO-TERMINATOR FLAG 
          RJ     PEJ         COMPILE EXTERNAL JUMP. 
          MX6    0
          SHRINK T=SAP,X6 
          SA1    B4+OR.OPR   GET OPERATOR 
          MX7    -OP.MODEL
          LX1    -OP.MODEP
          BX7    -X7*X1      EXTRACT MODE 
          SX7    X7-M.CHAR
          NZ     X7,O=FUN2   IF NOT CHARACTER 
          EQ     NULLOP 
  
**        JOINED HERE BY CALL-BY-VALUE RETURN JUMP. 
  
 O=FUN2   BX5    0
          MX7    0
          SB2    R.X6        0TR FOR UPPER HALF 
          =B3    0           RESULTS OF UPPER HALF
          SA7    UUC
          CALL   DIT         DEFINE INTERMEDIATE RESULTS
          =A1    B4+OR.OPR
          MX0    -OP.2MODL
          LX1    -OP.2MODP
          BX2    -X0*X1 
          SB2    X2-M.DBL 
          EQ     B2,B0,O=FUN3  IF MODE DOUBLE 
          NE     B2,B1,O=FUN5  IF MODE NOT COMPLEX
 O=FUN3   BX5    0
          SB2    R.X7        0TR FOR LOWER HALF 
          =B3    1           RESULTS OF LOWER HALF
          CALL   DIT         DEFINE INTERMEDIATE RESULTS
 O=FUN5   EQ     NULLOP      EXIT.. 
  
 FUNA     BSS    1
 O=GAP    SPACE  4,10 
**        O=GAP  GENERAL USER  APLIST PROCESSOR 
*                SETS APLIST TYPE INSERTS ARGUMENT IN APL 
*                AND STEPS THE ARGUMENT COUNTER 
* 
*         ENTRY  (1OP) = ARGUMENT 
*                (2OP) = NA 
  
  
 O=GAP    BSSENT 0
          SB5    T.API
          SB6    T.SAP
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
          =A1    B4+OR.1OP   GET APLIST ARGUMENT
          RJ     IAW         ISSUE APLIST WORD
          SB4    B4+Z=TURP   GET NEXT OPERATOR
          EQ     EIS.PNX
 O=HREL   SPACE  4,10 
**        HREL - CHARACTER RELATIONAL PROCESSORS. 
*         CALLED AS HREL FOR OPERATOR-TYPE RELATIONAL EXPRESSIONS,
*         OR AS HLEX FOR LEXICAL FUNCTION-TYPE EXPRESSIONS. 
  
 O=HLEX   BSSENT 0
          SA1    S=LMC
          BX6    X1 
          SA6    PCRB 
          EQ     PCR10
  
 O=HREL   BSSENT
          SA2    WO.CS
          SA1    S=FMC+X2    FMC./UMC.
          BX6    X1 
          SA6    PCRB 
  
 PCR10    RJ     SAS         STACK APLIST 
          SA1    CURSK       CURRENT SKELETON POINTER 
          BX7    X1 
          SA7    FUN.CUR     SAVE 
          =X6    0
          ADDWD  T.SAP       RESERVE FOR HEADER 
          SA1    APLEN
          =X6    X1+1 
          SA6    A1          BUMP APLIST POINTER
          =A5    B4+OR.1OP
          RJ     BGA         ISSUE LEFT SIDE
          SA1    T=SAP
          BX6    X1 
          SA6    PCRA        SAVE APLIST SIZE 
          =A5    B4+OR.2OP
          RJ     BGA         ISSUE RIGHT SIDE 
          SA1    PCRA 
          SA2    T=SAP
          SX3    X1-1 
          IX4    X2-X1
          LX3    IA.LEFTP 
          LX4    IA.RITEP 
          MX1    1
          SA2    T.SAP
          LX1    1+IA.CRHP    REL HEADER TYPE APLIST
          BX6    X3+X4
          BX7    X6+X1
          SA7    X2          STORE INTO RESERVED SPOT 
          SA1    PCRB        ROUTINE
          BX6    X1 
          LX6    P2.TAGP
          SA6    ROUTNAM
          RJ     PEJ         ISSUE CALL 
          RJ     PAS         RESTORE APLIST STRUCTURES
          =X7    0
          SA7    FAF         ZERO OUT FIRST APL FLAG
          SA1    FUN.CUR
          BX7    X1 
          SA7    CURSK       RESTORE SKEL POINTER 
          EQ     NULLOP 
  
 PCRA     BSS    1
 PCRB     BSS    1
 HSTO     SPACE  4,10 
**        HSTO - CHARACTER ASSIGNMENT.
  
 O=HSTO   BSSENT 0
          SA1    CURSK
          BX7    X1 
          SA7    FUN.CUR     SAVE SKELETON POINTER
          RJ     SAS         STACK APLIST STRUCTURES
          =A5    B4+OR.2OP
          RJ     PCI         ENTER TARGET INTO APLIST 
          SA5    B4+OR.1OP
          RJ     BGA         PROCESS RIGHT-HAND EXPRESSION
          =X6    0
          ADDWD  T.SAP       APLIST TERMINATOR
          SA2    APLEN
          =X6    X2+1 
          SA6    A2          INCREMENT APLIST LENGTH COUNTER
          SA1    S=MMC
          BX7    X1 
          LX7    P2.TAGP
          SA7    ROUTNAM     ROUTINE IS CHARACTER MOVE ROUTINE
          RJ     PEJ         ISSUE - RJ   MMC - 
          SA4    FUN.CUR
          BX7    X4 
          SA7    CURSK
          RJ     PAS         RESTORE APLIST STRUCTURES
          MX7    0
          SA7    FAF         SET FIRST APLIST FLAG
          EQ     NULLOP 
 O=IAP    SPACE  4,10 
**        O=IAP - ISSUE ACTUAL PARAMETER OF EXTERNAL INTRINSIC. 
* 
*         ENTRY  (1OP) = ACTUAL PARAMETER 
*                (OP.MODE) = MODE OF ARG. 
  
  
 O=IAP    BSSENT             ENTRY... 
          =A1    B4+OR.OPR
          MX0    -OP.MODEL
          SA2    APLEN
          LX1    -OP.MODEP
          SA3    X2+IAPA
          BX6    -X0*X1      ISOLATE MODE OF ARG
          SX7    X2+B1       COUNT ARGUMENTS
          SB7    X6-M.DBL 
          SA7    A2 
          EQ     B7,B0,IAP2  IF TYPE DOUBLE 
          EQ     B7,B1,IAP2  IF TYPE COMPLEX
          LX3    30 
 IAP2     =X6    X3          SET SUBSKEL
          EQ     SUB.RET     EXIT.. 
  
 IAPA     VFD    30/W=IAPS1,30/W=IAPD1
          VFD    30/W=IAPS2,30/W=IAPD2
 O=INF    SPACE  4,10 
**        O=INF - CALL EXTERNAL INTRINSIC FUNCTION. 
* 
*         ENTRY  (1OP) = ROUTINE TAG
*                (2OP) = NUMBER OF ARGUMENTS
  
  
 O=INF    BSSENT             ENTRY... 
          =A1    B4+OR.1OP
          BX6    X1 
          CRJ    NONE 
          BX7    0
          SA7    APLEN
          EQ     O=FUN2      CONTINUE.. 
 O=IOC    SPACE  4,10 
**        PROCESS IO CONTROL APLIST ITEM
*         PREPARES AND PASSES APLIST ITEMS TO SAP 
* 
*         ENTRY  OR.1OP = CONTROL CODE
*                OR.2OP = CONTROL ITEM
  
  
 O=IOC    BSSENT 0
          SB5    T.IOI
          SB6    T.IOA
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
          CLAS=  X1,AT,(IO,IOC) 
          BX6    X1 
          SA6    ATF         ATF BITS SET - IO,IOC
          SA1    B4+OR.2OP   GET CONTROL ITEM 
          RJ     IAW         ISSUE APLIST WORD FOR CONTROL ITEM 
          SA1    T=IOA       GET LEN OF IO APLIST TABLE 
          SA2    T.IOA       GET FWA OF IO APLIST 
          =A5    B4+OR.1OP   GET CONTROL CODE OPERAND 
          LX5    -P2.BIASP   POSITION CONTROL CODE
          MX0    -IA.MODEL
          IX2    X1+X2       ADD IOA FWA TO LENGTH
          SA3    X2-1        GET IOA ENTRY FOR CONTROL ITEM 
          LX3    -IA.MODEP
          BX2    X0*X3       CLEAR MODE FROM CONTROL ITEM IOA ENTRY 
          BX5    -X0*X5      EXTRACT CONTROL CODE 
          BX7    X2+X5       MODE[CONTROL ITEM] = CONTROL CODE
          LX7    IA.MODEP    RESET FOR RE-ENTRY TO IOA
          =X6    0
          SA7    A3          RESET IOA ENTRY
          ADDWD  T.IOA       ADD ZERO WORD 2ND WORD PLACE HOLDER
          SA1    APLEN
          =X6    X1+1 
          SA6    A1          INCREMENT APLEN
          SB4    B4+Z=TURP
          EQ     EIS.PNX
 O=IOD    SPACE  4,10 
**        O=IOD  IO DATA PROCESSOR
*         SET UP SAP CALLS FOR DATA LENGTH AND ITEM 
* 
*         ENTRY  (1OP) = DATA ITEM(ADDRESS) 
*                (2OP) = DATA LENGTH
  
 O=IOD    BSSENT 0
          SB5    T.IOI
          SB6    T.IOA
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
          CLAS=  X3,AT,(IO) 
  
**        DETERMINE IF NUL(NOT UNITY LENGTH) BIT IS SET IN ATF
  
          MX5    1
          =A1    B4+OR.1OP   GET DATA ITEM
          LX5    1+AT.NULP
          =A2    A1+OR.2OP-OR.1OP 
          HX2    P2.SHRT
          PL     X2,IOD10    IF LENGTH OPERAND NOT SHORT CON
          LX2    1+P2.SHRTP-P2.BIASP
          SX2    X2-1 
          NZ     X2,IOD10    IF BIAS[2OP] NE 1
          MX5    0           NUL[ATF] = 0 
  
 IOD10    BX6    X3+X5
          SA6    ATF         ATF BITS SET - IO, CONDITIONAL NUL 
          BX6    X5 
          SA6    IODA        SAVE NUL BIT FOR LENGTH WORD 
          RJ     IAW         ISSUE APLIST WORD FOR DATA ADDRESS 
          CLAS=  X2,AT,(IO,LEN) 
          SA5    IODA 
          =A1    B4+OR.2OP
          BX6    X2+X5       INSERT NON-UNITY LENGTH PROPERTY 
          SA6    ATF         ATF BITS SET - IO, LEN, CONDITIONAL NUL
          RJ     IAW         ISSUE LENGTH OF ITEM 
          SB4    B4+Z=TURP   RESET OPERATOR POINTER 
          EQ     EIS.PNX
  
 IODA     BSSZ   1
 O=IOF    SPACE  4,10 
**        O=IOF - ISSUE RJ TO I/O FUNCTION ROUTINE. 
* 
*         ENTRY  (B4) = ADDRESS OF TURPLE.
*                (1OP) = SUBROUTINE TAG 
*                (2OP) = RESTART INDICATOR
* 
*         EXIT   (T.PB) UPDATED WITH... 
*                SA1     AP-LIST POINTER
*                RJ      I/O ROUTINE
* 
*         CALLS  CIA, CRJ, NAP
  
  
 O=IOF    BSSENT 0           ENTRY... 
          DRITE  DEACTIVATE 
          CALL   CIA         CLEAR INTERMEDIATES / ASSOCIATES 
          SA5    B4+OR.2OP   GET THE RESTART INDICATOR
          SA2    FAF         GET FIRST APLIST ITEM FLAG 
          SB5    T.IOI
          SB6    T.IOA
          NZ     X2,IOF1     IF NON-EMPTY APLIST
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
  
 IOF1     SA1    APLEN       GET CURRENT APLIST LENGTH
          BX6    X5 
          =X7    0
          SBIT   X6,P2.BIASP
          SB3    X1+2        STEP APLEN FOR ZERO WORD TERMINATORS 
          AX6    59          SIGN EXTEND RESTART INDICATER
          =X5    IO          SET IO INDICATOR FOR NAP 
          SA7    FAF         SET FIRST APLIST ITEM FLAG 
          ADDWD  T.IOA       ADD RESTART WORD TO IO APLIST
          MX6    -1 
          ADDWD  T.IOA       ADD ZERO WORD TO PAIR WITH RESTSRT 
          RJ     NAP         ENTER THE AP-LIST IN T.APL 
          HX6    IA.TAG 
          AX6    -IA.TAGL    ISOLATE AP-LIST TAG
          LX6    PB.TAGP     POSITION FOR PRE-BINARY
          SX1    SA=BK+100B  FORCE AP-LIST LOAD INTO *A1* 
          LX1    PB.INSTP 
          BX7    X1+X6       INSTRUCTION + AP-LIST TAG
          WCODE  X7          COMPILE LOAD OF AP-LIST
          =A1    B4+OR.1OP   FETCH I/O ROUTINE TAG
          LX6    X1 
          SA3    TRACE
          CRJ    MUST        COMPILE THE RJ TO I/O ROUTINE
          EQ     NULLOP 
  
 O=IOU    SPACE  4,10 
**        O=IOU - IO UNIT TURPLE.  IT IS REALLY A IOC TURPLE
*         WHO, UNLIKE OTHER IOC TURPLES HAS A 2OP THAT IS A LENGTH
*         SPECIFIER, SO WE TREAT IT LIKE AN IOD-IOC HYBRED
* 
*         ENTRY - (OR.1OP) = UNIT ITEM
*                 (OR.2OP) = LENGTH 
  
  
 O=IOU    BSSENT 0
          SB5    T.IOI
          SB6    T.IOA
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
  
**        FIRST SET UP ATF BITS FOR UNIT
*         WE SET: IO, IOC .... ALWAYS 
*                 NUL ...  WHEN LENGTH NOT SHORT CON = 1
  
          CLAS=  X1,AT,(IO,IOC) 
          MX5    1
          LX5    1+AT.NULP
          SA2    B4+OR.2OP   GET LENGTH 
          HX2    P2.SHRT
          PL     X2,IOU10    IF NOT SHORT CON LENGTH
          LX2    1+P2.SHRTP-P2.BIASP
          SX2    X2-1 
          NZ     X2,IOU10    IF LENGTH NE 1 
          MX5    0
  
 IOU10    BX6    X1+X5       MERGE NUL WITH IO AND IOC BITS 
          SA6    ATF
          BX6    X5 
          SA6    IODA        SAVE NUL BIT 
          =A1    B4+OR.1OP   GET UNIT 
          RJ     IAW         ISSUE APLIS WORD 
          MX0    -IA.MODEL
          SA1    T.IOA       GET FWA
          SA2    T=IOA       GET LEN
          IX3    X1+X2       (X3) = LWA +1
          SA5    X3-1        GET APL ITEM FOR UNIT TO REPLACE MODE
          =X1    IC.UNT      (X1) = IO UNIT CONTROL CODE
          LX5    -IA.MODEP
          BX6    X0*X5       EXTRACT MODE FROM UNIT ENTRY 
          BX6    X6+X1       MODE[UNIT] = IC.UNIT 
          LX6    IA.MODEP    RESET IOA ENTRY
          SA6    A5          RE-ENTER UNIT
  
**        SET UP ATF FOR LENGTN 
*         SAME AS UNIT ONLY LEN BIT IS SET
  
          CLAS=  X1,AT,(IOC,IO,LEN) 
          SA5    IODA 
          BX6    X1+X5       INSERT NUL PROPERTY
          SA6    ATF
          SA1    B4+OR.2OP   GET LENGTH OPERAND 
          RJ     IAW         PROCESS LENGTH WORD
          SB4    B4+Z=TURP
          EQ     EIS.PNX
 O=SUB    SPACE  4,10 
**        O=SUB - ISSUE SUBROUTINE CALL.
* 
*         ENTRY  (1OP) = ROUTINE TAG. 
*                (B4) -> TURPLE BEING PROCESSED.
*                ARGUMENTS HAVE BEEN SET UP BY PRECEEDING *O=ARG* 
*                            TURPLES -- 
*                (APLEN) SET-UP BY *O=ARG*. 
*                (T.APL) SET-UP BY *O=ARG*. 
*         EXIT   TO *EIS.PNX*.
*                (B4) ADVANCED. 
*         CALLS  PEJ
  
  
 O=LIB    BSSENT             ENTRY... 
          SX6    1           NO TERMINTOR 
          EQ     SUB10
  
 O=SUB    BSSENT             ENTRY... 
          SA2    CO.ARGF
          BX6    X2          TERMINATOR ACCORD. TO ARG=FIXED
  
 SUB10    SA6    FUNA 
          SA2    FAF         GET FIRST APLIST ITEM INDICATOR
          SB5    T.API
          SB6    T.SAP
          SX5    A2+         SAVE ADDRESS OF FAF ACROSS IAS 
          NZ     X2,SUB1     IF NOT EMPTY APLIST
          NZ     X6,SUB1     IF NO TERMINATOR REQUIRED
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
  
 SUB1     =X7    0
          SA7    X5          SET FAF TO INDICATE FIRST ITEM 
          =A2    B4+OR.1OP
          BX6    X2 
          SA6    ROUTNAM
          SA1    FUNA        ZERO TERMINATOR FLAG 
          RJ     PEJ         PROCESS EXTERNAL JUMP
          MX6    0
          SHRINK T=SAP,X6 
          EQ     NULLOP      EXIT.. 
          TITLE  SUBROUTINES. 
 AAP      SPACE  4,10 
**        AAP - ADD WORD TO APLIST
* 
*         ENTRY  (X1) = OPERAND OR STATUS WORD TO PASS TO APL 
*                (B7) = PLUG FLAG 
* 
*         EXIT   (X5) = PRESERVED 
*                (X6) = IA. WORD PASSED/TO PASS TO APL
* 
*         USES   ALL BUT (B5) 
  
  
 AAP      SUBR               ENTRY/EXIT.
          SA5    ATF
          =X6    0           CLEAR X6 
  
**        EXTRACT IA. INFORMATION FROM ATF
  
 .ATF     ECHO   ,FLD=(IOC,CHAR,MODE) 
          CLAS=  X3,AT,FLD
          BX0    X3*X5                   EXTRACT ATF FIELD
          LX0    -AT.FLD_P+IA.FLD_P      POSITION FIELD IN IA. POSITION 
          BX6    X0+X6                   MERGE IN FIELD TO IA WORD
 .ATF     ENDD
  
**        EXTRACT P2 FIELDS FROM STATUS WORD
  
          MX3    P2.ORDL+P2.BIASL 
          LX3    P2.ORDL+P2.BIASL+P2.ORBIP
          BX0    X3*X1       TAG + BIAS 
          LX0    IA.ORBIP-P2.ORBIP
          BX6    X0+X6
          MX3    P2.PFXL
          LX3    P2.PFXL+P2.PFXP
          BX0    X3*X1
          LX0    IA.TAGP+P=PFX-P2.PFXP  REPOSITION PFX
          BX6    X0+X6
          SX0    B7 
          LX0    IA.STP      POSITION STORE BIT 
          SA1    WO.DOOT
          LX1    IA.VARP
          BX0    X0+X1       VAR[IA] = DOTRIP 
          BX6    X6+X0       MERGE IN STORE BIT 
          SA1    APTAB
          SBIT   X5,AT.SPRP 
          MI     X5,EXIT.    IF SPACE PREVIOUSLY RESERVED 
          ADDWD  X1          ADD IA WORD TO APTAB 
          SA1    APLEN
          SX7    X1+1 
          SA7    APLEN
          EQ     EXIT.
 BGA      SPACE  4,10 
**        BGA - BUILD GENERATED APLIST
* 
*         BGA CONTROLS THE CONSTRUCTION OF APLSITS PASSED TO
*         LIBRARY CHARACTER ROUTINES.  IT CALLS GNO, THE CONCATENATION
*         TREE SPANNER  AND PASSES THE LEAVES ON TO PCI,THE APLIST ITEM 
*         PROCESSOR 
* 
*         ENTRY - (X5) = OPERAND TO PASS TO APLIST
* 
*         USES ALL
* 
*         CALLS GNO,PCI(WHICH OFTEN CALLS ALL OF EIS) 
  
  
 BGA      SUBR               ENTRY/EXIT.
          SX0    RLOCK       SET LOCK BIT TO MARK 1ST OPD 
          BX7    X0+X5       LOCK FIRST CURRENT-LINK
  
**        TRICK - WE SET THE I. L. ORDINAL FIELD OF THE 
*         1ST LAST-LINK TO:  THE I. L. LENGTH - Z=TURP. THIS
*         POINTS TO A DUMMY TURPLE WHO'S 2ND OPERAND IS THE 
*         ZERO WORD AT THE END OF THE I. L.  THE COMBINA- 
*         TION OF MARKING THE 1ST CURRENT-LINK AS A 1ST 
*         OPERAND AND THEN ARANGING ITS CORESPONDING LAST-
*         LINK TO POINT TO A DUMMY OPERAND WITH A ZERO 2OP, 
*         TRICKS GNO INTO RETURNING A ZERO CURRENT-LINK WHEN
*         THE TREE WALK SHOULD TERMINATE. 
  
          =X6    0
          SA7    LNK.CUR
          SA2    T=PAR       GET I. L. LENGTH 
          SA6    CLEN        INITIALIZE CHAR LEN COUNTER FOR THIS LIST
          SX6    X2-Z=TURP   DUMMY ORDINAL TO INITIALIZE LNK.LST
          LX6    P2.BIASP    POSITION DUMMY ORDINAL 
          BX5    X7 
          SA6    LNK.LST
          RJ     GAS         GET APLIST STATUS OF OPERAND 
          GE     B1,B2,BGA1  IF NOT IN  A TEMP
          RJ     PCI         PROCESS CHAR ITEM
          EQ     EXIT.
  
 BGA1     ZR     X5,EXIT.    IF WALK DONE 
          RJ     GNO         GET NEXT OPERAND 
          SA5    LEAF 
          RJ     PCI         PROCESS CHARACTER ITEM 
          SA5    LNK.CUR
          EQ     BGA1 
 CCA      SPACE  4,8
**        CCA - COMPLETE CHARACTER ARRAY REFERENCE. 
* 
*         ENTRY  (X1) = INDEX OPERAND.
  
 CCA      SUBR
          MX7    0
          SA7    ATF         INDEX IS NOT TYPE CHAR 
          RJ     SAP         PASS ADDRESS FUNCTIION TO APLIST 
          SA2    S=FAR       GET ARRAY PROCESSOR SYMBOL ORDINAL 
          LX2    P2.TAGP     POSITION ROUTINE NAME
          BX6    X2 
          =X1    1           SUPPRESS ZERO TERMINATOR 
          SA6    ROUTNAM
          RJ     PEJ         PROCESS EXTERNAL JUMP
          RJ     PAS         POP APLIST STRUCTURES
          RJ     SCI         STORE CHARACTER ITEM 
          =A5    B4+OR.1OP   GET ARRAY OPERAND
          RJ     GAS
          =B6    1           SET STORE TO APLIST FLAG 
          RJ     ECA         ENTER DUMMY ITEM TO CALLER'S APLIST
          EQ     EXIT.
 CCT      SPACE  4,10 
**        CCT - CREATE CHARACTER TEMP 
* 
*         ENTRY  (X5) = I. L. OPERAND 
*                (X1) = CLEN
*                (B6) = SPR(SPACE PREVIOULSY RESERVED) BIT
* 
*         EXIT   (X6) = APL ENTRY FOR OPERAND 
* 
*         USES ALL
* 
*         CALLS ECA,ECA,SSC 
* 
*         NOTE - CCT INHIBITS AAP FORM ACTUALLY MAKING AN ENTRY 
*                WHENEVET (B6) = 1 ON ENTRY. IN THAT CASE THE 
*                IS THE CALLERS.
* 
  
  
 CCT      SUBR               ENTRY/EXIT 
          BX6    X1 
          CW     X2,X6
          SA3    N.ST        GET INDEX OF THIS TEMP 
          SX0    B6          GET SPR BIT
          IX6    X2+X3       INCREMENT TEMP COUNT BY NO OF WDS. NEEDED
          SA2    ATF
          LX0    AT.SPRP
          SA6    A3          RESET N.ST 
          BX7    X0+X2       ADD IN SPR PROPERTY
          LX1    WC.CLENP    POSITION CLEN OF TEMP
          SA7    A2          RESET ATF
          LX3    WC.RAP      POSITION TEMP ARRAY BIAS 
          BX6    X3+X1       MERGE CLEN AN ARRAY INDEX
          RJ     ECW         ENTER CAC WORD 
  
*         MARK EXPRESSION IN TEMPORARY, UNLESS IT INCLUDES A
*         VARIABLE SUBSTRING.  IN THAT CASE, WE NEED TO REEVALUATE
*         EXPRESSION BECAUSE APLIST WORD WITH CORRECT LENGTH IS 
*         RETURNED FROM MMC. AND MUST BE STORED TO OUTER APLIST.
  
          SA6    CCTC 
          SA3    S=ST        GET SYMBOL ORDINAL OF TEMPORARY ARRAY
          RJ     SSC         SET STATUS OF CHARACTER OPERAND
          SA2    CCTB 
          NZ     X2,CCT20    IF VARIABLE LENGTH EXPRESSION
          MX0    1
          LX0    1+ST.CTMP
          BX6    X0+X1       CTM[STATUS] = 1
  
 CCT10    SA6    A1 
          SA6    CCTA        SAVE FOR MAIN APLIST 
          SB6    0
          RJ     ECA         ENTER CHARACTER ITEM 
          EQ     EXIT.
  
 CCT20    SA2    N.ST 
          SA3    CCTC 
          SA5    T.OUS
          SB6    X5 
          SX6    A1-B6
          SA6    A3          SAVE STATUS WORD OFFSET
          BX6    X1 
          MX0    WC.RAL 
          =X7    X2+1        RESERVE TEMP FOR ADJUSTED-LENGTH ITEM
          LX0    WC.RAL+WC.RAP
          SA6    CCTD        SAVE ORIGINAL ITEM 
          SA7    A2 
          LX2    WC.RAP 
          BX6    -X0*X3      CLEAR OFFSET 
          BX6    X2+X6       INSTALL NEW TEMP OFFSET
          RJ     ECW         ENTER NEW CAC WORD 
          SA5    CCTD        RESTORE ORIGINAL ITEM
          SA3    S=ST 
          SX0    B7          CAC OFFSET 
          LX3    P2.TAGP
          LX0    P2.BIASP 
          BX2    X3+X0
          CLAS=  X3,ST,(CTM,CAC,UKL)
          BX6    X2+X3       STATUS IS ADJUSTED-LENGTH ITEM 
          SA2    T.OUS
          SA3    CCTC 
          IX0    X2+X3
          SA1    X0          RESTORE STATUS WORD ADDRESS
          BX1    X5          RESTORE ORIGINAL STATUS WORD FOR ECW 
          EQ     CCT10
  
 CCTA     BSS    1
 CCTB     BSSZ   1
 CCTC     BSS    1
 CCTD     BSS    1
 DAC      SPACE  4,10 
**        DAC    DETERMINE APLIST COMPLEXITY
* 
*         THIS ROUTINE IS CALLED WHENEVER A CHARACTOR TYPE
*         OPERAND IS DETECTED DURING APLIST (IO OR USER)
*         ITS PURPOSE IS TO DETERMINE WHETHER STACKING IS 
*         NECESSARY AND IF SO TO CALL THE CORRECT SUPPORT 
*         ROUTINES. 
* 
*         ENTRY  (X5) = OPERAND 
* 
*         EXIT   ENTRY MADE IN APLIST FOR OPERAND 
* 
*         USES ALL
*         CALLS  PCI,BGA,GCT,CGA,GAS,PAS,SAS
  
  
 DAC      SUBR               ENTRY/EXIT.
          BX3    X5 
          SBIT   X3,P2.CNCTP POSITION CONCAT BIT
          RJ     GAS         GET STATUS OF APLIST OPERAND 
          BX7    X5 
          SA7    DACA        SAVE OPERAND 
          PL     X3,DAC1     IF ITEM NOT A CONCATENATION TREE 
          LT     B1,B2,DAC1  IF IN A TEMP 
  
**        WE MUST BUILD AN APLIST FROM THE CONCATENATION TREE 
*                 ALLOCATE TEMP STORAGE 
*                 CREATE AN APLIST ENTRY FOR THE TEMP 
  
          RJ     SAS         STACK APLIST STRUCTURES
          =X6    0
          ADDWD  T.SAP       RESERVE SPACE FOR TEMP CELL
          SA1    APLEN
          =X6    X1+1 
          SA6    A1          INCREMENT APLEN
          MX7    0
          SA7    FVSUKL 
          RJ     BGA         BUILD GENERATED APLIST (INSERT CONCAT APL) 
          SA1    CLEN        SET CHARACTER LENGTH 
          =B6    1           SET SPACE PREVIOUSLY RESERVED FLAG FOR TEMP
          SA5    DACA        GET ORIGINAL OPERAND 
          SA3    FVSUKL 
          BX7    X3 
          SA7    CCTB 
          RJ     CCT         CREATE CHAR TEMP 
          MX7    0
          SA7    CCTB        RESTORE ST.CTMP SETTING
          SA1    APTAB
          SA2    X1          (X2) = FWA OF APLIST TAB 
          AX1    18          POSITION INDEX TO   FIRST WORD OF THIS LIST
          IX2    X1+X2
          SA6    X2          SET TEMP APL IN PREVIOUSLY RESERVED SPACE
          SA1    S=MMC       SYMBOL ORDINAL OF MOVE ROUTINE 
          SX7    X1 
          LX7    P2.TAGP
          SA7    ROUTNAM     SET ROUTINE NAME FOR PEJ 
          MX1    0           REQUEST ZERO TERMINATOR
          RJ     PEJ         PROCESS EXTERNAL JUMP
          RJ     PAS         POP APLIST STRUCTURE 
          SA1    FVSUKL 
          ZR     X1,DAC5     IF EXPRESSION LENGTH EXACTLY KNOWN 
          RJ     SCI         STORE NEW APLIST WORD FROM MMC. TO APL 
          SA1    CCTA 
          RJ     SUA         SAVE UNKNOWN-LENGTH APLIST 
          SA1    FVSUKL 
  
 DAC5     SB6    X1          STORE-TO-APLIST FLAG 
          SA1    CCTA        TEMP SAVED BY CCT
          RJ     ECA         ISSUE TEMP AS MAIN APLIST
          EQ     EXIT.
  
 DAC1     SA5    DACA        GET ORIGINAL OPERAND 
          RJ     PCI         PROCESS CHARACTER ITEM 
          EQ     EXIT.
  
 DACA     BSS    1
 DAT      SPACE  4,8
**        DAT - DEFINE APLIST ADJUSTED-LENGTH TEMP FOR SKEL.
* 
*         ENTRY  B6 = CAC ORDINAL FROM STATUS WORD
  
 DAT      SUBR
          SA1    T.CAC
          SA2    X1+B6
          SA3    S=ST 
          LX2    -WC.RAP
          LX3    P2.TAGP
          SX0    X2 
          LX0    P2.BIASP 
          BX2    X0+X3
          =X6    0
          CALL   POS         PREPARE OPERAND
          SA6    REG=G       GL1 FOR SKELETON 
          EQ     EXIT.
 DCF      SPACE  4,10 
**        DCF - DEFINE CHARACTER FUNCTION 
*         JUST AS DIT IN REG DEFINES AN INTERMIDIATE IN 
*         THE REGFILE AND SETS REGISTER STATUS,  DCF
*         DEFINES TEMPORARY STORAGE AND SETS STATUS FOR A CHARACTER 
*         FUNCTION INTERMEDIATE.
* 
*         ENTRY  ((B4)+OR.1OP) = FUNCTION 
* 
*         EXIT   STATUS WORD SET
*                TEMP STORAGE SET 
* 
*         CALL - CCT
  
  
 DCF      SUBR               ENTRY/EXIT.
          SA1    B4+OR.1OP   GET FUNCTION 
          AX1    P2.TAGP     POSITION ROUTINE NAMD
          ERRNZ  60-P2.TAGP-P2.TAGL 
          CLAS=  X4,OP,2ORD 
          SA3    B4+OR.OPR   GET OPERATOR 
          BX3    X4*X3       EXTRACT OUS ORDINAL
          =X0    1
          LX3    -OP.2ORDP+P2.TAGP SET DUMMY TAG FOR SSC
          BX4    X3+X0             ASIGN DUMMY USE COUNT
          ERRNZ  P2.USEP
          CALL   GCL         GET CHARACTER LENGTH 
          BX5    X4 
          =B6    1           SPACE PREVIOUSLY RESERVED
          RJ     CCT
          SA1    APTAB
          SA2    X1 
          SB2    X2 
          AX1    18          POSITION FIRST WORD INDEX OF THIS LIST 
          SA6    B2+X1       STORE IA. WORD IN FW OF LIST 
          EQ     EXIT.
 ECA      SPACE  4,10 
**        ECA - ENTER CHARACTER ITEM TO APLIST
*         THE MAIN JOB IS TO SET THE CHARACTER SPECIFIC 
*         FIELDS IN ATF AND CALL AAP. 
* 
*         ENTRY  (X1) = P2.TAGL/IA TAG,P2.BIASL/IA BIAS,REST/NA 
*                (B6) = STORE INDICATOR 
* 
*         EXIT   (X6) = IA WORD 
*                IF (^SPR[ATF]) THEN
*                   (APLEN) = (APLEN)+1 
*                   (X6) ENTERED IN APLIST
* 
*         USES ALL BUT A4,X4 B2-5 
* 
*         CALLS AAP 
  
  
 ECA      SUBR               ENTRY/EXIT 
          SA2    ATF
          SX0    M.CHAR      MODE = CHAR
          =X6    1
          CLAS=  X3,AT,MODE 
          LX6    AT.CHARP    POSITION CHAR BIT
          BX7    -X3*X2      CLEAR MODE FIELD 
          LX0    AT.MODEP 
          BX7    X7+X6       MERGE IN CHAR BITS 
          BX7    X7+X0       MERGE IN MODE
          SA7    ATF
          SB7    B6          SET STORE FLAG FOR AAP 
          RJ     AAP         ENTER APLIST WORD
          EQ     EXIT.
 ECW      SPACE  4,10 
**        ECW- ENTER CAC WORD 
*         HERE WE ENTER A CAC WORD
*         AND CHECK FOR UNIQUENESS. IF
*         THE ENTRY ALREADY EXISTS WE 
*         DELETE IT.
* 
*         ENTRY  (X6) = WC WORD FOR CAC (ONLY CLEN, RA, AND BCP)
* 
*         EXIT   (X6) - PRESERVED 
*                (B7) = ORDINAL INTO CAC OF ENTRY 
* 
*         USES - A1,A3 X0,X1,X5,X6 B6,B7
* 
*         SAVES  X5,B2-B5 
* 
*         CALLS ADDWD 
  
  
 ECW      SUBR               ENTRY/EXIT 
          ADDWD  T.CAC       ADD WC WORD TO CAC 
          SB6    B7-1        (B6) = LWA(CAC)
          SB7    -1 
 ECW1     SB7    B7+1 
          SA3    X1+B7
          BX0    X3-X6       COMPARE TO NEW ENTRY 
          NZ     X0,ECW1     IF NOT A MATCH 
          SX2    X2-1        LENGTH IF ENTRY A DUP
          SX0    A3-B6
          ZR     X0,EXIT. 
          SHRINK T=CAC,X2 
          EQ     EXIT.
 ESC      SPACE  4,8
**        ESC -  EXPAND SHORT CONSTANT
* 
*         ENTRY  (X5) = PROPOSED SHORT CONSTANT 
* 
*         EXIT   (X1) = (S=CON) 
*                (X3) = BIAS IN T.CON OF ENTERED VALUE. 
* 
*         USES   A1,A3,A6  X0,X1,X2,X3,X6  B2,B7
* 
*         CALLS  ADW, SCT 
  
  
 ESC      SUBR   =
          HX5    P2.BIAS     ADJUST TO GET SIGN EXTEND
          AX5    -P2.BIASL   SHIFT TO LOW WITH SIGN EXTEND
          BX6    X5 
          SCAN   T.CON,SCT
          SX3    B7 
          PL     B7,ESC10    IF CONSTANT IN TABLE 
          ADDWD  A1          ENTER CONSTANT 
          =X3    X2-1 
 ESC10    SA1    S=CON
          EQ     EXIT.       EXIT...
 FIA      SPACE  4,10 
**        FIA - FORMAT INTERMEDIATE ARRAY REDERENCE 
*         FIA CONTROLS APLIST CONSTRUCTION AND SETTING UP THE 
*         STORE CODE AND LIBRARY CALLS. 
* 
*         ENTRY  (X5) = OPERAND 
* 
*         EXIT   APLIST GENERATED AND PLUG CODE EMITED FOR ARRAY LOAD.
*                APL ADDED FOR ARRAY
* 
*         USES ALL
*         CALLS  PCA,SCA,SAP,PEJ
  
  
 FIA      SUBR               ENTRY/EXIT 
          BX0    X5 
          SA2    T.PAR       GET FWA I. L.
          AX0    P2.BIASP    POSITION I. L. ORD FOR ASSOCIATE OPERATOR
          SB2    X2 
          SB2    X0+B2       (B2) _ ASSOCIATE 
          SX6    B4-B2       (X6) = ADDR(ASSOCIATE)-ADDR(CURRENT OPR) 
          SB4    B2          RESET -ALLOC LOCKED- OPR POINTER 
          SA6    DEFDIF      SET DEFERED OPERATOR DIFERENCE 
  
**        WE NOW PROCESS THE APLIST FOR THE FIA 
*         LIBRARY CALL. 
  
          RJ     SAS         STACK APLIST STRUCTURES
          SA5    LEAF        GET ARRAY OPERAND
          RJ     GAS         GET APLIST STATUS
          GE     B2,B1,FIA1  IF IN CAC TABLE
          =A2    B4+OR.1OP   GET ARRAY SYMBOL OPERAND 
          BX1    X2 
  
 FIA1     BX6    X1          COPY STATUS WORD 
          SA6    A1          SET STATUS WORD TAG = SYM TAB ORDINAL
          RJ     PCA         PASS ARRAY OPERAND TO APLIST 
          SA1    B4+OR.2OP   GET ADDRESS FUNCTION 
          RJ     CCA         COMPLETE ARRAY REF 
          SA3    DEFDIF      GET OFFSET TO ORIGINAL TURPLE
          SB4    B4+X3       RESET (B4) 
          EQ     EXIT.
 FVS      SPACE  4,10 
**        FVS    FORMAT VARIABLE SUBSTRING
*         FVS HNDLES ALL THE STORE CODE, CAC, AND 
*         APLIST ENTRIES SUBSTRING OPERANDS.
* 
*         ENTRY  (X5) =SUBSTRING OPERAND
* 
*         EXIT   CODE, APLISTS, AND CAC ENTRIES MADE
*                (LEAF) = SUBSTRING OPERAND 
* 
*         USES   ALL
* 
*         CALLS ECW,ESC,PCA,SSC,SCI 
  
  
 FVS      SUBR               ENTRY/EXIT.
          SA3    S=FVS       SYMBOL ORDINAL OF FORM VARIABLE SUBSTRING
          BX6    X3 
          MX7    -P2.BIASL   SET I. L. ORDINAL MASK 
          SA6    FVSA        SAVE ROUTINE NAME
          SA2    T.PAR       GET FWA I. L.
          LX5    -P2.BIASP   POSITION I. L. ORDINAL 
          SB2    X2 
          BX0    -X7*X5      EXTRACT I. L. ORDINAL OF SBST TURPLE 
          SB2    B2+X0       (B2) = LOC(SUBSTRING TURP) 
          SX6    B4-B2       LOC(ORIGINAL)-LOC(SBST)= ORD(ORG)-ORD(SBST)
          SB4    B2          RESET LOCKED TURPLE POINTER TO SBST TURP 
          SA6    DEFDIF      SET DEFERED TURPLE DIFFERENCE
  
**        COMPUTE I.L. ORDINAL OF COLON 
*         (X0) = SBST TURP ORDINAL
*         (X2) = FWA I. L.
*         (X6) = ORD(ORIGINAL) - ORD(SBST)
*         (X7) = P2.BIAS MASK 
  
  
          SA3    B4+OR.2OP   GET : OPERAND
          IX6    X6+X0       (X6) = ORD(ORIGINAL) 
          LX3    -P2.BIASP   POSITION I. L. ORD OF : TURPLE 
          BX3    -X7*X3      (X3) = I. L. ORDINAL OF :  
          IX7    X3-X6       (X7) = ORD(:) - ORD(ORIGINAL)
          SA7    COLDIF      SET : DIFFERENCE CELL
          SB5    X3          (B5) = ORD(:)
  
**        GET SET UP ARRAY CASE. RESET (B4) _ ARRAY TURP
*         (X0) = ORD(SBST)
*         (X2) = FWA I. L.
*         (B4) _ SBST TURP
  
          =A5    B4+OR.1OP         GET CHARACTER OPERAND FORM 
          SBIT   X5,P2.INTRP
          PL     X5,FVS1     IF NOT INTERMEDIATE, (B4) IS CORRECT 
          LX5    1+P2.INTRP-P2.BIASP-P2.BIASL  PLACE ARRAY ORD HIGH 
          SA3    S=FAS       SYMBOL ORDINAL OF FORMAT ARRAY SUBSTRING 
          BX7    X3 
          SA7    FVSA        SAVE ROUTINE 
          SA1    DEFDIF                        GET DEFERED TURPLE DIFF
          AX5    -P2.BIASL   SIGN EXTEND ARRAY ORD
          IX2    X2+X5       (X2) _ ARRAY TURPLE
          IX7    X1+X0       (X7) = ORD(ORIGINAL) 
          SB4    X2          RESET LOCKED (B4) POINTER TO ARRAY 
          IX7    X7-X5       (X7) = ORD(ORIGINAL) - ORD(ARRAY)
          MX0    1
          BX7    X7+X0       SET BIT 59 TO INDICATE ARRAY 
          SA7    A1          RESET DEFDIF 
          EQ     FVS3        CONTINUE WITH PLUG CASE
  
  
**        DECTECT AND EFFECT CONSTANT SUBSTRING CASE
*         (X5) = VARIABLE OPD (1OP[SBST]), SHIFTED P2.INTRP 
*         (B5) = I. L. ORD( : TURPLE )
  
 FVS1     SA3    T.PAR       GET FWA I. L.
          =X3    X3+OR.1OP   ADD IN FIRST OPERAND OFFSET
          SA3    X3+B5       GET FIRST SBST INDEX 
          SBIT   X5,P2.FPP/P2.INTRP 
          BX6    X5          SAVE FP FLAG 
          SA6    FVSB 
          =A5    A3-OR.1OP+OR.2OP  GET SECOND SBST INDEX
          BX0    X3*X5
          SBIT   X0,P2.SHRTP
          PL     X0,FVS3     IF AT LEAST ONE SUBSTRING INDEX IS VARIABLE
          SA5    FVSB        GET FP FLAG
          PL     X5,FVS15    SKIP IF NOT FP 
          SA3    T.PAR
          =X3    X3+OR.1OP   (X3) FWA I.L. OFFSET BY 1OP
          SA3    X3+B5       GET FIRST SBST INDEX 
          =A4    A3-OR.1OP+OR.2OP  GET SECOND INDEX 
          LX3    -P2.BIASP
          LX4    -P2.BIASP
          SB3    X3-1        EVALUATE SUBSTRING LENGTH
          SB2    X4 
          SX7    B2-B3       LEN = U.B. - ( L.B. - 1 )
          SA7    FVSB        SAVE SUBSTRING LENGTH
          EQ     FVS3        GO STACK AND PLUG
  
 FVS15    BSS    0
          MX6    0           FVSB CONTAINS FLAG, SET TO ZERO
          SA6    FVSB        TO AVOID USING FOR CONST. SUBST. SIZE
          SA5    LEAF        GET SBST INTERMEDIATE OPERAND
          RJ     GAS         GET APLIST STATUS
          LT     B0,B2,FVS2  ID IN CAC TAB
  
  
**        ENTER CONSTANT SBST IN APLIST 
*         (A1,X1) _,= STATUS WORD 
*         (B5) = ORD(:) 
  
          SA2    B4+OR.1OP   GET CHARACTER OPERAND
          BX6    X2 
          SA6    A1          RESET STATUS WORD
          SA1    A1          GET NEW STATUS WORD
          RJ     SCB         SUBSUME CONSTANT BIAS
          SA3    T.PAR
          =X3    X3+OR.1OP   (X3) FWA I. L. OFFSET BY 1OP 
          SA3    X3+B5       GET FIRST SBST INDEX 
          =A4    A3-OR.1OP+OR.2OP GET SECOND INDEX
          LX3    -P2.BIASP
          LX4    -P2.BIASP
          CALL   ECS
          SX5    B7          (X5) = EQUIV CLASS BASE SYM TAB ORD
          RJ     ECW         ENTER CAC WORD 
          SX3    X5+         (X3) = EQIV CLASS BASE SYMBOL ORD
          SA5    LEAF 
          RJ     SSC         SET STATUS OF CHARACTER
 FVS2     SB2    1
          RJ     PCA         PROCESS CHARACTER APLIST ITEM
          SA1    DEFDIF 
          SB4    B4+X1       RESET (B4) 
          EQ     EXIT.
  
**        MAIN CASE: FP'S,  ARRAYS,  AND VARIABLE SUBSTRINGS
*         TASKS: STACK CURRENT APLIST,  CREATE A SUBSTRING APLIST,
*         POP BACK TO OUR ORIGINAL APLIST,  WRITE SOME PLUG CODE
*         TO THE TO A DUMMY ENTRY IN THE ORIGINAL APLIST, AND ADD 
*         THAT DUMMY TO THE APLIST. 
  
 FVS3     RJ     SAS         STACK APLIST INFO
          SA5    LEAF        GET SUBSTRING OPERAND
          RJ     GAS         GET APLIST STATUS OF SUBSTRING 
          LT     B0,B2,FVS4  IF ALREADY IN CAC TABLE
          SA1    B4+OR.1OP   GET CHARACTER OPERAND
  
 FVS4     BX6    X1 
          SA6    A1          PLACE CORRECT SYMTAB ORDINAL IN STATUS WORD
          RJ     PCA         PROCESS CHARACTER AP 
          SA2    DEFDIF      GET DEFERED TURPLE DIFFERENCE
          MX7    0
          SA7    ATF         INDEX AND SUBSTRING INDS NOT CHAR
          PL     X2,FVS5     IF NOT ARRAY INTERMED. 
          SA1    B4+OR.2OP   GET ADDRESS FUNCTION 
          RJ     SAP         SELECT NORMAL APLIST PROCESSOR 
  
 FVS5     SA2    DEFDIF      GET DEFERED TURPLE ORDINAL DIFFERENCE
          SA1    COLDIF      GET COLIN TURPLE DIFFERENCE
          SB4    B4+X2       RESET (B4) _ ORIGINAL TURPLE 
          SB4    B4+X1       SET (B4) _ : TURPLE
          BX6    -X1         (X6) = I.L. ORD(ORIGINAL) - ORD(:) 
          SA6    A1          RESET COLDIF 
          SA1    B4+OR.1OP   GET FIRST SBST INDEX FUNCTION
          RJ     SAP         OUTPUT APLIST WORD 
          SA1    B4+OR.2OP   GET SECOND SBST INDEX FUNCTION 
          RJ     SAP         OUTPUT APLIST WORD 
          SA1    FVSA        GET SUBSTRING ROUTINE SYM TAB ORD
          LX1    P2.TAGP     POSITION ORDINAL 
          BX6    X1 
          SA6    ROUTNAM     SET SUBSTRING ROUTINE NAME FOR PEJ 
          RJ     PEJ         PROCESS EXTERNAL JUMP TO SUBSTRING ROUTINE 
          SA1    COLDIF 
          RJ     PAS         POP APLIST STRUCTURE 
          SB4    B4+X1       (B4) _ ORIGINAL TURPLE 
          RJ     SCI         STORE INTO CHARACTER ITEM
          SA5    LEAF 
          RJ     GAS         GET STATUS WORD OF SUBSTRING 
          SB6    1           SET PLUG FLAG
          RJ     ECA         ENTER DUMMY ITEM 
          SX7    1
          SA7    FVSUKL      MARK EXPRESSION LENGTH NOT KNOWN 
          EQ     EXIT.
  
 FVSA     BSS    1
 FVSB     BSS    1
 FVSUKL   BSSZ   1
 GAS      SPACE  4,10 
**        GAS    GET APLIST STATUS OF OPERAND 
* 
*         GAS CHECKS WHETHER A CHARACTER INTERMEDIATE IS IN 
*         TEMPORARY STORAGE, TO AVIOD DUPLICATE ALLOCATIONS 
*         FOR THE SAME OPERAND.  IT ALSO CHECKS TYPE AND FINDS A
*         CAC ORDINAL IF ONE EXISTS.
* 
*         ENTRY - (X5) = I. L. ENTRY FOR OPERAND
* 
*         EXIT - (A1)_,(X1)= OPERAND STATUS WORD
*                (X5) - PRESERVED 
*                (B2) = -1: IF OPD NO TYPE CHARACTER
*                        0: IF TYPE[OPD] = CHAR BUT NO CAC ENTRY EXISTS 
*                        1: FOR TYPE CHAR WITH CAC ENTRY BUT NOT A TEMP 
*                        2: FOR CHAR TEMPS (=> IN CAC TAB)
*                        3: STATUS IS ADJUSTED-LENGTH ITEM (FROM MMC.)
*                (B7) = CAC ORDINAL IF (B2) .GE. 1
* 
*         USES   A1,A6, X0,X1,X5,X6, B2,B7
  
  
 GAS      SUBR               ENTRY/EXIT 
          LX6    X5 
          =B2    0           SET NOT IN TEMP OR CAC 
          BX1    X5 
          MX0    -P2.USEL 
          SA6    GASA        SAVE OPD FOR LATER CALL
          BX0    -X0*X5      EXTRACT USE COUNT
          ZR     X0,EXIT.    IF NO STATUS WORD EXISTS 
          SA1    T.OUS       GET FWA OF STATUS WORD TABLE 
          LX5    -P2.TAGP    POSITION OUS ORDINAL 
          SB7    X1 
          MX0    -P2.TAGL 
          BX0    -X0*X5 
          SA1    B7+X0       GET STATUS WORD
          BX6    X1 
          LX5    P2.TAGP
          SBIT   X6,ST.CACP 
          PL     X6,EXIT.    IF NOT IN CAC TAB
          =B2    B2+1              SET IN CAC BUT NOT TEMP
          SBIT   X6,ST.CTMP/ST.CACP 
          PL     X6,GAS1     IF NOT A TEMPORARY 
          =B2    B2+1                      SET CHAR TEMP FLAG 
          BX0    X6 
          SBIT   X0,ST.UKLP/ST.CTMP 
          PL     X0,GAS1     IF NOT UNKNOWN LENGTH
          =B2    B2+1 
  
 GAS1     MX0    -P2.BIASL   SET CAC ORDINAL MASK 
          LX6    1+ST.CTMP-P2.BIASP    POSITION CAC ORDINAL 
          BX0    -X0*X6                EXTRACT CAC ORDINAL
          SB7    X0 
          EQ     EXIT.
  
 GASA     BSSZ   1
 GNO      SPACE  4,10 
**        GNO - GET NEXT OPERAND
*         THIS IS THE ACTUAL CONCATENATION TREE SPANNER.  EACH
*         CALL PRODUCES THE NEXT LEAF AND THE NEXT RIGHT TREE 
*         LINK, (OR.2OP), TO EXPLORE. THESE ARE SAVED IN LEAF 
*         AND LNK.CUR RESP.  THE WALK DOES NOT INVOLVE A STACK
*         BUT INSTEAD RELIES ON A SYSTEM OF STORING PREVIOUS
*         LINKS DIRECTLY IN THE I. L.  UPON EXIT LNK.LST IS SET 
*         TO THE VALUE OF THE LAST LINK OPERAND.  LNK.CUR 
*         BECOMES THE NEXT R-LINK TO SEARCH, AND THE
*         I. L. LOCATION OF THE CURRENT LINK IS PLUGGED WITH
*         LINK PRECEEDING THE LAST LINK.
* 
*         NOTE - TO GNO OPERANDS ARE ONLY INPORTANT AS LINKS
*                IN THE TREE OR AS LEAVES. BGA ACTUALLY *VISITS*
*                THE LEAVES BY PUTTING THEM IN THE APLIST.
* 
*         ENTRY  (LNK.CUR) = THE CURRENT LINK TO INVESTIGATE
*                (LNK.LST) = IS THE LAST LINK OPERAND VISITED 
*                (X5) = LNK.CUR 
* 
*         EXIT   (LEAF) = NEXT OPERAND TO ADD TO APLIST 
*                LNK.CUR AND LNK.LST ARE SET AS ABOVE.
  
  
 GNO      SUBR               ENTRY/EXIT 
          SX0    RLOCK       LOCK BIT  DISTINGUISHES 1OP FROM 2OP 
          SA2    LNK.LST     GET LAST LINK
          SA1    T.PAR       GET FWA I. L.
          SB7    59-P2.CNCTP SET CONCAT BIT SHIFT COUNT 
          =B2    X1+OR.1OP   OFFSET FWA BY FIRST OPD POSITION 
          LX7    B7,X5       POSITION CONCAT BIT FOR TEST 
          EQ     GNO2        JUMP TO END OF LEFT LINK LOOP
  
**        LEFT LINK LOOP:   HERE WE WALK UP THE I. L. 
*         STORING LINKS AND FETCHING NEW LINKS UNTIL
*         WE ENCOUNTER A NON-CONCATENATION OPERAND. 
*         THIS IS THE LEAF. 
  
 GNO1     LX7    1+P2.CNCTP-P2.BIASP   POSITION I. L. ORDINAL OF LINK 
          BX6    X2                    (X6) = LAST LINK 
          SA1    B2+X7       NEXT LINK = OR.1OP(BIAS[CURNT OP]) 
          BX2    X5          LAST LINK = CURRENT LINK 
          LX7    B7,X1       POSITION CONCAT BIT OF NEXT LINK 
          SA6    A1+         OR.1OP(BIAS[CURNT OP]) = LAST LINK 
          BX5    X0+X1       CURRENT LINK = NEXT LINK WITH LOCK BIT SET 
 GNO2     MI     X7,GNO1     IF CURRENT OPERAND IS A LINK 
  
**        WE HAVE A LEAF
*         (X2) = NEW LAST LINK
*         (X5) = LEAF 
*         (X7) = (X5) SHIFTED BY 59-P2.CNCTP
*         (B2) = (T.PAR)+OR.1OP 
  
          BX6    X0*X5       EXTRACT LOCK BIT FOR 1ST (LEFT) OPD TEST 
          LX7    1+P2.CNCTP        RESET CUR OPD, IT'S A LEAF 
          SA7    LEAF 
          SB2    B2-OR.1OP+OR.2OP  (B2) = FWA I. L. + OR.2OP
          BX7    X2          PREPARE FOR RIGHT LINK RESET LOOP
          EQ     GNO4        ENTER BACKTRACK LOOP 
  
**        HERE WE STEP BACK DOWN THE I. L. REPLACING
*         OPERANDS UNTIL WE FIND A LINK THAT IS A LEFT
*         OPERAND.
  
 GNO3     AX7    P2.BIASP 
          BX6    X5          CUR = CURRENT LINK 
          SA1    B2+X7       LST = OR.2OP(BIAS[LAST LINK])
          ERRMI  P2.BIASL-18
          LX5    X2          CURRENT LINK = LAST LINK 
          SA6    A1          OR.2OP(BIAS[LAST LINK]) = CUR
          LX2    X1          LAST LINK = LST
          BX6    X0*X5       (X6) = LOCK BIT (CURRENT LINK) 
          LX7    X2 
 GNO4     ZR     X6,GNO3     IF NOT A 1ST (LEFT) OPD
  
          AX2    P2.BIASP    POSITION I. L, ORDINAL OF LAST LINK
          SA7    LNK.LST     SET LAST LINK FOR RETURN 
          SA1    B2+X2       (X1) = OR.2OP(BIAS[LAST LINK]) 
          BX6    -X0*X1      CLEAR LOCK BIT OR CURRENT LINK 
          SA6    LNK.CUR     SET CURRENT LINK FOR NEXT CALL 
          ZR     X1,EXIT.    IF OUR NEW R-LINK IS THE END OR WALK FLAG
  
          SA2    A1-OR.2OP+OR.1OP  GET OR.1OP (LEFT) OPD
          LX7    X2 
          SA7    A1          STORE PREVIOUS LAST LINK IN 2OP ,RIGHT OPD 
          BX6    -X0*X5      CLEAR LOCK BIT TO RESTORE OPERAND
          SA6    A2          RESET I. L. ENTRY TO ORIGINAL VALUE
          EQ     EXIT.
 IAS      SPACE  4,10 
**        IAS - STACK APLIST STRUCTURES 
*         APLEN, APTAB, APIND, AND ATF ARE INITIALIZED HERE 
* 
*         ENTRY  (B5) _ APLIST INDEX TABLE POINTER WORD 
*                (B6) _ APLIST TABLE POINTER WORD 
* 
*         EXIT   (B6) = CURRENT STACK DEPTH 
*                (LEVEL) = (B6) 
*                (APLEN) = 0
*                (APTAB) = 42/INDX OF FW OF LIST,18/TAB CONTAINING LIST 
*                (APIND) = APL NUMBER FOR - SA1  AP.(APIND) - 
*                (ATF) = 0
*                (APLIST INDEX TABLE + (APIND)) = 0 
* 
*         USES A1,A2,A3,A6   X1,X2,X3,X6   B5,B6
  
  
 IAS      SUBR               ENTRY/EXIT.
          SA3    LEVEL       GET CURRENT STACK DEPTH
          MX6    0
          SA6    ATF         APLIST TYPE FLAG = 0 
          NZ     X3,IAS1     IF LEVEL NOT ZERO INITIALIZE 
  
**        WE MUST DETERMINE IF THIS IS A SECOND VISIT 
*         OF IAS FOR THIS ZERO LEVEL APL. 
  
          SA2    FAF         GET FIRST APLIST FLAG
          NZ     X2,EXIT.    IF NOT FIRST VISIT INITIALIZE
  
**        INITIALIZE VALUES 
  
 IAS1     =X6    1
          SA6    FAF         TURN FIRST APL FLAG OFF
          SX6    B6          (X6) = APLIST TABLE PTR
          SA1    B6+N.TABLE  (X1) = APLIST TABLE LEN WORD 
          LX1    18 
          IX6    X1+X6
          SA6    APTAB       SET APLIST TABLES CELL 
          SA1    B5+N.TABLE  GET ORDINAL INTO INDEX TABLE 
          BX6    X1 
          SA6    APIND
          NZ     X3,IAS2     IF NOT USER FUNCTION 
          SA6    UAP         FLAG LAST USER APLIST FOR RETURNS PROCESSOR
  
 IAS2     MX6    0
          ADDWD  B5          ADD 0 WORD TO AP INDEX TAB 
          SA6    APLEN       INITIALIZE APLEN 
          EQ     EXIT.
  
 UAP      BSSENT 1
 IAW      SPACE  4,10 
**        IAW - ISSUE APLIST WORD.
*         CONTROLS ADDITION OF APLIST ITEM TO APPROPIATE (APL OR IOA) 
*         TABLE,  AND FILING OF OPT2 USE/DEF ENTRY. 
*         SET AT.LEV0 IF THIS OPD IS LEVEL 0. 
* 
*         ENTRY  (X1) = OPD, OPERAND WORD.
* 
*         EXIT   APLIST ENTRY MADE FOR INCOMMING OPERAND WORD 
* 
*         NOTE   THE ENTRY MADE MAY BE A TEMP RESULTING FROM A CONCAT 
*                WALK, A DUMMY TO BE PLUGGED, A POINTER TO THE CLW, 
*                TABLE OR A SIMPLE IA. REPRESENTATION OF THE OPERAND. 
* 
*         USES   ALL
*         CALLS  GAS,PCL,DAC,SAP
  
  
 IAW      SUBR               ENTRY/EXIT 
          BX5    X1 
          SA3    B4+OR.OPR
          RJ     GAS         GET APLIST STATUS
          SA2    ATF
          MX0    -OP.MODEL
          LX3    -OP.MODEP
          BX6    -X0*X3 
          SB6    X6-M.CHAR   (B6) = MODE - CHARATER MODE
          LX6    AT.MODEP 
          BX7    X2+X6       MODE[ATF] = MODE[TURP(1)]
          SA7    ATF
          ZR     B6,IAW30    IF CHARACTER 
          SA1    GASA        GET ORIGINAL OPERAND 
          RJ     SAP         SELECT APLIST PROCESS
          EQ     EXIT.
  
 IAW30    HX7    AT.LEN 
          PL     X7,IAW40    IF NOT PROCESSING CHAR ITEM LENGTH 
          SA1    GASA        GET ORIGINAL OPERAND 
          RJ     PCL         PROCESS CHAR LEN 
          EQ     EXIT.
  
 IAW40    RJ     DAC         DETERMINE APLIST COMPLEXITY
          EQ     EXIT.
 LUA      SPACE  4,8
**        LUA - LOAD UNKNOWN LENGTH ADJUSTED TEMP.
* 
*         ENTRY  B7 = CAC ORDINAL FROM STATUS WORD
  
 O=LURET  BSSENT 0           RETURN FROM SKELETON 
 LUA      SUBR
          SB2    REG.X+6
          SB6    B7 
          CALL   RUT         CLEAR X6 
          RJ     DAT         SET UP ST.+K FOR SKEL
          SX6    W=LUA
          EQ     SUB.RET
 NAP      SPACE  4,8
**        NAP -  ENTER AP-LIST IN TABLE.
* 
*         ENTRY  (B3) = LENGTH OF AP-LIST (INCLUDING THE ZERO WORD, IF
*                            ANY).
*                THE AP-LIST TO BE ENTERED IS THE LAST (B3) WORDS OF
*                            T.APL. 
* 
*         EXIT   (X6) = AP-TAG OF THE INDICATED LIST. 
*                (X3) = AP ORDINAL OF THIS AP-LIST. 
*                (TG.APL) IS UPDATED, AND ADDRESS OF TAG DEFINED. 
* 
*         USES   A1,A2,A3,A6  B2,B3,B7  X0
* 
*         CALLS  DPT, NCM 
  
  
 NAP      SUBR               ...ENTRY/EXIT... 
          SA1    T.APL+X5 
          SA2    T=APL+X5 
          SB7    -B3
          SB5    X5 
          IX0    X1+X2       LWA+1 OF LIST
          SB2    X0+B7       FWA LIST = LWA+1 - LEN 
          SB3    X0          (B3) = LWA + 1 FOR NCM 
          SX6    X2+B7       FAKE LENGTH FOR *NCM* PROCESSING.
          SA6    A2          RESET LENGTH FOR *NCM* 
          CALL   NCM         SEARCH AP-TABLE FOR DUPLICATE LIST 
          =X5    B5 
          PL     B7,NAP1     IF ALREADY IN T.APL
          SA2    T=APL+B5 
          IX6    X2+X0       RESTORE LENGTH 
          SA6    A2          RESET T=APL
          LX6    X2          ORDINAL OF T.APL ENTRY 
  
**        ADD WC FORMAT WORD TO T.API AND CONSTRUCT A NEW TAG FOR CALLER
  
 NAP1     =X2    1           WC.RL = 1
          AX6    B5 
          SX3    BN=APL+B5   WC.RB = BN=APL 
          LX6    WC.RAP 
          LX2    WC.RLP 
          IX6    X2+X6       ORDINAL + WC.RL
          LX3    WC.RBP 
          BX6    X3+X6       WC.RL + WC.RB + WC.RA
          SA1    T.API+B5    GET FWA OF APLIST INDEX
          SA2    APIND       GET ORDINAL INTO INDEX TABLE 
          IX1    X2+X1       ADD TABLE BASE TO INDEX
          SA6    X1          SET   API ENTRY
          LX5    P=PFX       POSITION APLIST TYPE OFFSET
          SX6    X2+K.AP     TAB = K.AP + APIND 
          IX6    X6+X5       ADD IN OFFSET
          LX6    IA.TAGP
          EQ     EXIT.
 PAS      SPACE  4,10 
**        PAS - POP APLIST STRUCTURES 
*         THIS ROUTINE ADJUSTS THE LEVEL AND RESTORES 
*         THE APLIST CELLS FROM THE PREVIOUS LEVEL. 
* 
*         ENTRY  (LEVEL) = APLIST STACK DEPTH 
* 
*         EXIT   (LEVEL) = (LEVEL)-1
*                (APLEN) = (APLEN+(LEVEL))
*                (APTAB) = (APTAB+(LEVEL))
*                (APIND) = (APIND+(LEVEL))
*                (ATF) = (ATF+(LEVEL))
* 
*         USES A2,A3,A6,  X2,X3,X6, B6
  
  
 PAS      SUBR               ENTRY/EXIT 
          SA3    LEVEL
          SB6    X3 
  
 .POP     ECHO   ,P=(APLEN,APTAB,APIND,ATF)    P(0)=P(LEVEL)
          SA2    P+B6 
          BX6    X2 
          SA6    A2-B6
 .POP     ENDD
  
          =X6    B6-1        DECREMENT LEVEL
          SA6    A3          RESET LEVEL
          SA2    APLEN
          ZR     X6,PAS10    IF POPPED TO ZERO LEVEL
          SA3    APTAB       GET OUTER APLIST TABLE ADDRESS 
          SB6    X3 
          SA3    A3+1        GET INNER APLIST TABLE ADDRESS 
          SB6    -B6
          SB6    X3+B6
          NE     B6,PAS10    IF NOT EQUAL, DO NOT ADD INNER APLEN 
          =A3    A2+1 
          IX2    X2+X3       INCLUDE LENGTH OF INNER APLIST 
  
 PAS10    SA3    ATF
          HX3    AT.IO
          AX3    59 
          BX2    -X3*X2      IF IO SHRINK SAP TO ZERO 
          SHRINK T=SAP,X2 
          EQ     EXIT.
 PCA      SPACE  4,10 
**        PCA - PASS CHARACTER APLIST ITEM
* 
*         ENTRY -(X5) = I. L. OPERAND 
*                (X1) = STATUS WORD 
*                (B2) = CAC/TEM INDICATOR 
*                (B7) = CAC ORD (IF EXISTS) 
* 
*         EXIT    APLIST AND CAC ENTRY MADE FOR OPD 
* 
*         USES ALL BUT X5 
* 
*         CALLS SCB,ECA,ECW,SSC 
  
  
 PCA      SUBR               ENTRY/EXIT.
          BX6    X5 
          SA6    PCAA        SAV OPERAND
          BX6    X1 
          SBIT   X6,P2.FPP
          MI     X6,PCA2     IF FORMAL PARAMETER
          LT     B0,B2,PCA1  IF CAC ENTRY EXISTS
          RJ     SCB         SUBSUME CONSTANT BIAS
          SX5    B7+         SAVE ORD OF EQV CLASS ACROSS ECW 
          RJ     ECW         ENTER CAC WORD (IN X6, FROM SCB) 
          SX3    X5          (X3) = EQV CLASS ORD 
          SA5    PCAA        (X5) = OPD 
          RJ     SSC         SET STATUS OF CHARACTER
          =B2    0
  
**        NOW INCREMENT CLEN AND ADD IA WORD TO APLIST
*         (X1) = STATUS WORD
*         (B7) = CAC ORDINAL
  
PCA1      SA2    T.CAC
          SA3    X2+B7       GET CAC WORD 
          MX0    -WC.CLENL
          LX3    -WC.CLENP
          SA2    CLEN 
          BX3    -X0*X3      EXTRACT OPERAND CLEN 
          IX7    X3+X2       ADD OPERAND CLEN TO CLEN TOTAL 
          SA7    CLEN 
          SB6    2
          GT     B2,B6,PCA15 IF UNKNOWN LENGTH ITEM 
          =B6    0
  
 PCA12    RJ     ECA
          SA5    PCAA 
          EQ     EXIT.
  
 PCA15    BX6    X1 
          SA6    PCAB 
          RJ     LUA         LOAD UNKNOWN-LENGTH ITEM ADJUSTMENT
          RJ     SCI
          SA1    PCAB 
          =B6    1
          EQ     PCA12
  
**        FORMAL PARAMETER CASE 
*         (X1) = STATUS WORD
  
 PCA2     SB6    0
          RJ     ECA         ENTER CHARACTER APLIST ITEM DIRECTLY 
          LX6    -IA.TAGP    POSITION SYMTAB ORDINAL IN APLIST WORD 
          SX1    X6          (X1) = SYM TAB ORDINAL FOR GCL 
          ERRNZ  18-IA.TAGL 
          RJ     GCL         GET CHARACTER LENGTH 
          PL     X2,PCA25    CHECK IF ASSUMED SIZE FP 
          SA1    FVSB        IF SO, GET CONST. SUB. SIZE
  
 PCA25    BSS    0
          SA3    CLEN        GET CURRENT CHARACTER LENGTH 
          IX6    X3+X1       ADD NEW LENGTH SO SUM
          SA6    A3          RESET CLEN 
          EQ     EXIT.
  
 PCAA     BSSZ   1
 PCAB     BSS    1
 PCF      SPACE  4,8
**        PCF - PROCESS CHARCTER FORMAL PARAMTER SCALAR.
*         CALLS ARRAY OBJECT ROUTINE (FAR) WITH ZERO INDEX
*         TO FORMAT ADDRESS WORD. 
* 
*         ENTRY  (X5) = OPERAND 
  
 PCF      SUBR
          RJ     SAS         STACK APLIST FOR FAR CALL
          RJ     GAS         GET STATUS WORD
          RJ     PCA         FILE HEADER
          MX2    1
          LX2    1+P2.SHRTP 
          =X6    1
          CALL   POS         PREPARE STATUS WORD
          BX1    X6 
          RJ     CCA         COMPLETE ARRAY REF 
          EQ     EXIT.
 PCI      SPACE  4,10 
**        PCI -  PROCESS CHARACTER ITEM 
* 
*         PCI IS CALLED WHEN IT IS DETERMINED THAT NON-CONCATENATION
*         CHARACTER ITEMS  ARE INVOLVED.  ITS FUNCTION IS TO SELECT THE 
*         CORRECT APLIST PROCESSOR FOR THIS OPERAND.
* 
*         ENTRY  (X5) = OPERAND 
* 
*         EXIT   (X5) = OPERAND 
*                (X1) = STATUS WORD 
*                (B2) = TEMP/CAC INDICATOR FLAG 
*                (B7) = CAC ORDINAL IF EXISTS 
* 
*         USES   ALL
* 
*         CALLS  GAS, PCA, ECA, FIA, FVS
  
  
 PCI      SUBR               ENTRY/EXIT 
          BX3    X5 
          LX7    X5 
          RJ     GAS         GET APLIST STATUS OF OPEAND
          SA7    LEAF        SAVE OPERAND 
          LT     B1,B2,PCI1  IF ALREADY IN TEMPORARY STORAGE
          SBIT   X7,P2.ARRP  POSITION ARRAY BIT 
          SBIT   X3,P2.INTRP
          MI     X3,PCI2     IF INTERMEDIATE, CALL FIA OR FVS 
          LX3    P2.INTRP-P2.FPP
          MI     X3,PCI4     IF FP SCALAR 
  
 PCI1     RJ     PCA         PASS CHARACTER APLIST
          EQ     EXIT.
  
 PCI2     PL     X7,PCI3     IF NOT AN ARRAY
          RJ     FIA         FORMAT INTERMEDIATE ARRAY
          EQ     EXIT.
  
 PCI3     BSS    0
  
 .TEST    IFEQ   TEST,ON
          SA2    T.PAR       GET FWA I. L.
          LX7    1+P2.ARRP-P2.BIASP      POSITION I. L. ORDINAL 
          SB2    X2 
          SA2    B2+X7       GET ASSOCIATE OPERATOR 
          AX2    OP.SKELP    POSITION SKELETON
          BX2    -X2         GET NEGATIVE OR SKEL 
          SB2    X2+V=SUBST 
          NZ     B2,"BLOWUP" IF NOT A SUBSTRING 
 .TEST    ENDIF 
  
          RJ     FVS         FORMAT VARIABLE SUBSTRING
          EQ     EXIT.
  
 PCI4     RJ     PCF         ISSUE CHARACTER FP SCALAR
          EQ     EXIT.
 PCL      SPACE  4,10 
**        PCL - PROCESS CHARACTER ARRAY ITEM LENGTH.
*         IN THE CASE OF IO LIST COLLAPS THERE IS NOT ENOUGH
*         ROOM TO SAVE ALL THE REQUIRED CLEN AND ARRAY LENGTH 
*         INFORMATION IN ONE CAC WORD,  SO WE MAKE TWO CLW ENTRIES
*         AND POINT TO THEM FORM THE APLIST. PCL ACOMPLISHES ALL OF 
*         THIS. 
* 
*         ENTRY  (X1) = OPD 
*                (LEAF) = LAST OPERAND PASSED TO APLIST 
* 
*         EXIT   CLW AND APLIST ENTRIES MADE
* 
*         USES   ALL BUT X4, B4 
* 
*         CALLS GCL,AAP,SAP 
  
  
  
 PCL      SUBR
          SA3    ATF
          HX3    AT.NUL 
          PL     X3,PCL50    IF NOT ARRAY ITEM
          SA2    APTAB
          BX6    X1 
          SX7    T.CLW
          SA6    PCLA        SAVE OPERAND 
          SA7    A2          RESET APTAB FOR CLW ENTRIES
          BX6    X2 
          SA6    PCLB        SAVE CURRENT APLIST TABLE
          SA5    LEAF        GET LAST OPERAND TO ALIST
          RJ     GAS         GET STATUS WORD OF LAST OPD TO APLIST
          BX0    X1 
          LX1    -ST.ORD1P
          HX0    P2.FP
          PL     X0,PCL10    IF NOT FORMAL PARAMETER
          LX1    ST.ORD1P-P2.TAGP 
  
 PCL10    MX0    -ST.ORD1L
          BX1    -X0*X1      EXTRACT ORIGINAL ORDINAL OF OPD
          CALL   GCL         GET FP LENGTH/TAG
          LX1    P2.BIASP 
          LX3    P2.TAGP
          BX1    X1+X3
          =B7    0
          RJ     AAP         ENTER CLEN TO CLW
          SA1    PCLA 
          RJ     SAP         LENGTH TO CLW
          SA5    APLEN
          SX6    X5-2 
          SA6    A5          DECRIMENT APLEN BY NUMBER OF CLW ENTRIES 
  
*         ELIMINATE LAST CLW PAIR IF ALREADY EXISTS.
  
          SA5    T.CLW
          SA3    T=CLW
          SB6    X5+2 
          IX0    X5+X3
          SB2    X0 
          =A2    B2-1 
          =A1    A2-1 
          SX0    X3-2        INDEX = T=CLW - 2
          SA3    X5 
          =A5    X5+1 
  
 PCL30    BX6    X1-X3
          BX7    X2-X5
          SA3    A3+2        W1 = W1+2
          BX6    X6+X7       2 CLW WORDS CANNOT BE COMPLEMENTS
          =A5    A3+1        W2 = W2+2
          NZ     X6,PCL30    IF NOT HIT 
          SB3    A3-B2
          ZR     B3,PCL40    IF HIT NOT END OF TABLE
          BX7    X0 
          SA7    T=CLW       T=CLW = T=CLW-2
          SX0    A3-B6       INDEX = W1-T.CLW-2 
  
 PCL40    AX2    B1,X0       BIAS = INDEX/2 
          SA3    PCLB        GET ORIGINAL APLIST TABLE POINTER
          BX7    X3 
          SA3    S=CL        SYMBOL ORDINAL CHARACTER LENGTH DESCRIPTORS
          LX2    P2.BIASP 
          LX3    P2.TAGP
          BX1    X2+X3
          SA7    APTAB       RESTORE ORIGINAL APTAB VALUE FOR THIS LEVEL
          =B7    0
          RJ     AAP         FILE CL. POINTER TO APLIST 
          EQ     EXIT.
  
 PCL50    =X6    0
          SA1    APTAB
          ADDWD  X1 
          SA1    APLEN
          =X7    X1+1 
          SA7    A1 
          EQ     EXIT.
  
 PCLA     BSS    1
 PCLB     BSS    1
 PEJ      SPACE  4,8
**        PEJ -  PROCESS EXTERNAL JUMP. 
* 
*         ENTRY  (APLEN) = NUMBER OF ARGUMENTS. 
*                (ROUTNAM)= TAG OF ROUTINE TO CALL. 
*                (T.APL) = CONTAINS THE ARGUMENTS, AT THE VERY END OF 
*                            THE TABLE. 
*                (TRACE) = LINE NO. FOR TRACEBACK 
  
*                (X1) = 0 IFF ZERO-TERMINATOR REQUIRED. 
* 
*         EXIT   EXTERNAL JUMP COMPILED.
*                (APLEN) = 0
* 
*         CALLS  ADDWD, CLOAD, CRJ
  
  
 PEJ6     SA1    ROUTNAM
          BX6    X1 
          SBIT   X1,P2.FPP
          PL     X1,PEJ7     IF NOT FORMAL PARAMETER
          LX1    1+P2.FPP-P2.TAGP  SHIFT ORDINAL TO BOTTOM
          MX7    -P2.TAGL 
          BX1    -X7*X1 
          =X7    1
          SB7    X1 
          SA7    ENT.SUB     SET ADDSUB FLAG
          SB7    B7+B7
          SA3    T.SYM       GET SYMBOL TABLE BASE
          =X3    X3+WB.W
          SB7    B7+X1       (B7) = 3 * ORDINAL 
          SA1    X3+B7       GET WB  OF ROUTINE 
          ERRNZ  3-Z=SYM
          SA3    T.FPI       GET FWA FP INDEX TABLE 
          LX7    FP.LENP     POSITION SUB COUNTER INCREMENT 
          HX1    WB.FPNO
          =B7    X3-1        (B7) = FWA-1 
          AX1    -WB.FPNOL   ISOLATE FPNO 
          SA1    B7+X1       GET FPI ENTRY FOR ROUTINE((A1)=FWA+FPNO-1) 
          IX7    X7+X1       INCREMENT RA 
          SA7    A1 
  
 PEJ7     SA3    TRACE       SET LINE NUMBER
          CRJ    MUST 
  
 PEJ      SUBR   -           ENTRY/EXIT...
          BX6    X1 
          SA6    PEJA 
          CALL   CIA         CLEAR INTERMEDIATES/ASSOCIATES 
          SA3    APLEN
          SA5    T=APL       GET CURRENT APLIST LENGTH
          ALLOC  T.APL,X3    RESERVE ENOUGH SPACE FOR STACKED APLIST
          IX3    X1+X5       (X3) = *TO* = FWA(APL) + PREVIOUS LEN(APL) 
          SA2    APTAB       GET POINTER TO STACKED APLIST
          SA5    X2          GET FWA OR STACKED APLIST
          AX2    18          POSITION INDEX OF LIST IN SAP
          SB2    X5 
          SA1    APLEN       (X1) = *COUNT* = LENGTH OF CURRENT LIST
          SX2    B2+X2       (X2) = *FROM* = FWA(SAP) + (INDEX OF LIST) 
          MOVE   X1,X2,X3    MOVE CURRENT LIST APL
          SA2    APLEN       GET APLIST LEN 
          MX6    0
          SA6    A2          APLEN = 0
          SB3    X2 
          SA2    PEJA 
          NZ     X2,PEJ1     IF NO TERMINATOR REQUESTED 
          =B3    B3+1 
          ADDWD  T.APL+USER  ZERO WORD APLIST TERM. 
  
 PEJ1     ZR     B3,PEJ6     IF NO APLIST 
  
 SNAP=L   IFNE   TEST        DUMP AP-LIST TABLE 
          SA3    CO.SNAP
          LX3    1RL
          PL     X3,PEJ3S    IF AP-LIST SNAP NOT SELECTED 
          DUMPT  APL
 PEJ3S    BSS    0
 SNAP=L   ENDIF 
  
          SX5    USER 
          RJ     NAP         SCAN/ENTER AP-LIST TABLE.
          MX0    -PB.TAGL 
          AX6    IA.TAGP
          SX1    SA=BK/1S3+10B     GHIJ PORTION OF SA1 INSTRUCTION
          BX6    -X0*X6            EXTRACT PB. TAG (AP. APLIST INDEX) 
          LX1    PB.GHIJP 
          LX6    PB.TAGP
          BX7    X6+X1       MERGE GHIJ WITH ADDRESS FIELD
          WCODE  X7,PEJ6     COMPILE LOAD OF AP-LIST TAG
  
 PEJA     BSS    1
 SAP      SPACE  4,20 
**        SAP - STANDARD APLIST PROCESSOR 
*               SAP PASSES A P2. FORMATTED WORD TO
*               AAP WHICH PLACED THE TAG AND BIAS IN
*               THE CORRESPINDING AP. POSITIONS FOR 
*               EVENTUAL ADDITION TO THE APROPRIATE APLIST
*               SAP ALSO SELECTS PLUG CODE AND STORE TO 
*               TEM CODE WHEN NEEDED. 
* 
*         ENTRY  (X1) = ARGUMENT IN OPERAND FORMAT
*                (IOCTL)= 0 OR IA.IOCM
*                (ATF) = 0      FOR NOT IO APL
*                        1      FOR AN IO APL ITEM/ADDERESS 
*                        1S59+1 FOR AN IO APL LENGTH/CONTROL CODE 
* 
*         EXIT   NEW ENTRY MADE IN T.APL OR T.IOA 
*                CODE COMPILED TO EFFECT APLIST PLUG OR STORE TO TEMP 
* 
*         WARNING - THIS SUBROUTINE CALLS SUBSKELETONS WHICH RETURN TO
*                   EXIT POINT VIA A CALL TO EIS. 
  
  
 SAP      SUBR               ENTRY/EXIT 
          BX5    X1 
          MX0    -P2.USEL 
          SA3    ATF
          SB6    X3          (B6) = IO INDICATOR
          BX0    -X0*X1      EXTRACT USE COUNT FIELD
          ZR     X0,SAP5     IF OPERAND WAS NOT DUC-ED
          SB2    0
          RJ     GST         GET PARTIAL STATUS OF UPPER HALF OF ARG
  
**        DETETMINE APLIST PROCESSOR
*         (X1) = EITHER ARGUMENT STATUS WORD OR OPERAND WORD. WHEN
*                A STATUS WORD EXISTS IT IS USED. IN BOTH CASES THE 
*                TAG AND BIAS FORMATS ARE SUITABLE FOR APLIST USE.
*                EXCEPTION: ARRAYS  REQUIRE A SEPERATE LOAD OF THE
*                1OP OF  THE DELAYED TURPLE.
*         (X5) = ARG OPERAND WORD (AOP). IT HAS ALL P2. BITS PRESENT. 
*         (B6) = IO INDICATOR*: 1 FOR IO, 0 FOR USER CALL.
  
 SAP5     LX3    X5 
          SA2    ATF         GET APLIST TYPE FUNCTION 
          BX0    X5 
          SBIT   X3,P2.INTRP
          PL     X3,SAP10    IF NOT INTERMEDIATE
  
 .TEST    IFEQ   TEST,ON
          MX6    -P2.USEL 
          BX6    -X6*X5 
          ZR     X6,"BLOWUP"           IF INTR NOT USE COUNTED
 .TEST    ENDIF 
  
          SBIT   X0,P2.ARRP 
          PL     X0,SAP50    IF NOT ARRAY INTERMEDIATE STORE TO TEMP
          MX6    -P2.TAGL 
          LX6    P2.TAGP
          AX1    P2.BIASP    POSITION I. L. ORDINAL 
          SA2    T.PAR
          SB7    X1+OR.1OP   (B7) = I. L. ORDINAL OF ARRAY TAG WORD 
          ERRMI  P2.BIASL-18
          SA1    B7+X2       GET ARRAY TAG
          BX1    -X6*X1            ISOLATE TAG
          SBIT   X3,P2.ADDRP/P2.INTRP 
          MI     X3,SAP30    IF LOCF STORE TO TEMP
          MI     X2,SAP30    IF I/O LENGTH  (A(I),I=1,J(K)) 
          EQ     SAP20             PLUG ADDRESS INTO APLIST 
  
 SAP10    SBIT   X0,P2.ADDRP
          MI     X0,SAP30    IF ADDRESS LOAD
          SBIT   X3,P2.FPP/P2.INTRP 
          SBIT   X0,P2.LCMP/P2.ADDRP
          BX0    X0+X3
          BX0    X2*X0
          MI     X0,SAP30    IF FP/LCM IO LENGTH, STORE VALUE TO TEMP 
          MI     X2,SAP80    IF OTHER IO, LENGTH ENTER DIRECTLY INTO APL
          MX0    -P2.TAGL 
          LX0    P2.TAGP     POSITION STATUS WORD 
          BX0    -X0*X1      EXTRACT TAG
          ZR     X0,SAP70    IF SHORT CON, EXPAND TO LONG CON 
          NZ     B6,SAP80    IF IO APL, ENTER IN APL DIRECTLY 
          PL     X3,SAP80    IF NOT FP, ENTER IN APL DIRECTLY 
  
**        PROCESSORS
*         CASE 1) VALUE LOADS FOR ARRAYS AND NON-IO FPS    ...SAP20 
*         CASE 2) ADDERESS LOADS AND IO LENGTH FOR FP/LCM  ...SAP30 
*         CASE 3) NON-ARY INTERMEDIATES                    ...SAP50 
*         CASE 4) NON-IO SHORT CONSTANTS                   ...SAP70 
*         CASE 5) EVERYONE ELSE: MOST COMMON CASE          ...SAP80 
* 
*         ENTRY  (X1) = ARGUMENT STATUS WORD/OPERAND
*                (X5) = ARGUMENT OPERAND
*                (B6) = IO INDICATOR
* 
*         EXIT   (X1) = TAG AND BIAS WORD TO REFORMAT AND ENTER IN APL
*                (B5) = ORDINAL OF PLUG/STORE SKELETON OR -1. 
*                (B7) = APLIST PLUG INDICATOR: 1 IF PLUG, ELSE 0
  
**        ARRAY AND NON-IO FP PROCESSOR 
*         SELECTS A STORE SKELETON WHICH PLUGS THE ADDRESS
*         OF THE ARG IN THE APLIST. GENTEATED L OPERANDS ARE
*         CONSTRUCTED.
  
 SAP20    =X2    1
          SA3    APLEN       GET CURRENT APL LENGTH FOR BIAS OF GL
          LX2    P2.ADDRP 
          BX5    X2+X5       SET ADDRESS BIT OF ARGUMENT
          AX3    B6          IF IO, DIVIED APLIST LENGTH BY 2 
          SA2    APIND       TAG[GL2] = INDEX IN APLIST INDEX TABLE 
          =X0    B6 
          SX2    X2+K2.AP    ADD IN PREFIX
          LX0    P2=PFX 
          IX2    X2+X0       TAG[GL2] = ORD[GL2] + PFX BASE + OFFSET
          LX3    P2.BIASP    BIAS[GL2] = NUMBER OF ARGUMENTS
          BX7    X1          (X7) = TAG AND BIAS WORD TO PASS TO APL
          LX2    P2.TAGP
          IX2    X2+X3       ADD BIAS INTO GL2 WORD 
          =X4    1           PLUG FLAG ON.
          SB5    W=IPLG0
          EQ     SAP40       DO GL BOOKEEPING AND SELECT SKEL 
  
**        ADDRESS LOADS AND FP/LCM IO LENGTHS 
*         NON-INTERMEDIATE STORE TO TEMP. STORES THE
*         ARGUMENT ADDRESS/VALUE IN TEMP AND THEN PASSEES 
*         THE TEMP TAG AND BIAS TO THE APLIST.
  
 SAP30    SA2    N.ST        GET NUMBER OF TEMPORARYS 
          SA3    S=ST        GET ORDINAL OF TEMPORARY ARRAY 
          =X6    X2+1 
          LX3    P2.TAGP     TAG[GL2] = ORDINAL OF TEMP ARRAY 
          =A6    A2          UPDATE N.ST
          LX2    P2.BIASP    BIAS[GL2] = NUMBER OF TEMPS
          =X4    0           PLUG FLAG IS OFF 
          IX2    X2+X3       ADD GL2 TAG TO BIAS
          MX0    -OP.2MODL
          BX7    X2          (X7) = TAG AND BIAS TO PASS TO APL 
          SB5    W=APSTR
  
**        BRANCH HERE IF SKELETON ALREADY SELECTED
*         (X5) = ARGUEMENT OPERAND
*         (X7) = TAG AND BIAS WORD FOR APL
*         (X2) = NEW STATUS WORD FOR GL2
*         (X4) = APL PLUG INDICATOR 
  
 SAP40    SA7    REG=G+1     SAVE APL TAG, BIAS AS GL2
          =X6    0
          CALL   POS         PREPARE STATUS WORD
          BX2    X5          (X2) = ARG OPERAND WORD
          SA5    REG=G+1     (X5) = APL TAG AND BIAS
          SA6    A5          SET GL2
          =X6    0
          CALL   POS         PROCESS OPERAND AND STATUS WORD
          SA6    REG=G       SET (GL1) = ARG
          SB7    X4          (B7) = STORE TO FLAG 
          BX1    X5          (X1) = APL TAG AND BIAS
          EQ     SAP90
  
**        NON-ARY INTERMEDIATE CASE 
*         STORE TO TEMP WHENEVER THE INTERMEDIATE IS STILL
*         IN A REGISTER.
*         THE SECOND GST SERVES TWO PURPOSES: 
*         1) IT ACTUALLY DOES CHECK THE REG STATUS FOR
*            COMPLEX AND DOUBLE PRECISION INTERMEDIATES.
*         2) IT PRODUCES A STATUS WORD WITH A TAG AND BIAS
*            SUITABLE FOR APL USE.
* 
*         (B2) = 0 IFF UPPER HALF IS NOT IN A REG.
  
 SAP50    SB3    0           TYPE=UPPER 
          CALL   STS         SET TAG STATUS (DECREMENT USE COUNT) 
          ZR     B2,SAP55    IF NOT IN REG
          BX6    X5 
          SA6    REG=G       SAVE OPERAND IN GENERATED OP TAB 
          CALL   CWI         STORE TO TEMPORARY 
          SA5    REG=G       RESTORE OPERAND
 SAP55    =B2    1           LOWER HALF 
          =B7    0           PARTIAL STATUS 
          CALL   GST         GET STATUS OF LOWER HALF 
          SB3    1           SET TYPE = LOWER 
          CALL   STS         SET TAG STATUS (DECREMENT USE TOTAL) 
          BX6    X1 
          SA6    REG=G       SAVE STATUS WORD IN G-OPERAND TABLE
          ZR     B2,SAP60    IF LOWER PART NOT IN REG/EXISTANCE 
          CALL   CWI         WRITE LOWER PART TO TEMPORARY
 SAP60    SA1    REG=G       (X1) = TEMP TAG, BIAS FOR APL
          =B7    0           PLUG FLAG OFF
          =B5    -1          INDICATE NO SKEL CALL
          EQ     SAP90
  
  
**        SHORT CON CASE
*         DIFFERS ONLY FROM REGULAR CASE IN THAT SHORT
*         CON MUST BE CONVERTED TO LONG CONS. THEY ARE
*         THEN PASSED ON AS FOR REGULAR PROCESSING. 
  
 SAP70    RJ     ESC         EXPAND SHORT CONSTANT
          LX1    P2.TAGP
          LX3    P2.BIASP 
          BX1    X1+X3
  
  
**        MAIN CASE 
*         SET FLAGS AND PASS TAG AND BIAS WORD TO APL 
  
 SAP80    SB5    -1          NO SKEL CALLS
          SB7    0           PLUG FLAG OFF
  
 SAP90    SA5    ATF         RESET APLIST TYPE FLAG 
          RJ     AAP
          SX6    B5          GET SKELETON 
          PL     B5,SUB.RET  PROCESS SKELETON 
  
**        O=APRET - RETURN FROM APLIST SUBSKELS 
*                THIS IS A DUMMY SO THAT SKELETONS CAN
*                PROCESS LIKE SUBROUTINES.
  
  
 O=APRET  BSSENT 0           SUB SKEL RETURN
          EQ     EXIT.       EXIT POINT FOR SAP 
 SAS      SPACE  4,10 
**        SAS - STACK APLIST STRUCTURES 
*         APLEN, APTAB, APIND, AND ATF ARE INITIALIZED HERE 
* 
*         ENTRY  (LEVEL) = CURRENT STACK DEPTH
* 
*         EXIT   (LEVEL) = NEW STACK DEPTH
*                (B6) = (LEVEL) 
*                (APLEN) = 0
*                (APTAB) = T.SAP OR PASSED VALUE
*                (APIND) = APL NUMBER FOR - SA1  AP.(APIND) - 
*                (ATF) = 0
*                (APLEN+(LEVEL)-1),(APTAB+(LEVEL)-1),...= THE  VALUES OF
*                (APLEN),(APTAB),...RESP. UPON ENTRY TO SAS.
* 
*         USES A1,A2,A3,A6   X1,X2,X3,X6   B6 
  
  
 SAS      SUBR               ENTRY/EXIT.
          SA3    LEVEL       GET CURRENT STACK DEPTH
          =B6    X3+1        (B6) = NEW LEVEL 
  
 .STACK   ECHO   ,P=(APLEN,APTAB,APIND,ATF)    P(LEVEL) = P(0)
          SA2    P
          BX6    X2 
          SA6    A2+B6
 .STACK   ENDD
  
**        INITIALIZE VALUES 
  
          SX6    B6 
          SA6    A3          RESET LEVEL
          SB5    T.API       APLIST INDEX POINTER 
          SB6    T.SAP       APLIST TABLE POINTER WORD
          RJ     IAS         INITIALIZE APLIST STRUCTURES 
          EQ     EXIT.
 SCI      SPACE  4,10 
**        SCI - STORE TO CHARACTER ITEM 
*         THIS ROUTINE SETS UP A GENERATED L OPERAND AND
*         SELECTS A STORE SKELETON THAT PERSERVES AND 
*         REPLACES THE FIELDS REQUIRED BY A PARTICULAR
*         ITEM. 
* 
*         ENTRY  NONE 
* 
*         EXIT   PLUG CODE WRITTEN TO PRE-BINARY
* 
*         USES - ALL BUT B4 
* 
*         CALLS EIS 
  
  
 SCI      SUBR               ENTRY/EXIT 
          SA5    ATF
  
**        CONSTRUCT GENERATED L OPERAND 
  
          SA3    APLEN       GET INDEX OF CURRENT ITEM IN APLIST
          SB6    X5 
          AX3    B6          LEN/2 IFF IO 
          SX6    X5+K=AP     TAG PFX = K=AP+IO[ATF]V
          LX3    -P2.TAGP+P2.BIASP
          SA1    APIND       GET CURRENT APLIST NUMBER
          LX6    P2=PFX 
          IX6    X1+X6       TAG = LIST NUMBER + PREFIX 
          IX2    X6+X3       ADD TAG AND BIAS (APLEN) 
          LX2    P2.TAGP
          =X6    0           SET USE COUNT INCREMENT
          CALL   POS         PERPARE OPERAND STATUS WORD
          SA6    REG=G       SET GL1 CELL 
  
**        NOW CHOOSE A SKELETON 
*         (X5) = ATF
  
          BX0    X5 
          LX0    -AT.NULP 
          =X3    -1          SET BIT-0 MASK 
          LX5    59-AT.IOP   POSITION IO BIT
          BX2    -X3*X0      EXTRACT NUL BIT
          AX5    59          SIGN EXTEND IO BIT 
          =X6    X2+CIO      (X6)=2*NUL + CSKTAB IO OFFSET
          BX6    X5*X6       CLEAR IF NOT IO
          SA2    X6+CSKTAB   GET PLUG SKELETON
          SX6    X2 
          EQ     SUB.RET
  
 O=SCRET  BSSENT 0           CHARACTER STORE SKELETON RETURN
          SB7    1           SET STORE FLAG TO AAP
          EQ     EXIT.
  
 CSKTAB   BSS    0
          LOC    0
 CUSR     CON    W=CAPST     USER 
 CIO      CON    W=CIS0S     IO SCALAR LEVEL 0
          CON    W=CIA0S     IO ARRAY LEVEL 0 
          LOC    *O 
 SSC      SPACE  4,10 
**        SSC - SET STATUS OF CHARACTER 
*         HERE WE SAVE PERTINENT INFORMATION ABOUT CHARACTER
*         OPERANDS.  OF INTEREST IS:  
*                CAC ORDINAL IN P2.BIAS FIELD 
*                EQIVALENCE CLASS ORDINAL IN P2.TAG FIELD 
*                ORIGINAL SYMBOL TABLE ENTRY IN ST.ORD1 FIELD 
*                CAC BIT IS SET (P2.CACP) 
* 
*         ENTRY  (X3) = EQUIV CLASS BASE ORDINAL
*                (X5) = OPD 
*                (B7) = CAC ORDINAL / FP NUMBER 
* 
*         EXIT   (A1,X1) _,= STATUS WORD
*                (X3) - PRESERVED 
*                (X5) - PRESERVED 
*                (B7) - PRESERVED 
* 
*         USES   A1,A2,A7 X0,X1,X2,X7  B2 
* 
  
  
 SSC      SUBR               ENTRY/EXIT.
  
.TEST     IFEQ   TEST,ON
          MX0    -P2.USEL 
          BX0    -X0*X5      EXTRACT USE COUNT
          ZR     X0,"BLOWUP"
.TEST     ENDIF 
  
          BX7    X5 
          SA2    T.OUS       GET FWA I. L.
          AX7    P2.TAGP     POSITION OUS ORDINAL 
          SB2    X2 
          LX3    P2.TAGP     POSITION EQUIV CLASS ORD 
          SX0    B7 
          SA1    B2+X7       GET STATUS WORD
          LX0    P2.BIASP    POSITION CAC ORD./FPNO 
          CLAS=  X2,P2,TAG
          IX0    X3+X0       MERGE EQV BASE ORD AND CAC ORD/FPNO
          BX7    X2*X1       EXTRACT SYM ORD OF OPD 
          CLAS=  X2,P2,(TAG,BIAS) 
          BX1    -X2*X1      CLEAR TAG AND BIAS 
          CLAS=  X2,ST,(ORD1) 
          BX1    -X2*X1      CLEAR OLD SYM TAB ORDINAL FIELD
          LX5    -P2.FPP
          LX7    -P2.TAGP+ST.ORD1P POSITION ORIGINAL SYM ORD
          =X2    1
          BX2    -X5*X2      (X2) = FP[OPD] 
          BX0    X0+X7       MERGE ORD1 (OLD SYM TAB ORD) INTO STAT. WD.
          LX3    -P2.TAGP    RESET X3 
          LX2    ST.CACP
          BX7    X0+X2       MERGE IN CAC BIT 
          LX5    P2.FPP 
          BX1    X7 
          SA7    A1 
          EQ     EXIT.
 SUA      SPACE  4,8
**        SUA - STORE UNKNOWN-LENGTH APLIST ADJUSTED TEMP.
* 
*         ENTRY  X1 = STATUS WORD.
  
 O=SURET  BSSENT 0           RETURN FROM SKELETON 
 SUA      SUBR
          LX1    -P2.BIASP
          SB6    X1 
          RJ     DAT         SET UP ST.+K FOR SKEL
          SX6    W=SUA
          EQ     SUB.RET
          SPACE  4,10 
**        GLOBAL DATA CELLS FOR FUN 
  
**        WALK CELLS
  
 LEAF     BSSZ   1
 LNK.CUR  BSSZ   1
 LNK.LST  BSSZ   1
  
**        SAVE CELLS
  
 FUN.CUR  BSS    1           CURRENT SKELETON POINTER 
*CALL COMFSCB 
  
**        COUNTERS,  POINTERS AND FLAGS 
  
 APLFLG   BSSENT 0
 APLEN    BSSZ   3           LENGTH OF CURRENT APLIST 
 APIND    BSSZ   3           INDEX INTO INDEX TABLE 
 APTAB    BSSZ   3           42/INDEX[FW LIST],18/TABLE PTR WORD (T.) 
 ATF      BSSZ   3           APLIST TYPE FUNCTION (CONTROLS IA. FORMAT) 
  
 CLEN     BSSZ   1           LENGTH COUNTER FOR GENERATED APLISTS 
  
 FAF      BSSZ   1           FIRST APLIST FLAG
  
 DEFDIF   BSSZ   1           DEFERED TURPLE POINTER DIFERENCE 
 COLDIF   BSSZ   1           COLIN TURPLE POINTER DIFFERENCE
  
 LEVEL    BSSZ   1           STACK DEPTH INDICATOR
 L.APLF   EQUENT *-APLFLG 
          SPACE  4,8
          LIST   D
          END 
