TITLE 'SCMD-B00,08/22/73,DWG702985' SYSTEM SIG7F CSECT 1 PCC 0 CONTROL CARDS NOT PRINTED. SCMD@ RES 0 ORIGIN OF SIMPLE-CMD MODULE. * * REF'S AND DEF'S * DEF SCMD@ = START OF 'SCMD' MODULE. DEF @WIDTH WIDTH COMMAND PROCESSOR. DEF @DIGITS DIGITS COMMAND PROCESSOR. DEF @ORIGIN ORIGIN COMMAND PROCESSOR. DEF @ERASE ERASE COMMAND PROCESSOR. DEF RESIDAM RESUME ERASING AFTER SI DAMAGE. DEF RERASE RESUME ERASING. DEF @GROUP GROUP COMMAND PROCESSOR. DEF @GRP GRP COMMAND PROCESSOR. DEF @FNS FNS COMMAND PROCESSOR. DEF @GRPS GRPS COMMAND PROCESSOR. DEF @VARS VARS COMMAND PROCESSOR. DEF @SIV SIV COMMAND PROCESSOR. DEF @SI SI COMMAND PROCESSOR. DEF @CATCH CATCH COMMAND PROCESSOR. DEF @OBSERVE OBSERVE COMMAND PROCESSOR. DEF FOROPEN FORCED OPEN OF CLOSED FN. SPACE 2 * REFS TO PROCEDURE: REF ACQCONLY ACQUIRES CONSTANT ONLY. REF ACQIT ACQUIRES NAME OR NUMERIC ITEM. REF ACQNAME ACQUIRES A NAME. REF ACQNB ACQUIRES NON-BLANK CHAR. REF ACQNXCC ACQUIRES NEXT CHAR & CODE. REF ALOCNONX ALLOC DATA BLK: N WDS + HDR, EVEN * SIZE. NON-EXECUTION MODE. REF CMDERR COMMAND ERROR. REF CMDEXIT COMMAND EXIT. REF DREF DE-REFERENCER. REF DUMPLING LINE OUTPUT ROUTINE. REF ERBADCMD ERROR -- BAD COMMAND. REF ERRERASE ERROR -- ... NOT ERASED. REF FERASECK CK FOR ERASE OF FUNC BEING DEFINED. REF FINDNAME FINDS A NAME, BUT WON'T CREATE NEW. REF FUNLDISP PUTS FUNC. NAME & LINE NO. IN IMAGE REF GENCHAR GENERATE CHARACTER (OR MNEMONIC) REF GENNAME GEN. NAME (EXPAND MNEM. IF PRESENT) REF GENNAME0 (DITTO, BUT WITHOUT INDENTATIONS). REF INPDIR DIRECT INPUT HANDLER. REF INPRET INPUT DRIVER ENTRY PT. REF ISVAL DISPLAYS 'IS ' & PARAMETER VALUE. REF MAYDREF DEREFERENCE IF R4 PTS AT A DATA BLK. REF OUTORANG EXIT (DUAL) FOR COMMON CMDS. REF SETDIGIT SET DIGITS,GET OLD VALUE REF SETORG SET NEW ORIGIN-GET OLD VALUE REF SETWIDTH SET WIDTH,GET OLD VALUE REF SICLR CLEARS STATE-INDICATOR TO GO-STATE. REF SIDAME SI DAMAGE DURING ERASE. REF SQUEEZER ENTRY IN APLINPUT TO SQUEEZE MNEM'S REF XWLOCGLB EXCHANGES LOCALS & GLOBALS. * REFS TO CONTEXT: REF BREAKFLG BREAK FLAG. REF CATCHTBL CATCH TABLE. REF CONSTBUF CONSTANT BUFFER. REF COPYSAVE SCRATCH DBLWD. REF DIGITS REF GOSTATE PT AT STATE-ENTRY TO CLEAR DOWN TO. REF HICOL HIGH COLUMN INDICATOR. REF HICOMMON HIGHEST ADDR. IN COMMON REGION. REF IMAGE IMAGE BUFFER. REF MODE EXECUTION MODE. REF NAMEBUF NAME BUFFER. REF OBSERVE OBSERVATION SETTING. REF OBSFLAG OBSERVE FLAG. REF OPENFN POINTER TO FNCT NAME OF FORCED CLOSE REF ORIGIN INDEX ORIGIN REF RESULT PTS AT A NEW DATA BLK. REF SAVE312 SAVE AREA. REF SICTRL STATE-INDICATOR CONTROL SETTING. REF STATEPTR PTS AT TOP STATE-ENTRY IN XEQ STACK. REF SYMT PTS AT SYM TBL. REF SYMTSIZE NO.OF ENTRIES IN SYM TBL. REF WIDTH * REFS TO CONSTANTS: REF BITPOS TBL OF BITS--BITPOS-K = K-TH BIT. REF BLANKS BLANKS. REF FUNTYPES DBLWD -- RANGE OF USER-DEFD FUN TYPS REF IDNOTGRP ERROR I.D. FOR -- NOT GROUPED. REF IDSYMFUL ERROR I.D. FOR -- SYM TBL FULL. REF IDWSFULL ERROR I.D. FOR -- WS FULL. REF MAXREAL X'7FFFFFFF' REF STACKOFF OFFSET FROM HI COMMON TO XEQ STACK. REF TEXTCLEA 'CLEA' REF TEXTOFF 'OFF ' REF X1FFFF X'1FFFF' * * 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 * * CATF EQU 10 FUNCTION-STATE CATEGORY, STACK-ENTRY QUAD EQU X'53' INTERNAL (EBCDIC) CHAR -- QUAD. NAMECODE EQU 23 CODESTRING DESIG -- ORDINARY NAME. LASTCSV EQU 138 LAST CODESTRING DESIGNATION = DUMMY. PENDFLAG EQU X'8000' MARKS PENDENT STATE-ENTRIES IN STACK TYPELOGL EQU 1 DATA BLK TYPE = LOGICAL. TYPELIST EQU 6 DATA BLK TYPE = LIST. TYPEGRP EQU X'11' DATA BLK TYPE = GROUP. * CONSTANTS * PAGE * * @WIDTH-CHANGE WIDTH AND(OR) REPORT OLD VALUE * @WIDTH LI,R6 SETWIDTH = WIDTH PARAMETER ROUTINE LOC. LW,R7 WIDTH CURRENT WIDTH SETTING. PARAMCMD STD,R6 COPYSAVE SAVE PARAM. ROUTINE LOC & VALUE. BAL,R14 ACQCONLY ACQ 1 CONSTANT ONLY, IF ANY... BL ISVAL NONE, DISPLAY 'IS ' & VALUE. BG ERBADCMD TOO MANY -- BAD COMMAND. LI,R5 OUTORANG OK, SET DUAL RETURN LOC AND B *COPYSAVE GO TO PARAMETER SET ROUTINE. PAGE * * @DIGITS-CHANGE DIGITS AND(OR) REPORT OLD VALUE * @DIGITS LI,R6 SETDIGIT = DIGITS PARAMETER ROUTINE LOC. LW,R7 DIGITS CURRENT DIGITS SETTING. B PARAMCMD PAGE * * @ORIGIN-CHANGE ORIGIN AND(OR) REPORT OLD VALUE * @ORIGIN LI,R6 SETORG = ORIGIN PARAMETER ROUTINE LOC. LW,R7 ORIGIN CURRENT ORIGIN SETTING. B PARAMCMD PAGE * * @ERASE-DRIVER TO ERASE NAMED GLOBAL OBJECTS FROM USERS WORKSPACE * @ERASE LI,R14 0 PRESET NAME COUNTER. STW,R14 CONSTBUF CI,R3 LASTCSV DOE A NAME FOLLOW ')ERASE'... BLE ERBADCMD NO -- INCORR. CMND. ERASEA BAL,R8 FINDNAME FIND THE NAME... B ERASEB NOT FOUND. MTW,1 CONSTBUF FOUND, BUMP NAME COUNT. LW,R7 CONSTBUF STW,R6 CONSTBUF,R7 PUT ITS NAME PTR IN BUFFER. ERASEB CI,R3 LASTCSV DOES ANOTHER NAME FOLLOW... BG ERASEA YES, LOOP BACK. AI,R2 -X'15' NO, VERIFY END OF STMT... BNEZ ERBADCMD OOPS -- INCORR. CMND. LW,R2 MODE IS THIS FUNC. DEFN MODE... BNEZ ERASEC NO. BAL,R14 FERASECK YES, MAY ERASE THE OPEN FUNCTION. ERASEC BAL,R14 XWLOCGLB EXCHANGE LOCALS & GLOBALS. LI,R1 0 PRE-SET INDICATING STW,R1 SAVE312 NOT ON A GROUP. LW,R1 CONSTBUF = # NAMES TO ERASE. ERASED LW,R6 CONSTBUF,R1 GET A NAME PTR. LW,R4 BITPOS-0 EXCHANGE ITS REFERENT-INDICATOR WITH XW,R4 *SYMT,R6 A CLEAR (GLOBAL-BIT ONLY) ONE, STW,R4 CONSTBUF,R1 AND SAVE THE REF-INDIC. AND,R4 X1FFFF IS THERE A REFERENT... BEZ ERASEJ NO -- SKIP IT. LB,R14 *R4 YES. CI,R14 TYPEGRP IS IT A GROUP... BE ERASEGRP YEP. CLM,R14 FUNTYPES IS IT A FUNCTION DESCRIPTOR... BCS,9 ERASEI HOORAY, IT IS NOT. LW,R14 1,R4 DAMN, GET ITS REF-COUNT. AI,R14 -1 DECR IT; IF ONLY 1 REF, WE CAN BEZ ERASEI ERASE THE FUNCTION EASILY. LI,R12 PENDFLAG OTHERWISE, CK FOR IT BEING PENDENT. LI,R5 X'1FFFF' LW,R2 STATEPTR B ERASEF ERASEE LI,R3 X'7FFF' AND,R3 0,R2 BEZ PENDENT NUTS, PENDENT (DYADIC WHOSE LEFT AW,R2 R3 ARG IS UNRESOLVED). ERASEF CS,R4 1,R2 BNE ERASEE CW,R12 0,R2 BANZ PENDENT NUTS, PENDENT (CALLED FOR SOMETHIG BDR,R14 ERASEE & NOT RETURNED TO). MTW,-1 1,R4 OK, SUSPENDED ONLY, DECR REF-CNT LW,R2 STATEPTR MOMENTARILY. B ERASEH DAMAGE EACH SUSPENSION. ERASEG LI,R3 X'7FFF' AND,R3 0,R2 AW,R2 R3 ERASEH CS,R4 1,R2 BNE ERASEG STW,R14 1,R2 (DAMAGED) MTW,-1 1,R4 (DECR REF-COUNT) BGZ ERASEG MTW,1 1,R4 SET REF-COUNT BACK TO 1, FOR SYM TBL BAL,R7 DREF AND DE-REF (DELETE) THE FUNCTION. B SIDAME ERROR -- SIDAMAGE, RESIDAM EQU ERASEJ RETURN AFTER DISPLAY OF ERR MSG. PENDENT LW,R4 CONSTBUF,R1 RESTORE THE ORIGINAL REFERENT-INDIC STW,R4 *SYMT,R6 BACK INTO THE FUNC.NAME SYM TBL * ENTRY. B ERRERASE ERROR -- NAME NOT ERASED, RERASE EQU ERASEJ RETURN AFTER DISPLAY OF ERR MSG. ERASEI BAL,R7 DREF DE-REFERENCE THE ERASED REFERENT. ERASEJ BDR,R1 ERASED LOOP TILL ERASE LIST EXHAUSTED. LW,R7 SAVE312 ARE WE WORKING ON A GROUP... BEZ RXEXIT NO. AI,R7 -1 YES, DECR ITS NAME COUNT. ERASEGQ STW,R7 SAVE312 SAVE THAT COUNT & IF NOT ZERO BGZ ERASEG1 ERASE ANOTHER NAME IN GROUP. LW,R1 SAVE312+2 DONE, RESTORE ORIG. ERASE LIST COUNT LW,R14 SAVE312+3 AND ITS 1ST NAME PTR. STW,R14 CONSTBUF+1 LW,R6 SAVE312+1 GET GROUP'S NAME PTR, AND EXCHANGE LW,R4 BITPOS-0 (AGAIN) ITS SYM TBL REF-INDIC WITH A XW,R4 *SYMT,R6 CLEAR (GLOBAL-BIT ONLY) ONE. B ERASEI THEN GET RID OF THE GROUP ITSELF. ERASEGRP LW,R14 SAVE312 IS THIS A GROUP IN A GROUP... BNEZ ERASEI YES -- DISPERSE IT. STW,R1 SAVE312+2 NO, SAVE CURRENT ERASE LIST COUNT. STW,R4 *SYMT,R6 PUT GROUP'S DB PTR BACK INTO SYM TBL STW,R6 SAVE312+1 SAVE NAME PTR TO THE GROUP. LW,R14 CONSTBUF+1 SAVE ERASE LISTS 1ST NAME PTR. STW,R14 SAVE312+3 AI,R4 2 PT AT COUNT FIELD OF THE GROUP LH,R7 *R4 GET ITS COUNT. B ERASEGQ ERASEG1 LW,R2 SAVE312+1 NAME PTR FOR GROUP ITSELF. LW,R3 *SYMT,R2 GET GROUP'S DATA BLK PTR AGAIN. AI,R3 2 OFFSET TO ITS COUNT FIELD. LH,R6 *R3,R7 GET ONE OF ITS NAME PTRS. AND PUT STW,R6 CONSTBUF+1 IT IN 1ST POS.OF 'ERASE LIST'. LI,R1 1 CLAIM ONLY 1 NAME PTR. LW,R14 MODE IS THIS FUN DEFN MODE... BNEZ ERASED NO--ERASE THAT ONE. STW,R1 CONSTBUF YES, ERASE AFTER CHECKING FOR LI,R14 ERASED MATCH OF THE OPEN FUNC. NAME PTR B FERASECK RXEXIT LI,R14 CMDEXIT TAKE COMMAND EXIT AFTER B XWLOCGLB RE-EXCHANGING LOCALS & GLOBALS. PAGE * * @GROUP-DRIVER TO GATHER LISTED NAMES INTO A GROUP OR DISPERSE A GROUP * @GROUP LI,R14 -1 PRESET NAME COUNTER. STW,R14 CONSTBUF CI,R3 LASTCSV DOES A NAME-START FOLLOW ')GROUP'... BLE ERBADCMD NO -- INCORR. CMND. GRPA BAL,R12 ACQNAME ACQ NAME IF POSSIBLE... B GRPSYMFL OOPS -- SYM TBL FULL. B GRPWSFL OOPS -- WS FULL. AI,R13 -NAMECODE OK, VERIFY ORDINARY NAME... BNEZ ERBADCMD STOP OR TRACE NAME -- INCORR.CMD MTW,1 CONSTBUF BUMP NAME COUNTER. LW,R7 CONSTBUF STW,R6 CONSTBUF+1,R7 SAVE ITS NAME PTR. CI,R3 LASTCSV DOES ANOTHER NAME FOLLOW... BG GRPA YES. AI,R2 -X'15' NO, VERIFY END OF LINE... BNEZ ERBADCMD NOPE -- INCORR. CMND. BAL,R14 XWLOCGLB EXCHANGE LOCALS & GLOBALS. LW,R6 CONSTBUF+1 SET R6 = GROUP'S NAME PTR. LI,R5 X'1FFFF' SET FOR SELECTIVE LOAD. LI,R4 0 LW,R7 CONSTBUF = NO.OF NAMES MINUS 1. BGZ GRPB (CREATE, REPLACE, OR EXPAND A GROUP) LS,R4 *SYMT,R6 (DISPERSE) GET REFERENT-INDICATOR... BEZ RXEXIT NONE -- ASSUME DISPERSED ALREADY. LB,R2 *R4 OK, VERIFY IT'S A GROUP... AI,R2 -TYPEGRP BEZ DISPERSE BINGO -- DE-REFERENCE IT. NOTGROUP LI,R14 ERNOTGRP ISSUE DIAGNOSTIC AFTER B XWLOCGLB RE-EXCHANGING LOCALS & GLOBALS. GRPWSFUL BAL,R14 XWLOCGLB RE-EXCHANGE LOCALS & GLOBALS. GRPWSFL LI,R8 IDWSFULL = ERROR I.D. FOR 'WS FULL'. B CMDERR CMD ERROR EXIT. GRPSYMFL LI,R8 IDSYMFUL = ERROR I.D. FOR 'SYM TBL FULL'. B CMDERR CMD ERROR EXIT. GRPB LS,R4 *SYMT,R6 GET REFERENT-INDICATOR... BEZ GRPC NONE -- CREATE NEW GROUP. LB,R14 *R4 SOME -- REPLACE OR EXPAND GROUP. AI,R14 -TYPEGRP VERIFY IT'S A GROUP... BNEZ NOTGROUP OOPS. GRPC LW,R11 CONSTBUF = # NAMES IN THIS )GROUP LIST. LI,R10 0 CLEAR GROUP-NAME REPETITION COUNT. * (SO WE CAN HANDLE EVEN WEIRDOS * LIKE ')GROUP G A G B G C G' ). GRPD CW,R6 CONSTBUF+1,R7 CK FOR REPEATED GROUP NAME PTR... BNE GRPE NO. AI,R10 -1 YES, DECR REPETITION COUNT AND STW,R10 CONSTBUF+1,R7 REPLACE NAME PTR BY IT. GRPE BDR,R7 GRPD WORK BACK THROUGH THE LIST. AW,R11 R10 = # NAMES GROUPED BY THE LIST. AI,R10 0 ANY GROUP-NAME REPETITION... BEZ GRPF NO. AI,R4 0 YES, DOES ITS GROUP ALREADY EXIST. BEZ GRPF NO (STUPID GROUP CMND). AI,R4 2 YES, ADD IN THE # NAMES IN THE AH,R11 *R4 OLD GROUP. GRPF STH,R11 CONSTBUF SET LENGTH OF NEW GROUP. AI,R11 2 ACCT FOR LENGTH HALFWD & ROUND UP. SLS,R11 -1 = SIZE NEEDED FOR NEW GROUP DATA BLK BAL,R14 ALOCNONX ALLOC IT & DB HDR... B GRPWSFUL OOPS -- WS FULL. STW,R4 RESULT FINE, SAVE PTR TO NEW DATA BLK. LI,R14 TYPEGRP MAKE IT A GROUP TYPE DATA BLK. STB,R14 *RESULT LI,R5 4 PLUG IN THE NEW GROUP'S LENGTH. LH,R10 CONSTBUF STH,R10 *RESULT,R5 INT,R7 CONSTBUF GET LENGTH OF )GROUP CMND'S LIST. GRPG LW,R10 CONSTBUF+1,R7 (FROM RT TO LF) GET LIST'S NAME PTR BLZ GRPI OR REPETITION INDICATOR. AI,R5 1 NOTE--PLUG IN NAME PTRS IN REVERSE ORDER STH,R10 *RESULT,R5 WITH RESPECT TO CMND'S LIST. GRPH BDR,R7 GRPG LI,R2 0 CLEAR & GET PTR TO NEW GROUP. XW,R2 RESULT LW,R4 *SYMT,R6 GET OLD REF-INDICATOR FOR THAT NAME. DISPERSE LI,R3 X'1FFFF' REPLACE OLD REF-INDIC BY PTR TO NEW STS,R2 *SYMT,R6 GROUP (BY ZERO IF A DISPERSE). LI,R7 RXEXIT GO TO 'RXEXIT' AFTER DE-REFERENCING B MAYDREF ANY OLD GROUP INDICATED. GRPI AI,R10 1 IS IT 1ST REPETITION... BNEZ GRPH NO, SKIP IT. LI,R2 0 U17-0008 LI,R3 X'1FFFF' YES, IS THERE AN OLD GROUP OF THE LS,R2 *SYMT,R6 SAME GROUP-NAME REPEATED... BEZ GRPH NOPE, SKIP IT. LI,R3 4 YEP. LH,R14 *R2,R3 GET # NAME PTRS IN OLD GROUP. BEZ GRPH NONE, SKIP IT. GRPJ AI,R3 1 LH,R10 *R2,R3 MOVE NAME PTRS FOR OLD GROUP INTO AI,R5 1 THE NEW GROUP (RETAINING SAME STH,R10 *RESULT,R5 ORDER AS FOR OLD GROUP -- WHICH BDR,R14 GRPJ WAS BACKWARDS FOR OLD GROUP'S B GRPH CMND LIST). ERNOTGRP LI,R8 IDNOTGRP ERROR I.D. FOR 'NOT GROUPED'. B CMDERR CMD ERROR EXIT. PAGE ************************************************************************ * * * GAP -- PUTS BLANKS INTO IMAGE BUFFER FOR SPACING & COLUMNARIZATION * * UNLESS -- WE ARE AT LEFT MARGIN OR REACH CURRENT WIDTH. * * REGS: R13 -- LINK, EXIT VIA *R13. * * R3 -- COLUMN INDICATOR. * * R7 IS VOLATILE * * * GAP AI,R3 0 ARE WE AT LEFT MARGIN... BEZ *R13 YES -- EXIT. LI,R7 ' ' NO, GET A BLANKETY-BLANK BLANK. GAPW CW,R3 WIDTH HAVE WE HIT WIDTH-SETTING... BGE *R13 YES -- EXIT. STB,R7 IMAGE,R3 NO, PLUG IN A BLANK. AI,R3 1 INCR COLUMN INDICATOR. CI,R3 3 IS IT A MULTIPLE OF 4... BANZ GAPW NOT YET. B *R13 YES -- EXIT. PAGE * * @GRP-DRIVER TO LIST NAMES OF OBJECTS IN A GROUP * @GRP CI,R3 LASTCSV DOES A NAME-START FOLLOW ')GRP'... BLE ERBADCMD NO -- INCORR. CMND. BAL,R8 FINDNAME YES, FIND THE NAME... B CMDEXIT NOT FOUND -- EXIT. AI,R2 -X'15' FOUND, VERIFY THAT ENDS THE CMND BNEZ ERBADCMD OOPS -- INCORR. CMND. STW,R6 CONSTBUF OK, SAVE THE NAME PTR. BAL,R14 XWLOCGLB EXCHANGE LOCALS & GLOBALS. LW,R6 CONSTBUF GET THE REFERENT-INDICATOR FOR THE LI,R1 X'1FFFF' NAMED ITEM... AND,R1 *SYMT,R6 BEZ RXEXIT NONE -- SKIP IT. LB,R14 *R1 OK, VERIFY REFERENT IS A GROUP. AI,R14 -TYPEGRP BNEZ NOTGROUP YUCK -- NOT GROUPED. AI,R1 2 PT AT 1ST WD OF THE GROUPING, AND STW,R1 CONSTBUF SAVE THAT LOC. LH,R1 *CONSTBUF GET LENGTH OF THE GROUP... BEZ RXEXIT ZERO -- SKIP IT. LI,R3 0 PRESET COLUMN INDICATOR. GRPOUT BAL,R13 GAP GIVE SPACING & COLUMNARIZATION. LH,R8 *CONSTBUF,R1 FROM LAST NAME PTR TO FIRST, DELIVER STW,R1 CONSTBUF+1 TO 'GENNAME0' WHICH PUTS THE NAMES BAL,R13 GENNAME0 IN IMAGE BUFFER (NO INDENTATIONS) LW,R1 CONSTBUF+1 IN PROPER FORM, OUTPUTTING AS BDR,R1 GRPOUT WHOLE LINES ARE FILLED UP. AI,R3 0 WAS LAST LINE OUTPUT ALREADY... BEZ RXEXIT YES. LI,R12 RXEXIT NO, GO TO 'RXEXIT' AFTER B DUMPLING OUTPUTTING LAST LINE. PAGE ************************************************************************ * * * QNAME -- COMPARES A TEST NAME-STRING AGAINST THE STRING IN CONSTBUF. * * REGS: R7 -- LINK, EXITS: 0,R7 = HIGH TEST STRING * * 1,R7 = EQUAL TEST STRING * * 2,R7 = LOW TEST STRING * * R6 -- (EXIT) = NO.OF WDS TO CONTAIN THE TEST STRING. * * R1 -- (ENTRY) PTS AT A SYMBOL TABLE NAME-INDICATOR WD * * AND HAS A 1 IN BYTE 0. FOR A SHORT NAME* * THE NAME-INDIC. WD CONTAINS IT. * * FOR A LONG NAME THE NAME-INDIC. WD * * CONTAINS A PTR TO THE 1ST WD OF THE* * NAME & BYTE 0 CONTAINS THE NO.OF * * WDS USED TO CONTAIN THE NAME. * * R9 -- (ENTRY) CONTAINS ALL BLANKS. * * R2 & R3 ARE VOLATILE. * * * QNAME LW,R6 BREAKFLG TEST FOR A BREAK OR HANG-UP... BNEZ QBREAK YES -- BREAK EXIT. LB,R6 *R1 GET BYTE 0 OF NAME-INDICATOR WD. CI,R6 20 IS IT LESS THAN A NAME-START CHAR... BLE QNAMEL YES, IT'S LONG NAME WD COUNT. LI,R6 1 NO, SHORT NAME, USE WD COUNT OF 1. LW,R3 R1 SET 'DESTINATION' REG (WD RESOLUT'N) B QNAMES QNAMEL LW,R3 0,R1 SET 'DESTINATION' REG (WD RESOLUT'N) QNAMES SLS,R3 2 USE BYTE RESOLUTION. LI,R2 BA(CONSTBUF) SET 'SOURCE' REG. CBS,R2 0 TEST SOURCE VS DESTINATION STRINGS. BL 0,R7 LO -- EXIT, TEST-STRING IS HIGH. BG 2,R7 HI -- EXIT, TEST-STRING IS LOW. CW,R9 CONSTBUF,R6 EQUAL, IS 'SOURCE' A LONGER NAME. BNE 2,R7 YES -- EXIT, TEST-STRING IS LOW. B 1,R7 NO -- EXIT, NAMES ARE IDENTICAL. PAGE * * @FNS-DRIVER TO LIST NAMES OF FUNCTIONS IN USERS WORKSPACE * * @GRPS-DRIVER TO LIST NAMES OF GROUPS IN USERS WORKSPACE * * @VARS-DRIVER TO LIST NAMES OF GLOBAL VARIABLES IN USERS WORKSPACE * @FNS LD,R10 FUNTYPES = RANGE OF USER-DEFD FUNCTION TYPES. AI,R11 3 EXPAND TO COVER INTRINSIC FUN TYPES. B QSET @GRPS LI,R10 TYPEGRP = RANGE OF GROUP TYPE DATA BLK TYPES QSETGRP LI,R11 TYPEGRP B QSET @VARS LI,R10 TYPELOGL = RANGE OF VARIABLE TYPES. LI,R11 TYPELIST QSET STD,R10 CONSTBUF+44 SAVE RANGE OF DB TYPES OF INTEREST. LI,R5 -11 LW,R9 BLANKS BLANK 22 WDS EACH OF THE QSETA STD,R9 CONSTBUF+22,R5 LO COMPARE STRING AND STD,R9 CONSTBUF+44,R5 HI COMPARE STRING. BIR,R5 QSETA STW,R5 CONSTBUF+47 ZERO (LEFT MARGIN) COL.INDIC. HOLDER LI,R5 '9' SET THE HI COMPARE STRING BIGGER STB,R5 CONSTBUF+22 THAN ANY BREADBOX. CI,R2 X'15' DOES CMND LINE END ALREADY... BE QX YES. LI,R5 -80 NO, MOVE UP TO 80 NEW CHARS INTO QSETB STB,R2 CONSTBUF+20,R5 THE LO COMPARE STRING. BAL,R4 ACQNXCC CI,R2 ' ' QUIT ON BLANK OR LESS. BLE QSETC BIR,R5 QSETB B ACQNXCC SKIP IF OVER 80 CHARS. QSETC BAL,R4 ACQNB GET 1ST NON-BLANK AFTER LO STRING. CI,R2 X'15' DOES CMND LINE END NOW... BE QX YES. LI,R5 -80 NO, MOVE UP TO 80 NEW CHARS INTO QSETD STB,R2 CONSTBUF+42,R5 THE HI COMPARE STRING. BAL,R4 ACQNXCC CI,R2 ' ' QUIT ON BLANK OR LESS. BLE QSETE BIR,R5 QSETD B ACQNXCC SKIP IF OVER 80 CHARS. QSETE BAL,R4 ACQNB GET 1ST NON-BLANK AFTER HI STRING. AI,R2 -X'15' VERIFY THAT ENDS THE CMND. BNEZ ERBADCMD OOPS -- INCORR. CMND. QX BAL,R14 XWLOCGLB EXCHANGE LOCALS & GLOBALS. BAL,R7 QINIT INIT. FOR SYMBOL COMPARISONS. QSYMA AI,R1 2 PT AT A NAME-INDICATOR WD. LI,R5 X'1FFFF' DOES THAT SYMBOL TABLE ENTRY HAVE A AND,R5 -1,R1 REFERENT... BEZ QSYML NO, LEAVE ITS HIT-BIT = 0. LB,R10 *R5 YES, GET REFERENT'S D.B. TYPE. CLM,R10 CONSTBUF+44 IS IT A TYPE WE ARE INTERESTED IN... BCS,9 QSYML NO, LEAVE HIT-BIT = 0. BAL,R7 QNAME @ YES, COMPARE NAME TO LO STRING... B %+1 @ ABOVE (SET HIT-BIT = 1). AWM,R13 -1,R1 @ EQUAL (SET HIT-BIT = 1). * @ BELOW (LEAVE HIT-BIT = 0). QSYML BIR,R8 QSYMA SWEEP THE WHOLE SYMBOL TABLE. LI,R5 -10 QSYMH LD,R8 CONSTBUF+42,R5 REPLACE LO COMPARE STRING BY HI STD,R8 CONSTBUF+20,R5 COMPARE STRING. BIR,R5 QSYMH BAL,R7 QINIT INIT. FOR SYMBOL COMPARISONS. QSYMB AI,R1 2 PT AT A NAME-INDICATOR WD. CW,R13 -1,R1 TEST HIT-BIT... BAZ QSYMZ 0 -- WE AREN'T INTERESTED. BAL,R7 QNAME @ 1 -- COMPARE NAME TO HI STRING... B QHITOFF @ ABOVE (SET HIT-BIT BACK = 0). B %+1 @ EQUAL. * @ BELOW. QSYMZ BIR,R8 QSYMB SWEEP THE WHOLE SYMBOL TABLE. * * NOTE --AT THIS PT ONLY SYM TBL ENTRIES WHOSE HIT-BIT = 1 ARE OF THE * RIGHT TYPE AND USE NAMES IN THE CORRECT RANGE. EACH OF THOSE * NAMES WILL BE DISPLAYED IN (EBCDIC) ORDER. WHEN DISPLAYED * THE CORRESPONDING HIT-BIT WILL BE SET = 0 TO AVOID USING * THAT NAME AGAIN. WE QUIT WHEN ALL HIT-BITS ARE SET = 0. * QHUNT LI,R7 QHUNTA EXIT FROM QINIT TO QHUNTA. QINIT LW,R9 BLANKS INSURE R9 = ALL BLANKS. LI,R13 X'40000' INSURE R13 = HIT-BIT. LCW,R8 SYMTSIZE = - NO.OF SYM TBL ENTRIES. LW,R1 SYMT PT AT SYM TBL. STW,R1 CONSTBUF+46 SET 'CANDIDATE' FLAG POSITIVE. AI,R1 -1 PT 2 WDS AHEAD OF 1ST NAME-INDICATOR AW,R1 BITPOS-7 SET R1'S BYTE 0 TO A ONE (= NO.OF * WORDS NEEDED FOR SHORT NAMES). B 0,R7 EXIT. QHITOFF EOR,R13 -1,R1 STW,R13 -1,R1 TURN OFF HIT-BIT. LI,R13 X'40000' RESTORE R13 = HIT-BIT. B QSYMZ QHUNTA AI,R1 2 PT AT A NAME-INDICATOR WD. CW,R13 -1,R1 TEST HIT-BIT... BAZ QHUNTZ 0 -- WE AREN'T INTERESTED. BAL,R7 QNAME @ 1, COMPARE NAME & LATEST CANDIDATE B QHUNTZ @ ABOVE (NOT INTERESTED YET). B %+1 @ EQUAL (ONLY FAST HIT OF HI ONE). STW,R8 CONSTBUF+46 @ BELOW (SET 'CANDIDATE' FLAG TO * MINUS SYMTSIZE + COUNT). LI,R3 QMOVE GO TO QMOVE AFTER SETTING UP BLANKS. QRESETHI LI,R5 -10 LW,R9 BLANKS QBLANK STD,R9 CONSTBUF+20,R5 BLANK THE CANDIDATE STRING. BIR,R5 QBLANK LI,R5 '9' SET 1ST BYTE ABOVE ALL NAMES. STB,R5 CONSTBUF B 0,R3 EXIT. QMOVE CI,R6 1 IS NEW CANDIDATE LONG OR SHORT... BG QLONG LONG. LW,R10 0,R1 SHORT, GET THAT NAME AND B QCANDY PUT IT IN CANDIDATE STRING. QLONG LW,R5 0,R1 PT AT 1ST WD OF LONG NAME. AI,R5 -1 BACK UP FOR INDEXING THRU THE NAME. QLONGET LW,R10 *R5,R6 GET NAME WDS (FROM LAST TO FIRST). QCANDY STW,R10 CONSTBUF-1,R6 PUT NAME WD IN CANDIDATE STRING. BDR,R6 QLONGET LOOP TILL 1ST NAME WD REPLACES THE * 'HI' WD OF CANDIDATE STRING. QHUNTZ BIR,R8 QHUNTA SWEEP THE WHOLE SYMBOL TABLE. LW,R8 CONSTBUF+46 GET LATEST CANDIDATE FLAG... BLZ QSCORE MINUS -- GOTCHA. LW,R3 CONSTBUF+47 NOT, GET COLUMN INDICATOR... BEZ RXEXIT 0 -- RE-EXCHANGE & EXIT. LI,R12 RXEXIT NZ, GO TO RXEXIT AFTER. B DUMPLING DISPLAYING LAST LINE. QBREAK LW,R8 SYMTSIZE ON BREAK OR HANG-UP, LW,R1 SYMT PUT ALL HIT-BITS = 0. EOR,R13 MAXREAL+1 (MAXREAL+1 = -1) GET ALL BUT HIT-BIT LI,R12 0 QGBACK LS,R12 0,R1 STW,R12 0,R1 AI,R1 2 BDR,R8 QGBACK B RXEXIT EXIT TO RE-EXCHANGE LOCALS & GLOBALS QSCORE AW,R8 SYMTSIZE GET ENTRY NO. FOR CANDIDATE. SLS,R8 1 MAKE IT A NAME PTR. LW,R3 R8 EOR,R13 *SYMT,R3 STW,R13 *SYMT,R3 SET ITS HIT-BIT BACK = 0. LI,R13 X'40000' LW,R3 CONSTBUF+47 GET LATEST COLUMN INDICATOR. BAL,R13 GENNAME0 PUT NAME IN IMAGE BUFFER, NO INDENTS BAL,R13 GAP PUT IN SPACING & COLUMNARIZATION. STW,R3 CONSTBUF+47 SAVE NEW COLUMN INDICATOR. LI,R3 QHUNT START ANOTHER SYM TBL SWEEP AFTER B QRESETHI RESETTING THE CANDIDATE STRING TOO * HIGH (SO ANY NAME WILL DO). PAGE * * @SIV-DRIVER TO LIST STATE VECTOR AND ASSOCIATED LOCAL VARIABLES * * @SI-DRIVER TO LIST STATE VECTOR * @SIV LI,R3 0 FLAG THAT THIS IS AN )SIV CMND. @SI STW,R3 CONSTBUF SAVE )SI VS )SIV FLAG. AI,R2 -X'15' VERIFY END-OF-STMT. BNEZ SIOPTION NO, CK FOR SI CONTROL OPTION. LW,R1 STATEPTR PT AT TOP STATE-ENTRY IN STACK. SIA STW,R1 CONSTBUF+1 SAVE CURRENT STATE PTR. LW,R2 BREAKFLG HAS A BREAK OCCURRED... BNEZ CMDEXIT YES -- EXIT LI,R2 X'7FFF' GET WD COUNT TO NEXT STATE-ENTRY. AND,R2 0,R1 BEZ CMDEXIT ZERO (FINAL ENTRY) -- EXIT. STW,R2 CONSTBUF+2 SAVE IT. LI,R3 0 PRESET COLUMN INDICATOR. LB,R14 *CONSTBUF+1 WHAT CATEGORY IS CURRENT STATE... AI,R14 -CATF BEZ SIB FUNCTION ENTRY. LI,R7 QUAD EVALUATED-INPUT ENTRY. LI,R13 SIF GO TO 'SIF' AFTER B GENCHAR PUTTING A QUAD IN IMAGE BUFFER. SIB LW,R14 1,R1 IS THIS A DAMAGED FUNCTION ENTRY... BEZ SIC YES, USE A BLANK FUNCTION NAME & * LINE NUMBER. BAL,R14 FUNLDISP NO, SHOW FUNC.NAME & LINE NUMBER. SIC LI,R13 SID WE MAY LOOP VIA 'GENCHAR'. SID LI,R7 ' ' SET A BLANK. CI,R3 6 HAVE WE REACHED COLUMN 6... BL GENCHAR NO, PUT BLANK & LOOP. LI,R12 PENDFLAG IS THIS A PENDENT FUNCTION... CW,R12 *CONSTBUF+1 BANZ SIE YES, PUT BLANK. LI,R7 '*' NO, PUT * TO SHOW SUSPENSION. SIE BAL,R13 GENCHAR LW,R13 CONSTBUF TEST FLAG FOR )SIV CMND... BEZ SIV IT IS -- SHOW ANY SHADOWED NAMES. SIF AI,R3 0 ARE WE AT LEFT MARGIN... BEZ SIG YES. BAL,R12 DUMPLING NO, OUTPUT LAST IMAGE. SIG LW,R1 CONSTBUF+1 AW,R1 CONSTBUF+2 PT AT NEXT STATE-ENTRY IN STACK. B SIA SIV LW,R6 CONSTBUF+1 PT AT THE FUNCTION STATE-ENTRY. LW,R14 3,R6 GET NO.OF SHADOWED NAMES... BEZ SIF NONE. AI,R6 2 SIW BAL,R13 GAP GIVE SPACING & COLUMNARIZATION. AI,R6 2 PT AT SHADOWED NAME PTR. LW,R8 0,R6 GET THAT NAME PTR. BAL,R13 GENNAME BDR,R14 SIW B SIF SIOPTION BAL,R14 ACQIT ACQUIRE OPTION NAME. LW,R8 NAMEBUF GET OPTION... CW,R8 TEXTCLEA BE SICLEAR CLEAR. CW,R8 TEXTOFF BE SIOFF OFF. SW,R8 TEXTON ON... BNEZ ERBADCMD (OOPS -- BAD COMMAND) SIOFF STW,R8 SICTRL ON=0 & OFF=NZ=DON'T SUSP.FUN ON ERR. B CMDEXIT TEXTON TEXT 'ON ' SICLEAR LW,R8 HICOMMON PT AT LAST WD IN COMMON REGION. AI,R8 -STACKOFF OFFSET TO 'FINAL' STATE ENTRY IN THE STW,R8 GOSTATE STATE-INDICATOR. LI,R14 INPDIR REQUEST DIRECT INPUT AFTER B SICLR CLEARING THE STATE-INDICATOR. PAGE * * @CATCH-DRIVER TO 'CATCH' ASSIGNMENTS TO A VARIABLE NAME * @CATCH CI,R2 X'15' CK FOR END-OF-STMT... BNE CATCH NO, SET A CATCH. STW,R6 CATCHTBL YES, CLEAR ANY CATCHES. STW,R6 CATCHTBL+2 NOTE--R6 IS NEGATIVE. B CMDEXIT EXIT. CATCH CI,R3 LASTCSV DOES A NAME-START FOLLOW )CATCH... BLE ERBADCMD NO -- BAD COMMAND. BAL,R12 ACQNAME ACQ VARIABLE NAME IF POSSIBLE... B GRPSYMFL OOPS -- SYM TBL FULL. B GRPWSFL OOPS -- WS FULL. STW,R6 CONSTBUF OK, SAVE NAME PTR. BAL,R14 ACQIT ACQ 'VIA'... LW,R8 NAMEBUF CW,R8 TEXTVIA BNE ERBADCMD DIDN'T -- BAD COMMAND. CI,R3 LASTCSV DID, DOES NAME-START FOLLOW VIA... BLE ERBADCMD NO -- BAD COMMAND. BAL,R12 ACQNAME ACQ FUNCTION NAME IF POSSIBLE... B GRPSYMFL OOPS -- SYM TBL FULL. B GRPWSFL OOPS -- WS FULL. LW,R7 CONSTBUF OK, GET VARIABLE NAME PTR AGAIN. LI,R5 -4 = SIZE OF CATCHTBL. CATCHN LW,R12 CATCHTBL+4,R5 IS CATCH TBL ENTRY IN USE... BLZ CATCHV NO, FILL IT IN. CW,R7 CATCHTBL+4,R5 YES, FOR SAME VARIABLE NAME... BE CATCHF YEP, JUST CHANGE FUNC.NAME PTR. AI,R5 2 NOPE, TRY NEXT ENTRY. BLZ CATCHN B ERBADCMD NO ROOM -- BAD COMMAND. CATCHV STW,R7 CATCHTBL+4,R5 FILL VARIABLE NAME PTR ENTRY. CATCHF STW,R6 CATCHTBL+5,R5 FILL FUNCTION NAME PTR ENTRY. B CMDEXIT EXIT. TEXTVIA TEXT 'VIA ' PAGE * * @OBSERVE-DRIVER TO 'OBSERVE' INTERMEDIATE RESULTS * @OBSERVE AI,R2 -X'15' VERIFY END-OF-STMT. BNEZ ERBADCMD OOPS -- BAD COMMAND. LI,R2 -2 PREPARE FOR DIRECT INPUT MODE. LI,R5 PENDFLAG CW,R5 *STATEPTR IS TOP STATE PENDENT... BAZ OBSERVES NO, DIRECT INPUT COMING UP. LI,R2 -1 YES, EXECUTION NOW IN PROGRESS. STW,R2 OBSERVE TURN ON OBSERVATION SETTING. OBSERVES STW,R2 OBSFLAG SET OBSERVE-CMD FLAG: -2 OR -1 B CMDEXIT SO IT WILL BE -1 DURING NEXT EXEC. PAGE * * FOROPEN-FORCED OPEN-ROUTINE TO FORE REOPEN OF FUNCTION WHICH * HAS BEEN FORCED CLOSE * * ISSUES MESSAGE- DEL AND FUNCTION NAME (WITH CR) * SIMULATES INPUT OF ISSUED MESSAGE * GOES TO DIRECT INPUT DRIVER TO HANDLE INPUT * (CODESTRINGER WILL RECOGNIZE OPENING DEL AND OPEN FN) * * OW ENTRY, OPENFN HAS NAME OF CLOSED FUNCTION * * REGISTERS ARE USED PROLIFICALLY AND NOT SAVED * * FOROPEN LW,R7 BLANKS BLANK PROMPT STD,R7 IMAGE LI,R3 6 LI,R7 X'7F' APL-DEL BAL,R13 GENCHAR OUTPUT IT (OR MNEMONIC) LI,R7 X'40' BLANK BAL,R13 GENCHAR LW,R8 OPENFN GET NAME PTR OF FN TO BE OPENED BAL,R13 GENNAME STW,R3 HICOL SAVE CHARACTER COUNT FOR SQUEEZER BAL,R12 DUMPLING OUTPUT THE LINE LB,R11 OPENFN RECOVER OLD MODE, U17-0010 BNEZ REMODE IF PRESENT; U17-0011 LI,R11 1 OTHERWISE, ASSUME DIRECT MODE. U17-0012 REMODE STW,R11 MODE U17-0013 LI,R11 INPRET+1 SET EXIT FROM 'APLINPUT'(SQUEEZER) STW,R11 SAVE312+8 USE TAIL-END OF APLINPUT ROUTINE B SQUEEZER TO REDUCE MNEMONIC IF PRESENT PAGE ************************************************************************ SPACE 2 Z SET %-SCMD@ SIZE OF SCMD MODULE IN HEX. SPACE Z SET Z+Z/10*6+Z/100*96+Z/1000*1536 SIZE IN DECIMAL. SPACE 3 END