IDENT LIST80,FETS
ABS
SYSCOM B1 DEFINE (B1) = 1
SPACE 4,10
*COMMENT LIST80 - COMPRESS COMPASS LISTINGS.
COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
SPACE 4,10
ENTRY LIST80
ENTRY RFL=
TITLE LIST80 - COMPRESS COMPASS LISTINGS.
TITLE
*** LIST80 - COMPRESS COMPASS LISTINGS.
* G. R. MANSFIELD.
* D. R. HILGREN. 79/04/25. RESEQUENCED.
SPACE 4,10
*** *LIST80* READS A FILE CONTAINING LIST OUTPUT
* PRODUCED BY THE COMPASS COMPILER AND COMPRESSES IT TO 80
* COLUMNS.
SPACE 4,10
*** CONTROL CARD CALL.
*
* LIST80(IFILE,OFILE,NR)
* IFILE FILE TO COPY FROM.
* OFILE FILE TO COPY TO.
* NR IF PRESENT, *IFILE* WILL NOT BE REWOUND.
*
* ASSUMED PARAMETERS.
* IFILE = *LIST*
* OFILE = *OUTPUT*
*
* PAGE SIZE AND PRINT DENSITY WILL BE BASED
* ON THE PRINT FILE TO BE PROCESSED.
*
SPACE 4,10
*** DAYFILE MESSAGES.
*
* * CONVERSION COMPLETE.* - *LIST80* COMPLETED.
*
* * FILE NAME CONFLICT.* - *IFILE* AND *OFILE* HAVE THE SAME
* NAME.
*
* * FL TOO SHORT FOR LIST.* - NOT ENOUGH STORAGE FOR LIST.
SPACE 4,10
**** ASSEMBLY CONSTANTS.
IBUFL EQU 2001B
OBUFL EQU 2001B
****
SPACE 4,10
* COMMON DECKS.
*CALL COMCMAC
*CALL COMCCMD
****
TITLE STORAGE ASSIGNMENT.
* STORAGE ASSIGNMENT.
ORG 110B
FETS BSS 0
I BSS 0 *IFILE*
LIST FILEC IBUF,IBUFL
O BSS 0 *OFILE*
OUTPUT FILEC OBUF,OBUFL,(FET=6)
MBUF BSS 136 WORKING READ BUFFER
MBUFL EQU *-MBUF
SBUF BSS 80 WORKING WRITE BUFFER
SBUFL EQU *-SBUF
BSS 10
SPACE 4,10
* PROGRAM CONSTANTS.
PD CON 1LS,0 PRINT DENSITY / CONTROL WORD
PL CON 0 PAGE LENGTH
BLANKS BSS 0 BLANKS
DUP 10,1
CON 1R
LIST80 TITLE LIST80 - MAIN PROGRAM.
LIST80 SB1 1 ENTRY
RJ ARG PROCESS ARGUMENTS
LST1 READ I
SX6 LSL SET LINE LIST
SA0 SRN SET INITIAL LIST DISABLE
SA6 CKSAE+1
EQ LST3 READ FIRST LINE OF *IFILE*
LST2 WRITES O,SBUF,SBUFL
LST3 READS I,MBUF,MBUFL
NG X1,LST4 IF EOF
NZ X1,LST1 IF EOR
SA1 MBUF
SX6 X1-1R1
ZR X6,PEJ IF PAGE EJECT
SB2 A0
JP B2 PROCESS LINE
LST4 WRITER O
MESSAGE (=C* CONVERSION COMPLETE.*),3
ENDRUN
TITLE SUBROUTINES.
CKS SPACE 4,10
** CKS - CHECK SUBTITLE.
*
* EXIT TO *LST2*.
*
* USES A - 0, 1, 2, 6.
* X - 1, 2, 4, 6, 7.
* B - 2.
*
* MACROS MOVE.
CKS SA1 MBUF+8 ASSEMBLE 10 CHARACTERS
MX4 1
BX6 X6-X6
CKS1 LX6 6
BX6 X1+X6
LX4 6
SA1 A1+B1
PL X4,CKS1 IF NOT END OF WORD
SA6 CKSAE
SA2 CKSA
SB2 B1+B1
CKS2 BX7 X6-X2
SA1 A2+B1
SA2 A2+B2
SA0 X1
NZ X7,CKS2 IF NOT SUBTITLE
SX6 1R
SA6 SBUF
SA6 A6+B1
MOVE 46,MBUF+8,A6+B1 MOVE SUBTITLE
MOVE 31,MBUF+69,SBUF+48 MOVE SUB-SUBTITLE
EQ LST2 WRITE LINE
CKSA BSS 0
CON 10HSTORAGE AL,STA
CON 10HSYMBOLIC R,REF
CON 10HERROR DIRE,ERD
CKSAE CON 0,LSL
ERD SPACE 4,10
** ERD - LIST ERROR DIRECTORY.
*
* EXIT TO *LST2*.
*
* USES A - 1, 6.
* X - 1, 6.
* B - 2, 3, 4.
*
* MACROS MOVE.
ERD SA1 MBUF+16
SX6 X1-1R
ZR X6,ERD1 IF NOT TYPE EXPLANATION
MOVE 16,MBUF+12,SBUF
MOVE 64,MBUF+40,SBUF+16
EQ LST2 WRITE LINE
ERD1 MOVE 21,MBUF+19,SBUF
SB2 9 NUMBER OF FIELDS TO MOVE
SB3 MBUF+44
SB4 SBUF+21
ERD2 MOVE 6,B3,B4 MOVE FIELD
SB3 B3+10
SB4 B4+6
SB2 B2-1
NZ B2,ERD2 IF NOT END OF LINE
MOVE 4,BLANKS,SBUF+75 CLEAR LAST PART OF LINE
SX6 LSL
SA6 CKSAE+1 RESET LINE LIST
EQ LST2 WRITE LINE
LSL SPACE 4,10
** LSL - LIST LINE.
*
* EXIT TO *LST2*.
*
* USES A - 0, 1, 2, 6, 7.
* X - 1, 2, 3, 4, 6, 7.
* B - 2.
*
* MACROS MOVE.
LSL MOVE 7,MBUF+7,SBUF+1 LOCATION FIELD
MOVE 64,MBUF+40,SBUF+8 CARD IMAGE
MOVE 6,MBUF+120,SBUF+72 SEQUENCE NUMBER
SA1 MBUF+1 FIRST ERROR CODE (IF ANY)
MX4 1
BX6 X1
SA6 SBUF+1
SA1 MBUF+112 ASSEMBLE CARD NAME
SB2 X1-1R
ZR B2,LSL2 IF BLANK NAME
BX6 X6-X6
LX4 3*6
SA2 LSLA
LSL1 LX6 6
BX6 X6+X1
LX4 6
SA1 A1+B1
PL X4,LSL1 IF NOT END OF WORD
BX3 X2-X6
ZR X3,LSL2 IF SAME CARD NAME
SA6 A2 SET NEW NAME
SX7 1R
SA7 SBUF+65
MOVE 7,MBUF+112,SBUF+66
LSL2 SA1 MBUF+40 CHECK CARD TYPE
SX6 X1-1R*
SB2 X1-1R,
ZR X6,LST2 IF COMMENT
ZR B2,LST2 IF CONTINUATION
SA1 MBUF+50 ASSEMBLE OPCODE
MX4 1
BX6 X6-X6
SA2 LSLB
LX4 3*6
LSL3 LX6 6
BX6 X6+X1
LX4 6
SA1 A1+B1
PL X4,LSL3 IF NOT END OF WORD
BX7 X2-X6
ZR X7,LSL5 IF *END*
LSL4 SA2 A2+B1
BX7 X2-X6
ZR X2,LST2 IF EOL
NZ X7,LSL4 IF NOT *EQU* TYPE
MOVE 7,MBUF+29,SBUF
SX6 1R
SA6 SBUF
EQ LST2 WRITE LINE
* PROCESS STATISTICS.
LSL5 SA0 LSL6 SET STATISTICS LIST
SX6 A0+
SA6 CKSAE+1
EQ LST2 WRITE LINE
LSL6 MX4 1 CHECK FOR NEW IDENT
SA1 MBUF+50
BX6 X6-X6
LX4 3*6
SA2 LSLC
LSL7 LX6 6
BX6 X1+X6
LX4 6
SA1 A1+B1
PL X4,LSL7 IF NOT YET 7 CHARACTERS
SX7 LSL
BX6 X6-X2
NZ X6,LSL8 IF NOT *IDENT*
SA0 X7
SA7 CKSAE+1
EQ LSL PROCESS IDENT
LSL8 MOVE 75,MBUF+27,SBUF
MOVE 5,BLANKS,SBUF+75
EQ LST2 WRITE LINE
LSLA CON 1H
LSLB BSS 0
CON 7REND
LSLC CON 7RIDENT
CON 7REQU
CON 7RSET
CON 7RDUP
CON 7RMAX
CON 7RMIN
CON 7RCOL
CON 7RBASE
CON 0
PEJ SPACE 4,10
** PEJ - PROCESS EJECT.
*
* EXIT (A0) = LINE PROCESSOR.
* EXIT TO *LST2*.
*
* USES A - 0, 1, 6, 7.
* X - 1, 6, 7.
*
* MACROS MOVE.
PEJ SA0 CKS SET SUBTITLE CHECK
SX6 1R1 SET EJECT
SX7 1R
SA6 SBUF
SA7 A6+1
MOVE 46,MBUF+8,A7+B1 TITLE
MOVE 21,MBUF+89,SBUF+47 DATE/TIME
MOVE 5,MBUF+115,SBUF+68 * PAGE*
MOVE 7,MBUF+121,SBUF+73 PAGE NUMBER
SA1 =1H CLEAR CARD NAME
BX6 X1
SA6 LSLA
SA1 PD+1 GET *PD* CONTROL WORD
BX6 X6-X6 DISABLE USE OF *PD*
SA6 A1
WRITEW O,PD,X1 WRITE PRINT DENSITY FORMAT CONTROL
EQ LST2 WRITE LINE
REF SPACE 4,10
** REF - LIST CROSS REFERENCE TABLE.
*
* EXIT TO *LST2*.
*
* USES A - 1, 6.
* X - 1, 6.
* B - 2, 3, 4.
*
* MACROS MOVE.
REF SA1 MBUF+67
SX6 X1-1R=
NZ X6,REF1 IF NOT QUALIFIER LINE
MOVE 30,MBUF+50,SBUF+18
EQ LST2 WRITE LINE
REF1 MOVE 9,MBUF+7,SBUF SYMBOL NAME
MOVE 7,MBUF+17,SBUF+9 SYMBOL VALUE
SB3 MBUF+42
SB2 8 NUMBER OF FIELDS TO MOVE
SB4 SBUF+16
REF2 MOVE 8,B3,B4 MOVE FIELD *PPP/LL F*
SB3 B3+10
SB4 B4+8
SB2 B2-1
NZ B2,REF2 IF NOT END OF LINE
SX6 LSL RESET LINE LIST
SA6 CKSAE+1
EQ LST2 WRITE LINE
SRN SPACE 4,10
** SRN - SET RECORD NAME.
*
* EXIT TO *LST3*.
*
* USES A - 1, 6.
* B - 3.
* X - 1, 4, 6.
*
* MACROS MESSAGE.
SRN SA1 MBUF
SB3 X1-1RS
ZR B3,SRN2 IF 6 LPI PRINT DENSITY IMAGE
EQ B3,B1,SRN2 IF 8 LPI PRINT DENSITY IMAGE
SX6 B0
MX4 10
SRN1 LX6 6
BX6 X6+X1
LX4 1
SA1 A1+B1
NG X4,SRN1 IF NOT 7 CHARACTERS CHECKED
LX6 -6
SA6 SRNA+1
MESSAGE A6-B1,1
EQ LST3 READ NEXT LINE
SRN2 SX6 X1
LX6 -6
SA6 PD
EQ LST3 READ NEXT LINE
SRNA DATA 10HCONVERTING
DATA 0,0
STA SPACE 4,10
** STA - LIST STORAGE ALLOCATION.
*
* EXIT TO *LST2*.
*
* USES A - 1.
* X - 1, 6.
*
* MACROS MOVE.
STA SA1 MBUF+26 CHECK LINE TYPE
SX6 X1-1R
ZR X6,STA1 IF NOT ALLOCATION
MOVE 76,MBUF+18,SBUF
EQ LST2 WRITE LINE
STA1 MOVE 76,MBUF+38,SBUF
EQ LST2 WRITE LINE
SPACE 4,10
** COMMON DECKS.
*CALL COMCCIO
*CALL COMCMVE
*CALL COMCRDS
*CALL COMCRDW
*CALL COMCSYS
*CALL COMCWTS
*CALL COMCWTW
BUFFERS SPACE 4,10
** BUFFERS.
ENDS BSS 0
USE //
IBUF BSS IBUFL
OBUF BSS OBUFL
END BSS 0
RFL= BSS 0
USE *
ARG SPACE 4,10
** ARG - PROCESS ARGUMENTS.
*
* USES A - 1, 2, 6, 7.
* X - 0, 1, 2, 3, 4, 6, 7.
* B - 2, 7.
*
* CALLS IPP.
*
* MACROS ABORT, MESSAGE, REWIND.
ORG IBUF
SEG
ARG5 NZ X0,ARG6 IF NO REWIND
REWIND I
ARG6 RJ IPP INITIALIZE PAGE PARAMETERS
ARG SUBR ENTRY/EXIT
SX7 A0-END CHECK FL
PL X7,ARG1 IF ENOUGH FIELD LENGTH
MESSAGE ARGA * FL TOO SHORT FOR LIST, NEED XXXXB.*
ABORT ABORT
ARG1 SB2 IBUF SPLIT FL BETWEEN BUFFERS
BX0 X0-X0 CLEAR NO REWIND
SX1 A0-B2
AX1 1
SX6 X1+B2 LIMIT FOR I = FIRST FOR O
SX7 A0+ LIMIT FOR O = FL
SA6 I+4
SA7 O+4
SA6 A7-B1
SA6 A6-B1
SX7 B1
LX7 18
BX6 X6+X7 SET FET SIZE TO 1+MINIMUM
SA6 A6-B1
SX7 B2 (0) = POINTER TO I BUFFER
SA7 B0
SA1 ACTR CHECK ARGUMENT COUNT
MX4 42
* PROCESS *IFILE* NAME.
SB7 X1
ZR B7,ARG5 IF NO ARGUMENTS
SA1 B1+B1 SET *IFILE* NAME
SA2 I
BX7 X4*X1
SX3 X2
ZR X7,ARG2 IF BLANK ARGUMENT
IX7 X7+X3
SA7 A2
* PROCESS *OFILE* NAME.
ARG2 SB7 B7-B1
ZR B7,ARG4 IF 1 ARGUMENT
SA1 A1+B1 SET *OFILE* NAME
SA2 O
BX7 X4*X1
ZR X7,ARG3 IF BLANK ARGUMENT
IX7 X7+X3
SA7 A2
* CHECK FOR NO REWIND.
ARG3 SX0 B7-B1
* CHECK FILE NAMES.
ARG4 SA1 I CHECK FILE NAMES
SA2 O
BX7 X1-X2
AX7 18
NZ X7,ARG5 IF *IFILE* NE. *OFILE*
MESSAGE ARGB * FILE NAME CONFLICT.*
ABORT ABORT
.1 OCTMIC ENDS+END-IBUF+20
ARGA DATA C* FL TOO SHORT FOR LIST, NEED ".1"B.*
ARGB DATA C* FILE NAME CONFLICT.*
IPP SPACE 4,15
** IPP - INITIALIZE PAGE PARAMETERS.
*
* ENTRY NONE.
*
* EXIT PRINT DENSITY SET UP IF NOT TTY.
*
* USES A - 6.
* B - NONE.
* X - 2, 6.
*
* CALLS STF.
*
* MACROS GETPP.
IPP SUBR ENTRY/EXIT
SX2 O FET ADDRESS OF PRINT FILE
RJ STF
ZR X6,IPPX IF TTY PRINT FILE
GETPP IPPA,PL,PD
SX6 B1+
SA6 PD+1 SET CONTROL WORD TO USE *PD*
EQ IPPX RETURN
IPPA BSSZ 2 GETPAGE RESPONSE BLOCK
SPACE 4,5
* COMMON DECKS FOR PRESET.
*CALL COMCCPM
*CALL COMCSTF
END