TITLE 'INDX-B00,10/10/73,DWG702985' PAGE * * * E X T E R N A L C O M M U N I C A T I O N * * * DEFINITIONS * DEF AXDRIVER INDEXED ASSIGNMENT EXEC DRIVER DEF COORDK K'TH COORDINATE SPEC DEF DBUFEND DIMENSION BUFFER END DEF DCATEN DYADIC CATENATE OP ROUTINE DEF DCOMPRES DYADIC COMPRESS OP ROUTINE DEF DDROP DYADIC DROP OP ROUTINE DEF DEXPAND DYADIC EXPAND OP ROUTINE DEF DROTATE DYADIC ROTATE OP ROUTINE DEF DTAKE DYADIC TAKE OP ROUTINE DEF DTRANS DYADIC TRANSPOSE OP ROUTINE DEF EXCHLUPS EXCHANGE MIDDLE/INNER LOOPS DEF GSCLRVAL GET INTEGER SCALAR VALUE DEF INDX@ START OF PROCEDURE DEF INDXLDLR INDEXED LOAD LOGICAL RIGHT DEF INERCNT INNER LOOP COUNT DEF INERSTEP INNER LOOP STEP SIZE DEF MAXDIMEN MAXIMUM NUMBER OF DIMENSIONS DEF MBUFDIMS MOVER BUFFER DIMENSIONS TO RS DEF MIDLCNT MIDDLE LOOP COUNT DEF MIDLSAVE MIDDLE LOOP SAVE TEMP DEF MIDLSTEP MIDDLE LOOP STEP SIZE DEF MREVERSE MONADIC REVERSE OP ROUTINE DEF MRTDIMS MOVER RT ARG DIMENSIONS TO RS DEF MTRANS MONADIC TRANSPOSE OP ROUTINE DEF OUTRCNT OUTER LOOP COUNT DEF OUTRSAVE OUTER LOOP SAVE TEMP DEF OUTRSTEP OUTER LOOP STEP SIZE DEF RSLIKRT1 ALOC RESULT LIKE RTARG DEF RSLIKRT2 ALOC RESULT LIKE RTARG U10-0004 DEF SETSPEC1 SPECIAL ADR SETUP DEF SETSPEC2 SPECIAL ADR SETUP DEF ST3LUPSN SET UP LOOP PARAMS, NO ALOC DEF SXDRIVER SUBSCRIPTED EXPRESSION EXEC DRIVER DEF XSETUP SET UP ADR FOR INDEXED LOAD * * REFERENCES * REF ALOCHNW ALLOCATE HEADER AND N WORDS REF ALOCRS ALLOCATE RESULT DATA BLOCK REF AXRETURN INDEXED ASSIGNMENT EXEC RETURN REF BITMASK BIT SELECTION MASK TABLE REF DREF DE-REF ERCOORD EQU ERRANK COORDINATE SPECIFICATION ERROR REF ERDOMAIN DOMAIN ERROR REF ERINDEX INDEX RANGE ERROR REF ERLENGTH LENGTH ERROR REF ERRANK RANK ERROR REF EXECUTE EXECUTE XSEG REF FLOT0 FLOATING PT 0.0 REF F2I CONVERT F TO I REF GENLOAD GEN LOAD BY RSTYPE REF GENLOADT GEN LOAD TO TEMP REF GXSEGINI GEN XSEG INITIALIZATION REF GXSTEXEC GEN XSEG STORE; EXECUTE XSEG REF INBUF INPUT BUFFER (USED AS TEMP BUFFER) REF INDXTMPS INDX TEMPS ARE IN WINDOW IN APLUTSI U10-0006 REF LBLOCK LOOP CONTROL BLOCK PNTR REF LFADR LEFT ARG ADDRESS REF LFARG LEFT ARG PNTR REF LFLGLADR LEFT LOGICAL DATA ADR REF LFLGLCNT LEFT LOGICAL BIT COUNT REF LFRANK LEFT ARG RANK REF LFSIZE LEFT ARG SIZE REF LFTYPE LEFT ARG TYPE REF LOADINST LOAD INSTRUCTION TABLE, BY TYPE REF LOOPLOC LOOP LOCATION REF MNOP MONADIC NO OP ROUTINE REF NILCK 'NIL CHECK' = SCRIPT LIST PNTR SCRIPT EQU NILCK SUBSCRIPT LIST POINTER REF OPER OPERATOR WORDS REF ORGADJ ORIGIN, ADJUSTED (=1-ORG) REF ORIGIN INDEX ORIGIN VALUE (0 OR 1) REF RESULT RESULT DATA BLOCK POINTER REF RETURN RETURN ADR CELL REF RSADR RESULT ADDRESS REF RSRANK RESULT RANK REF RSSIZE RESULT SIZE REF RSTYPE RESULT TYPE REF RTADR RIGHT ARG ADDRESS REF RTARG RIGHT ARG PNTR REF RTRANK RIGHT ARG RANK REF RTSIZE RIGHT ARG SIZE REF RTTYPE RIGHT ARG TYPE REF SETADR SET UP ADDRESS, SEQUENTIAL REF SETADRS1 SET UP ADDRESSES, SEQUENTIAL REF SETUPARG SET UP ARG PARAMS REF STORINST STORE INST TABLE REF SXRETURN SUBSCRIPTED EXP EXEC DRIVER RETURN REF SYSTERR SYSTEM ERROR REF TYCOMPAT TYPE COMPATIBILITY CHECK REF VECTORRS ALOCATE VECTOR RESULT REF XSEGBASE BASE OF XSEG AREA PAGE * * * A S S E M B L Y P A R A M E T E R S * * SYSTEM SIG5F PROGSECT CSECT 1 INDX@ RES 0 START OF PROCEDURE * * REGISTERS * IX EQU 0 EVEN/ODD PAIR IX1 EQU 1 * N EQU 1 XSEG EXECUTION REG N1 EQU 4 XSEG EXECUTION REG K1 EQU 4 XSEG EXECUTION REG N2 EQU 11 XSEG EXECUTION REG N3 EQU 10 XSEG EXECUTION REG X EQU 1 SCRIPT POINTER T EQU 2 TYPE REG NX EQU 3 COUNT REG XL EQU 3 XSEG LOC REG K EQU 2 SUBSCRIPT VALUE KB EQU 3 B-BLOCK POINTER KN EQU 8 LOOP COUNT KV EQU 9 ARRAY LOOP OFFSET KL EQU 10 LINK REG A EQU 4 ARG ADR/INDEX LZ EQU 4 INDEX LINK REG LX EQU 5 INDEX LINK REG OP EQU 6 OP CODE REG AF EQU 6 ACCUM FOR FLOT VALUES AF1 EQU 7 * LX7 EQU 7 INDEX LINK REG AI EQU 7 ACCUM FOR LOGL/CHAR/INTG VALUES BUF EQU 7 BUFFER FOR MOVING DATA/CODE GROUPS R EQU 8 GENERAL WORK REG BI EQU 9 2ND ACCUM FOR L/C/I VALUES S EQU 11 SIZE L3 EQU 12 LINK REG L2 EQU 13 LINK REG L1 EQU 14 LINK REG R15 EQU 15 * * ARG TYPE CODES * LOGL EQU 1 LOGICAL (BIT) CHAR EQU 2 CHARACTER (BYTE) INTG EQU 3 INTEGER (WORD) FLOT EQU 4 FLOATING (DOUBLEWORD) ISEQ EQU 5 INDEX SEQUENCE VECTOR LIST EQU 6 LIST * * CODESTRING DESIGNATIONS * DOPCMPRS EQU 84 DYADIC COMPRESS DOPCATEN EQU 87 DYADIC CATENATE/LAMINATE DOPTAKE EQU 116 DYADIC TAKE * * B-BLOCK STRUCTURE PARAMETERS * BN EQU 6 B BLOCK ITEM SIZE BSTEPVAL EQU 0 OFFSET TO STEP VALUE BINITOFS EQU 0 OFFSET TO INITIAL OFFSET VALUE BINITCNT EQU 1 OFFSET TO INITIAL COUNT BNULLCNT EQU 1 OFFSET TO NULL GROUP COUNT BSCRIPT EQU 2 OFFSET TO SCRIPT SAVE LOC BOFFSET EQU 2 OFFSET TO OFFSET SAVE LOC BCOUNT EQU 3 OFFSET TO COUNT SAVE LOC BADDEND EQU 4 OFFSET TO ADDEND VALUE BNULTEST EQU 4 OFFSET TO NULL TEST VALUE BLOOPTYP EQU 5 OFFSET TO LOOP TYPE CODE * SEQLOOP EQU 0 SEQUENCE LOOP ARAYLOOP EQU -1 ARRAY LOOP MIXLOOP EQU -2 MIXED SEQUENCE LONP LOPBIAS EQU -2 LOOP TYPE CODE BIAS * * DIMENSION BUFFER PARAMETERS * MAXDIMEN EQU 63 MAXIMUM NUMBER OF DIMENSIONS DIMENBUF EQU XSEGBASE DIMENSION BUFFER START DBUFEND EQU DIMENBUF+MAXDIMEN DIMENSION BUFFER END * * MISCELLANEOUS PARAMETERS * INFINITY EQU 1**19-1 PLUS INFINITY (FOR 'LI') LAMBIT EQU X'40' LAMINATE BIT PAGE * * * P R O C S * * TLOC SET 0 U10-0008 * TEMP CNAME 1 DTEMP CNAME 2 PROC DO1 NAME=2 TLOC SET TLOC+(TLOC&1) U10-0011 DISP TLOC U10-0012 LF EQU INDXTMPS+TLOC U10-0013 TLOC SET TLOC+NAME U10-0014 PEND * * EVEN CNAME 0 ODD CNAME 1 PROC LF EQU % ERROR,1,(CF(2)+NAME)&1 'REGISTER HAS WRONG PARITY' PEND * * EQUAL CNAME PROC LF EQU % ERROR,1,1-(CF(2)=CF(3)) 'REGISTERS MUST BE EQUAL' PEND * * EXCHANGE CNAME OPEN I,K,GROUP GROUP EQU LFARG,LFTYPE,LFSIZE,LFRANK,LFADR PROC LF EQU % I DO NUM(AF) K SET SCOR(AF(I),ARGS,TYPES,SIZES,RANKS,ADRS) ERROR,1,K=0 'UNKNOWN GROUP INDICATOR' LW,R GROUP(K) XW,R GROUP(K)+1 STW,R GROUP(K) FIN PEND CLOSE I,K,GROUP * * ISEQFIX CNAME PROC LF CI,CF(2) ISEQ BNE %+2 LI,CF(2) INTG PEND PAGE * * * XSEG GEN PROCS * * OPEN GEN GEN CNAME OPEN M,N,MN,I PROC LF EQU % ERROR,1,1-(NUM(CF)=3) 'WRONG NUMBER OF CF ARGS' M SET CF(2) N SET CF(3) MN SET M+N ERROR,1,1-(NUM(AF)=(M>0)+(N>0)) 'WRONG NUMBER OF AF ARGS' DO M>0 I DO N LW,AF(1)+M+I-1 AF(2)+I-1 FIN I DO MN*(MN<3) STW,AF(1)+I-1 I-1,XL ELSE LCI MN STM,AF(1) 0,XL FIN ELSE I DO MN*(MN<3) LW,BUF AF(1)+I-1 STW,BUF I-1,XL ELSE LCI N LM,BUF AF(1) STM,BUF 0,XL FIN FIN AI,XL MN PEND CLOSE M,N,MN,I PAGE * * * TABLE BUILDING PROCS * * TABLE CNAME OPEN T,N PROC T SET %-AF(1) LF EQU T DISP T PEND * * ITEM CNAME PROC N SET T+AF(1)-% ERROR,1,N<0 'ITEM OUT OF SEQUENCE' RES N*(N>0) DISP AF(1) PEND CLOSE T,N PAGE * * * O P E R A T O R E X E C U T I O N D R I V E R S * * USECT PROGSECT * * * SUBSCRIPTED EXPRESSION EXECUTION DRIVER * * ENTERED WITH SUBSCRIPT LIST POINTER IN 'SCRIPT' AND * POINTER TO EXPRESSION-TO-BE-SUBSCRIPTED IN 'LFARG'. * IF NO ERRORS OCCUR, IT RETURNS TO 'SXRETURN' WITH * RESULT POINTER IN 'RESULT', AND 'SCRIPT' DE-REFFED. * LEFT ARG POINTER WILL HAVE BEEN MOVED TO 'RTARG', * WHICH, ALONG WITH 'LBLOCK', STILLS NEEDS TO * BE DE-REFFED. * * SXDRIVER EQU % SUBSCRIPTED EXPRESSION EXEC DRIVER LI,A SXRETURN SET UP RETURN ADDRESS STW,A RETURN EXCHANGE ARGS PUT ARG PNTR IN RTARG. BAL,L2 INDEXA BUILD LOOP CONTROL BLOCK FROM * SCRIPT LIST; SET SIZE/RANK. LB,T *RTARG CI,T LIST DISALLOW LIST INDEXING BGE ERDOMAIN ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ STW,T RSTYPE SET TYPE * ALSELECT EQU % LW,S RSSIZE BAL,L1 ALOCRS ALLOCATE RESULT DATA BLOCK BAL,LX MBUFDIMS MOVE DIMENS FROM BUFFER TO RS MTSELECT EQU % LI,X -1 BAL,LX SETADR SET RSADR FOR SEQUENTIAL STORE BAL,LX GXSEGINI GEN XSEG INIT; EXIT IF RESULT NULL GEN,0,1 BAL1STSC GEN: BAL,L1 1STSCRPT LI,A 1 BAL,LX XSETUP SET RTADR FOR INDEXED LOAD LB,T *RTARG AW,R LOADINST,T GEN INDEXED LOAD GEN,1,0 R LI,A NXTSCRPT SET TO LOOP BACK TO 'NXTSCRPT' STW,A LOOPLOC B GXSTEXEC GEN STORE/LOOP CONTROL; EXECUTE * * * XSEG CODE: U10-0016 * U10-0017 * U10-0018 * LCW,N RSSIZE INIT STORE INDEX U10-0019 BAL1STSC BAL,L1 1STSCRPT 1ST SCRIPT CALL INST * LOAD RTARG(K) LOAD SELECTED ARG ELMT U10-0021 * STORE RESULT(N) STORE IN RESULT U10-0022 * BIR,N NXTSCRPT BUMP N, GET NEXT K U10-0023 * B *RETURN EXIT WHEN RESULT FILLED U10-0024 PAGE * * * INDEXED ASSIGNMENT EXECUTION DRIVER * * ENTERED WITH SUBSCRIPT LIST POINTER IN 'SCRIPT', * POINTER TO INDEXED VARIABLE (ON LEFT SIDE OF ASSIGNMENT * ARROW) IN 'LFARG', AND POINTER TO THE VALUE-TO-ASSIGN * IN 'RTARG'. IF NO ERROR OCCUR, IT RETURNS TO 'AXRETURN' * WITH RESULT POINTER (VALUE OF THE 'LFARG' VARIABLE, * AFTER THE INDEXED ASSIGNMENT) IN 'RESULT', AND 'SCRIPT' * DE-REFFED. 'LBLOCK' STILL NEEDS TO BE DE-REFFED. * AXDRIVER EQU % INDEXED ASSIGNMENT EXEC DRIVER LI,A AXRETURN SET RETURN ADR STW,A RETURN EXCHANGE ARGS SWAP ARGS BAL,L2 INDEXA BUILD LOOP CONTROL BLOCK FROM * SCRIPT LIST; SET SHAPE PARAMS. LI,A 0 SET UP PARAMS FOR BAL,LX SETUPARG VALUE TO BE ASSIGNED. LI,A 1 SET UP PARAMS FOR BAL,LX SETUPARG IND.VAR. BAL,LX TYCOMPAT MAKE SURE THE TYPES ARE COMPATIBLE, B ERDOMAIN PUT HIGHEST TYPE IN RSTYPE. LW,S RSSIZE SET SCRIPT SIZE (NUMBER STW,S SCRPTCNT OF SCRIPT VALUES). LI,S 1 CW,S LFSIZE IF ASSIGN VALUE IS 1-ELMT, BE 14Z2 SKIP RANK/DIMEN CHECKS. LI,AI 1 10-00071 LW,A LFARG SET UP TO COMPARE DIMENS OF ASSIGN 10-00072 LW,R LFRANK VALUE AND SUBSCRIPT STRUCTURE. 10-00073 AI,R 1 EXCEPT FOR 1'S (WHICH ARE SKIPPED 10-00074 LCW,K RSRANK OVER), THESE DIMENS MUST MATCH. 10-00075 AI,K -1 10-00076 14Z10 BDR,R 14Z13 GET A DIMEN FROM ASSIGN VALUE 10-00077 14Z11 BIR,K 14Z12 NO MORE: REMAINING SCRIPT B 14Z2 DIMENS MUST ALL BE 1'S. 10-00079 14Z12 CW,AI DBUFEND,K 10-00080 BE 14Z11 10-00081 B ERRANK 10-00082 14Z13 LW,S 2,A (NEXT ASSIGN-VALUE DIMEN) 10-00083 AI,A 1 10-00084 CI,S 1 IF IT'S 1, SKIP IT AND GET ANOTHER 10-00085 BE 14Z10 10-00086 14Z14 BIR,K 14Z15 GET NEXT SCRIPT DIMEN B ERRANK (THERE HAD BETTER BE ONE) 10-00088 14Z15 CW,AI DBUFEND,K IF IT'S 1, SKIP IT & GET NEXT 10-00089 BE 14Z14 10-00090 CW,S DBUFEND,K BOTH DIMENS NON 1: THEY 10-00091 BE 14Z10 ARE REQUIRED TO AGREE. 10-00092 B ERLENGTH 10-00093 14Z2 LW,S SCRPTCNT IF INDEX NULL,SET RESULT= 10-00061 BEZ MNOP INDEXED VARIABLE. LW,OP LFTYPE TEST FOR SPECIAL CASE: U10-0026 CW,OP RTTYPE ALLOW ONLY IF LFARG IS CONVERTIBLEU10-0027 BG 14Z21 TO RTARG'S TYPE, U10-0028 LI,OP ISEQ RT ARG IS NOT AN ISEQ, CW,OP RTTYPE BE 14Z21 LW,A RTARG U10-0029 LW,R 1,A AND RTARG IS RE-USABLE AS RESULT U10-0030 AI,R -2 (I.E., ITS REF COUNT IS 2). U10-0031 BNEZ 14Z21 NO GOOD U10-0032 * GOOD: CONDITIONS FOR THE SPECIAL U10-0033 * CASE HAVE BEEN MET. WE'LL NOW U10-0034 * USE RTARG FOR THE RESULT. U10-0035 LI,OP -100 SIGNAL TO GEN SPECIAL CODE U10-0036 MTW,1 1,A CREATE NEW COPY OF RTARG PTR U10-0037 STW,A RESULT USE IT FOR RESULT PTR U10-0038 B 14Z22 JOIN GENERAL CASE U10-0039 14Z21 EQU % GENERAL CASE: ALOC NEW RS BLOCK U10-0040 BAL,L1 RSLIKRT2 ALOC RS WITH SHAPE = IND.VAR.SHAPE BAL,LX MRTDIMS MOVE IND.VAR. DIMENS TO RESULT 14Z22 LW,S RTSIZE IF IND.VAR. IS NULL, U10-0042 BEZ *RETURN THEN SO IS RESULT. LI,X -3 BAL,LX SETADR ST LFADR FOR SEQ LOAD (N) LI,A 1 BAL,LX XSETUP SET RTADR FOR INDX LOAD (K) LI,A 2 BAL,LX XSETUP SET RSADR FOR INDX STORE (K) LI,XL XSEGBASE PREPARE TO GEN XSEG CODE LI,S 1 CW,S LFSIZE IF ASSIGN VALUE IS 1-ELMT, BNE 14Z3 LI,A 0 GEN LOAD/CONVERT ASSIGN BAL,L2 GENLOADT VALUE TO TEMP. 14Z3 BIR,OP 14Z4 JUMP IF SPECIAL CASE U10-0044 STW,XL LOOPLOC GENERAL CASE U10-0045 GEN,0,9 CODE7 GEN K-LOOP CONTROL AWM,XL -7,XL B 14Z5 JOIN SPECIAL CASE U10-0047 14Z4 GEN,0,1 BAL1STSC SPECIAL CASE: SIMPLER K-LOOP CONTROLU10-0048 14Z5 EQU % COMMON CODE U10-0049 LI,A 0 GEN LOAD/CONVERT OF ASSIGN-VALUE BAL,L1 GENLOAD ELMT FOR SELECTED POSITION. LW,T RSTYPE LW,R STORINST,T SET UP STORE INST AW,R RSADR BIR,OP 14Z6 JUMP IF SPECIAL CASE U10-0051 STW,R TEMP GEN,1,4 R,CODE8 GEN N-LOOP CONTROL LW,X LOOPLOC AWM,X -1,XL FILL IN BRANCH ADR AWM,XL 6,X LI,A 1 GEN LOAD/CONVERT OF IND.VAR. TO BAL,L1 GENLOAD FILL IN NON-SELECTED ELMTS. LW,R TEMP GEN,1,1 R,CODE11 GEN STORE/N-LOOP CONTROL 3 LW,X LOOPLOC AWM,X -1,XL FILL IN BRACH ADR * LI,R -1 PREPARE FOR XSEG EXECUTION: STW,R KTEMP 'OLD K' = -1, B 14Z7 JOIN SPECIAL CASE U10-0053 14Z6 GEN,1,3 R,CODE13 SPECIAL CASE: SIMPLER STORE CONTROL U10-0054 14Z7 EQU % COMMON CODE U10-0055 LCW,N LFSIZE N = ASSIGN-VALUE INDEX LW,N2 SCRPTCNT N2 = NUMBER OF SCRIPT VALUES BIR,OP XSEGBASE IF SPECIAL CASE, DONT ALLOW BREAKS U10-0057 B EXECUTE * KTEMP EQU TEMP SCRPTCNT EQU INERCNT * * * XSEG CODE: * * LOAD/CNV LFARG (ONLY IF LFARG IS U10-0059 * STORE LFTEMP 1-ELEMENT). CODE7 BAL,L1 1STSCRPT GET INDEX (K) OF 1ST SELECTED ELMT CW,K KTEMP IF NEW INDEX <= PREVIOUS BLE 0 (LOOP1) ONE, GO BACK & STORE IN IT. XW,K KTEMP SWAP W/INDEX OF PREVIOUS SEL.ELMT AI,K 1 IF THERE'S A GAP, CW,K KTEMP BNE 0 (LOOP2) GO FILL IN WITH IND.VAR. VALUES. CW,K RSSIZE IF THIS IS THE FINAL FILL-OUT BGE *RETURN PASS, STOP WHEN FULL. *LOOP1 LOAD/CNV LFARG(N) FETCH NEXT ELMT OF ASSIGN-VALUE * STORE RESULT(K) STORE ASSIGN-VALUE ELMT CODE8 AI,N 1 BUMP ASSIGN-VALUE INDEX BDR,N2 NXTSCRPT GET NEXT INDEX LW,K RSSIZE NO MORE INDECES, SET TO FILL B 3 (XW,K) OUT RESULT W/ IND.VAR. ELMTS. *LOOP2 LOAD/CNV RTARG(K) FETCH IND.VAR. ELMT TO FILL INTO * STORE RESULT(K) NON-SELECTED RESULT POSITION. CODE11 B 4 (AI,K) KEEP FILLING 'TIL WE HIT SELECTED * POSITION, OR FILL UP RESULT. * U10-0061 * U10-0062 * XSEG CODE FOR SPECIAL CASE (RTARG=RESULT): U10-0063 * U10-0064 * LOAD/CNV LFARG (ONLY IF LFARG IS U10-0065 * STORE LFTEMP 1-ELEMENT). U10-0066 * BAL,L1 1STSCRPT GET 1ST K-VALUE U10-0067 * LOAD/CNV LFARG(N) GET NEXT ELEMENT OF ASSIGN VALUE U10-0068 * STORE RESULT(K) STORE INTO SELECTED RESULT POSITION U10-0069 CODE13 AI,N 1 BUMP LOAD INDEX U10-0070 BDR,N2 NXTSCRPT GET NEXT K-VALUE U10-0071 B *RETURN EXIT WHEN ALL K-VALUES USED U10-0072 PAGE * * * M O N A D I C I N D E X I N G O P R O U T I N E S * * MTRANS EQU % MONADIC TRANSPOSE LI,A 1 BAL,LX SETUPARG SET UP RT ARG PARAMS LW,S RTRANK GET ARG RANK CI,S 1 IF ARG IS A SCALAR OR VECTOR, BLE MNOP RESULT = ARG. BAL,L2 INDEXB RANK>=2: ALOC LOOP CONTROL BLOCK BAL,L1 RSLIKERT ALOC RESULT DB LIKE ARG DB LW,KB OUTRBLOK PREPARE TO SET UP LOOP CONTROLS LI,OP SEQLOOP LOOP TYPE = SEQUENCIAL LI,S 1 FIRST STEP VAL = 1 LW,A RESULT INCREASING DIMEN INDEX LW,X RTRANK DECREASING DIMEN INDEX AND COUNTER MTW,1 RTARG POINT TO ARG DIMENS * FOR LOOP(K) ... 22Z1 STW,OP BLOOPTYP,KB TYPE = SEQUENCIAL STW,S BSTEPVAL,KB STEP = D(N)*D(N-1)*...*D(N+2-K) LW,R *RTARG,X STW,R BINITCNT,KB COUNT = D(N+1-K) STW,R 2,A SET K'TH RESULT DIMEN = D(N+1-K) MW,S *RTARG,X UPDATE STEP VALUE: MULT BY D(N+1-K) AI,A 1 BUMP INCREASING DIMEN INDEX AI,KB +BN BUMP TO NEXT HIGHER LOOP BLOCK BDR,X 22Z1 BUMP DECREASING DIMEN INDEX, COUNT MTW,-1 RTARG CORRECT ARG POINTER B MTSELECT USE LOOP CONTROL BLOCK TO PICK * RESULT ELEMENTS IN CORRECT ORDER. PAGE * * MREVERSE EQU % MONADIC REVERSE LB,T *RTARG GET ARGUMENT TYPE CI,T LIST BGE ERDOMAIN DISALLOW LIST OR ABOVE CI,T ISEQ IS IT AN ISEQ BNE 23Z1 NO, FORGET IT. LB,S OPER+1 CHECK FOR COORDINATE SPEC. BDR,S ERCOORD ERROR IF GREATER THAN 1 LI,S 3 YES, CREATE AN ISEQ RESULT BAL,LX7 ALOCHNW ALOC DATA BLOCK FOR RESULT STW,A RESULT SAVE POINTER LI,R ISEQ**8+1 TYPE=ISEQ, RANK=1 STH,R *RESULT LW,X RTARG GET ARG POINTER LW,S 2,X COMPUTE RESULT BASE VALUE = AI,S 1 A+B*(N+1) WHERE A/B ARE ODD,S MW,S 4,X THE ARG BASE/STEP VALUES. AW,S 3,X LCW,S+1 4,X RESULT STEP = -B LW,S-1 2,X RESULT SIZE = N LCI 3 STORE RESULT SIZE/BASE/STEP STM,S-1 2,A IN RESULT DATA BLOCK. B *RETURN EXIT 23Z1 EQU % ARG NOT ISEQ: PROCEED NORMALLY BAL,L2 SET3LUPS SET UP LOOP PARAMETERS LCW,R MIDLSTEP MIDDLE LOOP STEP = STW,R MIDLSTEP -D(K+1)*...*D(N). AW,R OUTRSTEP FVALUE = STW,R FVALUE (D(K)-1)*(D(K+1)*...*D(N). INDXOP1 LI,A 1 SET UP RT ADR FOR INDEXED LOAD BAL,LX XSETUP LI,X -1 SET UP RS ADR FOR SEQUENTIAL STORE BAL,LX SETADR LI,XL XSEGBASE PREPARE TO GEN XSEG GEN,0,7 CODE1 GEN OUTER/MIDDLE LOOP INIT CODE STW,XL LOOPLOC INNER LOOP LOC HERE LB,T *RTARG LW,R LOADINST,T GEN LOAD OF RIGHT ARG, AW,R RTADR LW,R+1 STORINST,T STORE TO RESULT, AW,R+1 RSADR GEN,2,1 R,AIN1INST INCREMENT OF STORE INDEX. GEN,0,9 CODE3 GEN INNER LOOP CONTROL LW,R LOOPLOC AWM,R -8,XL B EXECUTE EXECUTE XSEG * * XSEG CODE: * CODE1 LCW,N RSSIZE 0 INIT STORE INDEX LW,K FVALUE 1 INIT INDEX LW,N1 OUTRCNT 2 INIT OUTER LOOP STW,K OUTRSAVE 3 SAVE INDEX FOR OUTER LOOP LW,N2 MIDLCNT 4 INIT MIDDLE LOOP STW,K MIDLSAVE 5 SAVE INDEX FOR MIDDLE LOOP LW,N3 INERCNT 6 INIT INNER LOOP * LOAD RTARG(K) LOAD ARG * STORE RESULT(N) STORE RESULT AIN1INST AI,N 1 BUMP STORE INDEX CODE3 AW,K INERSTEP BUMP BY INNER LOOP STEP BDR,N3 0 (INNER LOOP LOC) COUNT INNER LOOP CODE5 LW,K MIDLSAVE RESTORE INDEX FOR MIDDLE LOOP AW,K MIDLSTEP BUMP BY MIDDLE LOOP STEP BDR,N2 XSEGBASE+5 COUNT MIDDLE LOOP LW,K OUTRSAVE RESTORE INDEX FOR OUTER LOOP AW,K OUTRSTEP BUMP BY OUTER LOOP STEP BDR,N1 XSEGBASE+3 COUNT OUTER LOOP B *RETURN EXIT PAGE * * * D Y A D I C I N D E X I N G O P R O U T I N E S * * DROTATE EQU % DYADIC ROTATE BAL,LX LISTCHK CHECK ARGUMENTS FOR LIST BAL,L2 SET3LUPS SET UP LOOP PARAMS BAL,LX EXCHLUPS EXCHANGE INNER/MIDDLE LOOPS LI,R 0 INIT FIXED PART VALUE STW,R FVALUE LI,A 1 BAL,LX XSETUP SET RIGHT ARG LI,A 2 AND RESULT BAL,LX XSETUP FOR INDICIAL ACCESS. LI,XL XSEGBASE PREPARE TO GEN CODE GEN,0,7 CODE1 GEN OUTER/MIDDLE LOOP INIT/SAVE MTW,-2 XSEGBASE CHANGE 'RSSIZE' TO 'LFSIZE' LI,X 1 THERE ARE TWO CASES OF ROTATE, LB,R *LFARG,X DEPENDING ON LEFT ARG RANK: BGZ 13Z3 >0: GENERAL CASE LW,X LFARG =0 (SCALAR): MUCH LIKE 'REVERSE' LB,T *LFARG BAL,LZ GSCLRVAL,T GET VALUE OF LEFT ARG (AS INTG) 13Z0 BGEZ 13Z1 LI,AI-1 -1 EXTEND SIGN B 13Z2 13Z1 LI,AI-1 0 13Z2 DW,AI-1 INERCNT COMPUTE MOD(LFARG,D(K)) AI,AI-1 0 BGEZ 13Z21 MAKE SURE SHIFT>=0 AW,AI-1 INERCNT 13Z21 STW,AI-1 TESTVAL = SPECIAL MIDL LOOP VALUE LW,AI TESTVAL MW,AI INERSTEP INIT DELTA = STW,AI IDELTA SHIFT*D(K+1)*...*D(N). GEN,0,2 CODE4 GEN COPY IDELTA TO DELTA B 13Z9 JOIN GENERAL CASE 13Z3 LI,A 0 GENERAL CASE STW,XL TEMP 10-00003 BAL,LX SETUPARG SET UP LFARG PARAMS. LW,XL TEMP 10-00005 AI,X 1 X=BLOCK POINTER+RANK+1 AI,AI -1 CHECK IF LEFT ARGUMENT HAS 1 ELEM. BNEZ 13Z31 NO-GO TO NORMAL PROCESSING LI,S 1 YES-FETCH THE SOLITARY ARRAY BAL,LZ GARAYVAL,T VALUE AND TREAT AS SCALAR. BAL,R15 SYSTERR THIS POINT SHOULDN'T BE REACHED. B 13Z0 13Z31 SW,X LFARG X=LFRANK+1 CW,X RTRANK NORMAL CASE,CHECK FOR RANK BNE ERRANK CONFORMABILITY. LW,S LFARG SAVE LFARG PTR MTW,1 RTARG POINT TO 1ST DIMEN -1 13Z4 CW,X COORDK IF WE'VE GOTTEN TO K'TH COORD, BNE 13Z6 MTW,1 LFARG LINE UP LF/RT DIMEN PTRS. 13Z5 BDR,X 13Z4 B 13Z7 13Z6 LW,R *LFARG,X MAKE SURE (ALL) LF DIMENS = CW,R *RTARG,X RT DIMENS (K'TH ONE DELETED). BE 13Z5 STW,S LFARG NO GOOD: RESTORE PNTRS MTW,-1 RTARG B ERLENGTH AND SIGNAL ERROR. 13Z7 STW,S LFARG OK: RESTORE PNTRS MTW,-1 RTARG LI,X -3 SET LEFT ARG FOR BAL,LX SETADR SEQUENTIAL LOAD. LI,T INTG STW,T RSTYPE LI,A 0 BAL,L1 GENLOAD GEN LOAD LEFT(N) IN INTG TYPE LW,T LFTYPE GEN,0,3 CODE2 GEN LCC TEST CODE 13Z9 STW,XL LOOPLOC SAVE INNER LOOP LOC GEN,0,1 AWKDELTA GEN ADD OF DELTA LW,T RTTYPE LW,A LOADINST,T GEN LOAD RIGHT(K), AW,A RTADR LW,A+1 SWKDELTA SUBTRACT OF DELTA, ISEQFIX,T LW,A+2 STORINST,T STORE RESULT(K), AW,A+2 RSADR GEN,3,2 A,CODE6 AND LOOP CONTROL CODE. GEN,0,7 CODE5 B EXECUTE * * XSEG CODE: * * SET OUTER LOOP * SET MIDDLE LOOP * LOAD/CNV LFARG(N) GET A SHIFT COUNT CODE2 BGEZ ROTATE1 EXTEND SIGN(AI) INTO AI-1 LI,AI-1 -1 B ROTATE2 CODE4 LW,R IDELTA RE-INIT DELTA (ONLY FOR STW,R DELTA ROTATE W/SCALAR LFARG). ROTATE1 LI,AI-1 0 *(THIS CODE NOT IN XSEG) ROTATE2 AI,N 1 * BUMP LFARG INDEX DW,AI-1 INERCNT * COMPUTE J=MOD(SHIFT COUNT, D(K)) AI,AI-1 0 * BGEZ 13Z91 * MAKE SURE J>=0 AW,AI-1 INERCNT * 13Z91 STW,AI-1 TESTVAL * J LW,AI TESTVAL * DELTA (DISTANCE BETWEEN UNSHIFTED MW,AI INERSTEP * AND SHIFTED INDEX VALUES) STW,AI DELTA * = J*D(K+1)*D(K+2)*...*D(N). LW,N3 INERCNT * RUN INNER LOOP D(K) TIMES ROTATE3 CW,N3 TESTVAL * UPON STARTING THE D(K)-J+1 'TH BNE *LOOPLOC * ITERATION OF INNER LOOP, LCW,R OUTRSTEP * DECR DELTA BY D(K)*D(K+1)*...*D(N) AWM,R DELTA * TO KEEP K'TH COORD INDEX B *LOOPLOC * IN BOUNDS. *LOOPLOC EQU % AWKDELTA AW,K DELTA SHIFT INDEX * LOAD RTARG(K) FETCH, SHIFTEDLY SWKDELTA SW,K DELTA UNSHIFT INDEX * STORE RESULT(K) STORE, UNSHIFTEDLY CODE6 AW,K INERSTEP BUMP BY INNER LOOP STEP BDR,N3 ROTATE3 COUNT INNER LOOP * ... COUNT MIDDLE/OUTER LOOPS * ... EXIT * DELTA TEMP DISTANCE 'TWEEN RTARG/RESULT ELMTS IDELTA TEMP INITIAL VALUE FOR DELTA TESTVAL TEMP LOOP COUNT SPECIAL TEST VAL PAGE * * DTRANS EQU % DYADIC TRANSPOSE BAL,LX LISTCHK CHECK ARGUMENTS FOR LIST LI,X 1 CB,X *LFARG,X LEFT ARG MUST BE VECTOR ... BNE ERRANK LB,S *RTARG,X ... OF LENGTH EQUAL RIGHT RANK. LW,X LFARG CW,S 2,X BNE ERLENGTH STW,S LFSIZE LI,R 0 STW,R RSRANK INIT RS RANK = 0 LI,R INFINITY LCW,X LFSIZE BEZ MNOP NO-OP IF RESULT SCALAR 11Z1 STW,R DBUFEND,X INIT RS DIMENS = +INF BIR,X 11Z1 BAL,LZ TRANSVAL SET UP NX= PTR TO LAST RT DIMEN -1, * AND INIT 'GARAYVAL' TO FETCH * LEFT ARG VALUES. B 11Z21 (DONE) AW,AI ORGADJ CONVERT NEW LFARG VAL TO ORIGIN 1 BLEZ ERDOMAIN RANGE CHECK: 1<=VAL<=LFSIZE CW,AI RSRANK BLE 11Z2 RSRANK=MAX(RSRANK,VAL) STW,AI RSRANK 11Z2 SW,AI LFSIZE FINISH RANGE CHECK, PREPARE TO BGZ ERDOMAIN INDEX INTO DIMENBUF. LW,R 1,NX GET CURRENT RT DIMEN AI,NX -1 DECR DIMEN PTR CW,R DBUFEND-1,AI BGE *L1 RSDIMEN(VAL) = MIN(RSDIMEN(VAL), STW,R DBUFEND-1,AI RTDIMEN). B *L1 GO FETCH NEXT VALUE FROM LFARG * 11Z21 LW,X RSRANK LF ARG SCAN DONE. NOW MAKE SURE * THE VALUES FORMED A DENSE SET, LI,A DBUFEND-1 AND COMPUTE RESULT SIZE. SW,A LFSIZE LI,NX DBUFEND-1 SW,NX RSRANK LI,S 1 11Z3 LW,R *A,X IF D(I)=INF, THEN THERE WAS CI,R INFINITY BE ERDOMAIN A GAP IN LF VALUES. STW,R *NX,X MOVE DIMENS TO END OF DIMENBUF MW,S R SIZE = D(1)*...*D(N) BDR,X 11Z3 STW,S RSSIZE STORE RS SIZE LB,T *RTARG ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ STW,T RSTYPE RESULT TYPE = RIGHT TYPE * * NOW SET UP THE LOOP CONTROL BLOCK * LW,S RSRANK GET LBLOCK BIG ENOUGH FOR BAL,L2 INDEXB N (=RSRANK) B-BLOCKS. LW,KB OUTRBLOK LI,R 0 LCW,X RSRANK INITIALIZE B-BLOCKS: 11Z4 LW,S DBUFEND,X STW,S BINITCNT,KB COUNT(J) = D(J) STW,R BSTEPVAL,KB STEP(J) = 0 EQUAL,0,SEQLOOP STW,R BLOOPTYP,KB TYPE(J) = SEQ AI,KB BN BIR,X 11Z4 LI,BI 1 INIT WEIGHT = 1 BAL,LZ TRANSVAL SET NX= PNTR TO D(N) -1; INIT * 'GARAYVAL' TO GET LFARG VALUES. B ALSELECT (DONE: ALOC RS, DO SELECTION) SW,AI ORIGIN CONVERT NEW LF VALUE TO ORIGIN 0 MI,AI BN COMPUTE INDEX TO B-BLOCK(VAL), EQUAL,BSTEPVAL,0 AT BSTEPVAL POSITION. AWM,BI *OUTRBLOK,AI ADD WEIGHT TO STEP(VAL) MW,BI 1,NX WEIGHT = D(K)*...*D(N) AI,NX -1 DECR D(K) PNTR B *L1 GO GET NEXT VALUE * * TRANSVAL EQU % LW,NX RTARG AW,NX LFSIZE (=RTRANK) NX = PTR TO LAST RT DIMEN -1 LW,X LFARG AI,X 2 X = PTR TO LEFT ARG +RANK+1 LB,T *LFARG T = LEFT TYPE LW,S LFSIZE S = LEFT SIZE B GARAYVAL,T BEGIN FETCHING LEFT VALUES; RETURN PAGE * * DEXPAND EQU % DYADIC EXPAND LI,OP DOPCMPRS+1 ALMOST LIKE COMPRESS DCOMPRES EQU % DYADIC COMPRESS BAL,LX LISTCHK CHECK ARGUMENTS FOR LIST LI,A 0 SET UP LEFT ARG RANK/SIZE/TYPE BAL,LX SETUPARG LI,X 1 CW,X LFSIZE LEFT ARG MUST BE EITHER BE 15Z0 A 1-ELEMENT ENTITY CW,X LFRANK OR A VECTOR. BNE ERRANK 15Z0 BAL,L2 ST3LUPSN SET UP LOOP PARAMS FROM RTARG, BUT * DON'T ALOC RESULT YET. LI,NX 0 SET UP FOR SWEEP THRU LW,S LFSIZE LEFT ARG VALUES. BEZ 15Z1 IF IT'S NULL, SKIP IT (SUM=0) LW,T LFTYPE TYPE LW,X LFARG AW,X LFRANK AI,X 1 DATA PNTR STW,OP OPTEMP SAVE OP VALUE BAL,LZ GARAYVAL,T GET 1ST B 15Z01 (DONE) AW,NX AI ACCUMULATE SUM OF VALUES CI,AI -2 NEXT: MAKE SURE IT'S 0 OR 1 BAZ *L1 GET NEXT B ERDOMAIN 15Z01 LW,OP OPTEMP RESTORE OP VALUE 15Z1 LI,S 1 DONE: NX = SUM OF LFARG VALUES CW,S RTSIZE IS RTARG A 1-ELEMENT THING ? BNE 15Z2 NO EXU OPTBL1,OP YES, SET RESULT SIZE STW,NX RSSIZE = SUM (COMPRESS), OR LW,T RTTYPE = LEFT SIZE (EXPAND). BAL,L2 VECTORRS ALOC RS = VECTOR B 15Z9 GO GEN XSEG CODE 15Z2 CW,S LFSIZE RTARG NORMAL: IS LFARG BNE 15Z6,OP A 1-ELEMENT THING ? B 15Z3,NX YES, WHAT IS ITS VALUE ? 15Z3 B 15Z4,OP 0: SPECIAL CASE FOR COMPRESS B MNOP 1: RESULT = RTARG 15Z4 TABLE DOPCMPRS LFARG = 0 (1-ELEMENT) B 15Z8 COMPRESS: TREAT AS IF LFSIZE=D(K) 15Z5 CW,NX MIDLCNT EXPAND: MAKE SURE THAT BNE ERLENGTH D(K) = +/(LEFT ARG) LW,NX LFSIZE AND SET M = LEFT SIZE. B 15Z8 15Z6 TABLE DOPCMPRS BOTH ARGS NORMAL. WHAT OP ? B 15Z7 COMPRESS B 15Z5 EXPAND 15Z7 LW,S LFSIZE COMPRESS: MAKE SURE THAT CW,S MIDLCNT D(K) = LEFT SIZE BNE ERLENGTH AND USE M = +/(LEFT ARG). 15Z8 SW,NX MIDLCNT IF M=D(K), BEZ MNOP RESULT= RTARG. STW,NX DELTA SAVE M-D(K) LW,L2 RTSIZE SAVE ACTUAL ARG SIZE MW,NX OUTRCNT RESULT SIZE DIFFERS FROM RT SIZE BY MW,NX INERCNT D(1)*...*D(K-1)*(M-D(K))* AWM,NX RTSIZE *D(K+1)*...*D(N). BAL,L1 RSLIKERT ALOC ARG LIKE RTARG (EXCEPT STW,L2 RTSIZE RESTORE ARG SIZE BAL,LX MRTDIMS FOR SIZE); COPY RT DIMENS. LW,K COORDK CHANGE K'TH DIMEN OF RESULT AI,K 1 FROM D(K) TO M BY ADDING LW,R DELTA D(K)-M TO IT. AWM,R *RESULT,K 15Z9 BAL,L1 SETN1KN SET UP LFADR FOR SEQ ACCESS (N1), * RTADR FOR IND ACCESS (K), * AND RSADR FOR SEQ ACCESS (N). BAL,LX GXSEGINI INIT XSEG; EXIT IF RESULT NULL GEN,0,4 CODE12 GEN LOOP INIT CODE LI,T LOGL SET TO CONVERT LFARG TO LOGL STW,T RSTYPE LI,A 0 GEN LOAD/CONVERT LEFT ARG ELMT BAL,L1 GENLOAD GEN,0,2 CODE14 GEN TEST/INNER LOOP INIT STW,XL LOOPLOC REMEMBER INNER LOOP LOC LW,T RTTYPE LW,R LOADINST,T GEN LOAD (RIGHT), AW,R RTADR ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ LW,R+1 STORINST,T STORE, AW,R+1 RSADR GEN,2,2 R,CODE15 AND LOOP CONTROL CODE. LI,S 1 LW,OP OPTEMP RESTORE OP CODE AGAIN CW,S RTSIZE IF RTARG IS 1-ELEMENT, BNE 15Z10,OP MODIFY CODE TO EXCLUDE MTW,1 -2,XL K-INCREMENTS. MTW,1 -6,XL B 15Z10,OP 15Z10 TABLE DOPCMPRS B 15Z11 COMPRESS: XSEG COMPLETED LI,AF1 X'1FFFF' EXPAND: CHANGE TEST INST LW,AF XL ADR FROM COMPRES2 TO HERE. STS,AF -6,XL LW,R CODE17 GEN INNER LOOP LW,T RTTYPE WHICH STORES NULL ELEMENTS ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ LW,R+1 NULLINST,T IN RESULT. LW,R+2 STORINST,T AW,R+2 RSADR GEN,3,2 R,CODE18 * 15Z11 LW,R LFLGLADR FETCH LOGL PARAMS FOR USE TO LW,R+1 LFLGLCNT RE-INIT LOGL. B EXECUTE EXECUTE XSEG * * OPTBL1 TABLE DOPCMPRS EXU TABLE - BY OP: NOP COMPRESS LW,NX LFSIZE EXPAND * OPTEMP TEMP TEMP FOR OP CODE * * NULLINST TABLE LOGL LOAD NULL INST - BY TYPE: LI,AI 0 LOGL LI,AI ' ' CHAR LI,AI 0 INTG LD,AF FLOT0 FLOT * * * XSEG CODE: * * LCW,N RSSIZE 0 INIT STORE INDEX CODE12 LI,K 0 1 INIT RTARG FETCH INDEX STW,R LFLGLADR 2 RESTORE INITIAL LOGL PARAMS STW,R+1 LFLGLCNT 3 LCW,N1 LFSIZE 4 INIT MIDDLE LOOP * LOAD/CNV LFARG(N1) 5 LOAD LFARG VALUE (0 OR 1) CODE14 BEZ COMPRES2 IF ZERO, GO TO SKIP (NULL-FILL) CODE LW,N2 INERCNT ONE: INIT INNER LOOP *LOOPLOC LOAD RTARG(K) COPY RTARG ELMTS TO RESULT * STORE RESULT(N) CODE15 BIR,N COMPRES1 COUNT RESULT B *RETURN EXIT WHEN FILLED COMPRES1 AI,K 1 * BUMP FETCH INDEX BDR,N2 *LOOPLOC * COUNT INNER LOOP BIR,N1 XSEGBASE+5 * COUNT MIDDLE LOOP B EXPAND3 * RE-START IF APPROPRIATE * COMPRES2 AW,K INERCNT * ZERO: SKIP OVER INNER LOOP BIR,N1 XSEGBASE+5 * COUNT MIDDLE LOOP B EXPAND3 * RE-START IF APPROPRIATE * ...OR... CODE17 LW,N2 INERCNT ZERO: INNER LOOP ... *LOOP4 LOAD NULL COPIES NULLS * STORE RESULT(N) TO RESULT. CODE18 BIR,N EXPAND2 COUNT RESULT B *RETURN EXIT WHEN FILLED EXPAND2 BDR,N2 -4,XL (LOOP4)* COUNT INNER LOOP BIR,N1 XSEGBASE+5 * COUNT MIDDLE LOOP EXPAND3 CW,N DELRSIZE * IF RESULT IS CHAR, DON'T TRY BGE *RETURN * TO FILL OUT TRAILING GAP. B XSEGBASE+2 * RE-START PAGE * * DTAKE EQU % DYADIC TAKE DDROP EQU % DYADIC DROP STW,OP OPTEMP SAVE OP CODE LI,A 1 SET UP RIGHT ARG'S RANK/SIZE/TYPE, BAL,LX SETUPARG CONVERTING ISEQ TO INTG VECTOR. LW,X LFARG GET LFARG POINTER LI,NX 1 CB,NX *LFARG,NX LEFT ARG MUST BE EITHER BL ERRANK BG 17Z0 A SCALAR, AI,X 1 OR A VECTOR OF LENGTH LW,NX 1,X = RIGHT ARG RANK. 17Z0 STW,NX LFSIZE SAVE LEFT ARG SIZE 10-00008 LI,R =1 IF RT ARG SCALAR, SET 'ARGDIMPT' 10-00009 LW,L3 RTRANK TO POINT TO '1' AND L3=0; U10-0074 BEZ 17Z01 OTHERWISE, 'ARGDIMPT' POINTS 10-00011 * TO ARG DIMENS, L3=-1 TO BUMP IT. U10-0076 CW,NX RTRANK RT ARG NOT SCALAR: LF ARG SIZE 10-00013 * MUST AGREE. 10-00014 BNE ERLENGTH LW,R RTARG SET UP TO ACCESS RT ARG AW,R RTRANK DIMENS D(N),...,D(1). 10-00016 AI,R 1 10-00017 LI,L3 -1 ..TO BUMP DIMEN PTR 10-00018 17Z01 STW,R ARGDIMPT 10-00019 LB,T *LFARG LI,BI 1 INIT RS SIZE AI,X 1 POINT TO LF DATA -1 LW,S LFSIZE GET SIZE OF LF ARG 10-00021 BNEZ 17Z1,OP ENTER TAKE/DROP LOOP UNLESS LFSIZE= B MNOP =RTRANK=0, IN WHICH CASE, DO NO-OP. 17Z1 TABLE DOPTAKE B 17Z4 TAKE BAL,LZ GARAYVAL,T DROP: GET A(N) VALUE B 17Z6 (DONE) STW,AI DIMENBUF,NX SAVE IT IN DIMEN BUF BGEZ 17Z2 J'TH RESULT DIMEN R(J) AW,AI *ARGDIMPT = MAX(0,D(J)-ABS(A(J))). 10-00023 BGEZ 17Z3 10-00024 B 17Z21 10-00025 17Z2 SW,AI *ARGDIMPT AI = +-R(J) 10-00026 BLEZ 17Z3 10-00027 17Z21 LI,AI 0 10-00028 17Z3 MW,BI AI ACCUMULATE +-RSSIZE BNOV 17Z5 = +-R(1)*...*R(N); GET NEXT A(J) B ERDOMAIN 17Z4 BAL,LZ GARAYVAL,T TAKE: GET A(N) VALUE B 17Z6 (DONE) STW,AI DIMENBUF,NX SAVE IT IN DIMEN BUF MW,BI AI R(J) = ABS(A(J)); ACCUM +-RSSIZE BOV ERDOMAIN = +-A(1)*...*A(N). 17Z5 AWM,L3 ARGDIMPT BUMP DIMEN POINTER 10-00030 BDR,NX *L1 REDUCE J, GET NEXT A(J) 10-00031 17Z6 LW,OP OPTEMP DONE, RESTORE OP CODE LAW,S BI RSSIZE = R(1)*...*R(N) STW,S RSSIZE LW,T RTTYPE RESULT TYPE/RANK ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ STW,T RSTYPE = RTARG TYPE/RANK. LW,R LFSIZE 10-00033 STW,R RSRANK BAL,L1 ALOCRS ALOC RS DATA BLOCK LW,S RSRANK ALOC LOOP CONTROL BLOCK BAL,L2 INDEXB AND INIT LOOP PARAMS. AI,L3 0 IF RT ARG NOT SCALAR, 10-00035 BEZ 17Z7 RE-INIT ARG DIMEN PTR. 10-00036 LW,R RTARG AW,R RTRANK 10-00038 AI,R 1 10-00039 STW,R ARGDIMPT THE D(J) 17Z7 EQU % 10-00041 LW,R RESULT AND THE R(J). AI,R 1 STW,R DIMENPTR LW,X RSRANK INIT LOOP: J=N; LW,KB INERBLOK INNERMOST B-BLOCK; LI,AI 1 NULL COUNT = R(J+1)*...*R(N); LI,BI 1 WEIGHT = D(J+1)*...*D(N). * * SET UP LOOP CONTROL BLOCK AND RESULT DIMENS * 17Z8 LAW,S DIMENBUF,X GET ABS(A(J)) B 17Z9,OP WHICH OP? 17Z9 TABLE DOPTAKE B 17Z10 TAKE LCW,S S DROP: COMPUTE R(J)=D(J)-ABS(A(J)) AW,S *ARGDIMPT 10-00043 BGEZ 17Z91 IF D(J)0, INCREASE BGZ 17Z13 FIXED-PART VAL BY A(J)*WEIGHT. B 17Z14 17Z10 STW,S *DIMENPTR,X TAKE: R(J)=ABS(A(J)); STORE IT AS STW,S BINITCNT,KB RESULT DIMEN AND LOOP COUNT. LW,S DIMENBUF,X GET A(J) BLZ 17Z12 A(J)<0: BRANCH CW,S *ARGDIMPT A(J)>=0: COMPARE WITH D(J) 10-00048 BLE 17Z14 LW,S =X'7FFFFFFF' A(J)>D(J): SPECIFY 'D(J) ELEMENTS SW,S *ARGDIMPT FOLLOWED BY A(J)-D(J) NULLS'. 10-00050 17Z11 STW,S NULTSBUF,X SET UP 'MIXED SEQUENCE' LOOP: STW,AI NULCTBUF,X NULL-TEST VAL IN 'NULTSBUF' AND LI,S MIXLOOP NULL GROUP COUNT IN 'NULCTBUF'. STB,X S INCLUDE BUFFER INDEX IN OP CODE WORD. B 17Z15 17Z12 AW,S *ARGDIMPT A(J)<0: COMPUTE A(J)+D(J) 10-00052 BLZ 17Z11 A(J)<-D(J): SPECIFY '-D(J)-A(J) * NULLS, FOLLOWED BY D(J) ELMTS'. 17Z13 MW,S BI INCR FIXED PART VAL BY A(J)*WEIGHT AWM,S FVALUE (DROP) OR (A(J)+D(J))*WEIGHT (TAKE 17Z14 LI,S SEQLOOP LOOP TYPE = ORDINARY SEQUENCIAL 17Z15 STW,S BLOOPTYP,KB STW,BI BSTEPVAL,KB STEP VALUE =WEIGHT=D(J+1)*...*D(N) MW,BI *ARGDIMPT UPDATE WEIGHT FACTOR (NO OVFL POSS) 10-00054 MW,AI *DIMENPTR,X UPDATE NULL COUNT =R(J+1)*...*R(N) AI,KB -BN POINT TO NEXT OUTER B-BLOCK AWM,L3 ARGDIMPT BUMP DIMEN PNTR (IF NOT SCALAR) 10-00056 BDR,X 17Z8 DECR J, DO NEXT COORD * * COORD LOOP DONE. NOW BUILD AND EXECUTE XSEG * LI,A 1 SET RTARG FOR INDICIAL LOAD BAL,LX XSETUP LI,X -1 SET RESULT FOR SEQUENTIAL STORE BAL,LX SETADR BAL,LX GXSEGINI INIT XSEG; EXIT IF RESULT NULL GEN,0,2 CODE20 GEN LOOP INIT CODE LW,T RTTYPE LW,R LOADINST,T GEN LOAD, AW,R RTADR ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ LW,R+1 STORINST,T STORE, AW,R+1 RSADR GEN,2,2 R,CODE21 LOOP CONTROL CODE. AI,OP -DOPTAKE IF IT'S 'DROP', THE XSEG IS FINISHED BNEZ EXECUTE LW,R NULLINST,T TAKE: GEN ADDITIONAL CODE GEN,2,4 R,CODE22 TO COPY NULLS TO RESULT. B EXECUTE * * * XSEG CODE: * * LCW,N RSSIZE 0 INIT STORE INDEX CODE20 LI,L2 XSEGBASE+7 1 SET NULL-COPY ADR (FOR 'TAKE' ONLY) BAL,L1 1STSCRPT 2 GET 1ST LOAD INDEX * LOAD RTARG(K) 3 COPY SELECTED ELEMENT * STORE RESULT(N) 4 TO RESULT. CODE21 BIR,N NXTSCRPT 5 BUMP STORE INDEX; GET NEXT LOAD INDX B *RETURN 6 EXIT WHEN RESULT FULL * LOAD NULL 7 COPY NULL ELEMENT * STORE RESULT(N) 8 TO RESULT. CODE22 BIR,N XSEGBASE+11 9 BUMP STORE INDEX B *RETURN 10 EXIT WHEN DONE BDR,N2 XSEGBASE+7 11 COUNT NULLS B NXTSCRPT 12 RETURN FOR NEXT LOAD INDEX VALUE * NULTSBUF EQU INBUF+0 NULL-TEST VALUE BUFFER NULCTBUF EQU INBUF+64 NULL-GROUP COUNT BUFFER PAGE * * DCATEN EQU % DYADIC CATENATE LI,X 1 LB,R *LFARG,X CB,R *RTARG,X PLACE HIGHER RANKED BLE 18Z0 ARG IN RTARG EXCHANGE ARGS AI,OP -1**17 IF ARGS SWAPPED, SET OP'S SIGN BIT 18Z0 LI,A 0 BAL,LX SETUPARG SET LFRANK/SIZE/TYPE LI,A 1 BAL,LX SETUPARG SET RTRANK/SIZE/TYPE BAL,LX TYCOMPAT CHECK COMPATIBILITY; SET RS TYPE B 18Z02 GO RESOLVE NUMERIC VS TEXT 18Z01 LW,S LFSIZE AW,S RTSIZE RESULT SIZE = SUM OF ARG SIZES STW,S RSSIZE LW,R RTRANK SET RESULT RANK STW,R RSRANK = HIGHEST ARG RANK. BNEZ 18Z1 ARE BOTH ARGS SCALARS? BAL,L2 VECTORRS YES: ALOC VECTOR RESULT (SIZE=2) LI,R 1 SET COUNTS TO 1 STW,R LFCOUNT STW,R RTCOUNT B 18Z12 JOIN MAIN CASE 18Z02 LW,S LFSIZE IS 'LFARG' EMPTY... BEZ 18Z03 YES, USE TYPE OF 'RTARG' LW,T LFTYPE NO, SET FOR TYPE OF 'LFARG' LW,S RTSIZE IS 'RTARG' EMPTY... BEZ 18Z04 YES, USE TYPE OF 'LFARG' B ERDOMAIN NO, CONFLICT-- DOMAIN ERROR 18Z03 LW,T RTTYPE SET FOR TYPE OF 'RTARG' 18Z04 ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ STW,T RSTYPE B 18Z01 OF (HOPEFULLY) NON-EMPTY ARG 18Z1 LB,K OPER+1 CHECK LAMINATION BIT CI,K LAMBIT BAZ 18Z2 OFF (CATENATION) AI,OP 2 ON (LAMINATION): MODIFY OP CODE AI,K -LAMBIT+1 GET RID OF LAM. BIT, BUMP COORD STB,K OPER+1 SPEC TO CEILING OF GIVEN COORD. LW,S RTSIZE SET RESULT SIZE SLS,S 1 =2* RIGHT ARG SIZE. STW,S RSSIZE LW,R LFRANK BEZ 18Z15 UNLESS LFARG IS SCALAR, CW,R RTRANK ARG RANKS MUST AGREE BNE ERRANK 18Z15 MTW,1 RSRANK RESULT RANK IS 1 HIGHER CW,K RSRANK COMPARE WITH K BL 18Z17 K<=ARG RANK: 'ST3LUPSN' WILL WORK BNE ERCOORD K> ARG RANK+1: ERROR STW,K COORDK K= ARG RANK+1: SIMULATE ST3LUPSN LI,A 1 STW,A MIDLCNT STW,A MIDLSTEP STW,A OUTRSTEP B 18Z6 JOIN OTHER CASE 18Z17 BAL,L2 ST3LUPSN SET LOOP PARAMS; CHECK K B 18Z6 18Z2 LW,R LFRANK EITHER LFARG IS SCALAR, BEZ 18Z3 CW,R RTRANK OR RANKS AGREE, BE 18Z4 AI,R 1 OR THEY MUST DIFFER BY 1. CW,R RTRANK BNE ERRANK 18Z3 AI,OP 1 MODIFY OP TO SAY 'DIFFERENT RANKS' 18Z4 BAL,L2 ST3LUPSN SET LOOP PARAMS FOR RTARG; CHECK K; LW,R LFRANK IF LFARG ISN'T SCALAR, BNEZ 18Z6 WE'VE ALREADY GOT RSSIZE. LW,S OUTRCNT IF IT IS, WE MUST SET MW,S INERCNT RSSIZE = D(1)*... BOV ERLENGTH 10-00063 AW,S RTSIZE *(D(K)+1)*...*D(N). BOV ERLENGTH 10-00065 STW,S RSSIZE 18Z6 LW,S RSSIZE GENERAL CASE: BAL,L1 ALOCRS ALOC RS DATA BLOCK LW,X RSRANK SET UP TO SCAN DIMENS B 18Z7,OP 18Z7 TABLE DOPCATEN MODIFY PNTR(S) - BY OP: MTW,1 LFARG CAT, RANKS SAME: ALIGN PNTRS MTW,1 RTARG CAT, RANKS DIFF: OFFSET PNTRS MTW,1 RESULT LAM: PNTRS ALIGNED, 1 LOW 18Z8 LW,R *RTARG,X DIMEN LOOP: GET D(I) CW,X COORDK IS I=K ? BNE 18Z13 NO, GO CHECK C(I)=D(I) EXU OPTBL2,OP YES, COMPUTE VALUE OF LEFT COUNT MW,S MIDLSTEP NOW, WHILE C(K) AND D(K) STW,S LFCOUNT ARE HANDY. EXU OPTBL3,OP COMPUTE K'TH RESULT DIMEN B 18Z9,OP DO APPROPRIATE PNTR MODIFY 18Z9 TABLE DOPCATEN B 18Z11 CAT, RANKS SAME: PNTRS ALIGNED B 18Z10 CAT, RANKS DIFF: ALIGN ARG PNTRS MTW,1 RTARG LAM: CORRECT FOR 1 EXTRA RS DIMEN 18Z10 MTW,1 LFARG 18Z11 STW,R *RESULT,X STORE I'TH RESULT DIMEN BDR,X 18Z8 COUNT DIMEN LOOP MTW,-1 LFARG DONE: RESTORE PNTRS MTW,-1 RTARG MTW,-1 RESULT 18Z12 STW,OP OPTEMP SAVE OP CODE BAL,L1 SETN1KN SET ADDRESSES BAL,LX GXSEGINI PREPARE TO GEN XSEG CODE LW,A LFRANK IF LFARG IS SCALAR BNEZ 18Z16 GEN LOAD/CONVERT OF BAL,L2 GENLOADT LFARG TO ITS TEMP. 18Z16 GEN,0,5 CODE23A GEN LOOP INIT CODE STW,XL LFLOOP SAVE LOC OF LEFT ARG LOOP LI,A 0 BAL,L1 GENLOAD GEN LOAD/CONVERT OF LFARG(N1) LW,T RSTYPE LW,R STORINST,T GEN STORE RESULT(N) AW,R RSADR STW,R TEMP GEN,1,2 R,CODE23 GEN LOOP CONTROL STW,XL RTLOOP SAVE LOC OF RIGHT ARG LOOP LI,A 1 BAL,L1 GENLOAD GEN LOAD/CONVERT OF RTARG(K) LW,R TEMP GEN STORE RESULT(N), GEN,1,2 R,CODE24 LOOP CONTROL B EXECUTE EXECUTE XSEG 18Z13 CW,R *LFARG,X DIMEN LOOP: FOR I/=K, WE BE 18Z11 REQUIRE C(I)=D(I). LW,S LFRANK DONT ACTUALLY DO COMPARISON BEZ 18Z11 IF LFARG IS SCALAR. CW,X COORDK ERROR,IF I>K,PNTRS ARE STILL AS 10-00059 BG 18Z14,OP INITIALIZED, AND MUST BE SELECT- * IVELY FIXED. IF I0, GET ARRAY VALUES (INTG) B 2Z11 (DONE) BAL,LX CHEKSUBS OFFSET/CHECK SUBSCRIPT MW,AI WEIGHT APPLY WEIGHT FACTOR MTW,-1 VPNTR STORE IT IN V-BLOCK STW,AI *VPNTR B *L1 GET NEXT VALUE 2Z11 LW,S XSIZE FINISH: GET SCRIPT SIZE STW,LZ ISEQFLAG RESET ISEQ FLAG (>0) LW,AI VPNTR GET V-POINTER SW,AI LBLOCK CONVERT TO L-BLOCK OFFSET VALUE LI,L1 ARAYLOOP SET LOOP TYPE = ARRAY B 3Z4 GO CREATE B-BLOCK ITEM * 2Z16 BAL,LZ GSCLRVAL,T GET SCALAR VALUE BAL,LX CHEKSUBS OFFSET/CHECK SUBSCRIPT VALUE STW,LX ISEQFLAG RESET ISEQ FLAG (>0) ODD,AI MW,AI WEIGHT INCR FIXED PART VALUE AWM,AI FVALUE BY WEIGHTED SCRIPT VALUE. B 3Z6 PROCESS NEXT SCRIPT * 3Z1 LW,AI 2,X ISEQ: CHECK RANGE OF LAST VALUE: BEZ 3Z7 MW,AI 4,X = A+B*N AW,AI 3,X BAL,LX CHEKSUBS LW,AI 3,X OFFSET/CHECK FIRST VALUE: AW,AI 4,X = A+B BAL,LX CHEKSUBS MW,AI WEIGHT INCR FIXED PART BY WEIGHTED AWM,AI FVALUE 1ST SCRIPT VALUE. 3Z7 LW,S 2,X SIZE = N LW,AI 4,X STEP = B * WEIGHT MW,AI WEIGHT 3Z2 MTW,-1 DIMENPTR ISEQ/NULL: PUT SIZE IN DIMEN BUF STW,S *DIMENPTR LI,L1 SEQLOOP SET LOOP TYPE = SEQ LCW,R ISEQFLAG TEST ISEQ FLAG: WAS LAST SCRIPT BLZ 3Z3 AN ISEQ? LW,T BPNTR YES, SEE IF WE CAN COMBINE THIS LW,BI BSTEPVAL,T ONE WITH THE LAST; THIS IS ODD,BI MW,BI BINITCNT,T POSSIBLE IFF (LAST SIZE)*(LAST CW,BI AI STEP) = (THIS STEP). BNE 3Z4 RATS. LW,AI S OH GOOD; MODIFY LAST B-BLOCK BY MW,AI BINITCNT,T SETTING ITS SIZE = STW,AI BINITCNT,T (LAST SIZE)*(THIS SIZE). B 3Z5 3Z3 STW,R ISEQFLAG ISEQ WAS RESET: SET IT NOW (<0) 3Z4 MTW,-BN BPNTR LW,T BPNTR BUILD NEW B-BLOCK: STW,AI BSTEPVAL,T INCLUDE ITS WEIGHTED STEP VALUE STW,S BINITCNT,T (OR V-OFFSET) AND SIZE. STW,L1 BLOOPTYP,T AND TYPE. 3Z5 MW,S RSSIZE UPDATE RESULT SIZE STW,S RSSIZE 3Z6 LW,AI *ARGDIMPT,NX UPDATE WEIGHT FACTOR MW,AI WEIGHT STW,AI WEIGHT BDR,NX 2Z1 DO NEXT SCRIPT * * DE-REF SCRIPT LIST DATA BLOCK U10-0118 * DREFSCR EQU % U10-0120 LI,A 0 XW,A SCRIPT DISCARD SCRIPT LIST PNTR BAL,LX7 DREF DE-REF SCRIPT LIST DATA BLOCK B *L2 RETURN PAGE * * * ALLOCATE LOOP CONTROL BLOCK * * CALLED WITH THE NUMBER OF B-BLOCKS NEEDED IN 'S'. * ALLOCATES AN LBLOCK BIG ENOUGH FOR THAT MANY B-BLOCKS * AND AN EMPTY V-BLOCK. SETS UP LBLOCK, OLDLBLOK, * INERBLOK, OUTRBLOK, FVALUE. LINK IS L2. * INDEXB EQU % MTW,-4 RETURN ALTER RETURN ADR SO THAT, UPON * EXIT FROM OP DRIVER, 'LBLOCK' * WILL BE DE-REFFED MI,S BN COMPUTE TOTAL SIZE OF B-BLOCKS STW,S TEMP SAVE IT BAL,LX7 ALOCHNW ALLOCATE L-BLOCK STW,A LBLOCK SAVE POINTER STW,A OLDLBLOK (FOR UPDATELP) LI,R INTG**8 SET TYPE (MUSTN'T LEAVE IT 0) STH,R *LBLOCK AI,A 2 STW,A OUTRBLOK PNTR TO OUTER B-BLOCK AW,A TEMP AI,A -BN STW,A INERBLOK PNTR TO INNER B-BLOCK LI,R 0 INITIALIZE FIXED PART VALUE STW,R FVALUE B *L2 RETURN * TEMP TEMP PAGE * * * SET UP PARAMETERS FOR THREE NESTED LOOPS * * USES THE COORDINATE SPECIFICATION VALUE (OR RTRANK, * IF NONE) TO SET UP THREE NESTED LOOPS: THE OUTER, * CORRESPONDING TO COORDS 1,2,...,K-1; THE MIDDLE, * FOR COORD K; AND THE INNER FOR COORDS K+1,...,N * (WHERE K= COORD SPEC, N = RT RANK). THIS ROUTINE * SETS UP RANK/SIZE/TYPE CELLS IDENTICALLY FOR RT ARG * AND RESULT, ALLOCATES RESULT DB, COPIES RT DIMENS * TO RESULT, AND SETS UP LOOP CONTROL PARAMETERS AS * FOLLOWS: * * COORDK = K * OUTRCNT = D(1)*D(2)*...*D(K-1) * OUTRSTEP = D(K)*D(K+1)*...*D(N) * MIDLCNT = D(K) * MIDLSTEP = D(K+1)*D(K+2)*...*D(N) * INERCNT = D(K+1)*D(K+2)*...*D(N) * INERSTEP = 1 * * IF THE RESULT SIZE IS 0 OR 1, THIS ROUTINE EXITS * TO 'MNOP' WHICH SETS RESULT = RTARG; OTHERWISE IT * RETURNS TO CALLER. LINK IS L2. * * 'ST3LUPSK' IS AN ALTERNATE ENTRY WHICH USES THE VALUE * IN REG 'K' AS COORDINATE SPEC, INSTEAD OF VALUE IN * OPER WORDS. 'ST3LUPSN' IS AN ALTERNATE ENTRY WHICH * DOESN'T ALOC RESULT, COPY DIMENS, OR EXIT TO 'MNOP'. * ST3LUPSN EQU % AI,L2 -1**17 SET FLAG BIT SET3LUPS EQU % LB,T *RTARG GET ARG TYPE STW,T RTTYPE LI,X 1 LB,R *RTARG,X GET ARG RANK STW,R RTRANK BEZ 10Z0 IF SCALAR, CHECK FOR NO COORD SPEC LB,K OPER+1 GET COORDINAT SPECIFICATION VALUE BEZ 10Z1 IF ZERO, NONE WAS GIVEN CW,K RTRANK IF GIVEN, MAKE SURE COORD<=RANK BLE 10Z2 B ERCOORD 10Z0 LB,K OPER+1 RTARG IS SCALAR: NO COORDINATE BNEZ ERCOORD MAY BE SPECIFIED. LI,S 1 STW,S INERSTEP SET ALL LOOP PARAMS = 1 STW,S INERCNT STW,S MIDLSTEP STW,S MIDLCNT STW,S OUTRSTEP B 10Z6 10Z1 LW,K RTRANK NO COORD: USE ARG RANK (=LAST COORD) * ST3LUPSK EQU % SET LOOPS, USING K-REG VAL 10Z2 STW,K COORDK SET K'TH COORD MTW,1 RTARG POINT TO 1ST DIMEN -1 LW,X RTRANK PREPARE TO MULTIPLY ALL DIMENS LI,S 1 INIT INNER COUNT STW,S INERSTEP INNER STEP = 1 10Z3 CW,X COORDK WHEN THE K'TH COORD IS REACHED, BNE 10Z4 STW,S INERCNT SET INNER COUNT AND MIDDLE STEP STW,S MIDLSTEP = D(K+1)*D(K+2)*...*D(N), MW,S *RTARG,X OUTER STEP STW,S OUTRSTEP = D(K)*D(K+1)*...*D(N), LW,S *RTARG,X AND MIDDLE COUNT = D(K); STW,S MIDLCNT LI,S 1 INIT S FOR OUTER COUNT, B 10Z5 SKIP DIMEN K. 10Z4 MW,S *RTARG,X ACCUM SIZE BOV ERLENGTH 10-00067 10Z5 BDR,X 10Z3 MTW,-1 RTARG DONE: RESTORE ARG PNTR 10Z6 STW,S OUTRCNT OUTER COUNT = D(1)*D(2)*...*D(K-1) MW,S OUTRSTEP BOV ERLENGTH 10-00069 STW,S RTSIZE SIZE = D(1)*D(2)*...*D(N) AI,L2 0 IF SIGN BIT SET, ENTRY WAS BLZ *L2 'ST3LUPSN': DONT ALOC RS. BDR,S 10Z7 IF RESULT IS 1 ELEMENT, B MNOP RESULT = RTARG. 10Z7 BAL,L1 RSLIKERT ALOC RESULT DB LIKE RT ARG BAL,LX MRTDIMS COPY ARG DIMENS TO RESULT B *L2 RETURN * * INERCNT TEMP INNER LOOP COUNT INERSTEP TEMP INNER LOOP STEP MIDLCNT TEMP MIDDLE LOOP COUNT MIDLSAVE TEMP MIDDLE LOOP STEP MIDLSTEP TEMP MIDDLE LOOP SAVE CELL OUTRCNT TEMP OUTER LOOP COUNT OUTRSAVE TEMP OUTER LOOP STEP OUTRSTEP TEMP OUTER LOOP SAVE CELL COORDK TEMP K'TH COORDINATE SPEC * * * EXCHANGE INNER/MIDDLE LOOPS * * EXHANGES INNER AND MIDDLE LOOP PARAMETRS, AND * SETS FVALUE TO ZERO. LINK IS LX. * EXCHLUPS EQU % LW,R INERCNT SWAP COUNTS XW,R MIDLCNT STW,R INERCNT LW,R INERSTEP SWAP STEPS XW,R MIDLSTEP STW,R INERSTEP LI,R 0 ZERO FVALUE STW,R FVALUE B 0,LX RETURN PAGE * * * CHECK SUBSCRIPT * * THE SUBSCRIPT VALUE IN 'AI' IS OFFSET TO ORIGIN 0 * AND RANGE-CHECKED. OFFSET VALUE IS RETURNED IN 'AI'. * LINK IS LX. * CHEKSUBS SW,AI ORIGIN OFFSET TO ORIGIN 0 BLZ ERINDEX MAKE SURE ITS VALUE IS CW,AI *ARGDIMPT,NX >=0 AND BL 0,LX < (CURRENT DIMEN). B ERINDEX PAGE * * * GET INTEGER ARRAY VALUES * * 'GARAYVAL' IS USED TO FETCH, ONE BY ONE (FROM LAST * TO FIRST), THE ELEMENTS OF AN ARRAY, CONVERTING THEM * TO THE INTEGER DOMAIN. IT IS CALLED WITH THE DATA * BLOCK POINTER +RANK+1 IN X, SIZE (ELEMENTS) IN S, * AND TYPE IN T; LINK IS LZ. THE CALLING SEQUENCE * IS AS FOLLOWS: * * BAL,LZ GARAYVAL,T * B ENDLOC * (PROCESS ONE VALUE) * ... * B *L1 * * 'GARAYVAL' WILL RETURN TO BAL+2 ONCE FOR EACH ARRAY * VALUE, WITH ITS INTG VAL IN AI AND LCC SET; VALUES ARE * PASSED IN REVERSE RAVEL ORDER. THE CALLER MUST NOT * CLOBBER THE FOLLOWING REGS: S, T, X, LZ. * AFTER ALL VALUES HAVE BEEN PASSED, 'GARAYVAL' WILL * RETURN TO BAL+1. * GARAYVAL EQU %-LOGL GET ARRAY VALUE: JUMP TABLE B 7Z5 L VALUES: CONVERT TO I B ERDOMAIN C VALUES: WRONG B 7Z10 I VALUES: OK B 7Z8 F VALUES: CONVERT TO I B 7Z1 ISEQ: GEN VALUES B ERDOMAIN LIST: WRONG * 7Z1 LW,AI 0,X ISEQ: INIT TO LAST VAL MW,AI 2,X AW,AI 1,X = BASE+STEP*SIZE 7Z2 STW,AI AVALTEMP SAVE VALUE (USER CLOBBERS) BAL,L1 1,LZ PASS IT TO CALLER LW,AI AVALTEMP RESTORE VALUE SW,AI 2,X SUBTRACT STEP VAL BDR,S 7Z2 DO NEXT B 0,LZ END: RETURN TO ENDLOC * 7Z5 LCW,T S SPLIT UP ARRAY SIZE INTO AI,S 31 WORD AND BIT COUNT. SLS,S -5 S = WORD COUNT OR,T =-32 T = - BIT COUNT 7Z6 LW,AI *S,X GET CURRENT WORD AND,AI BITMASK+33,T EXTRACT CURRENT BIT BEZ 7Z7 CONVERT TO INTG FORM: LI,AI 1 0 OR 1. 7Z7 BAL,L1 1,LZ PROCESS ARRAY VALUE BIR,T 7Z6 ALL BITS LI,T -32 RESET BIT COUNT BDR,S 7Z6 ALL WORDS B 0,LZ FINISH ARRAY PROCESSING * 7Z8 AND,X =-2 FLOT: CONVERT PNTR TO DOUBLEWORD ADR XW,S X COUNT MUST BE IN INDEX 7Z9 LD,AF *S,X GET NEXT VALUE BAL,LX F2I CONVERT TO INTEGER B ERDOMAIN (IF POSSIBLE) BAL,L1 1,LZ PROCESS IT BDR,X 7Z9 ALL VALUES B 0,LZ FINISH * 7Z10 LW,AI *S,X INTG: GET NEXT VALUE BAL,L1 1,LZ PROCESS IT BDR,S 7Z10 ALL VALUES B 0,LZ FINISH * AVALTEMP TEMP ARRAY VALUE TEMP PAGE * * * GET INTEGER SCALAR VALUE * * 'GSCLRVAL' IS USED TO OBTAIN THE VALUE OF A * SCALAR, CONVERTING IT TO THE INTEGER DOMAIN IF * NECESSARY. IT IS CALLED WITH THE DATA BLOCK * POINTER IN X AND TYPE IN T; LINK IS LZ. * THE CALLING SEQUENCE IS: * * BAL,LZ GSCLRVAL,T * * THE VALUE IS RETURNED IN 'AI' WITH LCC SET ACCORDING * TO VALUE'S SIGNUM. * GSCLRVAL EQU %-LOGL GET SCALAR VALUE: JUMP TABLE B 8Z3 L VALUE: CONVERT TO I B ERDOMAIN C VALUE: WRONG B 8Z5 I VALUE: OK B 8Z4 F VALUE: CONVERT TO I B 8Z1 ISEQ: (TO HANDLE 1-ELMT ARRAY) B ERDOMAIN LIST: WRONG * 8Z1 LW,AI 2,X ISEQ: VALUE = BASE+STEP AW,AI 3,X B 0,LZ RETURN * 8Z3 LW,AI 2,X LOGL SCALAR: GET VALUE AND,AI =X'80000000' BEZ 0,LZ LI,AI 1 CONVERT TO I-FORM B 0,LZ RETURN * 8Z4 AI,X 1 FLOT SCALAR: GET VALUE SLS,X -1 LD,AF 2,X BAL,LX F2I CONVERT TO INTO B ERDOMAIN (IF POSSIBLE) B 0,LZ RETURN * 8Z5 LW,AI 2,X INTG: GET VALUE B 0,LZ RETURN PAGE * * * GET SUBSCRIPT VALUES * * THESE SUBROUTINES EXECUTE THE LOOPS SPECIFIED BY THE * L-BLOCK, DELIVERING ONE ZERO-ORIGIN SUBSCRIPT VALUE * PER CALL. '1STSCRPT' INITIALIZES THE LOOPS AND RETURNS * THE FIRST SUBSCRIPT IN 'K'. 'NXTSCRPT' PRODUCES * ONE ADDITIONAL SUBSCRIPT IN 'K' EACH TIME IT IS CALLED. * LINK IS L1. THE FOLLOWING REGISTERS MUST * NOT BE CLOBBERED BY THE CALLER, ONCE THEY HAVE BEEN * SET UP BY '1STSCRPT': K, KB, KV, KN, KL. * * * THE LOOP CONTROL BLOCK CONTAINS THE PARAMETERS NEEDED * TO INITIALIZE EACH LOOP, AND SPACE TO HOLD RUNNING * LOOP VALUES. FOR A NESTING DEPTH OF N, THE BLOCK * CONSISTS OF N 6-WORD 'B-BLOCKS', EACH DESCRIBING ONE * LOOP, AND A 'V-BLOCK' LARGE ENUF TO CONTAIN ALL THE SUB- * SCRIPTS REQUIRED FOR 'ARRAY' LOOPS AS DESCRIBED BELOW. * LET YJ(IJ) (FOR IJ=1,2,...,MJ) BE THE VALUES PRODUCED * BY THE J'TH LOOP; THEN THE VALUES PRODUCED BY * 1STSCRPT/NXTSCRPT ARE =FVALUE+Y1(I1)+Y2(I2)+...+YN(IN), * WITH 'IN' RUNNING FASTEST AND 'I1' SLOWEST. * * EACH LOOP IS OF ONE OF THE FOLLOWING TYPES: * * 1. SEQUENCE LOOP: PRODUCES YJ(IJ)=(IJ-1)*STEPJ FOR * IJ =1,2,...,MJ. B-BLOCK CONTENTS: * * WORD 0 = STEPJ * WORD 1 = MJ * WORD 2 = FVALUE+Y1(I1)+...+YJ(IJ) * WORD 3 = MJ-IJ * WORD 4 = (UNUSED) * WORD 5 = 0 (OP CODE FOR 'SEQLOOP') * * EACH ITERATION REDUCES WORD 3 BY 1, AND ADDS * STEPJ TO WORD 2. * * 2. ARRAY LOOP: PRODUCES YJ(IJ) = L(VJ+IJ-1) FOR * IJ = 1,2,...,MJ. B-BLOCK CONTENTS: * * WORD 0 = VJ (OFFSET INTO V-BLOCK) * WORD 1 = MJ * WORD 2 = LOC(L)+VJ+IJ-1 * WORD 3 = MJ-IJ * WORD 4 = FVALUE+Y1(I1)+...+YK(IK) (K=J-1) * WORD 5 = -1 (OP CODE FOR 'ARAYLOOP') * * EACH ITERATION REDUCES WORD 3 BY 1, INCREASES * WORD 2 BY 1 AND ACCESSES NEW YJ VALUE FROM V-BLOCK * LOCATION GIVEN BY WORD 2. * * 3. MIXED SEQUENCE LOOP: USED BY 'TAKE' OPERATOR, THIS * LOOP PRODUCES PJ 'NULL GROUPS' FOLLOWED BY MJ-PJ * VALUES OF THE 'SEQUENCE' LOOP VARIETY - OR, IT * FIRST PRODUCES QJ VALUES, THEN MJ-QJ NULL GROUPS. * CASE 1: YJ(IJ) ='NULL GROUP' FOR IJ=1,...,PJ * =(IJ-PJ-1)*STEPJ FOR IJ=PJ+1,...,MJ. * CASE 2: YJ(IJ) =(IJ-1)*STEPJ FOR IJ=1,...,QJ * ='NULL GROUP' FOR IJ=QJ+1,...,MJ. * B-BLOCK CONTENTS: * * WORD 0 = STEPJ * WORD 1 = MJ * WORD 2 = FVALUE+Y1(I1)+...+YJ(IJ) * WORD 3 = MJ-IJ * WORD 4 = T+IJ (T= NULL TEST VAL, SEE BELOW) * WORD 5 = (X,-2) X (IN THE UPPER 8 BITS) * IS THE INDEX INTO NULTSBUF FOR 'T' * AND INTO NULCTBUF FOR 'G'. THE * LOWER 24 BITS CONTAIN -2, THE OP * CODE FOR 'MIXLOOP'. * * NULTSBUF(X) CONTAINS 'T', THE NULL TEST VALUE: IN * CASE 1, T=-PJ<0; IN CASE 2, T=X'7FFFFFFF'-QJ>0. * NULCTBUF(X) CONTAINS 'G', THE NULL-GROUP COUNT: * G=MK*...*MN (K=J+1). * EACH ITERATION LOWERS WORD 3 BY 1 AND RAISES * WORD 4 BY 1 TESTING ITS SIGN: IF T+IJ>0, THE LOOP * ACTS LIKE A 'SEQUENCE' LOOP, ADDING STEPJ TO * WORD 2; IF T+IJ<=0, A NULL GROUP OF LENGTH G IS * PASSED TO THE RESULT, AND THE EXECUTION OF LOOPS * J+1,...,N IS SKIPPED. NXTSCRPT PASSES THE NULL * GROUP BY PUTTING G IN REG 'N2' AND EXITING ON * LINK L2, INSTEAD OF L1. * * 1STSCRPT EQU % GET 1ST SCRIPT BAL,LX UPDATELP UPDATE L-BLOCK POINTERS LW,KB OUTRBLOK INIT B-BLOCK PNTR TO OUTERMOST BLOCK LW,K FVALUE INIT SCRIPT VAL = FIXED PART VALUE CW,KB INERBLOK ARE THERE ANY B-BLOCKS ? BLE 4Z6 YES, GO INITIALIZE THEM LI,KN 1 NO, SET COUNT FOR 1 SCRIPT VAL BAL,KL *L1 AND GIVE 'EM THE ONLY SCRIPT * (FVALUE); SET KL TO SOMETHING * SO 'BDR,KN 0,KL' WONT GET ADR * TRAP (EVEN THOUGH IT WONT BRANCH). * NXTSCRPT EQU % GET NEXT SCRIPT BDR,KN *KL BRANCH IF CURRENT LOOP NOT DONE * (KL HAS BEEN SET BY ONE OF * SEVERAL 'BAL,KL ...' OPS). 4Z1 AI,KB -BN LOOP DONE: MOVE TO NEXT OUTER LOOP CW,KB OUTRBLOK IF ALL LOOPS FINISHED, BL *RETURN EXIT FROM OP ROUTINE. U10-0122 LW,KN BCOUNT,KB RESTORE ITS SAVED COUNT LW,LX BLOOPTYP,KB GET LOOP TYPE CODE BDR,KN 4Z3,LX GO TO APPROPRIATE RESTORE B 4Z1 4Z21 LW,KV BOFFSET,KB ARRAY LOOP: RESTORE OFFSET VAL * LOC, THEN GO COUNT THIS LOOP. AI,KV 1 BUMP THE NON-INNER ARRAY LOOP: LW,K *KV INCR OFFSET, AND GET ARRAY ELMT; AW,K BADDEND,KB ADD IN ADDEND. 4Z2 STW,KV BOFFSET,KB SAVE THIS LOOP'S OFFSET AND COUNT, B 4Z5 INIT INNER LOOPS. * 4Z3 TABLE LOPBIAS LOOP RESTORE ROUTINE TBL B 4Z13 MIXED SEQUENCE LOOP B 4Z21 ARRAY LOOP 4Z31 LW,K BSCRIPT,KB SEQ LOOP: RESTORE SCRIPT VAL AW,K BSTEPVAL,KB BUMP THE NON-INNER SEQUENCE LOOP 4Z4 STW,K BSCRIPT,KB AND SAVE ITS SCRIPT VAL. 4Z5 STW,KN BCOUNT,KB SAVE THIS LOOP'S COUNT AI,KB BN INIT INNER LOOPS: MOVE TO NEXT 4Z6 LW,KN BINITCNT,KB INNER LOOP; INITIALIZE COUNT LW,LX BLOOPTYP,KB GET LOOP TYPE CODE B 4Z7,LX GO TO APPROPRIATE INIT ROUTINE 4Z61 LW,KV BINITOFS,KB AND OFFSET (IF ARRAY LOOP). AW,KV LBLOCK ARRAY LOOP: CONVERT OFFSET TO STW,K BADDEND,KB ACTUAL PNTR; SET ADDEND VAL. AW,K *KV K = 1ST SCRIPT FOR THIS LOOP CW,KB INERBLOK IF THIS ISN'T THE INNERMOST LOOP, BL 4Z2 SAVE ITS STUFF & INIT INNER LOOPS. BAL,KL *L1 SET KL TO INNER-ARRAY-LOOP LOC, * AND RETURN K TO CALLER. AI,KV 1 BUMP INNER ARRAY LOOP: INCR OFFSET, LW,K *KV FETCH NEXT ARRAY VALUE, AW,K BADDEND,KB AND ADD ADDEND. B *L1 RETURN K TO CALLER. * 4Z7 TABLE LOPBIAS LOOP INIT ROUTINE TBL B 4Z9 MIXED SEQUENCE LOOP B 4Z61 ARRAY LOOP * SEQ LOOP CW,KB INERBLOK IF THIS ISN'T THE INNERMOST LOOP, BL 4Z4 SAVE ITS STUFF & INIT INNER LOOPS. BAL,KL *L1 SET KL TO INNER-SEQUENCE-LOOP LOC, * AND RETURN K TO CALLER. 4Z8 AW,K BSTEPVAL,KB BUMP INNER SEQUENCE LOOP BY SIMPLY B *L1 ADDING THE STEP VAL; RETURN. * INIT MIXLOOP: 4Z9 LB,LX LX MIXLOOP: GET NULTSBUF INDEX LW,LX NULTSBUF,LX GET NULL TEST INITIALIZATION VALUE STW,LX BNULTEST,KB INIT NULL TEST WORD 4Z10 MTW,1 BNULTEST,KB BUMP NULL TEST VALUE BGZ 4Z11 >0 TREAT LIKE SEQLOOP LI,KL 4Z10 <=0 FIRST, SEND A NULL GROUP, B 4Z12 THEN TRY AGAIN. 4Z11 CW,KB INERBLOK IS THIS THE INNERMOST LOOP ? BL 4Z4 NO, SAVE STUFF & INIT NEXT INNER LUP BAL,KL *L1 YES, SEND SCRIPT (K) TO CALLER, MTW,1 BNULTEST,KB AND ADD STEP TO SCRIPT, AS LONG BGZ 4Z8 AS NULL TEST >0. 4Z12 LW,LX BLOOPTYP,KB GET NULCTBUF INDEX LB,LX LX LW,N2 NULCTBUF,LX GET NULL-GROUP COUNT B *L2 GO TO SEND-NULL ROUTINE 4Z13 MTW,1 BNULTEST,KB BUMP NON-INNER MIXLOOP BGZ 4Z31 IF NULL TEST >0, TREAT LIKE SEQLOOP LI,KL 4Z13 IF <=0, SEND NULL GROUPS UNTIL B 4Z12 IT GOES >0 (OR LOOP COUNTS OUT). PAGE * * * MOVE BUFFER DIMENSIONS * * COPIES DIMENSION BUFFER CONTENTS TO RESULT DIMENS. * LINK IS LX. * MBUFDIMS EQU % LCW,X RSRANK GET -RANK BEZ 0,LX IF RANK=0, NO DIMENS TO MOVE LW,A RESULT GET PNTR TO 1ST RS DIMEN -2 9Z1 LW,R DBUFEND,X GET DIMEN FROM BUFFER STW,R 2,A STORE IT IN RESULT AI,A 1 BIR,X 9Z1 DO 'EM ALL B 0,LX RETURN * * * MOVE ARG DIMENSIONS * * COPIES RIGHT ARG DIMENSIONS TO RESULT DIMENS. * LINK IS LX. * MRTDIMS EQU % LW,X RSRANK GET RANK BEZ 0,LX IF RANK=0, NO DIMENS TO MOVE MTW,1 RTARG POINT TO 1ST DIMEN -1 MTW,1 RESULT 9Z2 LW,R *RTARG,X GET A DIMEN FROM ARG STW,R *RESULT,X STORE IT IN RESULT BDR,X 9Z2 DO 'EM ALL MTW,-1 RTARG RESTORE POINTERS TO NORMALCY MTW,-1 RESULT B 0,LX RETURN PAGE * * * SET UP ADDRESS FOR INDEXED LOAD/STORE * * SETS UP LFADR IF A=0; RTADR IF A=1; RSADR IF A=2. * FOR CHAR/INTG/FLOT TYPE, SETS UP ADDRESS OF 1ST * DATA VALUE, WITH 'K' IN INDEX FIELD; FOR LOGL, * SETS UP ADR OF THE INDEXED LOAD-STORE LOGL ROUTINE. * LINK IS LX. ADDRESS IS ALSO RETURNED IN 'R'. * XSETUP EQU % LW,X LFARG,A GET ARG PNTR LI,T 1 LB,R *X,T GET LEFT ARG RANK AW,R LFARG,A AI,R K**17+2 INIT ADR = ARG+RANK+2,K LB,T *X GET TYPE CODE B %+1-LOGL,T GO INTO JUMP TABLE - BY TYPE: B 6Z1 LOGL B 6Z2 CHAR B 6Z2 INTG B 6Z3 FLOT STW,R XSEQLADR,A ISEQ: SAVE BASE VALUE ADR LW,R XSQADRTB,A GET ADR OF ISEQ CALC ROUTINE B 6Z2 STORE ADR, EXIT * 6Z1 STW,R XLGLLADR,A LOGL: SAVE ADR OF LOGL DATA LW,R XLGADRTB,A ADR = LOC OF LOGL COPY SUBR 6Z2 STW,R LFADR,A STORE ADR B 0,LX RETURN 6Z3 AI,R 1 FLOT: ADR = AND,R =-2 ARG+RANK+(2 OR 3),K STW,R LFADR,A STORE ADR B 0,LX RETURN * XLGADRTB TABLE 0 LOGL LOAD/STORE SUBR ADR TABLE PZE INDXLDLL INDEXED LOAD LOGICAL LEFT PZE INDXLDLR INDEXED LOAD LOGICAL RIGHT PZE INDXSTLG INDEXED STORE LOGICAL RESULT * XSQADRTB TABLE 0 ISEQ CALC ROUTINE ADR TABLE PZE INDXLSQL INDEXED LOAD ISEQ LEFT PZE INDXLSQR INDEXED ISEQ LOAD RIGHT PAGE * * * SET UP ARG ADRS IN SPECIAL WAY * * SETS LFADR FOR SEQUENTIAL LOAD USING INDEX N1, * RTADR FOR INDICIAL LOAD USING INDEX K, AND RSADR * FOR SEQUENTIAL STORE USING INDEX N. LINK IS L1. * ALSO SETS 'DELRSIZE' = (OLD RSSIZE)-(NEW RSSIZE). * THIS VALUE IS NONZERO ONLY FOR CERTAIN CHARACTER RESULTS, * IN WHICH CASE IT MAY EQUAL -1, -2, OR -3. * SETN1KN EQU % LI,X -3 SET UP LEFT ADR CELL FOR BAL,LX SETADR SEQUENTIAL LOAD. SETSPEC1 EQU % LI,A 1 SET UP RTADR FOR BAL,LX XSETUP INDEXED LOAD: INDEX=K. LW,BI RSSIZE KEEP OLD RSSIZE LI,X -1 SET UP RSADR FOR SEQUENCIAL BAL,LX SETADR STORE: INDEX(IF ANY) =N. SW,BI RSSIZE COMPUTE DELRSIZE = OLD RSSIZE STW,BI DELRSIZE - NEW RSSIZE. SETSPEC2 EQU % LD,IX N1REGMSK IF IT HAS AN INDEX (=N, IF ANY), CW,IX1 LFADR CHANGE IT TO N1. BAZ SETLK1 STS,IX LFADR B *L1 RETURN SETLK1 LW,IX LFADR IF LFARG IS LOGL OR ISEQ, CI,IX INDXLDLL CHANGE ADR OF INDX-LOAD BE 20Z1 SUBROUTINE TO ADR OF ONE CI,IX INDXLSQL THAT USES K1 AS THE INDEX, BNE *L1 INSTEAD OF K. LI,IX INDSQLL1 B 20Z2 20Z1 LI,IX INDLDLL1 20Z2 STW,IX LFADR B *L1 * * BOUND 8 N1REGMSK PZE 0,N1 N1 INDEX VALUE PZE 0,-1 AND MASK. * DELRSIZE TEMP CHANGE IN RSSIZE PAGE * * * INDEXED LOAD LOGICAL * * LOADS INTO AI THE K'TH BIT (ORIGIN 0) OF * LFARG/RTARG. * LINK IS LX. K IS NOT ALTERED. * INDXLDLL EQU % INDEXED LOAD LOGICAL LEFT LW,AF XLGLLADR GET LFARG DATA ADR B 16Z1 INDXLDLR EQU % INDEXED LOAD LOGICAL RIGHT LW,AF XLGLRADR GET RTARG DATA ADR * SPLIT SUBSCRIPT INTO 16Z1 LCW,AI K -BIT INDEX IN AI OR,AI =-X'20' SCS,K -5 AND WORD INDEX IN K. LW,AI BITMASK+32,AI SELECT APPROPRIATE BIT AND,AI *AF,K FROM APPROPRIATE WORD. SCS,K 5 RESTORE K BEZ 0,LX CONVERT TO 0 OR -1 REPRESENTATION LI,AI -1 B 0,LX * * * INDEXED LOAD LOGICAL, INDEX K1 * * LOADS INTO AI THE K1'TH BIT (ORIGIN 0) OF LFARG * LINK IS LX. K1 IS NOT ALTERED. * INDLDLL1 EQU % INDEXED LOAD LOGICAL LEFT (K1) * SPLIT SUBSCRIPT INTO LCW,AI K1 -BIT INDEX IN AI OR,AI =-X'20' SCS,K1 -5 AND WORD INDEX IN K1. LW,AI BITMASK+32,AI SELECT APPROPRIATE BIT AND,AI *XLGLLADR,K1 FROM APPROPRIATE WORD. SCS,K1 5 RESTORE K1 BEZ 0,LX CONVERT TO 0 OR -1 REPRESENTATION LI,AI -1 B 0,LX * * * INDEXED STORE LOGICAL * * STORES AI (0 OR -1) INTO K'TH BIT (ORIGIN 0) OF RESULT. * LINK IS LX. K IS NOT ALTERED. * INDXSTLG EQU % LW,AI-1 AI * SPLIT SUBSCRIPT INTO LCW,AI K -BIT INDEX IN AI OR,AI =-X'20' SCS,K -5 AND WORD INDEX IN K. LW,AI BITMASK+32,AI SELECT APPROPRIATE BIT STS,AI-1 *XLGSTADR,K STORE DATA BIT INTO APPROP WORD SCS,K 5 RESTORE INDEX VALUE LW,AI AI-1 RESTORE VALUE OF AI B 0,LX * XLGLLADR TEMP INDEXED LOGICAL LOAD LEFT ADR XLGLRADR TEMP INDEXED LOGICAL LOAD RIGHT ADR XLGSTADR TEMP INDEXED LOGICAL STORE ADR * * * INDEXED LOAD ISEQ * * COMPUTES K'TH ELEMENT OF ISEQ LFARG/RTARG * AND PLACES IT IN AI. LINK IS LX. K IS * NOT ALTERED. * INDXLSQL EQU % INDEXED LOAD ISEQ LEFT LW,AF XSEQLADR GET ISEQ BASE ADR 21Z1 LW,AI K GET INDEX 21Z2 ODD,AI MW,AI 1,AF ISEQ ELEMENT = STEP*(K+1)+BASE AW,AI 1,AF = STEP*K+STEP+BASE. AW,AI 0,AF B 0,LX RETURN * INDXLSQR EQU % INDEXED LOAD ISEQ RIGHT LW,AF XSEQRADR GAE RIGHT ISEQ BASE ADR B 21Z1 CONTINUE AS FOR LFARG * INDSQLL1 EQU % INDEXED LOAD ISEQ LEFT, K1 INDEX LW,AF XSEQLADR GET BASE ADR LW,AI K1 GET INDEX FROM K1, NOT K B 21Z2 CONTINUE AS FOR LF LOAD FROM K * XSEQLADR TEMP ISEQ BASE ADR FOR LFARG XSEQRADR TEMP ISEQ BASE ADR FOR RTADR PAGE * * * ALLOCATE RESULT LIKE RIGHT ARG * * SETS UP RESULT RANK/SIZE/TYPE CELLS TO MATCH * THOSE OF RTARG, AND ALLOCATES THE RESULT DATA * BLOCK. LINK IS L1. PNTR RETURNED IN 'A' AND RESULT. * 'RSLIKRT1' IS AN ALTERNATE ENTRY WHICH DOES * THE SAME THING, EXCEPT IT TAKES RSTYPE FROM 'T'. * 'RSLIKRT2' DOESN'T SET UP RSTYPE AT ALL. * RSLIKERT EQU % LW,T RTTYPE RSLIKRT1 EQU % ISEQFIX,T USE TYPE INTG INSTEAD OF ISEQ STW,T RSTYPE RESULT TYPE = ARG TYPE RSLIKRT2 EQU % LW,R RTRANK STW,R RSRANK RESULT RANK = ARG RANK LW,S RTSIZE STW,S RSSIZE RESULT SIZE = ARG SIZE B ALOCRS ALLOCATE RESULT; RETURN TO CALLER PAGE * * UPDATE L-BLOCK POINTERS * * IF THE L-BLOCK MAY HAVE BEEN MOVED (DUE TO AN ALLOCATION * OR DE-REF OPERATION), A CALL UPON THIS ROUTINE WILL * ASSURE THAT ALL NECESSARY L-BLOCK POINTERS REMAIN VALID. * LINK IS LX. * UPDATELP EQU % UPDATE L-BLOCK POINTERS LW,K LBLOCK NEW L-BLOCK LOC SW,K OLDLBLOK OLD L-BLOCK LOC BEZ 0,LX RETURN, IF THEY ARE EQUAL AWM,K OLDLBLOK NOT EQUAL: ADD DIFFERENCE TO AWM,K INERBLOK ALL POINTERS. AWM,K OUTRBLOK B 0,LX RETURN * * LISTCHK-CHECKS LFARG AND RTARG-ERROR IF TYPE IS LIST OR HIGHER * LISTCHK LI,A LIST CB,A *LFARG BLE ERDOMAIN CB,A *RTARG BG 0,LX B ERDOMAIN PAGE * * * TEMPS FOR INDEX ROUTINES * ARGDIMPT TEMP ARG DIMEN POINTER BLENGTH TEMP B BLOCK LENGTH VLENGTH TEMP V BLOCK LENGTH BPNTR EQU OUTRBLOK B BLOCK POINTER VPNTR TEMP V BLOCK POINTER DIMENPTR TEMP DIMENSION POINTER SCRIPT2 TEMP SUBSCRIPT LIST PNTR +2 ISEQFLAG TEMP ISEQ FLAG (<0 FOR .TRUE.) XRANK TEMP SUBSCRIPT RANK XSIZE TEMP SUBSCRIPT SIZE WEIGHT TEMP WEIGHT FACTOR FVALUE TEMP FIXED PART VALUE OLDLBLOK TEMP OLD L-BLOCK POINTER INERBLOK TEMP INNERMOST B-BLOCK POINTER OUTRBLOK TEMP OUTERMOST B-BLOCK POINTER * ERROR,X'F',TLOC>38 'TOO MANY TEMPS' U10-0124 NTEMPS SET TLOC U10-0125 23Z END