TITLE 'INTRINS-B00,08/22/73,DWG702985' SYSTEM SIG7F CSECT 1 PCC 0 CONTROL CARDS NOT PRINTED. INTRINS@ RES 0 ORIGIN OF INTRINSIC FUNCTIONS MODULE * * REF'S AND DEF'S * DEF INTRINS@ = START OF INTRINS MODULE. DEF MIBEAM MONADIC I-BEAM FUNCTIONS. DEF MTBAR MONADIC T-BAR FUNCTION. DEF DTBAR DYADIC T-BAR FUNCTION. DEF MINTRIN MONADIC -- INTRINSIC FUNCTIONS. DEF DINTRIN DYADIC -- INTRINSIC FUNCTIONS. DEF NINTRIN NILADIC -- INTRINSIC FUNCTIONS. DEF QZOUT STARTS QUAD-0 (GRAPHICS) OUTPUT. DEF QZOUTRET RESUMES AFTER QUAD-0 OUTPUT. DEF QZIN STARTS QUAD-0 (GRAPHICS) INPUT. DEF QZINRET RESUMES AFTER QUAD-0 INPUT. DEF MXRETURN RETURNS: MONADIC INTRINSIC OR OPERATOR, DEF DXRETURN DYADIC INTRINSIC OR OPERATOR, DEF NIRETURN NILADIC INTRINSIC, DEF SXRETURN SUBSCRIPTING, DEF AXRETURN ASSIGNED INDEXING, DEF XEQNIL NO CODESTRING 'EXECUTE' OPERATION. DEF BCBRANCH CLR BREAK & DO ERR-CTRL BRANCH. DEF ECBRANCH DO ERR-CTRL BRANCH. DEF IV1 GET INTEGER NO. FROM RT ARG. DEF OPBREAK BRK DURING OPERATOR EXECUTION. DEF ERLSERR LINE-SCAN ERR (DURING EXECUTION). DEF ERSYN SYNTAX ERROR. DEF ERUND UNDEFINED. DEF ERNOR NO RESULT. DEF ERIO I/O ERR (DURING CODESTRING EXECUT'N) DEF ERDOMAIN DOMAIN ERROR. DEF ERRANK RANK ERROR. DEF ERLENGTH LENGTH ERROR. DEF ERWSFUL WS FULL. DEF ERSING SINGULAR MATRIX. DEF ERFORMAT FORMAT ERROR. DEF ERINDEX INDEX ERROR. DEF ERXEQ ERROR DURING AN 'EXECUTE' OPERATION. DEF ERTERMAL WRONG TERMINAL DEF ERFILEIO FILE I/O ERR (IDENTIFIED BY R2). SPACE 3 * REFS TO PROCEDURE: REF ERRN GEN. VECTOR -- ERROR NO. & LINE NO. REF ERRF GEN. VECTOR -- ERROR FUN.NAME. REF ERRX GEN. VECTOR -- HEX I/O ERR CODE. REF LOBRNCK START ERR-CTRL BRANCH CHECKING. REF TIMODAY TIME-OF-DAY. REF DATE DATE. REF CPUTIME CPU TIME. REF OVERTIME OVERHEAD TIME. REF UNSYMS UNUSED SYMBOLS. REF NUMUSERS NUMBER OF USERS. REF SETWIDTH SETS WIDTH. REF SETDIGIT SETS DIGITS. REF SETORG SETS ORIGIN. REF SETFUZZ SETS FUZZ. REF TABSET SETS TABS. REF DELAYER DELAYS EXECUTION. REF DELTAGRF DELTA-GRF =GRAPHIC SERVICES ROUTINE. REF DELTAFMT DELTA FMT (SPECIAL OUTPUT FORMATTER) REF FILEOPS INTRINSIC-OP USED BY FILE I/O SUB- * SYSTEMS. REF RETURNMX RESUME AFTER: MONADIC REF RETURNDX DYADIC REF RETURNNI NILADIC REF RETURNSX SUBSCRIPTING REF RETURNAX ASSIGNED INDEXING REF XEQEMPTY NIL 'EXECUTE' REF QOUTRET QUAD-0 (GRAPHICS) OUTPUT. REF QDBDONE QUAD-0 (GRAPHICS) INPUT. REF QZOUTPUT QUAD-0 (GRAPHICS) OUTPUT ROUTINE. REF QZINPUT QUAD-0 (GRAPHICS) INPUT ROUTINE. REF ERRSET ERROR HANDLER. REF DREF DE-REFERENCER. REF MAYDREF DE-REFS IF R4 IS NON-ZERO. U05-0004 REF SYSTERR SYSTEM ERROR (UNIMPLEMENTED INTRINS) REF ALOCBLK ALLOCATES A DATA BLOCK. REF ALOCHNW ALLOCS DATA BLK -- HDR + N WDS, EVEN REF ALOCTRES ALLOCS A TEXT RESULT DATA BLK. REF F2I FLOATING-TO-INTEGER CONVERTER. * REFS TO CONTEXT: REF LOGONTIM LOG-ON TIME. REF TERMTYPE TERMINAL TYPE. REF USERACCT USER'S ACCOUNT. REF RANDOM RANDOM VALUE. REF OPER DBLWD TEMP FOR OPERATOR INFO. REF ON%OFF ON-LINE VS BATCH FLAG (1 VS 0). REF BREAKFLG BREAK FLAG (0 = CLEAR). REF XSEGBRK EXECUTION SEGMENT BREAK TRIGGER. REF OFFSET USED TO SET 'ERROR POSITION'. REF LBLOCK PTS AT LOOP-CONTROL BLOCK. REF RTARG PTS AT RT ARG'S DATA BLOCK. REF LFARG PTS AT LF ARG'S DATA BLOCK. REF RESULT PTS AT RESULT'S DATA BLOCK. REF RSTYPE HOLDS TYPE -- USUALLY FOR RESULT. REF RSRANK HOLDS RANK -- USUALLY FOR RESULT. REF RSSIZE HOLDS SIZE -- USUALLY FOR RESULT. REF CONSTBUF USED AS A TEMP STORAGE BLK. REF DYNBOUND PTS AT HI BOUND OF DYNAMIC AREA. REF FREETOTL # UNUSED WDS IN CURR. DYNAMIC AREA. REF TOPOSTAK PTS AT TOP OF EXECUTION STACK. REF STATEPTR PTS AT TOP STATE-ENTRY IN STACK. SPACE 3 * * STANDARD EQU'S * REGISTERS R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 * * OTHER EQU'S * TYPETEXT EQU 2 DATA BLK TYPE -- TEXT. TYPELOGL EQU 1 LOGICAL. TYPEINTG EQU 3 -- INTEGER. TYPEXSEQ EQU 5 -- INDEX SEQUENCE. CATQ EQU 7 EXEC.STACK CATEGORY FOR EVAL-INPUT. DYINT EQU 14 DYADIC INTRINSIC TYPE. NYINT EQU 16 NILADIC INTRINSIC TYPE. FLINFLG EQU X'10000' FUNCTION-LINE FLAG BIT (S-CATEGORY). * * DOUBLEWORD CONSTANTS * DELAYRNG DATA 1,86400 DELAY RANGE -- 1 SECOND TO 1 DAY. ONE EQU DELAYRNG = 1 INTRANGE DATA DYINT,NYINT INTRINSIC FUNCTION TYPE RANGE. * * OTHER CONSTANTS * 24HRS DATA 5184000 # 60THS OF A SECOND IN ONE DAY. PAGE PAGE OPBREAK BAL,R2 SETERR -1 @ BREAK ERLSERR BAL,R2 SETERR 0 @ LINE-SCAN ERR ('SYNTAX ERR') ERSYN BAL,R2 SETERR 1 @ SYNTAX ERROR ERUND BAL,R2 SETERR 2 @ UNDEFINED ERNOR BAL,R2 SETERR 3 @ NO RESULT ERIO BAL,R2 SETERR 4 @ I/O ERROR ERDOMAIN BAL,R2 SETERR 5 @ DOMAIN ERROR ERRANK BAL,R2 SETERR 6 @ RANK ERROR ERLENGTH BAL,R2 SETERR 7 @ LENGTH ERROR ERWSFUL BAL,R2 SETERR 8 @ WS FULL ERSING BAL,R2 SETERR 9 @ SINGULAR MATRIX ERFORMAT BAL,R2 SETERR 10 @ FORMAT ERROR ERINDEX BAL,R2 SETERR 11 @ INDEX ERROR ERXEQ BAL,R2 SETERR 12 @ ERROR DURING AN EXECUTE-OPERATION. * ERFILEIO EQU SETERR2 R2 SET FILE I/O ERR (R2 SAYS WHICH ONE). ERTERMAL EQU SETERR2 R2 SET WRONG TERMINAL SPACE SETERR AI,R2 -OPBREAK-2 SET ERROR I.D. SETERR2 LI,R3 0 CLEAR EXECUTION-SEGMENT BREAK STW,R3 XSEGBRK TRIGGER. INT,R3 OPER+1 SET BYTE OFFSET IN CURR. CODESTRING STW,R3 OFFSET AT WHICH ERROR WAS DETERMINED. B ERRSET DO ERROR HANDLING. PAGE * * I N T E R F A C E S T O R E S U M E E X E C U T I O N * * A F T E R S U C C E S S F U L O P E R A T I O N . . . * XEQNIL B XEQEMPTY ASSUME EMPTY RESULT FOR AN 'EXECUTE' NIRETURN LI,R4 0 NILADIC INTRINSIC COMPLETED. STW,R4 XSEGBRK (CLR EXEC.SEGMENT BREAK TRIGGER) LW,R3 OPER+1 (RESTORE CODESTRING OFFSET) B RETURNNI (RESUME -- R4 = 0) SXRETURN LI,R4 0 SUBSCRIPTING COMPLETED. STW,R4 XSEGBRK (CLR EXEC.SEGMENT BREAK TRIGGER) XW,R4 LBLOCK BAL,R7 MAYDREF (DE-REF. ANY LOOP CONTROL BLOCK) U05-0006 LW,R3 OPER+1 (RESTORE CODESTRING OFFSET) B RETURNSX (RESUME) AXRETURN LI,R4 0 ASSIGNED-INDEXING COMPLETED. STW,R4 XSEGBRK (SEE COMMENTS FOR SXRETURN) XW,R4 LBLOCK BAL,R7 MAYDREF U05-0008 LW,R3 OPER+1 B RETURNAX LI,R4 0 @ MON.OP (USING LBLOCK) COMPLETED. STW,R4 XSEGBRK @ (SEE COMMENTS FOR SXRETURN) XW,R4 LBLOCK @ BAL,R7 DREF @ MXRETURN LI,R2 0 @ MONADIC OPERATION COMPLETED. STW,R2 XSEGBRK (CLR EXEC.SEGMENT BREAK TRIGGER) B RETURNMX (RESUME WITH R2 = 0) LI,R4 0 @ DY.OP (USING LBLOCK) COMPLETED. STW,R4 XSEGBRK @ (SEE COMMENTS FOR SXRETURN) XW,R4 LBLOCK @ BAL,R7 DREF @ DXRETURN LI,R2 0 @ DYADIC OPERATION COMPLETED. STW,R2 XSEGBRK (CLR EXEC.SEGMENT BREAK TRIGGER) B RETURNDX (RESUME WITH R2 = 0) PAGE ************************************************************************ * * * BCBRANCH -- CLEARS BREAK FLAG & DOES ERROR-CONTROL BRANCH, ON ENTRY * * R12 = MINUS THE CONTENTS OF BREAKFLG. * * ECBRANCH -- DOES ERROR-CONTROL BRANCH. * * REGS: R1 (ENTRY) PTS AT PENDENT FUNCTION STATE THAT IS * * TAKING ERROR CONTROL (TOP OF STACK). * * R12 (EXIT) = FLINFLG -- AS IF BRANCH IS FROM INSIDE * * THAT FUNCTION: STOP WILL BE * * HONORED IF ENCOUNTERED. * * OTHER REGS MAY BE REGARDED VOLATILE. * * * BCBRANCH AWM,R12 BREAKFLG CLEAR THE BREAK. ECBRANCH LI,R12 FLINFLG SET R12 AS IF FUNCTION DID BRANCH. B LOBRNCK START BRANCH CK FOR ERR-CTRL FUNC. PAGE * * G R A P H I C S I N T E R F A C I N G . . . * QZOUT B QZOUTPUT START GRAFIX OUTPUT. QZOUTRET LI,R4 0 RESUME AFTER GRAFIX OUTPUT. XW,R4 RTARG (DEREF. RT. ARG. PTR) BAL,R7 DREF LW,R3 OPER+1 RESTORE CS OFFSET TO THE QUAD-0. B QOUTRET RESUME CODESTRING EXECUTION. SPACE 2 QZIN B QZINPUT START GRAFIX INPUT. QZINRET RES 0 RESUME AFTER GRAFIX INPUT. LW,R1 TOPOSTAK PT AT TOP OF EXEC.STACK. LW,R3 OPER+1 RESTORE CS OFFSET TO THE QUAD-0. B QDBDONE RESUME CODESTR.XEQ WITH RESULT SET. PAGE ************************************************************************ * * * IV1 -- GETS A SINGLE INTEGER VALUE FROM RT ARG'S DATA BLOCK. * * DOMAIN ERROR IF RT ARG: IS TEXT OR LIST TYPE * * IS REAL AND VALUE IS NOT WITHIN FUZZ * * OF AN INTEGER. * * LENGTH ERROR IF RT ARG HAS MORE THAN 1 ELEMENT OR IS EMPTY. * * * * REGS: R14 -- LINK, EXIT VIA *R14. * * R2 -- (EXIT) CONTAINS RT ARG'S DATA BLK TYPE. * * R7 -- (EXIT) CONTAINS THE INTEGER VALUE (ALSO STORED * * IN 'CONSTBUF') * * R1,R4,R5,R6,R8 ARE VOLATILE (SEE ALSO 'F2I'). * * * IV1 LW,R4 RTARG PT AT WD AFTER RT ARG'S REF-COUNT. AI,R4 2 LI,R1 1 LB,R8 *RTARG,R1 GET RT ARG'S RANK... BEZ IV1OK SCALAR. IV1Q AI,R4 1 ARRAY, VERIFY LENGTHS ARE 1... CW,R1 -1,R4 BNE ERLENGTH NOT -- LENGTH ERROR. BDR,R8 IV1Q IV1OK LW,R7 0,R4 GET (SUPPOSED) VALUE WD. LB,R2 *RTARG GET RT ARG'S TYPE. IV1TYPE B IV1TYPE,R2 @ VECTOR ON TYPE: 0 -- IMPOSSIBLE. B IV1LOGL @ 1 -- LOGICAL. B ERDOMAIN @ 2 -- TEXT. B IV1INTG @ 3 -- INTEGER. B IV1REAL @ 4 -- REAL. B IV1XSEQ @ 5 -- INDEX SEQUENCE. B ERDOMAIN @ 6 -- LIST. IV1LOGL SLS,R7 -31 GET THE LOGICAL VALUE. B IV1INTG IV1XSEQ AW,R7 1,R4 ADD COEFFICIENT TO BIAS. B IV1INTG IV1REAL AI,R4 1 PT AT NEXT WD (ODD OR EVEN OK). SLS,R4 -1 PT AT REAL DBLWD VALUE. LD,R6 0,R4 GET REAL VALUE. BAL,R5 F2I CONVERT TO INTEGER IF POSSIBLE... B ERDOMAIN NO LUCK -- DOMAIN ERROR. IV1INTG STW,R7 CONSTBUF OK, SAVE INTEGER VALUE. B *R14 EXIT. PAGE SPACE MIBEAM BAL,R14 IV1 GET SINGLE INTEGER ELEMENT. U05-0010 AI,R7 -19 OFFSET BY MINIMUM ACCEPTED NO. U05-0011 BLZ NEGIBEAM OOPS, TRY NEGATIVE I-BEAM. CI,R7 29-19 VERIFY NOT TOO BIG... U05-0013 BLE IGO,R7 OK, TAKE CORRESPONDING BRANCH. U05-0014 B ERDOMAIN OOPS -- DOMAIN ERROR. IGO B I19 @ SESSION TIME. B I20 @ TIME OF DAY. B I21 @ CPU TIME. B I22 @ BYTES OF WORKSPACE REMAINING. B I23 @ NUMBER OF USERS. B I24 @ LOG-ON TIME. B I25 @ DATE B I26 @ TOP LINE NO. B I27 @ VECTOR OF LINE NOS. B I28 @ TERMINAL TYPE. * B I29 @ USER'S ACCOUNT. I29 LI,R11 6 @ ALLOCATE A 6-WD DATA BLK. BAL,R7 ALOCBLK STW,R4 RESULT SAVE PTR TO RESULT DATA BLK. LI,R11 (TYPETEXT**8)+1 TYPE = TEXT RANK = 1 (VECTOR). STH,R11 *RESULT LI,R11 8 LENGTH = 8. LW,R12 USERACCT USER'S ACCOUNT (8 CHARS, POSSIBLY LW,R13 USERACCT+1 INCLUDING TRAILING BLANKS). LCI 3 STM,R11 2,R4 FILL IN LENGTH AND ACCOUNT. B MXRETURN RETURN FROM MONADIC-OP EXECUTION. I19 BAL,R14 TIMODAY GET TIME-OF-DAY (R11) 60THS OF SEC. SW,R11 LOGONTIM SUBTRACT LOG-ON-TIME. BGEZ SCLRRES = SESSION TIME... AW,R11 24HRS OOPS, CORRECT FOR MIDNITE CROSSED. B SCLRRES ITS A SCALAR RESULT. I20 LI,R14 SCLRRES SCALAR RESULT IN R11 IS B TIMODAY TIME-OF-DAY IN 60THS OF SEC. I21 LI,R14 SCLRRES SCALAR RESULT IN R11 IS B CPUTIME CPU TIME IN 60THS OF SEC. I22 LW,R11 TOPOSTAK SW,R11 DYNBOUND = # WDS BETWEEN STACK & END OF DYN. AW,R11 FREETOTL + UNUSED WDS OF DYNAMIC. SLS,R11 2 IN BYTES. AI,R11 -64 WITH 64-BYTE CUSHION. BGEZ SCLRRES SCALAR RESULT. LI,R11 0 USE 0 IF PUSH INTO CUSH. B SCLRRES I23 LI,R14 SCLRRES SCALAR RESULT IN R11 IS B NUMUSERS NO.OF USERS IN 100THS OF A PERSON. I24 LW,R11 LOGONTIM = TIME OF DAY AT LOG-ON IN 60THS/SEC B SCLRRES FOR THE SCALAR RESULT. I25 LI,R14 SCLRRES SCALAR RESULT IN R11 IS 'MMDDYY' AS B DATE BASE 10 VERSION OF THE DATE. I26 LI,R7 SCLRRES-1 (SET EXIT FROM SVSTART). SVSTART LW,R5 STATEPTR PT AT TOP STATE-ENTRY. LI,R8 0 SET FOR SELECTIVE LOADS. LI,R9 X'7FFF' STATE LS,R8 0,R5 GET 'NEXT' FIELD OF STATE-ENTRY. BEZ 0,R7 NONE -- TAKE FINAL-ENTRY EXIT. LB,R6 *R5 GET CATEGORY. CI,R6 CATQ BNE STATEF FUNCTION-CATEGORY. LI,R11 0 QUAD-CATEGORY USE 0. B 1,R7 TAKE NORMAL EXIT. STATEF LW,R11 1,R5 GET LINE NO. & FUNC.PTR, IF ANY... BNEZ STATEFL OK. LI,R11 -1 DAMAGED, USE -1. STATEFL SAS,R11 -17 = LINE NO. ONLY. B 1,R7 TAKE NORMAL EXIT. LI,R11 0 @ USE 0 FOR FINAL-ENTRY ON I26. SCLRRES LW,R4 RTARG @ PT AT RIGHT ARGUMENT DATA BLK. U05-0016 LW,R5 1,R4 GET ITS REF-COUNT. U05-0017 AI,R5 -1 IF NOT EXACTLY ONE, U05-0018 BNEZ SCLRINTG ALLOCATE A FRESH BLOCK FOR RESULT.U05-0019 LH,R2 *RTARG IF EXACTLY ONE, IT'S A TEMP. U05-0020 AI,R2 -(TYPEINTG**8) SO, IF SCALAR INTEGER ALREADY, U05-0021 BEZ RESRTARG USE RT ARG'S BLOCK FOR RESULT. U05-0022 SCLRINTG STW,R11 CONSTBUF SAVE INTEGER VALUE FOR RESULT. SCLRINTA LI,R11 4 ALLOCATE A 4-WD DATA BLK. BAL,R7 ALOCBLK LI,R11 TYPEINTG INTEGER TYPE. STB,R11 *R4 LW,R11 CONSTBUF RECOVER THE VALUE. B SETVALUE RESRTARG MTW,1 1,R4 BUMP REF-COUNT. SETVALUE STW,R4 RESULT SAVE PTR TO RESULT DATA BLK. STW,R11 2,R4 SET ITS VALUE. B MXRETURN I27 LI,R11 0 COUNTS NO.OF STATE-ENTRIES TILL FIN. LW,R5 STATEPTR PT AT TOP STATE-ENTRY. LI,R8 0 SET FOR SELECTIVE LOADS. LI,R9 X'7FFF' B I27Q START QUERY. I27N AW,R5 R8 PT AT NEXT STATE-ENTRY. AI,R11 1 COUNT THE PREVIOUS ONE. I27Q LS,R8 0,R5 IS THIS THE FINAL ENTRY... BNEZ I27N NO. STW,R11 CONSTBUF YES, SAVE STATE-ENTRY COUNT. AI,R11 1 ADD 1 FOR THE LENGTH OF THE VECTOR. BAL,R7 ALOCHNW ALLOC THAT MANY WDS + HDR & EVEN NO. STW,R4 RESULT SAVE PTR TO RESULT DATA BLK. LI,R7 (TYPEINTG**8)+1 TYPE = INTEGER RANK = 1 (VECTOR). STH,R7 *RESULT LW,R11 CONSTBUF GET NO.OF STATE ENTRIES. STW,R11 2,R4 THAT'S THE LENGTH OF THE VECTOR. AI,R4 2 BAL,R7 SVSTART @ START LOOKING AT STATE-VECTOR AGAIN. B MXRETURN @ FINAL ENTRY. AI,R4 1 @ OTHER. STW,R11 0,R4 FILL IN ITS LINE NO. INDICATION. AW,R5 R8 PT AT NEXT STATE-ENTRY. B STATE FIND ITS CATEGORY ETC. LOOPING. I28 LW,R11 TERMTYPE GET TERMINAL TYPE NUMBER FOR THE B SCLRRES SCALAR RESULT. PAGE NEGIBEAM AI,R7 19 RESTORE OFFSET. LCW,R7 R7 GET (HOPEFULLY) PLUS VALUE... BLEZ ERDOMAIN OOPS -- DOMAIN ERROR. CI,R7 NEGIBBND VERIFY IN RANGE... BLE NIGO,R7 OK, TAKE CORRESPONDING BRANCH. NIGO B ERDOMAIN @ OOPS -- DOMAIN ERROR. B NI1 @ OVERHEAD TIME. B NI2 @ NO.OF UNUSED SYMBOLS. B NI3 @ ON-LINE VS BATCH. SPACE 2 NEGIBBND EQU %-NIGO-1 = NO.OF NEGATIVE I-BEAM BRANCHES. SPACE 2 NI1 LI,R14 SCLRRES SCALAR RESULT IN R11 IS B OVERTIME OVERHEAD TIME IN 60THS OF SEC. NI2 LI,R14 SCLRRES SCALAR RESULT IN R11 IS B UNSYMS NO.OF UNUSED SYMBOLS. NI3 LW,R11 ON%OFF = 1 IF ON-LINE OR 0 IF BATCH. B SCLRRES SCALAR, INTEGER RESULT. MTBAR LB,R11 *RTARG GET RT ARG'S TYPE & B SCLRINTG USE THAT VALUE FOR SCALAR,INTEGER * RESULT. DTBAR LI,R5 TYPEINTG VERIFY LEFT ARG IS INTEGER TYPE... CB,R5 *LFARG BNE ERDOMAIN NO -- DOMAIN ERROR. LI,R8 X'FF' VERIFY LEFT ARG IS SCALAR... CH,R8 *LFARG BANZ ERRANK NO -- RANK ERROR. LW,R4 LFARG PT AT LEFT ARG. LW,R6 2,R4 GET ITS VALUE. CI,R6 2 IS IT 2... BNE INTRIGUE NO, GUESS ITS FOR INTRINSIC. STW,R6 RSTYPE YES, SET TYPE OF RESULT. CB,R5 *RTARG VERIFY RT ARG IS INTEGER TYPE... BE DTBARI OK. LI,R5 TYPEXSEQ NO, TRY FOR INDEX SEQUENCE... CB,R5 *RTARG BNE DTBART NOPE, LOGICAL PERHAPS. LW,R4 RTARG OK, PT AT ITS DATA BLOCK. LW,R11 2,R4 GET ITS LENGTH VALUE. STW,R11 RSSIZE THAT IS THE NO.OF ELEMENTS. LI,R5 1 STW,R5 RSRANK RANK OF RESULT IS 1 (VECTOR). BAL,R14 ALOCTRES ALLOC A TEXT TYPE RESULT DATA BLK. LW,R5 RTARG PT AT RT ARG AGAIN. LW,R14 RSSIZE GET NO.OF ELEMENTS AGAIN. STW,R14 2,R4 THAT IS LENGTH OF NEW TEXT VECTOR... BEZ DXRETURN ZERO. LW,R9 3,R5 GET INDEX SEQ'S BIAS VALUE. AI,R4 3 PT AT 1ST VALUE WD OF RESULT. SLS,R4 2 USE BYTE ADDRESSING. DTBARX AW,R9 4,R5 ADD INDEX SEQ'S COEFFICIENT VALUE. STB,R9 0,R4 PUT BYTE IN RESULT. AI,R4 1 PT AT NEXT RESULT BYTE POSITION. BDR,R14 DTBARX LOOP TILL LAST VALUE. LW,R11 3,R5 RE-CALC. FIRST VALUE. AW,R11 4,R5 OR,R11 R9 MERGE THE FIRST & LAST VALUES. B DTBARQ CK THAT RANGE. DTBART LI,R5 TYPELOGL IS RT ARG LOGICAL TYPE... CB,R5 *RTARG BNE ERDOMAIN NO -- DOMAIN ERROR. DTBARI LI,R5 1 LB,R4 *RTARG,R5 GET RANK OF RT ARG AND SAVE IT. STW,R4 RSRANK BEZ DTBARS SCALAR. LW,R14 RSRANK ARRAY, CALC. NO.OF ELEMENTS. AW,R4 RTARG DTBARN MW,R5 1,R4 AI,R4 -1 BDR,R14 DTBARN DTBARS STW,R5 RSSIZE SAVE NO.OF ELEMENTS. LW,R11 RSSIZE ALLOCATE A TEXT TYPE DATA BLK RESULT BAL,R14 ALOCTRES FOR THAT MANY ELEMENTS, SAME RANK. LW,R5 RTARG PT AT WD AFTER RT ARG'S REF-COUNT. AI,R5 2 AI,R4 2 LIKEWISE FOR RESULT. LW,R14 RSRANK GET RANK... BEZ DTBARE SCALAR, WE PT AT THE VALUE WD. DTBARF LW,R9 0,R5 ARRAY, COPY LENGTHS OF RT ARG STW,R9 0,R4 INTO LENGTHS OF RESULT. AI,R4 1 AI,R5 1 BDR,R14 DTBARF FINISH POINTING AT 1ST VALUE WD. DTBARE LW,R14 RSSIZE GET NO.OF ELEMENTS... BEZ DXRETURN NONE. SLS,R4 2 SOME, USE BYTE ADDRESSING ON RES. LI,R11 0 LI,R9 TYPELOGL IS RT ARG LOGICAL... (TYPE = 1) CB,R9 *RTARG BNE DTBARK NO, INTEGER. DTBARLW LW,R10 0,R5 YES, LOAD LOGL VALUE WD. AI,R5 1 PT AT NEXT VALUE WD, IF ANY. LI,R8 32 32 LOGL VALUES PER WD. DTBARLB AI,R10 0 TEST A LOGL VALUE... BGEZ DTBARLZ ZERO. STB,R9 0,R4 ONE, STORE BYTE = 1. DTBARLU AI,R4 1 PT AT NEXT BYTE. BDR,R14 DTBARLS LOOP TILL B DXRETURN DONE WITH LOGL ELEMENTS. DTBARLZ STB,R11 0,R4 STORE BYTE = 0. B DTBARLU DTBARLS SLS,R10 1 GET NEXT LOGL VALUE BIT, BDR,R8 DTBARLB IF ANY REMAIN IN THIS VALUE WD. B DTBARLW GET NEXT WD. DTBARK LW,R9 0,R5 MOVE EACH ELEMENT FROM RT ARG OR,R11 0,R5 (ACCUMULATING BITS FOR VALIDATION) STB,R9 0,R4 INTO RESULT. AI,R4 1 AI,R5 1 BDR,R14 DTBARK DTBARQ CI,R11 X'FFF00' VALIDATE NO ELEMENT EXCEEDED 8 BITS. BAZ DXRETURN OK. B ERDOMAIN OOPS -- DOMAIN ERROR. ITEST CI,R2 #DINTRS @ NO.OF DYADIC INTRINSICS. CI,R2 #MINTRS @ NO.OF MONADIC INTRINSICS. NINTRIN CI,R2 #NINTRS @ NO.OF NILADIC INTRINSICS. BL NYV,R2 OK, VECTOR ON THE INTRINSIC NO. BAL,R15 SYSTERR TOO BIG MINTRIN CI,R6 #MINTRS NO.OF MONADIC INTRINSICS. BL MYV,R6 OK, VECTOR ON THE INTRINSIC NO. BAL,R15 SYSTERR TOO BIG DINTRIN CI,R6 #DINTRS NO.OF DYADIC INTRINSICS. BL DYV,R6 OK, VECTOR ON THE INTRINSIC NO. BAL,R15 SYSTERR TOO BIG INTRIGUE CLM,R6 INTRANGE VERIFY TYPE VALUE IS INTRINSIC... BCS,9 ERDOMAIN NO -- DOMAIN ERROR. CH,R8 *RTARG OK, VERIFY SCALAR RT ARG... BANZ ERRANK NOPE -- RANK ERROR. LW,R4 RTARG YEP, PT AT RT ARG DATA BLK. LW,R2 2,R4 GET RT ARG VALUE WD. CB,R5 *RTARG IS RT ARG AN INTEGER TYPE... BE INTRIGUI YES. SLS,R2 -31 NO, PROBABLY LOGICAL TYPE, GET BIT LI,R5 TYPELOGL VERIFY LOGICAL TYPE... CB,R5 *RTARG BNE ERDOMAIN OOPS -- DOMAIN ERROR. INTRIGUI AI,R2 0 VERIFY POSITIVE VALUE. BLZ ERDOMAIN NEGATIVE -- DOMAIN ERROR. EXU ITEST-DYINT,R6 VERIFY NOT TOO BIG... BGE ERDOMAIN IT IS -- DOMAIN ERROR. LI,R11 2 OK, ALLOCATE A 2-WD DATA BLK. BAL,R7 ALOCBLK STW,R4 RESULT SAVE PTR TO RESULT DATA BLK. STH,R2 *RESULT PLUG IN THE INTRINSIC NO. STB,R6 *RESULT PLUG IN THE INTRINSIC TYPE. B DXRETURN RETURN FROM DYADIC-OP EXECUTION, DYV B DELTAFMT @ DYADIC INTRINSIC NO. 0 BDR,R6 %+1 @ (FILEOPS--SET R6=0) 1 B FILEOPS @ (APL ERR-HANDLING VERSION) 2 B DELTAGRF @ 3 BAL,R15 SYSTERR @ 4 BAL,R15 SYSTERR @ 5 BAL,R15 SYSTERR @ 6 BAL,R15 SYSTERR @ 7 #DINTRS EQU %-DYV @ # DYAD.INTRINSICS. MYV B IORIGIN @ MONADIC INTRINSIC NO. 0 B IWIDTH @ 1 B IDIGITS @ 2 B ITABS @ 3 B ISETLINK @ 4 B ISETFUZZ @ 5 B IDELAY @ 6 BAL,R15 SYSTERR @ 7 BAL,R15 SYSTERR @ 8 BAL,R15 SYSTERR @ 9 BAL,R15 SYSTERR @ 10 BAL,R15 SYSTERR @ 11 #MINTRS EQU %-MYV @ # MON.INTRINSICS. NYV B ERRN @ NILADIC INTRINSIC NO. 0 B ERRF @ 1 B ERRX @ 2 BAL,R15 SYSTERR @ 3 #NINTRS EQU %-NYV @ IORIGIN BAL,R14 IV1 GET THE ELEMENT. LI,R5 EZQ-1 GO TO 'EZQ' AFTER B SETORG SETTING THE ORIGIN. B ERDOMAIN @ (ERR RETURN FROM THE SET-ROUTINES) EZQ LW,R11 R7 @ PUT OLD VALUE (RESULT) IN R11. U05-0024 B SCLRRES PRODUCE SCALAR, INTEGER RESULT. U05-0025 IWIDTH BAL,R14 IV1 GET THE ELEMENT. LI,R5 EZQ-1 GO TO 'EZQ' AFTER B SETWIDTH SETTING THE WIDTH. IDIGITS BAL,R14 IV1 GET THE ELEMENT. LI,R5 EZQ-1 GO TO 'EZQ' AFTER B SETDIGIT SETTING DIGITS. ISETFUZZ BAL,R14 IV1 GET THE ELEMENT. LI,R5 EZQ-1 GO TO 'EZQ' AFTER B SETFUZZ SETTING FUZZ. ISETLINK BAL,R14 IV1 GET THE ELEMENT. OR,R7 ONE INSURE THAT WE USE ODD LINK. BLZ ERDOMAIN NEGATIVE -- DOMAIN ERROR. XW,R7 RANDOM SET NEW, GET OLD LINK. B EZQ IDELAY BAL,R14 IV1 GET THE ELEMENT. CLM,R7 DELAYRNG VERIFY REASONABLE DELAY VALUE. BCS,9 ERDOMAIN NOT -- DOMAIN ERROR. BAL,R5 DELAYER OK -- DELAY EXECUTION...... LI,R11 0 (RESUME EXECUTION) STW,R11 CONSTBUF SET UP TO FAKE OUT THE TAB RESULT B IMEMPTY GENERATOR SO THAT AN EMPTY VECTOR * RESULTS. ITABS LB,R2 *RTARG GET RT ARG'S TYPE... AI,R2 -TYPEINTG BEZ ITABSI INTEGER. AI,R2 TYPEINTG-TYPEXSEQ BNEZ ITABSQ LOGICAL PERHAPS. LW,R4 RTARG INDEX SEQUENCE. LW,R6 2,R4 GET ITS LENGTH. CI,R6 16 BG ERLENGTH TOO LONG -- LENGTH ERROR. LW,R7 3,R4 GET ITS BIAS VALUE. LI,R5 CONSTBUF+17 PT AT BUFFER TO SAVE NEW TAB VECTOR. ITABSX AW,R7 4,R4 ADD ITS COEFFICIENT VALUE. STW,R7 0,R5 PUT ANSWER IN BUFFER. AI,R5 1 PT AT NEXT WD IN BUFFER. BDR,R6 ITABSX LW,R6 2,R4 GET LENGTH AGAIN. LI,R4 CONSTBUF+17 PT AT 1ST VALUE IN BUFFER. B ITABSET ITABSQ LI,R2 TYPELOGL**8 VERIFY LOGICAL SCALAR. CH,R2 *RTARG BNE ERDOMAIN OOPS -- DOMAIN ERROR. ITABSI LW,R4 RTARG PT AT WD AFTER RT ARG'S REF-COUNT WD AI,R4 2 LI,R6 1 INIT LENGTH = 1 (ALSO BYTE OFFSET). LB,R8 *RTARG,R6 GET RANK OF RT ARG. BEZ ITABSET SCALAR. AI,R8 -1 BNEZ ERRANK NON-VECTOR ARRAY -- RANK ERROR. LW,R6 0,R4 VECTOR, GET ITS LENGTH. AI,R4 1 PT AT 1ST VALUE WD. ITABSET BAL,R2 TABSET SET TABS IF OK. B ERDOMAIN OOPS -- DOMAIN ERROR. LW,R11 CONSTBUF OK, GET NO.OF OLD TAB VALUES. IMEMPTY AI,R11 1 ALLOCATE VECTOR OF THAT LENGTH BAL,R7 ALOCHNW PLUS 2-WD HDR & EVEN SIZE. STW,R4 RESULT SAVE PTR TO RESULT DATA BLK. LI,R11 (TYPEINTG**8)+1 TYPE = INTEGER RANK = 1. STH,R11 *RESULT LW,R6 CONSTBUF GET NO.OF OLD TAB VALUES. STW,R6 2,R4 SET LENGTH OF VECTOR RESULT. AI,R4 2 PT AT LENGTH WD. ITABSZ LW,R7 CONSTBUF,R6 FILL IN VALUES STW,R7 *R4,R6 FROM LAST BDR,R6 ITABSZ TO FIRST. B MXRETURN PAGE ************************************************************************ SPACE 2 Z SET %-INTRINS@ SIZE OF INTRINS IN HEX. SPACE Z SET Z+Z/10*6+Z/100*96+Z/1000*1536 SIZE IN DECIMAL. SPACE 3 END