TITLE 'APLOUT-B00,08/21/73,DWG702985'
SYSTEM SIG7F
SYSTEM BPM
PAGE
* REF'S:
REF APLINPUT COMMON INPUT ROUTINE
REF BITPOS BIT TABLE
REF BLANKS X'40404040'
REF BREAKFLG BREAK OR 'HANGUP' FLAG
REF BREPROMT BRANCH TO REPROMPT.
REF BRFUNDEF RESUME IN FUNDEF MODULE.
REF BSPFLAG BACKSPACE VALIDITY FLAG
REF CURRCS CURRENT CS BLOCK POINTER
REF DIGITS
REF DWSIZIM DW'S IN IMAGE
REF ERRORCHR ERROR SIGNAL CHARACTER
REF IMAGE APL 'IMAGE' I/O BUFFER
REF INBUF APL INPUT-OUTPUT BUFFER
REF INPDIR DIRECT INPUT DRIVER
REF INPF FUNCTION EDIT INPUT DRIVER
REF INPFAPND INPUT FUN.LINE APPEND.
REF MAXCOL MAX COL POS FOR INPUT
REF MERGECOL MERGE OR EDIT COLUMN # (FROM 1)
REF MNEMT1 MNEMONIC TABLE 1-CHAR
REF MNEMT2 MNEMONIC TABLE 2-CHAR
REF MNEMT3 MNEMONIC TABLE 3-CHAR
REF MODE MODE FLAG
REF OFFSET CODESTRING ERROR BYTE OFFSET
REF ON%OFF ONLINE-OFFLINE FLAG
REF OUTMNEMT OUTPUT MNEMONIC-OVST FLAG TABLE
REF OUTRANST OUTPUT TRANSLATION TABLE
REF OUTMAXSZ OUTPUT RECORD BLOCK SIZE
REF OUTSIZ SIZE OF OUTPUT RECORD(5)
REF OVHWTABL OVERSTRIKE HW TABLE
REF PRMTIMAG PROMPT WITH CURRENT IMAGE
REF RDAPL READ A RECORD
REF SYMT ADDRESS OF ADDRESS OF SYMBOL TABLE
REF SYSTERR SYSTEM ERROR
REF TABVALS TAB VALUES
REF UNREF END DECODE OPS FOR ERROR DIAG.
REF VISIMAGE BUFFER TO SAVE IMAGE DURING EDIT
REF WIDTH
REF WROUTWB WRITE OUTPUT-WORD BOUND
REF WRTEXTC WRITE OUTPUT-TEXTC FORM
REF X4E1 X'4E100000'
REF X1FFFF ADDRESS MASK
REF ZEROZERO
* DEF'S:
DEF APLOUT@ START OF PROCEDURE
DEF APLOUT0 START OF CONTEXT
DEF CHEKWID CHECK WIDTH
DEF CINTIM CONVERT INTEGER INTO IMAGE
DEF CREALBIN CONVERT REAL TO BINARY.
DEF DECODOPS DECODESTRINGER
DEF ENDIMAGE END OF IMAGE IN USE
DEF DUMPLINE 13-00006
DEF DUMPLING LINE DUMP ROUTINE
DEF DUMPLINP DUMP IMAGE-PROBABLY AS PROMPT
DEF EDECODOP ERROR CALL TO: DECODOPS
DEF EDUMPLIG DUMPLING
DEF EDUMPLIN DUMPLINE
DEF FFFFFFFE
DEF FLHALF
DEF FLONE
DEF FLTEN
DEF FUNLDISP FUNCTION LINE DISPLAY
DEF FUNLDIS%
DEF GENCHAR
DEF GENDIGS GEN. EBCDIC DIGITS.
DEF GENDIGSE GEN. E-FORMAT
DEF GENEXP GEN. EXPONENT FORM.
DEF GENNAME
DEF GENNAME0 GENNAME ENTRY FOR NO INDENT ON VFL
DEF GENTEXT TEXT GENERATOR ROUTINE
DEF IDBUF ID RECORD BUFFER
DEF IMAGEPOS IMAGE POSITION
DEF IMAGES
DEF MAXREAL MAX REAL #
DEF MIXEDOUT COMPOUND STATEMENT OUTPUT
DEF MTEMPIM2 MOVE TO IMAGE
DEF NAMEBUF NAME PTR BUFFER
DEF PLUSREAL
DEF RANKARR ARRAY RANK
DEF SAVESIX SAVE TEMP-USED BY )COPY-SHARED
DEF SETCHAR STORES A CHAR.
DEF SHOWFL DISPLAY-APPEND-OR EDIT-FUNCTION LN.
DEF SHOWSTOP
DEF SIDR SI DAMAGE WARNING REPORT
DEF SINGOUT SINGLE DATA BLOCK OUTPUT
DEF STASHBL STASH BLANK IN IMAGE
DEF TABPNTR TAB INDICATOR
DEF TABPNTR1 TAB POINTER TEMP
DEF TENSTBL POWERS OF 10 (FIXED POINT)
DEF TEXTC2I MOVE TEXTC MSG TO IMAGE.
* STANDARD EQU'S:
R0 EQU 0
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
BLANK EQU X'40'
IDLE EQU X'16'
*
* CODESTRING PARAMETERS
*
CSBLOCK EQU 7 TYPE FOR CODESTRING DATA BLOCK
CSEND EQU 139 OFFSET OF LAST CS VALUE
FNOFF EQU 5 FUNCT NAME OFFSE1
PAGE
* MODULE DESCRIPTION
*
* THIS MODULE INCLUDES THE OUTPUT ROUTINES AND PROCESSORS
* FOR APL-EXCEPT WORKSPACE FILE OUTPUT AND THE FILE OUTPUT SYSTEM
* INCLUDED ARE DIRECT AND QUAD OUTPUT,BLIND OUTPUT, AND
* OUTPUT GENERATED AS A RESULT OF SOME COMMAND ACTIVITY
* OUTPUT CONVERSION ROUTINTES AS WELL AS OUTPUT IMAGE FORMATTING
* IS INCLUDED
*
PAGE
APLOUT0 CSECT 0
*
* VARIABLE PARAMETERS AND TEMPS
*
TABPNTR DATA 0 TAB VALUE FLAG
TABPNTR1 RES 1 TEMP POINTER TO TABVALS
* PROGRAM SWITCH IN DUMPLINE ROUTINE
GBYTOTAB LB,R4 IMAGE,R3 (OR B CHEKTABS)
*
ENDIMAGE RES 1 END OF IMAGE POINTER
CSERRBYT RES 1 CODESTRING ERROR BYTE
BOUND 8
IMAGES DATA 0,0 NO. OF IMAGE LINES OUTPUT
IMERRBYT EQU IMAGES+1 IMAGE ERROR BYTE POSITION
IMAGEPOS RES 1 IMAGE POSITION
LASTSCAN RES 1
SAVENDS RES 1 SAVE BYTES ENCLOSING CODESTRING
CURRTAB RES 1 CURRENT TAB-TEMP
OUTBUF RES 1 INBUF-OUTBUF SIZE POINTER
BLCOUNT RES 1 BLANK COUNT-TEMP
SAVE8 RES 1 TEMP
*
* SAVE AND TEMP AREA FOR SINGOUT AND MIXEDOUT
*
*
*
* CONVRTR-PROGRAM SWITCH FOR OUTPUT CONVERSION ROUTINES SINGOUT-MIXEDOUT
*
CONVRTR B INTARRAY (EXAMPLE)
BOUND 8 @@@@@@@
HIREAL RES 2 @
DMAX EQU HIREAL @
EFLAG EQU HIREAL+1 @
LOREAL RES 2 @
DMINP5 EQU LOREAL @
BITCOUNT EQU LOREAL+1 @@@@@@@
BOUND 8
IDBUF RES 16 STORAGE FOR WS OR FIO ID RECORD
SAVE114 EQU IDBUF REG SAVE FOR MIXEDOUT-SINGOUT
ROWSIZE EQU IDBUF+14 ROW LENGTH-OUTPUT ROUTINES
RANKARR EQU IDBUF+15 RANK OF ARRAY-OUTPUT ROUTINES
BOUND 8
NAMETEMP RES 64 BUFFER TO BUILD OUTPUT NAMES
NAMEBUF EQU NAMETEMP NAME POINTER BUFFER
BLOCKNUM RES 1 NUMBER OF DATA BLOCKS TO OUTPUT
DBASE RES 1 DATA BASE-OUTPUT ROUTINES
DSIZE RES 1 DATA SIZE-OUTPUT ROUTINES
EVALUE RES 1 EXPONENT VALUE-TEMP
LBASEM1 RES 1 BASE-1 OF LENGTH WORDS FOR ARRAY
PTRPTR RES 1 DATA POINTER-POINTER
SAVESIX EQU BLOCKNUM BLOCKNUM TO PTRPTR-SHARED WITH
* SAVESIX. SAVESIX IS USED BY
* WRACTIV IN MODULE APLUTSC,DURING
* EXECUTION OF )COPY
SAVE212 RES 11 SAVE R2-R12 -BY-DUMPLINE
PAGE
APLOUT@ CSECT 1
*
BOUND 8
* PRANGE-TABLE OF FLOATING POINT-LONG VALUES:1E0 TO 1E16
*
DATA,8 FL'1E-1' ** PRANGE-2
PRANGE DATA,8 FL'1E0',FL'1E1',FL'1E2',FL'1E3',FL'1E4',FL'1E5'
DATA,8 FL'1E6',FL'1E7',FL'1E8',FL'1E9',FL'1E10',FL'1E11'
DATA,8 FL'1E12',FL'1E13',FL'1E14',FL'1E15',FL'1E16'
FLONE EQU PRANGE
FLTEN EQU PRANGE+2
FLHALF DATA,8 FL'0.5'
FLTENS DATA,8 FL'10',FL'10000',FL'10000000000000'
MAXREAL DATA X'7FFFFFFF',X'FFFFFFFF' MAX FL #
POWERS DATA 1,4,13
*
* TENSTBL-TABLE OF POWERS OF 10 AS INTEGERS
*
TENSTBL DATA 1,10,100,1000,10000,100000,1000000
DATA 10000000,100000000,1000000000
*
FFFFFFFE DATA X'FFFFFFFE' MASK
*
PAGE
*
* DUMPLINE-ROUTINE TO DUMP A LINE FROM 'IMAGE' VIA F:OUT
*
* ENTRIES:DUMPLINE-NOT A PROMPT-LINE FOLLOWED BY CR
* DUMPLINP-LINE IS FUNCTION EDIT PROMPT-ENDS WITH 'IDLE'
*
* IF ENTRY IS FROM DUMPLINE,R3 IS THE BYTE OFFSET TO
* 1 CHARACTER PAST END OF IMAGE. ENDIMAGE OFFSET IS
* SAVED AND R3 IS SET TO 'BLANKS'. ON EXIT, R3 IS SET
* TO 6 AND THE FIRST 8 BYTES OF IMAGE ARE BLANKED
*
* IF ENTRY IS FROM DUMPLINP,THE LAST CHARACTER IS AN IDLE,
* INDICATING NO CR(TO COC HANDLER). ENDIMAGE IS SAVED,
* AND R3 IS SET 0. ON EXIT, IMAGE IS INTACT
*
* IMERRBYT IS TESTED AND,IF SET (>0) THE IMAGE OUTPUT IS
* FOLLOWED BY AN ERROR POINTER
*
* R12 IS LINK
*
* REGISTERS R2 TO R12 ARE SAVED AND RESTORED PRIOR TO EXIT
*
* INTERNALLY:R3 IS POINTER IN IMAGE
* R6 IS POINTER IN INBUF(OUTPUT BUFFER)
*
* CALWROUT IS CALLED FOR ACTUAL OUTPUT OF LINE
* SEGMENTS:LINK R7,REGISTERS USED,R8,R9,R10
*
* OUTPUT LINE SEGMENTS ARE BUILT SEQUENTIALLY IN 'INBUF' AND
* LEFT IN PLACE FOR POSSIBLE SUBSEQUENT USE
*
LOCAL LCI,TABN,TABLESS,GETIMBYT,NOTABS,CHEKTABS,BUMPTAB
LOCAL CHKBLNK,SETTAB,VARTABS,NOTYET,OUTBLNKS,BLOOP,UPBLCT
LOCAL USCL,SINGLOUT,BSOVST,NEXTMOVE,FORWARD,BSSET,BLANKIT
LOCAL LASTSEG,NOMOROUT,PUSHOUT1,PUSHOUT2
LOCAL CARETSET
EDUMPLIG EQU DUMPLING ERROR CALL TO DUMPLING.
DUMPLING CI,R3 0 CHECK FOR NULL LINE
BLE *R12 YES-EXIT
AI,R3 -1 ADJUST POINTER
DUMPLINP STW,R3 ENDIMAGE SAVE END OF IMAGE
LI,R3 0 SET R3=0-FLAG FOR EXIT
B LCI
EDUMPLIN EQU DUMPLINE ERROR CALL TO DUMPLINE.
DUMPLINE AI,R3 -1 ADJUST IMAGE POINTER
STW,R3 ENDIMAGE SAVE IT
LW,R3 BLANKS SET R3= BLANKS-USED IN EXIT
LCI LCI 11
STM,R2 SAVE212
MTW,1 IMAGES KICK IMAGE COUNT
LW,R3 ENDIMAGE RESTORE R3 IMAGE END
BLEZ CKIMERR IF ZERO,SKIP NEXT ITEM
LB,R2 IMAGE,R3 CHECK FOR AND DELETE
CI,R2 X'40' TRAILING BLANKS
BNE %+2
BDR,R3 %-3
STW,R3 ENDIMAGE SET NEW END OF IMAGE
CKIMERR LCW,R6 IMERRBYT CHECK IF IMAGE IS ERROR FLAGGED
BGEZ FORWARD NO
MTW,0 BSPFLAG CHECK FOR BS CAPABILITY ON TERMINAL
BEZ FORWARD NO
CI,R3 MAXCOL CHECK FOR WIDE IMAGE
BG FORWARD YES
SW,R3 IMERRBYT GET DISTANCE FROM HI-END
CW,R3 IMERRBYT COMPARE WITH DISTANCE FROM LOW END
BGE FORWARD
AI,R3 1
LI,R5 8 BS
LW,R4 ENDIMAGE
BSSET AI,R4 1
STB,R5 IMAGE,R4 LOOP-BS'S
BDR,R3 BSSET
LI,R5 X'20' IX
AI,R4 1
STB,R5 IMAGE,R4
LB,R5 ERRORCHR ERROR CARET-TERMINAL DEPENDANT
AI,R4 1
CARETSET STB,R5 IMAGE,R4
STW,R6 IMERRBYT SET IMERRBYT NEGATIVE
STW,R4 ENDIMAGE RESET ENDIMAGE
FORWARD LW,R6 NOTABSET SET SWITCH TO SKIP TAB CHECKS
LW,R3 TABPNTR CHECK FOR TAB SETS
BEZ TABLESS NO
LW,R6 TABSET SET SWITCH TO USE TAB CHECKS
CI,R3 128 YES-CHECK EQUIDISTANT VS INDIVIDUAL
BL TABN EQUIDISTANT
LI,R3 1 INDIVIDUAL
STW,R3 TABPNTR1 GET FIRST SET
LB,R3 TABVALS,R3
TABN STW,R3 CURRTAB SET CURRENT TAB
MTW,-1 CURRTAB DECREMENT (FOR 0 INDEXING)
TABLESS LI,R3 0 SET IMAGE POSITION AT START
STW,R6 GBYTOTAB PROGRAM SWITCH (TABS OR NOTABS)
LI,R4 INBUF
STW,R4 OUTBUF SET START OF OUTBUF=INBUF
LI,R6 0 SET INBUF POSITION AT START
STW,R6 BLCOUNT ZERO BLANK COUNT
LW,R12 OUTMAXSZ
AI,R12 -1 SET LOOP FOR LINE SEGMENT OUTPUT
GETIMBYT EXU GBYTOTAB LB,R4 IMAGE,R3 OR B CHEKTABS
NOTABS LB,R5 OUTRANST,R4 GET OUTPUT CHAR OR OFFSET
LB,R7 OUTMNEMT,R4 GET TYPE FLAG
BEZ SINGLOUT SINGLE CHARACTER
CI,R7 4 CHECK TYPE FLAG
BE BSOVST OVERSTRIKE-GENERAL
BG USCL UNDERSCORED LETTER
AW,R5 MNEMTN-1,R7 ** THIS POINT SHOULD BE REACHED ONLY
LW,R2 R5 ** FROM LINE-SCAN ERROR-WIDTH SETTING
LW,R4 R7 ** MAY BE EXCEEDED.
LI,R5 X'5B' TRUE (NOT APL.) %
BAL,R11 PUSHOUT1 OUTPUT IT
LI,R11 %+1 SET LOOP
LB,R5 0,R2 GET MNEMONIC CHARACTER
AI,R2 1
BDR,R4 PUSHOUT1 OUTPUT MNEMONIC CHARACTERS
B SINGLOUT
CHEKTABS LB,R4 IMAGE,R3 GET CHARACTER
CW,R3 CURRTAB CHECK IF TAB SET REACHED
BL NOTYET NO
LW,R5 TABPNTR CHECK TYPE OF TAB OPTION
CI,R5 128
BGE VARTABS INDIVIDUAL SETS
BUMPTAB AWM,R5 CURRTAB VECTOR-KICK BY INTERVAL
CHKBLNK CI,R4 BLANK
BNEZ OUTBLNKS NOT BLANK-DUMP ANY PENDING
LI,R5 0
XW,R5 BLCOUNT RESET BLANK COUNT
BEZ NOTABS IF IT WAS 0, OUTPUT BLANK
SETTAB LI,R4 5 SET TAB CHAR (INTERNAL) IN R4
B NOTABS GENERATE IT
VARTABS MTW,1 TABPNTR1 POINT TO NEXT TAB
LW,R7 TABPNTR1
LB,R7 TABVALS,R7 GET NEXT TAB
BEZ BUMPTAB TOO FAR-SET TO ACCUMULATE BLANKS
AI,R7 -1 OFFSET
STW,R7 CURRTAB SET NEW CURRTAB
B CHKBLNK
NOTYET CI,R4 BLANK
BE UPBLCT
OUTBLNKS LW,R2 BLCOUNT CHECK FOR PENDING BLANKS
BEZ NOTABS NONE
LI,R5 BLANK SOME-SET BLANK
BLOOP BAL,R11 PUSHOUT1 OUTPUT BLANK
BDR,R2 BLOOP LOOP UNITL BLCOUNT=0
STW,R2 BLCOUNT REJET BLANK COUNT
B NOTABS GET OUTPUT CHAR
UPBLCT MTW,1 BLCOUNT KICK BLANK COUNT
B NEXTMOVE
*
USCL BAL,R11 PUSHOUT1 LETTER
LI,R5 8 BACKSPACE
BAL,R11 PUSHOUT1
LI,R5 X'6D' UNDERSCORE
LB,R5 OUTRANST,R5 TRANSLATE IT
SINGLOUT LI,R11 NEXTMOVE
B PUSHOUT1
*
BSOVST LH,R8 OVHWTABL,R5 GET FIRST & SECOND CHARACTER IN R8
STW,R8 SAVE8 SAVE
LI,R5 2 SET INDEX
LB,R5 R8,R5 GET FIRST CHAR IN R5
LB,R5 OUTRANST,R5 TRANSLATE SINGLE CHARACTER
BAL,R11 PUSHOUT1 PUSH IT
LI,R5 8 BS
BAL,R11 PUSHOUT1
LI,R5 X'FF' BYTE MASK
AND,R5 SAVE8 GET 2ND BYTE
LB,R5 OUTRANST,R5 AND TRANSLATE IT
B SINGLOUT
*
NEXTMOVE AI,R3 1
CW,R3 ENDIMAGE CHECK IF IMAGE PROCESS COMPLETE
BLE GETIMBYT NO
MTW,0 BLCOUNT CHECK FOR TRAILING BLANKS 13-00001
BEZ LASTSEG NO 13-00002
LI,R5 BLANK YES-INSERT 1 BLANK 13-00003
BAL,R11 PUSHOUT1 13-00004
LASTSEG SW,R12 OUTMAXSZ YES
AI,R12 1 CHECK IF OUTPUT REMAINS
BEZ NOMOROUT NO
LCW,R9 R12 YES-SIZE IN BYTES
BAL,R11 PUSHOUT2 GENERATE RECORD
LW,R4 IMERRBYT CHECK IF ERROR LINE FOLLOWS
BLEZ NOMOROUT NO
LW,R5 BLANKS YES-BLANK IMAGE
LI,R7 DWSIZIM
BLANKIT STD,R5 IMAGE-2,R7
BDR,R7 BLANKIT
LB,R5 ERRORCHR GET ERROR CARET
LI,R6 -1 FLAG -NEGATIVE- FOR IMERRBYT
B CARETSET
NOMOROUT STW,R6 OUTSIZ SET OUTSIZ-IN CASE OUTPUT IS PROMPT
LCI 11
LM,R2 SAVE212 RESTORE REGISTERS
AI,R3 0 CHECK TYPE OF ENTRY
BEZ *R12 DUMPLINP-LEAVE IMAGE INTACT
STD,R3 IMAGE SET BYTES 0-7 OF IMAGE BLANK
LI,R3 6 SET R3=6
B *R12 EXIT
*
PUSHOUT1 STB,R5 INBUF,R6 STASH BYTE FOR OUTPUT
AI,R6 1
BDR,R12 *R11 COUNT DOWN
CW,R3 ENDIMAGE CHECK COINCIDENT END OF IMAGE
BE LASTSEG YES-OUTPUT LAST LINE SEGMENT
LI,R12 IDLE NO-SET IDLE IN LINE
STB,R12 INBUF,R6 THIS SIGNALS -NO CR-
AI,R6 1
LW,R9 OUTMAXSZ MAX OUTPUT SIZE IN BYTES
PUSHOUT2 LW,R8 OUTBUF OUTPUT BUFFER ADDRESS
BAL,R7 WROUTWB OUTPUT A LINE SEGMENT (OR LINE)
SLS,R9 -2 SIZE IN WORDS
AWM,R9 OUTBUF SET NEW OUTBUF START
LW,R12 OUTMAXSZ RESET COUNTDOWN
BDR,R12 *R11 DECREMENT (FOR IDLE) AND RETURN
* PROGRAM SWITCHES
NOTABSET LB,R4 IMAGE,R3 GET BYTE FROM IMAGE
TABSET B CHEKTABS CHECK TABS
PAGE
*
* STASH ROUTINES
* R11 IS LINK
* R3 UPDATED R8 USED
* R12 USED IF DUMPLINE CALLED
* DUMPLINE SAVES & RESTORES REGS. EXCEPT R3-UPDATED
*
QSTASHBL LI,R8 1 CHECK OLD LASTSCAN-SET NEW
XW,R8 LASTSCAN LASTSCAN NON-ZERO
BEZ *R11 EXIT IF OLD LASTSCAN=0
CW,R3 IMERRBYT CHECK IF THIS IS ERROR POINT
BNE STASHBL NO
MTW,1 IMERRBYT YES-KICK POINTER PAST BLANK
STASHBL LI,R8 BLANK SET BLANK
STASHIM CW,R3 WIDTH CHECK WIDTH OVERFLOW
BL SETR8 NO
BAL,R12 DUMPLINE YES-DUMP LINE FIRST
SETR8 STB,R8 IMAGE,R3 STASH BYTE
AI,R3 1 UPDATE POSITION
B *R11 EXIT
PAGE
*
* CHECKWID-CHECK IF WIDTH PERMITS PRINTING MULTI-CHARACTER FIELD
* IF NOT,DUMP LINE-R7 IS NOT RESTORED
*
CHEKWID AW,R7 R3 ADD POSITION TO FIELD WIDTH-1
CW,R7 WIDTH
BL *R11 OK
BAL,R12 DUMPLINE NO-DUMP LINE
B *R11
PAGE
*
* GENMNEM-GENERATE OUTPUT MNEMONIC IN IMAGE
*
*
* ON ENTRY TO GENMNEM:
* R3 POINTS TO IMAGE BYTE FOR STASHING OUTPUT
* R4 CONTAINS THE INTERNAL APL CHARACTER TO BE REPLACED BY MNEM.
* R5 IS LINK
* R6 POINTS TO SOURCE-CODESTRING OR TEXT
* R7 CONTAINS MNEMONIC TYPE 1CHAR,2CHAR OR 3CHAR.
*
* GENMNEM USES:
* R2,R5,R7,R8,R11,R12 CHANGED
* R3-UPDATED
* R4-UNCHANGED
*
* GENMNEM CALLS:
* CHECKWID (WHICH USES R3,R7,R11,R12)
* SETR8 (WHICH USES R3,R8,R11)
* DUMPLINE (WHICH USES R12-SAVES & RESTORES OTHER REGISTERS
* CHANGES R3)
*
LOCAL LOOP%
GENMNEM BAL,R11 CHEKWID CHECK IF MNEMONIC WILL FIT
LB,R7 OUTMNEMT,R4 RESTORE MNEMONIC TYPE IN R7
LB,R2 OUTRANST,R4 GET TABLE OFFSET
AW,R2 MNEMTN-1,R7 GET ADDRESS OF MNEMONIC
LI,R8 X'43' %
BAL,R11 SETR8 STASH IT
AI,R7 1
LI,R11 LOOP% SET LOOP
LOOP% LB,R8 0,R2 GET MNEMONIC BYTE(S)
AI,R2 1
BDR,R7 SETR8 STASH
B 0,R5 RETURN
*
* MNEMTN-BYTE ADDRESSES OF MNEMONIC TABLES
*
MNEMTN DATA BA(MNEMT1)
DATA BA(MNEMT2)
DATA BA(MNEMT3)
PAGE
*
* GENTEXT-ROUTINE TO GENERATE TEXT IN IMAGE BUFFER
* MNEMONICS ARE EXPANDED,OVERSTRIKES ARE NOT
* IF ENTRY FROM CODESTRING TEXT, QUOTES ARE DOUBLED
*
* R13=LINK
* R10=BYTE COUNT-DECREMENTED TO 0
* R6 POINTS TO FIRST SOURCE BYTE-1 ON ENTRY
* POINTS TO LAST SOURCE BYTE ON EXIT
* R3 POINTS TO IMAGE BYTE OFFSET ON ENTRY
* POINTS TO NEXT IMAGE BYTE OFFSET ON EXIT
* R4,R5,R7,R8 USED INTERNALLY
*
* ROUTINES CALLED:
* STASHIM (USES R3,R8,R11,R12)
* DUMPLINE(USES R12-USES&SAVES OTHER REGISTERS-CHANGES
* R3)
* GENMNEM (USES R2,3,4,5,7,8,AND 11)
*
LOCAL GENTEXT2,SETR4,GENTEXT3,GENTEXT4
LOCAL LOOP
GENTEXT1 LI,R10 1 SET LOOP SIZE 1
B GENTEXTC BYPASS SET-UP OF R4
GENTEXT AI,R10 0 CHECK FOR EMPTY TEXT
BEZ *R13 YES-QUICK EXIT
LOOP AI,R6 1 POINT TO SOURCE BYTE
GENTEXTM LB,R4 0,R6 GET BYTE
GENTEXTC LB,R7 OUTMNEMT,R4 CHECK FOR MNEMONIC
BEZ SETR4 NO
CI,R7 4 MAYBE
BGE SETR4 NO-(DON'T EXPAND OVERSTRIKES)
BAL,R5 GENMNEM YES-GENERATE MNEMONIC
GENTEXT2 BDR,R10 LOOP
B *R13 EXIT
SETR4 CI,R4 X'15' CHECK FOR EMBEDDED CR
BE GENTEXT3 YES
CI,R13 CSGNTEXT+1 CHECK IF CALLED FROM CS-TEXT
BNE GENTEXT4 NO-QUOTES NOT DOUBLED
CI,R4 X'7D' YES-CHECK FOR QUOTE
BNE GENTEXT4 NO
LI,R8 X'7D' YES-DOUBLE IT
BAL,R11 STASHIM STASH IT
GENTEXT4 LW,R8 R4 SET R8 FOR STASH
LI,R11 GENTEXT2 SET RETURN
B STASHIM SET BYTE
GENTEXT3 LI,R12 GENTEXT2 SET RETURN
AI,R3 0 CHECK IF CR AT START OF LINE
BGZ DUMPLING NO
LI,R4 X'40' YES
STB,R4 IMAGE GEN BLANK
LI,R3 1
B DUMPLING
PAGE
*
* CINTIM -CONVERT INTEGER TO EBCDIC AND PUT IN IMAGE
*
* ON ENTRY:R3 IS OFFSET POINTER TO IMAGE
* R6 POINTS TO NEXT SOURCE BYTE-DO NOT CHANGE
* R10 IS EXTERNAL LOOP COUNTER-DO NOT CHANGE
* R13 IS LINK
* R2,R3,R7,R8,R9,R11,R12 USED AND CHANGED
*
* ON EXIT, R3 POINT TO NEW OFFSET IN IMAGE
*
* 'CHEKWID' IS USED TO CHECK FOR WIDTH OVERFLOW-IF SO,
* IMAGE IS DUMPED BEFORE MOVE IF WIDTH EXCEEDED.
*
* CINTIM IS USED FOR INTEGER SCALARS AND VECTORS-ARRAYS ARE
* TREATED SEPARATELY
*
LOCAL CHEKSIZ,SIZFOUND,POSINT
CINTIM LAW,R9 R8 GET ABS VALUE IN R9
LI,R2 9 NO-CHECK SIZE
CHEKSIZ CW,R9 TENSTBL,R2
BGE SIZFOUND
BDR,R2 CHEKSIZ
SIZFOUND AI,R2 1 ADJUST COUNT
LW,R7 R2 USE SIZE TO CHECK FOR IMAGE FIT
AI,R8 0
BGEZ POSINT NON-NEG NUMB
AI,R7 1 NEG NUMB-KICK SIZE FOR SIGN BIT
POSINT BAL,R11 CHEKWID
AI,R8 0 CHECK SIGN AGAIN
BGEZ DIVLOOP POSITIVE
LI,R8 X'72' NEGATIVE-SET SIGN
BAL,R11 SETR8
DIVLOOP LI,R8 0
DW,R8 TENSTBL-1,R2 DIVIDE VALUE BY POWER OF 10
XW,R8 R9 R8=DIGIT, R9=REMAINING VALUE
ZERINT AI,R8 X'F0' CONVERT TO EBCDIC
BAL,R11 SETR8 STASH VALUE IN IMAGE
BDR,R2 DIVLOOP LOOP
B *R13 EXIT*
*
PAGE
*
* CINTARR-CONVERT INTEGER FOR ARRAY OUTPUT
* FIXED FIELD WIDTH=DMAS+2
* NUMBER IS RIGHT JUSTIFIED IN FIELD
*
* R13=LINK
* R10 IS EXTERNAL LOOP COUNTER-DO NOT CHANGE
* R3 IS IMAGE OFFSET AND IS CHANGED
* R2,R7,R8,R9,R11,R12 USED AND CHANGED
*
LOCAL CHEKSIZ,SIZFOUND
CINTARR LW,R7 DMAX GET
AI,R7 2 FIELD WIDTH
BAL,R11 CHEKWID AND CHECK IMAGE OVERFLOW
LAW,R9 R8 GET +VALUE
LW,R7 R8 SAVE VALUE FOR SIEN & 0 TESTS
LW,R2 DMAX SET LOOP SIZE
CHEKSIZ CW,R9 TENSTBL-1,R2 CHECK SIZE OF VALUE
BGE SIZFOUND
BAL,R11 SETR8BL SET BLANK
BDR,R2 CHEKSIZ LOOP
SIZFOUND BAL,R11 SETR8BL SET 1 MORE BLANK
LI,R11 DIVLOOP
LW,R8 R7 CHECK VALUE
BGZ SETR8BL +,SET 1 MORE BLANK
BEZ ZERINT 0, SHORTCUT
LI,R8 X'72' APL -
B SETR8
SETR8BL LI,R8 X'40' SET BLANK
B SETR8
PAGE
*
* CREALBIN-CONVERTS FL-LONG VALUE IN R8-R9 TO INTEGER IN R8-R9
* WITH-DECIMAL POSITION IN R12
* R12=0 INDICATES .XXX
* R12>0 INDICATES NO.DIGITS LEFT OF DECIMAL
* R12<0 INDICATES NO.ZEROS BETWEEN DECIMAL AND FIRST DIGIT
*
* R11 IS LINK
* R7=X'72' (APL-SIGN) IF R8-R9 NEGATIVE,BLANK IF NOT
* R2 USED INTERNALLY
* R5 USED INTERNALLY
*
LOCAL SCALER,ROUNDER,FIXIT,ZEROREAL,DOWNSCL,UPSCALE
CREALBIN LW,R5 DIGITS PRECISION SETTING
LI,R7 BLANK SIGN FLAG-OFF
AI,R8 0 CHECK SIGN AND VALUE
BEZ ZEROREAL 0
BGZ PLUSREAL +
LI,R7 X'72' -
LCD,R8 R8 USE POSITIVE VALUE
PLUSREAL LW,R12 R5 GET SIGNIFICANCE
LI,R2 3 SET SCALER LOOP
SCALER CD,R8 PRANGE,R5 CHECK HIGH END
BGE DOWNSCL TOO HIGH
CD,R8 PRANGE-2,R5 CHECK LOW END
BL UPSCALE TOO LOW
ROUNDER FAL,R8 FLHALF ROUND OFF
CD,R8 PRANGE,R5 CHECK OVERFLOW OF RANGE
BL FIXIT NO
AI,R12 1 YES-
LD,R8 PRANGE-2,R5 ADJUST
FIXIT FAL,R8 X4E1 CONVERT TO BINARY INTEGER
SW,R8 X4E1
B *R11 EXIT
ZEROREAL LI,R9 0 ASSURE TRUE 0
LI,R12 1 SET DECIMAL POS
B *R11 EXIT
DOWNSCL FDL,R8 FLTENS-2,R2 DIVIDE BY POWER OF 10
AW,R12 POWERS-1,R2 ADJUST DECIMAL POSITION
CD,R8 PRANGE,R5 CHECK
BGE DOWNSCL -MORE-
BDR,R2 SCALER CHECK AGAIN
B ROUNDER FALL-THROUGH-SHOULDN'T BE REACHED
UPSCALE FML,R8 FLTENS-2,R2 MULTIPLY BY POWER OF 10
SW,R12 POWERS-1,R2 ADJUST DECIMAL POSITION
CD,R8 PRANGE-2,R5 CHECK
BL UPSCALE NEEDS MORE
BDR,R2 SCALER (SHOULD ALWAYS BRANCH)
B ROUNDER FALL-THROUGH-SHOULDN'T BE REACHED
PAGE
*
* GENDIGS-ROUTINE TO GENERATE EBCDIC DIGITS
* FROM BINARY VALUE IN R8-R9
* DECIMAL INDICATOR IN R12
*
*
* GENDIGSE-ENTRY POINT FOR E FORMAT
* R4=LINK
* R2,R5,R7,R11 USED INTERNALLY
*
* NO LEADING OR TRAILING BLANKS GENERATED
* NO TRAILING ZEROS RIGHT OF DECIMAL POINT
*
LOCAL ZLOOP,CDIGITS,DIVID,DIVIDS,NONZERO,NODOT
LOCAL ZEROPUT,ZLOOP2
GENDIGSE AI,R12 -1
STW,R12 EVALUE SAVE 'E' VALUE
LI,R12 1 SET TO GEN FORM X.XX---
GENDIGS AI,R12 0 CHECK DECIMAL INDICATOR
BGZ CDIGITS
BAL,R11 SETZER 0
LI,R7 X'4B' .
BAL,R11 SETCHAR
AI,R12 0 CHECK AGAIN
BEZ CDIGITS NO LEADING ZEROS
LI,R11 ZLOOP
AI,R12 -1 ADJUST COUNT
ZLOOP BIR,R12 SETZER OUTPUT ZEROS AS REQUIRED
CDIGITS LI,R7 0 SET SHORT FORM (LOW HALF=0)
LW,R2 DIGITS CHECK DIGITS
CI,R2 10
BLE DIVIDS OK DIVIDE R8-R9 BY PWR OF 10
DW,R8 TENSTBL+9 DAMN: EXTENDED FORM
LW,R7 R8 SAVE LOW HALF OF VALUE
AI,R2 -9 ADJUST 'DIGITS'
DIVID LI,R8 0 CLEAR R8
DIVIDS DW,R8 TENSTBL-1,R2 DIVIDE BY POWER OF 10
XW,R8 R9 SHIFT DIGIT TO R8-REST TO R9
AI,R8 X'F0' FORM EBCDIC VALUE
STB,R8 0,R5 STASH IT
AI,R5 1
AI,R9 0 CHECK FOR 0 REMAINDER
BNEZ NONZERO NO
AI,R7 0 MAYBE-CHECK LOW HALK
BEZ ZEROPUT YES
NONZERO AI,R12 -1 NO-CHECK FOR DECIMAL POSITION
BNEZ NODOT NO
LI,R8 X'4B' YES
STB,R8 0,R5
AI,R5 1
NODOT BDR,R2 DIVID LOOP ON 'DIGITS'
XW,R9 R7 DONE-CHECK FOR EXTENDED FORM
BEZ 0,R4 NO
LI,R2 9 DIGITS GR THAN 10-TWO PHASES OF
B DIVID DIVISION
ZEROPUT LI,R11 ZLOOP2
ZLOOP2 BDR,R12 SETZER
B 0,R4
SETZER LI,R7 X'F0'
SETCHAR STB,R7 0,R5
AI,R5 1
B *R11
PAGE
*
* GENEXP-GENERATE EX EXX E-X OR E-XX
* R4=LINK R7,R8,R9,R11,R5 USED
*
LOCAL POSEXP,ONECHAR
GENEXP LI,R7 'E' GENERATE 'E'
BAL,R11 SETCHAR
LW,R9 EVALUE GET EXP. VALUE
BGEZ POSEXP
LI,R7 X'72' SET - IF NEGATIVE
BAL,R11 SETCHAR
LAW,R9 EVALUE
POSEXP LI,R8 0
DW,R8 TENSTBL+1 SEPARATE EVALUE INTO 10'S AND 1'S
BEZ ONECHAR NO 10'S
LW,R7 R9
AI,R7 X'F0' SET 10'S DIGIT
BAL,R11 SETCHAR
ONECHAR LW,R7 R8
LW,R11 R4
AI,R7 X'F0' SET 1'S DIGIT
B SETCHAR AND EXIT
PAGE
*
* CREALIM-CONVERT REAL VALUE IN R8-R9 TO PRINT FORMAT AND
* PLACE IN IMAGE BUFFER
*
* THIS ROUTINE IS FOR CONVERSION OF SCALARS OR ELEMENTS
* OF VECTORS-LEADING OR TRAILING BLANKS ARE **NOT** GENERATED
* (BECAUSE OF USE IN CODESTRING OUTPUT)
*
* R13=LINK
*
* REGISTERS R1,R2,R4,R5,R7,R11,R12 USED INTERNALLY
* REGISTER 3 USED AND UPDATED(IMAGE POINTER)
*
* ROUTINES USED: CREALBIN-CONVERT TO INTERMEDIATE FORM
* GENDIGS -GENERATE DIGITS AND DEC. PT.
* MTEMPIM -MOVE CHARACTERS FROM TEMP TO IMAGE
*
* THE RESULT IS FORMED IN A TEMP AREA BECAUSE LENGTH IS NOT
* DETERMINATE PRIOR TO CONVERSION-WIDTH CHECK IS MADE BY MTEMPIM
* PRIOR TO MOVE TO IMAGE
*
LOCAL NOTNEG,EFORM,MOVEIM
CREALIM BAL,R11 CREALBIN CONVERT TO INTEGER & DEC POS
LI,R5 BA(NAMETEMP)
CI,R7 X'72' NEG SIGN CHECK
BNE NOTNEG
BAL,R11 SETCHAR SET -
NOTNEG CI,R12 -4 CHECK OUTPUT FORM
BLE EFORM E FORM-TOO LOW
CW,R12 DIGITS
BG EFORM E FORM-TOO HIGH
BAL,R4 GENDIGS ORDINARY FORM-GENERATE DIGITS
MOVEIM AI,R5 -BA(NAMETEMP) GET LENGTH
LW,R1 R5
MTEMPIM LW,R7 R1
BAL,R11 CHEKWID CHECK IF NAME FITS ON IMAGE
MTEMPIM2 LI,R8 BA(NAMETEMP) SET SOURCE ADDRESS FOR MBS
LI,R9 BA(IMAGE)
AW,R9 R3 SET TARGET ADDRESS FOR MBS
STB,R1 R9 SET COUNT FOR MBS
MBS,R8 0
AW,R3 R1
B *R13
EFORM BAL,R4 GENDIGSE E FORM GENERATE X.XXX---
BAL,R4 GENEXP GENERATE EXX OR E-XX
B MOVEIM
TEXTC2I LB,R1 *R8 LINK=R13 GET BYTE COUNT OF TEXTC ITEM.
SLS,R8 2
AI,R8 1 = BA(TEXT STRING)
B MTEMPIM2+1 MOVE THE STRING INTO IMAGE BUFFER.
PAGE
*
* CREALARR-CONVERT REAL ARRAY DATUM TO PRINT FORM IN IMAGE BUFFER
*
* R13=LINK
* R2,R4,R5,R7,R11,R12 USED INTERNALLY
* R3 USED AND UPDATED (IMAGE BUFFER POINTER)
*
* ROUTINES USED:CHEKWID CHECK IF FIELD FITS IN IMAGE
* CREALBIN CONVERT TO INTEGER-DEC. EXP. FORM
* SETCHAR SET CHARACTER
* GENDIGS,GENDIGSE GENERATE DIGITS
* GENEXP GENERATE E-FIELD
*
* FIELD WIDTH IS DIGITS+7 BLANKS AND ZEROS INSERTED AS
* FORM INDICATES
*
LOCAL MAXBLNK,BLOOP,ENDBLNKS,BLOOP2,EFORMARR,ZLOOPE
LOCAL NODOT
CREALARR LW,R7 DIGITS FIELD WIDTH IS FIXED
AI,R7 7 AT DIGITS+7
BAL,R11 CHEKWID CHECK VS IMAGE POSITION
BAL,R11 CREALBIN CONVERT TO INTEGER-DEC. EXP. FORM
LI,R5 BA(IMAGE) GET ADDRESS
AW,R5 R3 TO STASH BYTES
LW,R4 R7 SAVE SIGN OR BLANK
MTW,0 EFLAG CHECK IF E-FORMAT
BNEZ EFORMARR YES
LW,R2 DMINP5 NO-CHECK FOR BLANK
CI,R12 1 INSERTION REQUIREMENT
BLE MAXBLNK MAX BLANK INSERTION
AI,R2 1
SW,R2 R12 VARIED BLANK INSERTION
MAXBLNK LI,R11 BLOOP
LI,R7 BLANK
BLOOP BDR,R2 SETCHAR
LW,R7 R4 - SIGN OR BLANK
BAL,R11 SETCHAR
BAL,R4 GENDIGS GENERATE DIGITS AND DEC. PT.
ENDBLNKS LW,R2 DIGITS
SW,R2 R5 CALCULATE BLANK PAD TO RIGHT
AW,R2 R3 FOR FIELD WIDTH DIGITS+7
AI,R2 BA(IMAGE)+8
LI,R7 BLANK GEN. BLANKS
LI,R11 BLOOP2
BLOOP2 BDR,R2 SETCHAR
AW,R3 DIGITS SET NEW IMAGE POS FOR R3
AI,R3 7
B *R13 EXIT
EFORMARR LI,R7 BLANK LEADING BLANK
BAL,R11 SETCHAR
LW,R7 R4 SIGN OR BLANK
BAL,R11 SETCHAR
BAL,R4 GENDIGSE DIGITS E FORMAT
AI,R12 0 CHECK IF DECIMAL NEEDED
BNEZ NODOT NO
LI,R8 X'4B' YES-INSERT IT
STB,R8 0,R5
AI,R5 1
NODOT LW,R2 DIGITS
AI,R2 BA(IMAGE)+4 CALCULATE 0'S PAD TO RIGHT
AW,R2 R3 BEFORE GENERATING E-FIELD
SW,R2 R5
LI,R7 X'F0' GEN. 0'S
LI,R11 ZLOOPE
ZLOOPE BDR,R2 SETCHAR
LI,R4 ENDBLNKS SET EXIT
B GENEXP GENERATE E-FIELD
PAGE
*
* SINGOUT AND MIXEDOUT--EXECUTION OUTPUT ROUTINES
*
* MIXEDOUT IS CALLED AT THE END OF EXECUTION OF A STATEMENT
* IF ONE OR MORE DATA BLOCKS ARE TO BE PRINTED
*
* SINGOUT IS CALLED FOR QUAD OUTPUT OF A SINGLE DATA BLOCK
*
* ENTRY CONDITIONS:
* MIXEDOUT-R13=# OF BLOCKS TO BE OUTPUT
* R1 = POINTER TO LIST OF DATA BLOCK POINTERS(-1)
* SINGOUT-R4 CONTAINS DATA BLOCK POINTER
*
* REGISTER USEAGE: R1-R14 SAVED AND RESTORED
*
* R14=LINK NORMAL RETURN TO CALL+2
* ERROR RETURN TO CALL+1 (NOT USED)
*
*
*
LOCAL NXTBLKOT,BLOCKOUT,GETSIZE,BYTDBASE,NOTDWB,NEXTROW
LOCAL ROWLOOP,DECRSIZE,PANELER,DUMPLAST
LOCAL QTEXT,LOGICSET,VECTOR,REALVECT,INTVECT1,INTVECT
LOCAL REALVSP,INTVSP
LOCAL LOGTEXT
MIXEDOUT STW,R13 BLOCKNUM
STW,R1 PTRPTR
LCI 14 SAVE
STM,R1 SAVE114 R1 TO R14
NXTBLKOT MTW,1 PTRPTR UPDATE POINTER TO DBPTR
LW,R4 *PTRPTR GET NEXT DBPTR
B BLOCKOUT
SINGOUT LCI 14 SAVE
STM,R1 SAVE114 R1 TO R14
LI,R3 0 SET IMAGE OFFSET 0
STW,R3 BLOCKNUM FLAG SINGLE BLOCK ENTRY
BLOCKOUT LI,R15 % FOR ERROR INFO IF SYSTERR
LB,R2 *R4 GET DATA TYPE IN R2
BEZ SYSTERR INVALID DATA TYPE
CI,R2 5
BG EMPTY INVALID DATA TYPE-TREAT AS EMPTY
BE INDSEQ INDEX-SEQUENCE SPECIAL CASE
LI,R7 1
LB,R6 *R4,R7 GET RANK IN R6
BEZ SCALAR
CI,R6 1
BE VECTOR
STW,R6 RANKARR ARRAY-SAVE RANK
AI,R4 1
STW,R4 LBASEM1 SAVE BASE-1 OF LENGTH VALUES
LW,R9 *LBASEM1,R6
STW,R9 ROWSIZE SAVE LAST DIMENSION-ROW SIZE
LI,R9 1
GETSIZE MW,R9 *LBASEM1,R6 SIZE=PRODUCT OF LENGTHS
BEZ EMPTY
BDR,R6 GETSIZE
STW,R9 DSIZE SET NUMBER OF UNITS IN BLOCK
AW,R4 RANKARR R4 POINTS TO LAST LENGTH WORD
AI,R4 1 NOW TO FIRST DATA WORD
QTEXT CI,R2 2 CHECK TYPE FOR TEXT
BL LOGICSET
BE BYTDBASE YES
CI,R2 4 CHECK IF SHIFT TO DW BOUND NEEDED
BNE NOTDWB NO
AI,R4 1 YES-INSURE DW BOUND
AND,R4 FFFFFFFE
B NOTDWB
LOGICSET LI,R11 32 SET INITIAL COUNT
STW,R11 BITCOUNT FOR LOGIC VALUE OUTPUT
B NOTDWB
BYTDBASE SLS,R4 2 SHIFT R4 TO BYTE ADDRESSING
NOTDWB STW,R4 DBASE SAVE ADDRESS OF DATA
AI,R6 0 CHECK FOR VECTOR (TEXT OR LOGIC)
BNEZ CVARRTBL-1,R2 YES-SHORTCUT
CI,R2 3 NO-CHECK FOR INTEGER OR REAL ARRAY
BGE GETRANGE-3,R2 YES-GET RANGE OF VALUES(ABSOLUTE)
SETCONV LW,R9 CVARRTBL-1,R2 NO
STW,R9 CONVRTR TO FETCH & CONVERSION ROUTINES
LW,R9 BLOCKNUM CHECK IF NOT 1ST DATA BLOCK
BLEZ NEXTROW FIRST-NO PROBLEM
BAL,R12 DUMPLING LATER-GENERATE RESIDUAL IMAGE
NEXTROW LW,R10 ROWSIZE SET LOOP
LI,R13 DECRSIZE SET EXIT FROM CONVERT SUBROUTINES
ROWLOOP EXU CONVRTR PROCESS DKTUM
DECRSIZE MTW,-1 DSIZE DECREMENT TOTAL COUNT
BEZ LASTROW QUIT IF DONE
BDR,R10 ROWLOOP LOOP ON ROWSIZE
LINEOUT BAL,R12 DUMPLING DUMP LINE WITH CR,RESET R3=0
LW,R6 RANKARR SET RANK FOR LOOP
AI,R6 -1 REDUCE TO RANK-1
LI,R4 0
LW,R5 DSIZE GET REMAINING DATA COUNT
DW,R4 ROWSIZE DIVIDE BY ROW SIZE
PANELER DW,R4 *LBASEM1,R6 USE REMAINDER TEST TO DETERMINE
AI,R4 0 PANEL SEPARATION
BNEZ NEXTROW REMAINDER NOT=0, NO MORE BLANKS
LI,R8 BLANKS SET TO
LI,R9 1 OUTPUT
BAL,R7 WROUTWB A SINGLE BLANK WITH CR
BDR,R6 PANELER LOOP (SHOULD NOT FALL THROUGH)
LASTROW MTW,-1 BLOCKNUM LAST ROW-CHECK IF LAST(OR ONLY) BLK
BGZ NXTBLKOT NO
DUMPLAST BAL,R12 DUMPLING YES-OUTPUT WITH CR
OUTEXIT LCI 14 RESTORE
LM,R1 SAVE114 R1 TO R14
AI,R14 1 INCREMENT FOR CALL+2 RETURN
B *R14 RETURN
EMPTY MTW,-1 BLOCKNUM CHECK IF MORE DATA BLOCKS
BGZ NXTBLKOT YES-CONTINUE PROCESSING
AI,R3 0 NO-CHECK IF IMAGE IS EMPTY
BEZ OUTEXIT YES-EXIT
B DUMPLAST NO
*
* VECTOR-SET UP TO PROCESS VECTOR FOR OUTPUT
*
VECTOR LI,R6 0 SET INDEX
AI,R4 2 POINT TO LENGTH OF VECTOR
LW,R10 *R4 GET LENGTH IN R10 FOR LOOP
BEZ EMPTY
AI,R4 1 POINT TO FIRST DATA WORD (UNLESS DW)
CI,R2 3 CHECK TYPE
BL LOGTEXT LOGIC OR TEXT
BE INTVECT1 INTEGER VECTOR-READY TO PROCESS
AI,R4 1 REAL-SKIP TO DW BOUND
STW,R4 DBASE SAVE DATA BASE ADDRESS
REALVECT LW,R8 BREAKFLG CHECK FOR BREAK
BNEZ OUTEXIT YES
LD,R8 *DBASE,R6 NO-GET DATUM
AI,R6 1
BAL,R13 CREALIM CONVERT IT
BDR,R10 REALVSP GO SET SPACES (UNLESS DONE)
B LASTROW DONE!
REALVSP BAL,R11 STASHBL
BAL,R11 STASHBL
B REALVECT LOOP
INTVECT1 STW,R4 DBASE SAVE BASE ADDRESS OFDATA
INTVECT LW,R8 BREAKFLG CHECK FOR BREAK
BNEZ OUTEXIT YES
LW,R8 *DBASE,R6 NO-GET DATUM
AI,R6 1
BAL,R13 CINTIM CONVERT IT
BDR,R10 INTVSP GO SET SPACES (UNLESS DONE)
B LASTROW DONE!
INTVSP BAL,R11 STASHBL
BAL,R11 STASHBL
B INTVECT LOOP
LOGTEXT STW,R10 DSIZE SAVE DATA SIZE
STW,R10 ROWSIZE ALSO ROW LENGTH
STW,R6 RANKARR FAKE RANK 0 ON VECTOR
LI,R6 1 SET TO CATCH VECTOR
B QTEXT REENTER ARRAY ROUTINE
*
* GETRANGE-GET MAGNITUDE RANGE OF INTEGER OR REAL ARRAY
*
LOCAL RNGLOOP,UPINDEX,EFORM,CHEKHI,INTRANGE,MAGLOOP
LOCAL KIKINDX,DMXLOOP,SETDMAX
GETRANGE B INTRANGE INTEGER
LD,R8 ZEROZERO
STD,R8 HIREAL PRESET HIREAL
LD,R8 MAXREAL
STD,R8 LOREAL AND LOREAL
LW,R10 DSIZE
RNGLOOP LAD,R8 *DBASE,R6 GET DATUM
BNEZ %+2 SKIP IF NOT ZERO
LD,R8 FLONE REPLACE ZERO BY ONE
CD,R8 LOREAL CHECKLO
BGE CHEKHI
STD,R8 LOREAL UPDATE LOW
UPINDEX AI,R6 1
BDR,R10 RNGLOOP LOOP
LD,R8 LOREAL GET LOW VALUE
BAL,R11 CREALBIN FIND DECIMAL POSITION
CI,R12 -3 CHECK IF LOW
BL EFORM YES-E FORMAT INDICATED
AI,R12 5
STW,R12 DMINP5 SET DMINP5-USED BY CREALARR ROUTINE
LD,R8 HIREAL GET HIGH VALUE
BAL,R11 CREALBIN CHECK DECIMAL POSITION
CW,R12 DIGITS VS DIGITS
BG EFORM TOO-HIGH,EFORM
CW,R12 DMINP5 VS DMINP5
BGE EFORM RANGE TOO WIDE-EFORM
LI,R11 0 RESET EFLAG
EFORM STW,R11 EFLAG
LI,R2 4 RESTORE TO 'REAL' TYPE
B SETCONV PROCEED-AT LAST-TO CONVERSION
CHEKHI CD,R8 HIREAL CHECK VS HIREAL
BLE UPINDEX
STD,R8 HIREAL UPDATE
B UPINDEX
*
INTRANGE STW,R6 DMAX INTEGER ARRAY RANGE CHECK
LW,R10 DSIZE SET LOOP
MAGLOOP LAW,R8 *DBASE,R6 GET DATUM
CW,R8 DMAX CHECK
BLE KIKINDX
STW,R8 DMAX UPDATE DMAX
KIKINDX AI,R6 1
BDR,R10 MAGLOOP LOOP
LI,R6 10
LW,R8 DMAX GET HIGHEST VALUE
DMXLOOP CW,R8 TENSTBL-1,R6 CHECK # OF DIGITS
BGE SETDMAX
BDR,R6 DMXLOOP LOOP
SETDMAX STW,R6 DMAX SET # OF DIGITS
B SETCONV PROCEED WITH OUTPUT CONVERSION
*
* INDSEQ-INDEX SEQUENCE OUTPUT CONVERTER
*
LOCAL INDLOOP,FIRSTOUT
INDSEQ AI,R4 2
LW,R10 *R4 GET COUNT
BEZ EMPTY MIGHTY SHORT INDEX SEQUENCE!
AI,R4 1
LW,R8 *R4 GET BASE INTEGER
STW,R8 DBASE
AI,R4 1 GET ADDEND INTEGER
LW,R9 *R4
STW,R9 DSIZE
B FIRSTOUT OUTPUT FIRST ELEMENT AND LOOP
INDLOOP BAL,R11 STASHBL GENERATE
BAL,R11 STASHBL BLANK SPACERS
LW,R8 BREAKFLG BREAK TEST
BNEZ OUTEXIT SCRAM!
FIRSTOUT LW,R8 DBASE
AW,R8 DSIZE UPDATE ELEMENT
STW,R8 DBASE
BAL,R13 CINTIM OUTPUT ELEMENT
BDR,R10 INDLOOP LOOP
B LASTROW EXIT
*
* SCALAR-PROCESSOR FOR SCALAR OUTPUT
*
LOCAL SCALTYPE,SCALTEXT,SCALOGIC,SETLOGIC,ONBIT
SCALAR LI,R13 LASTROW SET EXIT
AI,R4 2 POINT TO DATUM
LD,R8 *R4 GET DW (MAY ONLY NEED PART OF IT)
SCALTYPE B SCALTYPE,R2 VECTOR ON TYPE 1-4 @@@@@@@
B SCALOGIC 1-LOGIC @
B SCALTEXT 2-TEXT @
B CINTIM 3-INTEGER @
B CREALIM 4-REAL @@@@@@@
SCALTEXT LB,R4 *R4 GET CHARACTER
B GENTEXT1
SCALOGIC BLZ ONBIT CHECK IF 1-BIT
LI,R8 X'F0' NO
SETLOGIC LI,R11 LASTROW
B STASHIM STASH 1 OR 0 BYTE
ONBIT LI,R8 X'F1'
B SETLOGIC
*
* LOGICOUT-OUTPUT FOR LOGIC VECTOR OR ROW OF LOGIC ARRAY
*
LOCAL NEWORD,TESTBIT,ABIT,BITSHIFT,SBLNKS,LOGARRAY,ONEBIT
LOGICOUT LW,R7 BITCOUNT GET BIT POS IN WORD
NEWORD LW,R9 *DBASE GET WORD
TESTBIT CW,R9 BITPOS-32,R7 CHECK BIT
BANZ ONEBIT 1
LI,R8 X'F0' 0
ABIT LW,R11 BREAKFLG CHECK FOR BREAK
BNEZ OUTEXIT YES-QUIT
BAL,R11 STASHIM NO-SET BIT
BDR,R10 SBLNKS LOOP ON ROWSIZE
LW,R10 DSIZE END OF ROW
SW,R10 ROWSIZE ADJUST DSIZE
BEZ LASTROW DONE!
STW,R10 DSIZE
BDR,R7 BITSHIFT UPDATE BIT POINTER
MTW,1 DBASE (AND WORD IF NECESSARY)
LI,R7 32
BITSHIFT STW,R7 BITCOUNT
B LINEOUT OUTPUT THE ROW
SBLNKS BAL,R11 STASHBL SET BLANK
LW,R11 RANKARR CHECK VECTOR VS ARRAY
BNEZ LOGARRAY ARRAY
BAL,R11 STASHBL VECTOR-2 BLANKS BETWEEN VALUES
LOGARRAY BDR,R7 TESTBIT
MTW,1 DBASE
LI,R7 32
B NEWORD
ONEBIT LI,R8 X'F1'
B ABIT SET '1' BYTE
*
* TEXTOUT-PROCESS TEXT VECTOR OR ROW OF TEXT ARRAY
*
TEXTOUT LW,R6 DBASE GET DATA ADDRESS
AWM,R10 DBASE UPDATE FOR NEXT PASS
BAL,R13 GENTEXTM GENERATE ROW OF TEXT
LW,R10 DSIZE
SW,R10 ROWSIZE UPDATE REMAINING DATA SIZE
BEZ LASTROW QUIT IF LAST ROW
LW,R13 BREAKFLG CHECK FOR BREAK
BNEZ OUTEXIT YES-EXIT
STW,R10 DSIZE
B LINEOUT
*
* INTARRAY-PROCESS ELEMENT IN INTEGER ARRAY
*
INTARRAY LW,R8 BREAKFLG CHECK BREAK
BNEZ OUTEXIT YES-QUIT
LW,R8 *DBASE GET DATUM
MTW,1 DBASE KICK POSITION
B CINTARR CONVERT AND OUTPUT
*
* REALARRY-PROCESS ELEMENT IN REAL ARRAY
*
REALARRY LW,R8 BREAKFLG CHECK BREAK
BNEZ OUTEXIT YES-QUIT
LD,R8 *DBASE GET DATUM
MTW,2 DBASE KICK POSITION
B CREALARR CONVERT AND OUTPUT
*
* CVARRTBL-PROGRAM SWITCHES-SET IN CONVRTR
*
CVARRTBL B LOGICOUT
B TEXTOUT
B INTARRAY
B REALARRY
PAGE
*
* GENCHAR-GENERATE A CHARACTER OR MNEMONIC IN IMAGE
*
* R13=LINK
* ON ENTRY:R7 CONTAINS INTERNAL FORM OF CHARACTER
* R3 IS IMAGE OFFSET TO STASH CHARACTER
*
* INTERNALLY, R2,R7, AND R14 USED AND CHANGED
*
* ON EXIT: R3 IS IMAGE OFFSET FOR NEXT CHARACTER
*
* THIS ROUTINE DOES NOT PERFORM WIDTH CHECK
*
LOCAL GENLOOP,ONECHAR
GENCHAR LB,R2 OUTMNEMT,R7 CHECK CHARACTER CLASS
BEZ ONECHAR 1 FOR 1
CI,R2 4
BGE ONECHAR OVSTK-LEAVE AS IS
LB,R7 OUTRANST,R7 MNEMONIC-EXPAND IT (GET OFFSET)
AW,R7 MNEMTN-1,R2 BA OF MNEMONIC
AI,R2 1 LOOP SIZE
LI,R14 X'43' APL %
GENLOOP STB,R14 IMAGE,R3
AI,R3 1
LB,R14 0,R7 MNEMONIC CHARACTER
AI,R7 1
BDR,R2 GENLOOP LOOP
B *R13
ONECHAR STB,R7 IMAGE,R3 SINGLE CHARACTER
AI,R3 1
B *R13 EXIT
PAGE
*
* CNAMEIM-CONVERT A NAME-MOVE TO IMAGE BUFFER
*
* ON ENTRY:R3 IS OFFSET PTR FOR IMAGE
* R6 POINTS AT 2ND BYTE OF NAME POINTER
* R5 IS NAME ENTRY OFFSET FROM SYMT
* R4 IS FLAG -1=STOPNAME 0=TRACENAME 1=NAME
* R13 IS LINK
*
* REGISTERS R1 TO R12-EXCEPT R6-ARE USED AND CHANGED
*
* GENNAME IS AN ALTERNATE ENTRY WHICH DOES NOT CHECK FOR STOP OR TRACE
* FOR THIS ENTRY, R8 IS THE NAME OFFSET TO SYMT
*
*
* ON EXIT, R6 IS UNCHANGED. R3 POINTS TO NEW OFFSET IN IMAGE
*
* MNEMONICS ARE EXPANDED IF ENCOUNTERED,AND THE NAME IS FORMED
* IN 'NAMETEMP'
* 'CHEKWID' IS USED TO CHECK FOR WIDTH OVERRUN-IF SO,IMAGE IS
* DUMPED PRIOR TO MOVING THE NAME FROM NAMETEMP TO IMAGE
*
LOCAL CNAM1,CNAM2,CNAM3,CNAM4,LONGNAME
LOCAL STUFNAM1,STUFNAM2,STUFNAM3,STUFNAM4
LOCAL CNAM5,CNAM6
GENNAME0 LI,R1 1
STW,R1 SAVE212 SET FLAG-NO INDENT ON WIDTH OVERFLOW
LI,R1 0
B CNAM2
GENNAME LI,R1 0 SET NAMETEMP POINTER
STW,R1 SAVE212 SET FLAG FOR INDENT ON WIDTH OVERFLO
B CNAM2 BYPASS STOP-TRACE CHECKS
CNAMEIM LI,R1 0 SET NAMETEMP POINTER
STW,R1 SAVE212 SET FLAG FOR INDENT ON WIDTH OVRFLOW
LI,R2 'S' PRESET STOP-NAME
LW,R8 R5 SAVE SYMT OFFSET IN R8
AI,R4 0 CHECK NAME-TYPE FLAG
BGZ CNAM2 PLAIN NAME
BLZ CNAM1 STOP
LI,R2 'T' TRACE
CNAM1 BAL,R11 STUFNAM4 SET S OR T
LI,R2 X'48'
BAL,R11 STUFNAM1 SET DELTA OR %DLT
CNAM2 AW,R8 SYMT GET SYMBOL ADDRESS
AI,R8 1
LB,R10 *R8 CHECK NAME TYPE
CI,R10 BLANK
BL LONGNAME
LI,R10 4 SHORT NAME-SET LOOP TO 4
CNAM3 LI,R4 0 SET POINTER FOR NAMETEMP
CNAM4 LB,R2 *R8,R4 GET BYTE
AI,R4 1
BAL,R11 STUFNAM1 SET BYTE-OR MNEMONIC
BDR,R10 CNAM4 LOOP
CNAM5 LW,R2 SAVE212 GET FLAG FOR WIDTH OVERFLOW ACTION
B CNAM6,R2
CNAM6 B MTEMPIM INDENT-USE MTEMPIM
LW,R7 R1 NO IDENT
AW,R7 R3 CHECK WIDTH
CW,R7 WIDTH
BL MTEMPIM2 OK-MBS
BAL,R12 DUMPLING OVERFLOW-DUMP LINE FIRST
B MTEMPIM2 NOW-MBS
LONGNAME SLS,R10 2
LW,R8 *R8
AND,R8 X1FFFF ADDRESS MASK
B CNAM3
STUFNAM1 LB,R5 OUTMNEMT,R2 GET MNEMONIC FLAG
BEZ STUFNAM3 NOT MNEMONIC-CHECK FOR BLANK
CI,R5 4 MAYBE
BGE STUFNAM4 NOT MNEMONIC OR BLANK
CI,R1 251 CHECK FOR TOO DAMN BIG
BG CNAM5 YES-TRUNCATE
LB,R7 OUTRANST,R2 MNEMONIC-GET TABLE OFFSET
AW,R7 MNEMTN-1,R5 ADD TABLE ADDRESS
LI,R2 X'43' SET '%'
AI,R5 1 SET MNEMONIC SIZE LOOP
STUFNAM2 STB,R2 NAMETEMP,R1 STASH % AND MNEMONIC NAME
AI,R1 1
LB,R2 0,R7
AI,R7 1
BDR,R5 STUFNAM2 LOOP
B *R11 EXIT
STUFNAM3 CI,R2 BLANK BLANK CHECK
BE CNAM5 YES-END OF SCAN
STUFNAM4 STB,R2 NAMETEMP,R1 STORE NON-BLANK CHAR
AI,R1 1
CI,R1 255 CHECK FOR GROSS OVERFLOW
BLE *R11 NO-RETURN
B CNAM5 YES-TRUNCATE
PAGE
*
* FUNLDISP-DISPLAY FUNCTION NAME AND LINE NO.
* (FUNLDIS% - ALT.ENTRY, R6 HAS CURRLINO & NAME PTR AND
* R8 HAS NAME PTR FOR FUNCTION.)
*
* R14=LINK
*
* ON ENTRY,R1 POINTS TO F STACK ENTRY
* NAME AND LINE # SET IN IMAGE STARTING AT POSITION 0
* ON EXIT R3 IS NEXT IMAGE BYTE OFFSET
* R6 CONTAINS CURRLINO AND FDEFPTR
* NO REGISTERS ARE SAVED-MOST ARE USED
*
FUNLDISP LW,R6 1,R1 GET CURRLINO AND FDEFPTR IN R6
LW,R8 FNOFF,R6 GET NAME POINTER IN R8
FUNLDIS% LI,R3 0 START AT BYTE 0 IN IMAGE
BAL,R13 GENNAME CONVERT NAME & MOVE TO IMAGE
LI,R4 X'B4'
BAL,R13 GENTEXT1 LEFT BRACKET-MAY BE MNEMONIC
LH,R8 R6
SLS,R8 -1 GET FUNCTION LINE #
BAL,R13 CINTIM CONVERT
LI,R4 X'B5'
BAL,R13 GENTEXT1 RIGHT BRACKET(MAY BE MNEMONIC)
BAL,R11 STASHBL TWO BLANKS
BAL,R11 STASHBL FOR SPACING
B *R14 AND EXIT
PAGE
*
* SHOWSTOP-GENERATE STOP DISPLAY-EXIT TO INPDIR
*
SHOWSTOP BAL,R14 FUNLDISP DISPLAY FUNCTION NAME-LINE NUMBER
BAL,R12 DUMPLING
B INPDIR GO TO DIRECT INPUT
PAGE
*
* SIDR-(HOW ABOUT THAT!)-ROUTINE TO WARN USER THAT SI DAMAGE WILL
* RESULT IF HE CLOSES THE CURRENTLY OPEN FUNCTION
*
* RESPONSE IS REQUESTED: GO MEAN3 PROCEED TO CLOSE
*
* R14=LINK RETURN IS VIA R14 WITH CONDITION CODES AS INDICATOR
* 'EQUAL' MEANS GO
*
SIDR LW,R7 ON%OFF
BEZ *R14 OFF-LINE,ASSUME 'GO'
AW,R7 BREAKFLG (ON%OFF=1)
BLEZ *R14 BREAKFLG NEG.=HANGUP='GO'
LI,R8 SIDAMSG
BAL,R7 WRTEXTC GENERATE MESSAGE
LI,R8 0
BAL,R11 RDAPL+1 READ RESPONSE
LH,R7 INBUF
CH,R7 GOMSG CHECK VS 'GO'
B *R14
SIDAMSG TEXTC 'SI DAMAGE WILL RESULT:TYPE ''GO'' TO CLOSE'
GOMSG TEXT 'GO '
PAGE
*
* SHOWFL-ROUTINE TO DISPLAY FUNCTION LINE OR HEADER
*
* ENTRY CONDITIONS:1. R14=LINK, MERGECOL IS SET NEGATIVE
* DISPLAY ONLY,RETURN VIA R14
* 2. MERGECOL=0 GENERATE LINE AS PROMPT-EXIT TO
* FIHANDLER
* 3. MERGECOL POSITIVE-GENERATE LINE AND BLANK PROMPT
* TO MERGECOL-1, EXIT TO EDITCTRL
*
* A. CURRCS=0 NO DECODESTRINGING REQUIRED
*
* B CURRCS=PTR TO CS OLOCK-DECODESTRINGING REQUIRED
*
LOCAL SAVNBLNK
SHOWFL STW,R3 IMAGEPOS SET NO.OF BYTES ALREADY IN IMAGE
LW,R12 CURRCS CHECK LINE VS HEADER
BNEZ DECODOPS LINE-REQUIRES DECODESTRING
LW,R12 MERGECOL CHECK DISPLAY-APPEND-EDIT
BEZ INPF APPEND
BAL,R12 DUMPLING DISPLAY OR EDIT
LW,R3 IMAGEPOS GET NO. OF BYTES
DECODRTN LI,R12 0
STW,R12 CURRCS RESET CURRCS (NO DREF NEEDED)
LW,R12 MERGECOL GET NO. OF BYTE)
BLZ *R14 DISPLAY
BEZ INPFAPND APPEND.
MTW,-1 IMAGES CHECK FOR MULTI-LINE DISPLAY
BGZ BREPROMT YES -- CAN'T BE EDITED.
LI,R7 X'15' CR
STB,R7 IMAGE,R3 INSERT FOR VISIMAGE
LI,R7 33 (132 BYTES)
LW,R9 BLANKS
SAVNBLNK LW,R8 IMAGE-1,R7
STW,R8 VISIMAGE-1,R7 SAVE IMAGE IN VISIMAGE
STW,R9 IMAGE-1,R7 BLANK IMAGE
BDR,R7 SAVNBLNK LOOP
LW,R3 MERGECOL
AI,R3 -1
BAL,R11 PRMTIMAG
BAL,R11 APLINPUT
B BRFUNDEF RETURN FOR EDIT-CTRL.
PAGE
*
*
* DECODESTRING OPERATIONS
*
* THE FOLLOWING ROUTINES COVER CONVERSION OF CODESTRING TO
* LINE IMAGE(S) FOR OUTPUT DISPLAY.
*
* THE ROUTINES ARE ACCESSED FOR EXECUTION ERROR DISPLAYS
* AND FOR DISPLAYS ASSOCIATED WITH FUNCTION EDITING.
*
* DECODESTRINGING IS A 3 PHASE PROCESS
*
* 1. SCAN CODESTRING RIGHT TO LEFT.
* WHENEVER A MULTI-BYTE ITEM IS ENCOUNTERED THE
* KEY BYTE IS ON THE RIGHT. ANY LENGTH BYTE OR
* HALFWORD FOLLOWS. THE DATA IS TO THE LEFT BUT
* IS INTERNALLY ORDERED LEFT-RIGHT.
*
* PASS 1 'FLIPS' THE DATA-LENGTH-KEY SEQUENCE
* TO KEY-LENGTH-DATA
*
* 2. SCAN MODIFIED CODESTRING LEFT TO RIGHT
* THIS IS THE BUSY PHASE. CHARACTERS ARE SCANNED
* LEFT TO RIGHT. SINGLE BIT CODESTRING CHARACTERS
* GENERATE CHARAETERS,SKIPS,OR MULTI-CHARACTER
* MNEMONICS IN 'IMAGE'
* MULTI-BIT CODESTRING ITEMS REQUIRE CONVERSION:
* NAME LOOKUP ( NAME, S NAME, OR T NAME )
* NUMERIC CONVERSION-SCALARS & VECTORS-INTEGER & REAL
* TEXT CONVERSION-TEXT SCALARS & VECTORS & COMMENTS
* ERROR LOCATION IS TRACKED FOR POSITIONING ERROR CARET
* IMAGE LINE-OR LINES-ARE OUTPUT
*
* IF INDICATED,ERROR CARET LINE IS PRODUCED
*
* 3. SCAN CODESTRING LEFT TO RIGHT
* REVERSE PROCESS OF PHASE 1.
*
* ***** *****
* * *
* * PHASE 1-PHASE 3 SEQUENCE IS CRITICAL-BREAKS SHOULD NOT *
* * BE HONORED IN THIS SEQUENCE EXCEPT TO SQUELCH THE *
* * PHYSICAL DISPLAY. IF, FOR ANY REASON, THE SEQUENCE *
* * CANNOT BE COMPLETED, SYSTEM ERROR AND CLEAR SHOULD *
* * BE EXECUTED *
* * *
* ***** *****
*
PAGE
LOCAL
EDECODOP EQU DECODOPS ERROR CALL TO DECODOPS.
DECODOPS LW,R6 CURRCS POINTER TO CODESTRING BLOCK+2
LI,R15 % *FOR ERROR INFO IS SYSTERR
AI,R6 -2 *POINT TO BLOCK
LB,R8 *R6 * CHECK BLOCK TYPE
AI,R8 -CSBLOCK *
BNEZ SYSTERR *NOT CODESTRING-SYSTEM ERROR
LW,R6 CURRCS
LH,R8 *R6 OFFSET
SLS,R6 2 BA(OFFSET)
AI,R6 1
LI,R10 CSEND DECODET OFFSET FOR EOS FLAG
STB,R10 0,R6 SET LEFT-END STOP
AW,R6 R8 END OF CS+1
LB,R9 0,R6 GET BYTE TO RIGHT OF CODESTRING
STB,R10 0,R6 SET RIGHT-END STOP
STB,R9 R8 R8-BYTE 3=LEFT END-1,BYTE 0=RT END+1
STW,R8 SAVENDS
LI,R11 -1 SET RIGHT-LEFT SCAN
B STEP1 MOVE LEFT 1 BYTE AND START
*
* PHASE 1 & PHASE 3 PROCESSOR(DEPENDING ON R11)
*
* RIGHT-LEFT OR LEFT-RIGHT SCAN TO FLIP-OR-FLOP MULTIBYTE CODESTRING
* ITEMS.
*
LOCAL PICKBYTE,SHIFTN,SHIFTV,STEPN,STEP3,STEP5,STEP9,STEP2
LOCAL LFACT,BITS,LONGTEXT,LONGT1,LONGT2,ENDFLIP
PICKBYTE LB,R5 0,R6 GET BYTE FROM CODESTRING
CI,R5 CSEND CHECK RANGE
BG SYSTERR !IMPOSSIBLE!
LB,R4 DECODET,R5 DECODE BYTE
CI,R4 X'11' CHECK IF MULTI-BYTE ENTRY
BG STEP1 NO-SKIP IT
BE ENDFLIP EOS-STOP FLIP-FLOP SCAN
AI,R4 -2 CHECK TYPE OF SPECIAL CODESTRING
BLEZ STEP1 SINGLE CHARACTER-SKIP IT
LW,R3 R6 SET POINTER
AW,R3 R11 TO NEXT BYTE (MAY BE LENGTH)
LB,R9 0,R3 R9=2ND BYTE
AI,R4 -2
BLEZ STEP2 2 CHARACTER SET-FLIP THEM
AI,R4 -4
BLZ STEP3 3 CHARACTERS
BEZ STEP5 5 CHARACTERS
AI,R4 -2
BLZ STEP9 9 CHARACTERS
AW,R3 R11 SET TO 3RD BYTE
CI,R4 6
BE LONGTEXT LENGTH IS 2 BYTES
LW,R10 R9 SET LOOP COUNTER TO LENGTH
BEZ STEP2 EMPTY TEXT VECTOR OR NULL COMMENT
LI,R12 STEP2 SET EXIT FROM BYTE-SHIFT LOOP
EXU LFACT,R4 GET BYTE COUNT FROM LENGTH
B SHIFTV ENTER BYTE-SHIFT LOOP
SHIFTN LI,R12 STEPN
SHIFTV LB,R7 0,R3 BYTE SHIFT
STB,R7 0,R6 LOOP
AW,R6 R11
AW,R3 R11
BDR,R10 SHIFTV
B *R12 EXIT
STEP2 STB,R9 0,R6 STORE 2ND BYTE
AW,R6 R11
STEPN STB,R5 0,R6 STORE KEY BYTE
STEP1 AW,R6 R11 MOVE TO NEXT BYTE
B PICKBYTE
STEP3 LI,R10 2 NAME ITEM HW+KEY BYTE
B SHIFTN
STEP5 LI,R10 4 INTEGER WORD SCALAR
B SHIFTN
STEP9 LI,R10 8 REAL DW SCALAR
B SHIFTN
* LFACT-EXU VECTOR
LFACT B BITS LOGIC VECTOR @@@@@@@
B SHIFTV BYTE-FIELD @
B SHIFTV BYTE-FIELD @
SLS,R10 2 WORD FIELD-COUNT=4*L @
SLS,R10 3 DW FIELD-COUNT=8*L @
B SHIFTV BYTE FIELD @@@@@@@
*
BITS AI,R10 7
SLS,R10 -3 GET BYTE COUNT FROM BIT COUNT
B SHIFTV
*
LONGTEXT LB,R4 0,R3 GET 3RD BYTE-PART OF L
AW,R3 R11 MOVE TO 4TH BYTE
CI,R11 -1 CHECK DIRECTION
BE LONGT1 RIGHT-LEFT
XW,R9 R4 LEFT-RIGHT,SWITCH BYTES 2 & 3
LONGT1 LW,R10 R4 R4=L1
SLS,R10 8 R9=L2
AW,R10 R9 R10=LENGTH
CI,R11 -1
BNE LONGT2 LEFT-RIGHT
XW,R9 R4 RIGHT-LEFT,SWITCH BYTES 2 & 3
LONGT2 BAL,R12 SHIFTV SHIFT L BITS
STB,R4 0,R6 SET L1 OR L2
AW,R6 R11
B STEP2 FINISH LAST 2 BYTES
*
ENDFLIP CI,R11 -1 CHECK PHASE
BNE DECODEND PHASE 3-
LW,R11 SAVENDS
STB,R11 0,R6 RESTORE 2ND BYTE OF OFFSET
LI,R11 0
STD,R11 IMAGES AND IMMERBYT PRESET FOR PHASE 2
STW,R11 LASTSCAN @@@@
LW,R3 CURRCS GET ADDRESS OF CS
SLS,R3 2 FORM BYTE ADDRESS
MTW,0 MODE CHECK MODE
BNEZ ERRDISPL ERROR DISPLAY
AI,R3 10000 FUNCTION EDIT-SET LARGE VALUE
B DECODOUT
ERRDISPL AW,R3 OFFSET
* @
* PHASE 2-SCAN LEFT-RIGHT AND GENERATE LINE DISPLAY @
* @
LOCAL PASSERR,SETBYTE,CHEKMNEM,RESLAST,HARDWAY @
LOCAL TEXT,TEXT1,COMMENT,NOTEXT,REALV1,REALV,REAL1 @
LOCAL INTV1,INTEGERV,INTEGER1,INTEGERB,LOGICV,LOGICV1
LOCAL LOGICV2,YES,NXTBIT,NAME
DECODOUT STW,R3 CSERRBYT SET CS ERROR BA (OR HI VALUE)
LW,R3 IMAGEPOS
SKIP AI,R6 1
COMPBYTE CW,R6 CSERRBYT CHECK IF PAST ERROR POSITION
BL PASSERR NO-OR NO ERROR INDICATED
MTW,0 IMERRBYT CHECK IF ERROR CARET ALREADY SET
BNEZ PASSERR YES
STW,R3 IMERRBYT NO-SET ERROR CARET POSITION
PASSERR LB,R5 0,R6 R5=CS VALUE
LB,R4 DECODET,R5 R4=APL INTERNAL OR SPECIAL INDIC.
CI,R4 X'11' CHECK FOR SPECIAL
BL HARDWAY SPECIAL
BE ENDCONV EOS-QUIT DISPLAY
CI,R5 9 SINGLE CHAR-CHECK DIGIT
BG CHEKMNEM NO
BAL,R11 QSTASHBL YES-SET BLANK IF LASTSCAN INDICATES
SETBYTE LW,R8 R4 R8=INTERNAL APL CHAR.
LI,R11 SKIP SET EXIT
B STASHIM SET BYTE
*
CHEKMNEM LB,R7 OUTMNEMT,R4 CHECK IF BYTE IS MNEMONIC FOR
BEZ RESLAST OUTPUT DEVICE
CI,R7 4
BGE RESLAST NO
BAL,R11 QSTASHBL YES-SET BLANK IF LASTSCAN INDICATES
BAL,R5 GENMNEM GENERATE MNEMONIC
B SKIP
*
* RESLAST-RESET LASTSCAN=0 AND SET BYTE
*
RESLAST LI,R8 0
STW,R8 LASTSCAN
B SETBYTE
*
* HARDWAY-START OF PROCESSING FOR SPECIAL CS ITEMS
*
HARDWAY CI,R4 3
BL SKIP DUMMY,BOS
BE TEXT1
AI,R6 1
LB,R10 0,R6 GET 2ND BYTE
CI,R4 X'B' CHECK FOR TEXT VECTOR
BL NOTEXT
BE TEXT
CI,R4 X'C' CHECK FOR COMMENT
BE COMMENT
CI,R4 X'F' CHECK FOR LINE-SCAN ERROR
BE LSCERR YES
BL NOTEXT
AI,R6 1 GET L2
LB,R11 0,R6
SLS,R10 8
AW,R10 R11 SET TEXT BYTE COUNT IN R10
TEXT LI,R8 X'7D' SET LEADING QUOTE
BAL,R11 STASHIM
CSGNTEXT BAL,R13 GENTEXT
LI,R4 X'7D'
B RESLAST SET CLOSING QUOTE AND RESET LASTSCAN
*
TEXT1 LI,R10 1
B TEXT
*
COMMENT AI,R10 1 KICK COUNT FOR COMMENT CHARACTER
LI,R4 X'59' COMMENT CHARACTER
BAL,R13 GENTEXTC
B SKIP
*
* LSCERR LINE-SCAN ERROR-TEXT+ERROR POINTER
*
LSCERR AW,R6 R10 MOVE TO ERROR POINTER
LB,R5 0,R6 GET IT
SW,R6 R10 MOVE BACK
LW,R4 R3 GET IMAGE POINTER
AW,R4 R10 ADD LENGTH
SW,R4 R5 SUBTRACT ERROR POINTER
AI,R4 -1 1 MORE
MTW,0 MODE CHECK IF DISPLAY
BEZ %+2 YES-DONT INDICATE ERROR
STW,R4 IMERRBYT SAVE IMAGE ERROR POSITION
AI,R10 -1 DONT COUNT THE ERROR POINTER AS TEXT
BAL,R13 GENTEXT GENERATE TEXT
AI,R6 1 SKIP THE ERROR POINTER
B SKIP PROCEED (SHOULD HIT END NEXT)
*
*
NOTEXT BAL,R11 QSTASHBL INSERT BLANK IF NEEDED -SET LASTSCAN
CI,R4 4
BE INTEGERB BYTE INTEGER
CI,R4 8
BL NAME NAME,STOP-NAME,OR TRACE-NAME
BE INTEGER1 SCALAR INTEGER
CI,R4 9
BE REAL1 SCALAR REAL
AI,R6 1 MOVE TO 3RD BYTE
CI,R4 X'D'
BE INTEGERV INTEGER VECTOR
BL LOGICV LOGIC VECTOR
B REALV REAL VECTOR-LENGTH IN R10
REALV1 BAL,R11 STASHBL SET INTERVENING BLANK
REALV LW,R7 SET89 SET TO MOVE FROM ADDRESS IN R6
MBS,R6 0 TO R8-R9
BAL,R13 CREALIM CONVERT AND STORE IN IMAGE
BDR,R10 REALV1
B COMPBYTE
REAL1 LI,R10 1 SET COUNT TO 1
B REALV
SET89 DATA X'08000020' MBS 8 BYTES TO R8-R9
*
INTV1 BAL,R11 STASHBL SET INTERVENING BLANK
INTEGERV LW,R7 SET8 SET TO MOVE FROM CS TO R8
MBS,R6 0 LOAD R8
BAL,R13 CINTIM CONVERT AND STASH
BDR,R10 INTV1 LOOP
B COMPBYTE EXIT
INTEGER1 LI,R10 1 INTEGER SCALAR
B INTEGERV
INTEGERB LW,R8 R10 1 BYTE INTEGER
LI,R13 SKIP SET EXIT
B CINTIM CONVERT AND STASH
SET8 DATA X'04000020' MBS 4 BYTES TO R8
*
LOGICV LI,R5 8 SET BIT-IN-BYTE COUNTER
LB,R9 0,R6 GET BYTE
LOGICV1 CW,R9 BITPOS-32,R5 CHECK BIT
BANZ YES 1
LI,R8 X'F0' 0
LOGICV2 BAL,R11 STASHIM STASH CHAR.
BDR,R10 NXTBIT LOOP ON TOTAL BIT COUNT
B SKIP EXIT
YES LI,R8 X'F1' 1
B LOGICV2
NXTBIT BAL,R11 STASHBL SET INTERVENING BLANK
BDR,R5 LOGICV1 LOOP ON BIT-IN-BYTE
AI,R6 1 WORK NEXT BYTE
B LOGICV
*
NAME AI,R4 -6 SET R4 -1 FOR STOP,0 FOR TRACE
AI,R6 1 +1 FOR ORDINARY NAME
LB,R5 0,R6
SLS,R10 8
AW,R5 R10 R5=NAME POINTER ,R4=FLAG FOR S OR T
LI,R13 SKIP
B CNAMEIM
*
*
* ENDCONV-END OF DECODESTRING CONVERSION FOR OUTPUT-PHASE2
*
ENDCONV LI,R12 ENDCONV1 END OF CODESTRING
LW,R6 MODE CHECK MODE
BGZ DUMPLINE NOT EDIT-MUST BE DISPLAY
LW,R6 MERGECOL CHECK DISPLAY-APPEND-EDIT
BNEZ DUMPLING DISPLAY OR EDIT-USE CR
BAL,R11 PRMTIMAG APPEND-NO CR
ENDCONV1 LW,R6 CURRCS
SLS,R6 2 SET R6 FOR LEFT-RIGHT SCAN OF CS
AI,R6 1 (PHASE 3)
LI,R11 1 SET DIRECTION LEFT-RIGHT
B STEP1 START PHASE 3 SCAN
*
* DECODEND-END OF PHASE 3
*
DECODEND LB,R11 SAVENDS
STB,R11 0,R6 RESTORE BYTE PAST END OF CS
LW,R3 MODE CHECK MODE
BGZ UNREF NOT EDIT-DEREF CS BLOCK
LW,R3 ENDIMAGE FN EDIT
AI,R3 1 GET CHAR COUNT
B DECODRTN
*
*
* DECODET-TABLE TO CONVERT CODESTRING TO CHARACTER IMAGE FOR OUTPUT
* THIS TABLE IS USED IN THE FOLLOWING PHASES:
* 1. RIGHT-LEFT SCAN TO FLIP KEY AND LENGTH BYTES TO
* THE LEFT ON MULTTI-BYTE ITEMS.
*
* 2. LEFT-RIGHT SCAN TO GENERATE IMAGE OF INTERNAL
* CHARACTERS-NOTE-THIS SCAN ALSO USES OUTRANS TABLE
* TO SET MNEMONICS AS REQUIRED FOR TTY,PRINTER,ETC.
*
* 3. LEFT-RIGHT SCAN TO RESTORE CODESTRING TO EXECUTION
* FORM.
*
* ENTRIES ABOVE BLANK (X'40') ARE SINGLE CHARACTER CODESTRING
* ITEMS WHICH MAP TO SINGLE INTERNAL APL CHARACTERS
*
* ENTRIES BELOW BLANK INDICATE SPECIAL ACTION TO GET IMAGE
* CHARACTERS-NUMERIC TRANSLATION,NAME LOOK UP,ETC.
* CODESTRING BYTE IS KEY FOLLOWED BY INFORMATION BYTES
* ACTION VECTOR: BYTES IN CODESTRING
* 0 DUMMY-SKIP ITEM 1
* 1 ERROR 1
* 2 BOS-SKIP ITEM 1
* 3 SCALAR-TEXT 2
* 4 SCALAR-INTEGER-BYTE 2
* 5 STOPNAME -SYMTAB PTR 3
* 6 TRACENAME-SYMTAB PTR 3
* 7 NAME- SYMTAB PTR 3
* 8 SCALAR-INTEGER 5
* 9 SCALAR-REAL 9
* A VECTOR-BITS (L+7)/8+2
* B VECTOR-TEXT-SHORT L+2
* C COMMENT L+2
* D VECTOR-INTEGERS 4L+2
* E VECTOR-REALS 8L+2
* F LINE-SCAN ERROR L+2
* 10 VECTOR-TEXT-LONG L+3 (L=2 BYTES)
* 11 END OF STATEMENT (TEMPORARY VALUE)
*
DECODET DATA X'F0F1F2F3' 0,1,2,3
DATA X'F4F5F6F7' 4,5,6,7
DATA X'F8F90408' 8,9,INTEGER-BYTE,INTEGER
DATA X'09030A0D' REAL,CHAR,LOGICS,INTEGERS
DATA X'0E0B100F' REALS,CHARS,MANY CHARS,LINESCAN ERR
DATA X'0C050607' COMMENT,STOPNAME,TRACENAME,NAME
DATA X'01B6B7B8' ERROR,QUAD0,QUAD1,QUAD2
DATA X'B9BABBBC' QUAD3-QUAD6
DATA X'BDBEBF53' QUAD7,QUAD8,QUAD9,QUAD
DATA X'52025EB4' QQUAD,BOS,SEMI,LEFT BRACKET
DATA X'B54D5DFC' RIGHT BRACKET,LPAREN,RPAREN,BRANCH
DATA X'FD4B5A01' ASSIGNMENT,.,SMALL CIRCLE,ERROR
DATA X'0101FE6F' ERROR,ERROR,DOMINO,QUESTION MARK
DATA X'54636149' T-BAR,REDUCTION1,REDUCTION,IOTA
DATA X'6C6B6858' RHO,COMMA,ROTATE1,ROTATE
DATA X'B24E60FA' TRANSPOSE,+,-,MULTIPLY
DATA X'FB5C5756' DIVIDE,*,LOG,CIRCLE
DATA X'62444F41' MAX,MIN,ABS,BANG
DATA X'01015146' ERROR,ERROR,I-BEAM,GRADE UP
DATA X'735F0101' GRADE DOWN,NOT,ERROR,ERROR
DATA X'FE6F5463' DOMINO,QUESTION MARK,T-BAR,REDUCT1
DATA X'61496C6B' REDUCTION,IOTA,RHO,COMMA
DATA X'6858B24E' ROTATE1,ROTATE,TRANSPOSE,+
DATA X'60FAFB5C' -,MULTIPLY,DIVIDE,*
DATA X'57566244' LOG,CIRCLE,MAX,MIN
DATA X'4F414C74' ABS,BANG,LT,LE
DATA X'6E767B7E' GT,GE,NE,=
DATA X'70797778' AND,OR,NAND,NOR
DATA X'01014255' ERROR,ERROR,DECODE,TEE
DATA X'6A64B0B1' TAKE,DROP,EXPAND1,EXPAND
DATA X'45010171' EPSILON,ERROR,ERROR,DIERESIS
DATA X'726D437C' NEGSIGN,UNDERSCORE,%,ALPHA
DATA X'667F754A' OMEGA,DEL,LOCK,CPL
DATA X'67505B7A' CPR,CAP,CUP,:
DATA X'01010011' ERROR,ERROR,DUMMY,END-OF-STMT
*
END