.

/ ADD

NAME=APLDEV
MACRO
00630000
&L
APLDEV &ADR,&TYPE=AMBIG,&SAD=SAD1,&EXPRESS=NO
01260000
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
01890000
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
02520000
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
03150000
GBLA &PADR,&TCNT,&FADR
03780000
GBLB &TERMT
04410000
GBLC &TERMTL,&PUBFIR,&PUBLAST
05040000
LCLA &ADR2,&ADR3,&ADR4,&ADR5
05670000
LCLB &LB1,&LB2,&LB3,&LB4
06300000
LCLC &LC1,&LC2,&LC3
06930000
.*
&LB1 TRUE FOR 270X DEVICE
07560000
.*
&LB2 TRUE FOR AUXILIARY
08190000
.*
&LB3 TRUE FOR HARD-WIRED 270X DEVICE
08820000
.*
&LB4 TRUE FOR AN EXPRESS PORT
09450000
LCLA &ADR2HI
10080000
AIF (N'&ADR EQ 1 OR N'&ADR EQ 2).ADROK
10710000
.ADRNG MNOTE 16,'INVALID FORMAT FOR DEVICE ADDRESS PARAMETER ' &ADR 11340000
MNOTE 16,'MACRO IGNORED.'
11970000
MEXIT
BETTER LUCK NEXT TIME
12600000
.ADROK ANOP
13230000
AIF (T'&ADR(1) EQ 'O' OR T'&ADR(N'&ADR) EQ 'O').ADRNG
13860000
.*
14490000
.* THE POSITIONAL PARAMETER &ADR CAN HAVE TWO FORMS:
15120000
.*
1)
X'##' OR ##
TO INDICATE A SINGLE PORT
15750000
.*
2)
(FIRST,LAST)
TO GENERATE ALL PORTS WITH ADDRESSES 16380000
.*
FROM FIRST TO LAST INCLUSIVE,
17010000
.*
HAVING IDENTICAL CHARACTERISTICS. 17640000
.*
18270000
&ADR2
SETA &ADR(1)
FIRST OF A GROUP OF CONSECUTIVE PORTS 18900000
&ADR2HI SETA &ADR(N'&ADR)
LAST OF A GROUP OF CONSECUTIVE PORTS 19530000
AIF (&ADR2 GT &ADR2HI).ADRNG WE DONT WANT TO COUNT BACKWARD 20160000
&LB4
SETB ('&EXPRESS' EQ 'YES')
20790000
&LB3
SETB ('&TYPE' EQ '1050' OR '&TYPE' EQ '2741' OR
X21420000
'&TYPE' EQ 'TS41')
22050000
&LB2
SETB ('&TYPE' EQ 'AUX')
22680000
&LB1
SETB (&LB3 OR '&TYPE' EQ 'AMBIG')
23310000
AIF (&LB1 OR &LB2 OR '&TYPE' EQ '1052' OR
X23940000
'&TYPE' EQ 'END').OKTYP
24570000
MNOTE 16,'INVALID DEVICE TYPE, MACRO IGNORED'
25200000
MEXIT
25830000
.OKTYP ANOP
26460000
AIF ('&SAD' EQ 'SAD0').OKSAD
27090000
AIF ('&SAD' EQ 'SAD1').OKSAD
27720000
AIF ('&SAD' EQ 'SAD2').OKSAD
28350000
AIF ('&SAD' EQ 'SAD3').OKSAD
28980000
AIF ('&SAD' EQ 'NOP').OKSAD
29610000
MNOTE 16,'INVALID SAD, MACRO IGNORED'
30240000
MEXIT
30870000
.OKSAD ANOP
31500000
AIF ('&EXPRESS' EQ 'YES' OR '&EXPRESS' EQ 'NO').OKEXP
32130000
MNOTE 16,'INVALID EXPRESS DESIGNATION, MACRO IGNORED'
32760000
MEXIT
33390000
.OKEXP ANOP
34020000
AIF ('&TYPE' EQ 'AUX').A23
34650000
AIF (&PADR GE &ADR2).A24
SEQUENCE ERROR
35280000
AIF (&PADR+1 NE &ADR2).A2
35910000
.A6
AIF (&ADR2 NE 16*(&ADR2/16)).A1
36540000
.A2
ANOP
37170000

&ADR3
&ADR4

SETA &PADR/16
SETA &ADR2/16
AIF (&ADR3 NE &ADR4).A3
.*
GENERATE DUMMY PUBENT OR PERTERM
&ADR3
SETA &ADR2-&PADR-1
.A20
ANOP
&LC3
SETC 'ATERM&TCNT'(1,8*&TERMT)
&LC3
DC
A(0,0,0,0,X'4000') SAME LENGTH AS PUBENT
DC
(&TERMTL-PUBENTL)X'00'
&ADR3
SETA &ADR3-1
&TCNT
SETA &TCNT+1*&TERMT
AIF (&ADR3 GT 0).A20
AGO .A1
.A3
AIF (&PADR LT 0).A4
CONFIG CSECT
ORG MPXCUTAB+&ADR3*8
&ADR5
SETA &FADR*256+&PADR
DC
A(&TERMTL*F*F+&ADR5)
DC
AL1(0)
PUBN MAY BE NEGATIVE. AL3 FORCES PROPER
DC
AL3(PUB&ADR3)
ADDRESS AFTER LINKEDIT RELOCATION
.A4
AIF ('&TYPE' EQ 'END').A12
&FADR
SETA &ADR2
&ADR3
SETA &ADR2-&ADR4*16
&TERMT SETB (&LB1)
&LC3
SETC 'PUBENTPERTERM'(6*&TERMT+1,6+&TERMT)
&TERMTL SETC '&LC3.L'
&LC3.G CSECT
ORG
PUB&ADR4 EQU *-&TERMTL*&ADR3
.A1
AIF (&TERMT NE &LB1).A5
&PADR
SETA &ADR2
AIF (&TCNT EQ 0).A24
.*
THIS CALL REPRESENTS A PHYSICAL DEVICE OF SOME SORT
AIF ('&TYPE' EQ '1052').A10
.*
GENERATE DATA ITEMS FOR PERTERM AREA
.A9
ANOP
ATERM&TCNT APLPUB &ADR2,&TYPE,WRITES
DC
A(ATERM&TCNT+X'58') PUCCB
AIF (&FADR NE &ADR2).A31
.A11
ENTRY ATERM&TCNT
.A31
DC
AL1(X'30',X'01',X'40'+X'01'*&LB2,X'80'*&LB3+X'08'*&LB4)
DC
A(EMPT3)
PTCORE
BCR 0,0
MESSCELL
DC
AL2(0) (YYREC)
DC
2H'0'
RESERVED,PTBUFA
DC
4A(EMPT3)
PTFBUF,PTLBUF,PTIBUF,PTRBUF
DC
6F'0' PTABTM,PTICTME,PTMTIME,PTSOTM,PTMTIM2,PTMTIM3
DC
2H'0'
PTCPULIM,PTCPULM2
DC
AL1(EMPTYM,&SAD,0,0,0) DESBYTE,PTSAD,PTDNT,PDSOP,PTRESP
DC
7X'00'
RESERVED
.*
READ AND WRITE CCW CHAIN
AIF (&LB3).R3
CCW X'2F',0,CC+SLI,1
DISABLE CCW FOR AMBIG TYPE
CCW &SAD,ATERM&TCNT+X'50',SLI,1 SAD CCW
AGO .R4
.*
SAD FOLLOWED BY ENABLE FOR NON DIALUP DEVICES.
.R3
CCW &SAD,0,CC+SLI,1
PTCCW1 - SAD.
CCW X'27',ATERM&TCNT+X'50',SLI,1 PTCCW2 ENABLE
.R4
DC
A(EMPT3)
PTCCW3 BECOMES TIC
DC
F'0'
PTMAN

37800000
38430000
39060000
39690000
40320000
40950000
41580000
42210000
42840000
43470000
44100000
44730000
45360000
45990000
46620000
47250000
47880000
48510000
49140000
49770000
50400000
51030000
51660000
52290000
52920000
53550000
54180000
54810000
55440000
56070000
56700000
57330000
57960000
58590000
59220000
59850000
60480000
61110000
61740000
62370000
63000000
63630000
64260000
64890000
65520000
66150000
66780000
67410000
68040000
68670000
69300000
69930000
70560000
71190000
71820000
72450000
73080000
73710000
74340000
74970000

DC
4X'00'
PTMANI,LAST BYTE RESERVED
DC
2H'0'
PTWSQ,PTWSA
&TCNT
SETA &TCNT+1
AIF (&TERMT OR &LB2).A7
PUBENTG CSECT
.A7
ANOP
&ADR2
SETA &ADR2+1
INCREMENT PORT NUMBER
AIF (&ADR2 LE &ADR2HI).A6 DO ANOTHER OF CONSECUTIVE PORTS?
MEXIT
.A12
ANOP
ORG
TERMCOUN EQU &TCNT
MEXIT
.*
.*
1052-7 TERMINAL
.*
.A10
DC
A(ATERM&TCNT,0,0,0,0) SAME LENGTH AS PUBENT
PERTERMG CSECT
ATERM&TCNT APLPUB &ADR2,1052,READS
DC
A(ATERM&TCNT+X'68') PUCCB
AGO .A11
.A23
AIF (&TCNT NE 0).A24
*
*
AUXILIARY MESSAGE BUFFER FOR OPERATOR
*
COPY SOURCE TERMINAL
*
PERTERMG CSECT
ENTRY AUXTERM
AUXTERM APLPUB X'FF',AUX,IDLE
ATERM&TCNT EQU AUXTERM
DC
A(9)
PUCCB (ILLEGAL CAW SETTING)
AGO .A11
*
.A5
MNOTE 4,'INTERMIXED PUB AND PERTERM BLOCKS'
.*
THIS RESTRICTION MIGHT BE REMOVABLE
.A24
MNOTE 16,'APLDEV CALLS OUT OF ORDER, MACRO IGNORED'
MEXIT
MEND
./ ADD
NAME=APLDS
MACRO
&L
APLDS &X,&DS,&RPS=NO,&DC=YES
5989
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
GBLA &I
GBLA &E
GBLB &OS
GBLC &CS
GBLC &AA
GBLC &DPARS
LCLC &D(6)
2541
LCLA &D1,&D2,&LG
2541
LCLB &RP
DASD
LCLB &ISSWAP,&DCH
5989
LCLC &A
LCLC &DD
&ISSWAP SETB ('&L' EQ 'SWAP')
5989
&DCH
SETB ('&DC' EQ 'NO')
5989
AIF (&DCH OR '&DC' EQ 'YES').DCOK
5989
MNOTE 0,'DC OPERAND INVALID, YES ASSUMED'
5989

75600000
76230000
76860000
77490000
78120000
78750000
79380000
80010000
80640000
81270000
81900000
82530000
83160000
83790000
84420000
85050000
85680000
86310000
86940000
87570000
88200000
88830000
89460000
90090000
90720000
91350000
91980000
92610000
93240000
93870000
94500000
95130000
95760000
96390000
97020000
97650000
98280000
98910000
00890000
01780000
02670000
03560000
04450000
05340000
06230000
07120000
08010000
08900000
09790000
10680000
11570000
12460000
13350000
14240000
15130000
16020000
16910000
17800000
18690000

.DCOK

AIF (&OS).OS
AIF ('&SYSECT' EQ 'SOFTPARS').A
SOFTPARS CSECT
.A
AIF (T'&L EQ 'O' AND T'&X NE 'O').B
AIF ('&DPARS' EQ '&L').B
AIF ('&DPARS' EQ '').C
ENTRY &DPARS.PZ
&DPARS.PZ EQU *-1
.C
AIF (T'&X EQ 'O').Z
ENTRY &L.PARS
&L.PARS EQU *
&DPARS SETC '&L'
.B
AIF (T'&DS EQ 'O').T0
AIF ('&DS'(1,1) EQ '''' AND '&DS'(K'&DS,1) EQ '''').T1
.T0
MNOTE 16,'FILE NAME INVALID, MACRO REJECTED'
MEXIT
.T1
AIF (&X LT 0 OR &X GT 244).T2
AIF ('&DPARS' NE 'SWAP' OR (&X NE 4 AND &X NE 5)).T3
.T2
MNOTE 16,'LOGICAL UNIT INVALID, MACRO REJECTED'
MEXIT
.T3
AIF (K'&DS LE 44).T4
MNOTE 0,'FILE NAME TOO LONG, TRUNCATED'
.T4
DC
AL1(0,0,1,&X)
DC
5F'0'
DC
AL1(B'&RP&ISSWAP&DCH.00000',0,0,0)
DC
F'0'
DC
CL44&DS
&I
SETA &I+1
.Z
MEXIT
.OS
ANOP
.* LOGAD WILL CONTAIN THE NUMBER I CORRESPONDING TO THE ITH DCB.
.AY
AIF (&I NE 1).AX
&E
SETA
0
.AX
AIF (T'&L EQ 'O').A3
&CS
SETC '&L'
&AA
SETC '&CS.PARS'
.A3
AIF (T'&X NE 'O').A4
AIF (T'&L EQ 'O').A5
&CS
SETC '&L'
.A5
ANOP
&CS.PARS CSECT
&CS.PZ EQU *-1
ENTRY &CS.PZ
MEXIT
.A4
ANOP
&AA
CSECT
&D2
SETA 2
&LG
SETA K'&X-1
AIF ('&X'(1,1) EQ '''' AND '&X'(K'&X,1) EQ '''').A1
&D2
SETA 1
&LG
SETA K'&X
.A1
ANOP
&D1
SETA &D1+1
AIF (&LG-&D2 LT 8).OUT
&D(&D1) SETC '&X'(&D2,8)
&D2
SETA &D2+8
AGO .A1
.OUT
ANOP
&D(&D1) SETC '&X'(&D2,&LG-&D2+1)
&A
SETC 'FILE&I'

5989 19580000
20470000
21360000
22250000
23140000
24030000
24920000
25810000
26700000
27590000
28480000
29370000
30260000
31150000
32040000
32930000
33820000
34710000
35600000
36490000
37380000
38270000
39160000
5989 40050000
5989 40940000
5989 41830000
42720000
43610000
44500000
45390000
46280000
47170000
48060000
48950000
49840000
50730000
51620000
52510000
53400000
54290000
55180000
56070000
56960000
57850000
58740000
59630000
2541 60520000
2541 61410000
2541 62300000
2541 63190000
2541 64080000
64970000
2541 65860000
2541 66750000
2541 67640000
2541 68530000
2541 69420000
2541 70310000
2541 71200000
72090000

&A

DC
DC
AIF
MNOTE
ANOP
SETB
AIF

Y(0,&I)
5F'0'
(T'&DS EQ 'O').DSOK
0,'&DS MEANINGLESS, IGNORED'

72980000
73870000
74760000
75650000
.DSOK
76540000
&RP
('&RPS' EQ 'YES')
77430000
(&RP OR '&RPS' EQ 'NO').DC
78320000
.*
DASD
79210000
MNOTE 0,'RPS OPERAND INVALID, NO ASSUMED'
80100000
.DC
DC
AL1(B'&RP&ISSWAP&DCH.00000',0,0,0)
80990000
DC
F'0'
81880000
DC
CL44'&D(1).&D(2).&D(3).&D(4).&D(5).&D(6).'
82770000
APLSDCBS CSECT
83660000
ORG *+4
84550000
ENTRY APLDCB&I
85440000
&DD
SETC 'APL&CS&E.'
86330000
AIF ('&CS' NE 'LIB').DCB
87220000
AIF (&E GT 9).DCB
88110000
&DD
SETC 'APL&CS.0&E.'
89000000
.DCB
ANOP
89890000
APLDCB&I DCB DSORG=DA,DDNAME=&DD,MACRF=(E),
X90780000
PCIA=WA,CENDA=WB,XENDA=WC
91670000
ORG APLDCB&I+50
92560000
DC
X'D0'
TURN OFF X'20'
93450000
ORG
94340000
MNOTE *,'//&DD DD DISP=SHR,DSNAME=&D(1).&D(2).&D(3).&D(4).&D(5X95230000
).&D(6).'
2541 96120000
&I
SETA &I+1
97010000
&E
SETA &E+1
97900000
MEND
98790000
./ ADD
NAME=APLPUB
MACRO
10000000
&L
APLPUB &ADR,&TYPE,&STATE
20000000
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
30000000
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
40000000
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
50000000
DS
0F
60000000
&L
DC
AL1(Q&TYPE,&STATE,&ADR,0) PTTYPE,STATE,PTUNAD,PUSENS
70000000
DC
2F'0'
SAVCSW
80000000
MEND
90000000
./ ADD
NAME=APLSCONF
MACRO
00520000
APLSCONF &DIRS=5,
NUMBER OF USER DIRECTORIES
*01040000
&INCORE=3,
NUMBER OF WS SLOTS IN CORE
*01560000
&WSSIZE=36000,
WORKSPACE SIZE IN BYTES
*02080000
&HOST=,
HOST APL SYSTEM
*02600000
&EXPLIM=8,
EXPRESS TIME LIMIT
*03120000
&DOSEND=X'3000',
SEND MACRO PARAMETER FROM DOS SYSGEN*03640000
&MPXCHAN=0,
MULTIPLEX CHANNEL ADDRESS
5991*04160000
&IODEBUG=200
SIZE OF I/O DEBUG TRACE TABLE
04680000
.*
5734-XM6 COPYRIGHT IBM CORP 1969,1970,1972
05200000
.*
5736-XM6 COPYRIGHT IBM CORP 1969,1970,1972
05720000
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
06240000
GBLA &MDEV,&PADR,&CACNT,&WSLN,&TCNT,&MANHASH
06760000
GBLA &MPXCH
5991 07280000
GBLB &DOS,&OS,&CP67
07800000
GBLC &PN
08320000
LCLC &S
08840000
&MPXCH SETA &MPXCHAN
5991 09360000
AIF ((&MPXCH GE 0) AND (&MPXCH LT 32) AND
*09880000
5989
DASD
DASD
DASD
DASD
DASD
**D
DASD
DASD
5989
2541

(N'&MPXCHAN EQ 1)).CK00
MNOTE 0,'MPXCHAN OPERAND INVALID, 0 ASSUMED'
.*
&MPXCH
.CK00

.CK0
.CK1
.CK3
.CK4
.CK5

SETA
ANOP
AIF
MNOTE
MEXIT
AIF
MNOTE
AIF
MNOTE
MEXIT
AIF
MNOTE
MEXIT
AIF
MNOTE
MEXIT
AIF

MNOTE
MEXIT
.CK6
ANOP
&DOS
SETB
&OS
SETB
&CP67
SETB
&S
SETC
AIF
MNOTE
AGO
.OSCM
MNOTE
.DOSC
ANOP
AIF
PUNCH
AIF
PUNCH
PUNCH
AIF
PUNCH
AGO
.BIGSUP PUNCH
.SMALSUP PUNCH
PUNCH
AGO
.INCL3 PUNCH
PUNCH
.INCL4 PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH

5991
5991
**D
5991
5991

10400000
10920000
5991
11440000
0
11960000
12480000
(&WSSIZE GE 20480).CK0
13000000
16,'WS SIZE TOO SMALL, MACRO IGNORED'
13520000
14040000
(&WSSIZE EQ 36000).CK1
14560000
0,'WARNING - NON STANDARD WORKSPACE SIZE'
15080000
(&INCORE GT 1).CK3
15600000
16,'INCORE MAY NOT BE LESS THAN 2, MACRO IGNORED'
16120000
16640000
(&DIRS GT 1).CK4
17160000
16,'DIRS MAY NOT BE LESS THAN 2, MACRO IGNORED'
17680000
18200000
(&IODEBUG GT 0).CK5
18720000
16,'IODEBUG MAY NOT BE LESS THAN 1, MACRO IGNORED'
19240000
19760000
('&HOST' EQ 'DOS' OR '&HOST' EQ 'APL' OR '&HOST' EQ 'OS'*20280000
OR '&HOST' EQ 'CP67').CK6
20800000
16,'HOST SPECIFICATION INVALID, MACRO IGNORED'
21320000
21840000
22360000
('&HOST' EQ 'DOS' OR '&HOST' EQ 'OS')
22880000
('&HOST' EQ 'OS')
23400000
('&HOST' EQ 'CP67')
23920000
'ADC*'(1+&DOS+2*&CP67,1)
24440000
(&OS).OSCM
24960000
*,'5736-XM6 COPYRIGHT IBM CORP 1969,1970,1972'
25480000
.DOSC
26000000
*,'5734-XM6 COPYRIGHT IBM CORP 1969,1970,1972'
26520000
27040000
(&OS).NOPC
27560000
' CATALR APLSLINK,1.1 '
C053 28080000
(&DOS).INCL3
28600000
' PHASE APLSLOW,+0,NOAUTO
' 29120000
' INCLUDE APL&S.ASUP,(APLSUP) '
29640000
(&DOSEND GT X'37D0').BIGSUP
30160000
' PHASE APL360,*+249,NOAUTO
' 30680000
.SMALSUP
31200000
' PHASE APL360,S,NOAUTO '
31720000
' INCLUDE APLSCONF,(COIBM) '
32240000
' INCLUDE APL&S.ASUP,(PERDEVXG,HDIR,HTAB) '
32760000
.INCL4
33280000
' INCLUDE APLSCONF,(COIBM) '
33800000
' INCLUDE APL&S.ASUP,(APLSUP,PERDEVXG,HDIR,HTAB) '
34320000
' INCLUDE APLSCONF,(SOFTPARS,PERTERMG,PUBENTG,CONFIG,APL*34840000
SVC) '
35360000
' INCLUDE APL&S.TRTA '
35880000
' INCLUDE APL&S.PCSB '
36400000
' INCLUDE APLSXREF '
36920000
' INCLUDE APLSAGOR '
37440000
' INCLUDE APLSARTH '
37960000
' INCLUDE APLSATCH '
38480000
' INCLUDE APLSBLOW '
39000000
' INCLUDE APLSDIOT '
39520000
' INCLUDE APLSDPY '
40040000
' INCLUDE APLSDQRY '
40560000
' INCLUDE APLSDRHO '
41080000

.NOPC
COIBM

PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
PUNCH
ANOP
AIF
CSECT
DC

' INCLUDE APLSDSER '

' INCLUDE APLSDTRA '
' INCLUDE APLSDYIB '
' INCLUDE APLSEPSI '
' INCLUDE APLSERAF '
' INCLUDE APLSFFSS '
' INCLUDE APLSGOUT '
' INCLUDE APLSGRAD '
' INCLUDE APLSINDX '
' INCLUDE APLSMDIV '
' INCLUDE APLSMIBM '
' INCLUDE APLSMSOP '
' INCLUDE APLSMRIO '
' INCLUDE APLSMTRA '
' INCLUDE APLSOCTL '
' INCLUDE APLSRAVL '
' INCLUDE APLSROTR '
' INCLUDE APLSSCOP '
' INCLUDE APLSSLCT '
' INCLUDE APLSSYNT '
' INCLUDE APLSTAKE '
' INCLUDE APLSTBCD '
' INCLUDE APLSTPIN '
' INCLUDE APLSVDOP '
' INCLUDE APL&S.SINI '
' INCLUDE APLSOPEN '
' INCLUDE APLSCONF,(CONFINIT)'
'.END
' CATALR APLUTIL,1.1 '
' PHASE APLUTIL,S+4096,NOAUTO
' INCLUDE APLSCONF,(COIBM,SOFTPARS) '
' INCLUDE APLSOPEN '
' INCLUDE APLUBILL
' INCLUDE APLUINST
' INCLUDE APLUUREC '
' INCLUDE APLUDISK
' INCLUDE APLUTAPE
' INCLUDE APLURSTR
' INCLUDE APLUDUMP
' INCLUDE APLUMAIN
' INCLUDE APLLABEL
' ENTRY MAIN
'.END
' CATALR APLSCONF,1.1 '

'
'
'
'
'
'
'
'
'
'
C053

(&OS).OSC
C'5736-XM6 COPYRIGHT IBM CORP 1969,1970,1972'

*
.OSC
COIBM

'
C053
'

DC
C'202157'
F.E. SERVICE NUMBER
AGO .OSC1
ANOP
CSECT
DC
C'5734-XM6 COPYRIGHT IBM CORP 1969,1970,1972'

*
DC
C'201156'
F.E. SERVICE NUMBER
.OSC1
ANOP
TITLE 'C O N F I G U R A T I O N P A R A M E T E R S'
PERTERMG CSECT
PUBENTG CSECT

**D
C049

**D
C049

41600000
42120000
42640000
43160000
43680000
44200000
44720000
45240000
45760000
46280000
46800000
47320000
47840000
48360000
48880000
49400000
49920000
50440000
50960000
51480000
52000000
52520000
53040000
53560000
54080000
54600000
55120000
55640000
56160000
56680000
57200000
57720000
58240000
58760000
59280000
59800000
60320000
60840000
61360000
61880000
62400000
62920000
63440000
63960000
64480000
65000000
65520000
66040000
66560000
67080000
67600000
68120000
68640000
69160000
69680000
70200000
70720000
71240000
71760000
72280000

DC
F'0'
AVOID CSECT OF LENGTH ZERO.
*
*
SOFTWARE PARAMETERS
&CACNT SETA
&INCORE
NUMBER OF WSS IN CORE SIMULTANEOUSLY
&WSLN
SETA &WSSIZE/8*8
WORKSPACE LENGTH (DOUBLEWORD)
&MANHASH SETA &DIRS
NUMBER OF DIRECTORIES.
*
&PADR
SETA 0-100
&MDEV
SETA 4
DC
EQU X'80'
CC
EQU X'40'
SLI
EQU X'20'
EMPT3
EQU X'800000'
EMPTYM EQU X'80'
F
EQU 256
SAD0
EQU X'13'
SAD1
EQU X'17'
SAD2
EQU X'1B'
SAD3
EQU X'1F'
NOP
EQU X'03'
QTS41
EQU 4
Q2741
EQU 24
QAMBIG EQU 44
Q1050
EQU 64
Q1052
EQU 84
QAUX
EQU 104
WRITES EQU 0
IDLE
EQU 3
READS
EQU 4
EXPLIM EQU &EXPLIM*60*300
WSLENR EQU ((&WSLN+2047)/2048)*2048
PERTERML EQU 120
PUBENTL EQU 20
PERCOREL EQU 8
CONFIG CSECT
ENTRY MPXCUTAB
*
FOR FORMAT OF MPXCUTAB SEE MPXINT IN APLSUP
MPXCUTAB DC
32F'0'
UNIT ADDRESS TO PERTERM MAP
DC
4A(0)
ENTRY SOOKTXT,SOOKEXTX,IODBUGG,IODBUGZ
SOOKTXT DC
H'19'
DC
FL4'-1617389416,1452828056,1637356696,-1885826408'
DC
FL4'-1935696739'
SOOKEXTX DC
H'27'
DC
FL4'-1617389416,1452828056,1637356696,-1885826408'
DC
FL4'-1936172435,1701272168,1755290781'
IODBUGG DS
(&IODEBUG)XL10'00' I/O DEBUG TRACE TABLE
IODBUGZ EQU *
END OF IODBUGG TABLE
EJECT
APLDEV 0,TYPE=AUX
MEND
./ ADD
NAME=APLSEND
MACRO
APLSEND &MAP=254,&QEND=,&INIT=,&FMSK=
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
GBLA &MDEV,&PADR,&CACNT,&WSLN,&TCNT,&MANHASH,&MINB
GBLA &MPXCH
5991
GBLB &DOS,&OS,&CP67

72800000
73320000
73840000
74360000
74880000
75400000
75920000
76440000
76960000
77480000
78000000
78520000
79040000
79560000
80080000
80600000
81120000
81640000
82160000
82680000
83200000
83720000
84240000
84760000
85280000
85800000
86320000
86840000
87360000
87880000
88400000
88920000
89440000
89960000
90480000
91000000
91520000
92040000
92560000
93080000
93600000
94120000
94640000
95160000
95680000
96200000
96720000
97240000
97760000
98280000
98800000
00940000
01880000
02820000
03760000
04700000
05640000
06580000
07520000

GBLC &PN
LCLA &I
*
.NOTOS
*

AIF (NOT &OS).NOTOS

APLDS ,
ANOP

DUMMY FINAL APLDS CALL

APLDEV X'100',TYPE=END
*
EXTRN APLSUP,MPXSAVE,EXTIM2,APLSETLO,IM
ENTRY PERCOREG,PERDISKG,PERDISKZ,FREE3,CONFSWAP
&I
SETA 0
PERCOREG DC
0D'0'
.I1
DC
H'0'
PCQUONT
DC
AL3(IM+&I*WSLENR,EMPT3)
&I
SETA &I+1
AIF (&I LT &CACNT).I1
PERDISKG DC
0D'0'
DC
(&TCNT+5)A(0,EMPT3)
PDDA,PDTERM
PERDISKZ EQU *-4
FREE3
DC
0D'0'
IETBRN EQU 6
DC
3A(EMPT3)
INITIAL VALUE OF FREE SP LIST
DC
A(IETBRN*F*F*F+APLSETLO,*+8,1) INTERVAL EVENT LIST HEAD
DC
(&TCNT+5)A(IETBRN*F*F*F+EXTIM2,*+8,1) DUMMY IE
&I
SETA 1
.I4
DC
A(ATERM&I,*+8,1)
MPX INTERVAL EVENT
&I
SETA &I+1
AIF (&I LT &TCNT).I4
DC
A(IETBRN*F*F*F+EXTIM2,EMPT3,1) LAST DUMMY EVENT
CONFSWAP DC
0D'0'
DC
X'01'
DC
A(SWAPPARS)
DC
A(&TCNT+2)
WORKSPACES NEEDED
.*
NOTE THAT TCNT INCLUDES A DUMMY APLDEV CALL
DC
A(PERDISKG)
DC
F'8'
PERDISK INCREMENT
&MINB
SETA 20+&TCNT*(5+15*&CP67)
OVERBOOK EQU 3
FAIRSHARE IS COMPUTED FROM THIS * ORIG FREE COUN
CONFINIT APLSUPC
VALCON EQU ALEN+&DOS+2*&OS
SOFTPARS CSECT
AIF (&OS).NOTDOS
APLDS ,
DUMMY FINAL APLDS CALL
.NOTDOS ENTRY CCWAR,DIRTAB,KMANHASH,RD1DA,WSLEN
* * * * * * * *ASSUMES 2311 IS DEVICE WITH SHORTEST TRACK * * * * * * *
CCWAR
DS
((&WSLN+3599)/3600*4+2)D
RD1DA
EQU *+2
* * * * * * * * RD1DA+2 MUST BE ON A WORD BOUNDARY * * * * * * * * *
DC
((&WSLN+3599)/3600+1)H'256,0,0,0'
KMANHASH DC
A(&MANHASH)
WSLEN
DC
A(&WSLN)
DIRTAB DS
(2*&MANHASH+1)F
1 WORD OF SLOP NEEDED BY OPLIB
AIF (T'&MAP EQ 'O').NTE1
AIF (&MAP GT 255).NTE2
APLSVC CSECT
ENTRY APLMAP
APLMAP EQU APLSVC+&MAP*X'10000'
ENTRY MPXCH
5991
MPXCH
EQU APLSVC+&MPXCH*X'10000'
5991

08460000
09400000
10340000
11280000
12220000
13160000
14100000
15040000
15980000
16920000
17860000
18800000
19740000
20680000
21620000
22560000
23500000
24440000
25380000
26320000
27260000
28200000
29140000
30080000
31020000
31960000
32900000
33840000
34780000
35720000
36660000
37600000
38540000
39480000
40420000
41360000
42300000
43240000
44180000
45120000
46060000
47000000
47940000
48880000
49820000
50760000
51700000
52640000
53580000
54520000
55460000
56400000
57340000
58280000
59220000
60160000
61100000
62040000
62980000
63920000

DC
F'0' AVOID ZERO LENGTH CSECT
AIF (&OS).OSCODE
MEXIT
.OSCODE ANOP
.*
AIF (T'&FMSK NE 'O' OR T'&QEND NE 'O').NTE4
.CONTIN ANOP
AIF (T'&INIT EQ 'O').NTE1
AIF (&INIT GT 255).NTE2
AIF (&INIT EQ &MAP).NTE3
ENTRY APLINIT
APLINIT EQU APLSVC+&INIT*X'10000'
SPACE 3
MNOTE *,'LIST OF APL LOAD MODULE AND ENTRY POINT NAMES' C056
MNOTE *,'
APL360
APLOS
' C056
MNOTE *,'
APLSINIT
SUPINI
' C056
MNOTE *,'
APLUTIL
MAIN
' C056
SPACE 3
MNOTE *,' LINKAGE EDITOR CONTROL CARDS FOR NUCLEUS LINKEDIT'
MNOTE *,' '
MNOTE *,' CHANGE IGCINIT(IGC&INIT),IGCMAP(IGC&MAP)'
MNOTE *,' INCLUDE RESMODS(APLSMVT1)
FOR MVT, OMIT FOR MFT'
MNOTE *,' INCLUDE RESMODS(APLSMFT1)
FOR MFT, OMIT FOR MVT'
MEXIT
.NTE1
MNOTE 16,'SYMBOLIC PARAMETER(S) UNDEFINED'
MEXIT
.NTE2
MNOTE 16,'SYMBOLIC PARAMETER(S) OUT OF RANGE'
MEXIT
.NTE3
MNOTE 16,'SYMBOLIC PARAMETER(S) NOT UNIQUE'
MEXIT
.NTE4
MNOTE *,' SVCS FMSK AND QEND NOT NEEDED -- IGNORED'
MNOTE *,'* * * * * * * * * * * * * * * * * * * *'
MNOTE *,'* * * YOU MUST RELINKEDIT YOUR NUCLEUS * * *'
MNOTE *,'* * * FOR THIS VERSION OF APL
* * *'
MNOTE *,'* * * * * * * * * * * * * * * * * * * *'
AGO .CONTIN
MEND
./ ADD
NAME=APLSUPC
MACRO
&L
APLSUPC
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
GBLA &CACNT,&MANHASH,&WSLN,&MINB
GBLB &DOS,&OS,&CP67
C058
*
APLSUP, SUPINI, CONFIG COMMUNICATION REGION
AIF ('&L' EQ '').A5
NO LABEL MEANS DSECT IN OTHER ASSMB
AIF ('&L' EQ 'SUPPARD').A1
AIF ('&L' EQ 'CONFINIT').A4
ENTRY &L
&L
DC
0F'0'
AGO .A2
.A5
ANOP
SUPPARD DSECT
APLSUP EQU 0
AVOID UNDEF FLAG
PERCOREL EQU 8
AVOID UNDEF FLAG
AGO .A6
.A4
ANOP
&L
CSECT
AGO .A3

64860000
65800000
66740000
67680000
68620000
69560000
70500000
71440000
72380000
73320000
74260000
75200000
76140000
77080000
78020000
78960000
79900000
80840000
81780000
82720000
83660000
84600000
85540000
86480000
87420000
88360000
89300000
90240000
91180000
92120000
93060000
94000000
94940000
95880000
96820000
97760000
98700000
01330000
02660000
03990000
05320000
06650000
07980000
09310000
10640000
11970000
13300000
14630000
15960000
17290000
18620000
19950000
21280000
22610000
23940000
25270000
26600000
27930000
29260000

.A1
&L
.A6
EXPLIM
.A2
PERTERMG
PERCOREG
TERMCOUN
PERDISKG
PERDISKZ
OVERBOOK
.A3
LSUPC
PTBXLE

ANOP
DSECT
,THIS IS SUPINI
ANOP
EQU 0
AVOID UNDEF FLAG
ANOP
EQU 1
AVOID UNDEF FLAG
EQU 1
AVOID ERROR MESS
EQU 1
AVOID ERROR MESS
EQU 1
AVOID ERROR MESS
EQU 1
AVOID ERROR MESS
EQU 2
NOMINAL VALUE, CONFIG CONTROLS
ANOP
DC
A(VALCON)
FOR VERSION VALIDATION
DC
A(PERTERML)
FOR ITERATION ON PERTERM
DC
A(PERTERMG+PERTERML*(TERMCOUN-1)) LAST PERTERM
DC
A(PERTERMG)
FIRST PERTERM
PDBXLE DC
F'8'
LENGTH OF PERDISK DSECT
MAXARM DC
A(PERDISKZ)
LIMIT OF DISK SWAP SEARCH
ARM
DC
A(PERDISKG)
CURRENT ARM POSITION
DC
A(PERDISKG)
START OF PERDISK
PCBXLE DC
A(PERCOREL)
LENGTH OF PERCORE
DC
A(PERCOREG+(&CACNT-1)*PERCOREL) LAST PERCORE
DC
A(PERCOREG)
FIRST PERCORE
SLOTS
DC
A(&CACNT)
NUMBER OF CORE SLOTS
RRCORE DC
A(PERCOREG)
VARAIBLE USED AS QZA2
TERMMAX DC
A(TERMCOUN)
WLEN
DC
A(&WSLN)
WORKSPACE LENGTH
COPLIM DC
Y(3)
MAX SIMULTANEOUS )LIB OPERATIONS
SYSPARS DC
AL1(B'&DOS.&OS.&CP67.00000',0) SYSTEM PARAMETERS
C058
KMHASH DC
A(&MANHASH)
MANHASH FOR COMPUTING DIRECTORY NUM
KOVERBOK DC
A(OVERBOOK)
ADJUSTED BY SUPINI
REALTIME DC
F'0'
LOW ORDER BIT = 3.33 MILLISECONDS
SVBASE DC
A(MPXSAVE)
BASE REG FOR MPX AND SVC CODE
PTBASE DC
A(0)
PERTERM ADDR OF GUY WE ARE RUNNING
CURRENTM DC
A(0)
WORKSP ADDR OF GUY WE ARE RUNNING
APLBASE DC
A(APLSUP)
NON-STANDALONE R14 SETTING
FREEBA DC
A(0)
HEAD OF FREE BUFFER CHAIN
FREEBC DC
F'0'
COUNT OF FREE BUFFERS
ACTKEY DC
X'40'
KEY FOR ACTIVE WS AND INTRP
INACTKEY DC
X'30'
KEY FOR INACTIVE WS
DC
H'0'
UNUSED
ALEN
EQU *-PTBXLE
LENGTH OF MOVE
AIF ('&SYSECT' EQ 'APLSUP').AZ
*
FOLLOWING VALUES ARE FOR SUPINI & CONFINIT ONLY
AWSLENR DC
A(WSLENR)
2048*CEIL WSLENGTH DIV 2048
KMINBUF DC
F'&MINB'
MINIMUM TYPEWRITER BUFFERS
KEXPLIM DC
A(EXPLIM)
EXPRESS TIME LIMIT
AIF ('&L' EQ 'CONFINIT').AZ
WSLENR EQU 0*2048
CONFIG WILL DEFINE
MINBUF EQU 0
CONFIG WILL DEFINE
MPXSAVE EQU 1
SUPINI DOESN'T NEED TO KNOW
.AZ
MEND
./ ADD
NAME=COIBM
MACRO
COIBM &ID
.*
THIS IS A DEVELOPMENT MACRO. THE MACRO IS REPLACED BY A
.*
CURRENT COPYRIGHT STATEMENT BY THE SPLIT-UP PROGRAM
AIF ('&ID' NE '5734').A
* 5734-XM6 IBM CONFIDENTIAL
AGO .B

30590000
31920000
33250000
34580000
35910000
37240000
38570000
39900000
41230000
42560000
43890000
45220000
46550000
47880000
49210000
50540000
51870000
53200000
54530000
55860000
57190000
58520000
59850000
61180000
62510000
63840000
65170000
66500000
67830000
69160000
70490000
71820000
73150000
74480000
75810000
77140000
78470000
79800000
81130000
82460000
83790000
85120000
86450000
87780000
89110000
90440000
91770000
93100000
94430000
95760000
97090000
98420000
08330000
16660000
24990000
33320000
41650000
49980000
58310000

.A
AIF ('&ID' NE '5736').B
* 5736-XM6 IBM CONFIDENTIAL
.B
ANOP
MEND
./ ADD
NAME=APLDEFN
TITLE 'A P L D E F N -- G L O B A L D E F I N I T I O N S'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
UVR
EQU 0
MFMT
EQU 0
MR
EQU 11
BASE REGISTER FOR M-ARRAY
PR
EQU 12
BASE REGISTER FOR PROGRAM
LR
EQU 13
BASE REGISTER FOR LOCAL VARIABLES
TLR
EQU 14
TOP OF SPACE NEEDED FOR LOCAL VARBS
LKR
EQU 15
LINK REGISTER
STLENGTH EQU 2048
LENGTH OF SYMBOL TABLE
USING M,MR
MEMORY DSECT
M
DS
0X
REGSV
DS
16F
SUPERVISOR REGISTER SAVE AREA
FRSAVE DS
5D
FLOATING REGISTERS AND SVC OLD PSW
VVMM
DS
F
VERSION, MOD. LVL (ONLY IN DIR) C059
NUMDIRS DS
F
NO. OF DIRECTORIES (ONLY IN DIR)C059
DS
4F
UNUSED
C059
LR13STK EQU 1000
LENGTH OF R13 STACK
QR13STK DC
A(36000-LR13STK)
BOTTOM OF R13 STACK
QSYMBOT DC
A(36000-LR13STK-STLENGTH) BOTTOM OF SYMBOL TABLE
MX
DC
A(0)
FIRST FREE STORAGE LOCATION POINTER
SVI
DC
A(0)
'TOP' OF STACK POINTER
PARREL DC
A(0)
OFFSET TO TOP ENTRY IN EXEC STACK
ONADRS EQU *-64
ONXOF
DC
2A(0)
FIXED OVERFLOW ERROR ADDRESS
ONXDZ
DC
2A(0)
FIXED ZERO-DIVIDE ERROR ADDRESS
DS
4A
DECIMAL OVERFLOW, DIVIDE
ONFP
DC
2A(0)
FLOATING OVERFLOW ERROR ADDRESS
*
FOLLOWING OVERLAP UNUSED FP CHECKS
CARRPOS DC
F'0'
CURRENT CARRIER POSITION
3587
DS
A
UNSED
3587
ONATTN DC
2A(0)
CPULIM OR DOUBLE ATTENTION SIGNAL
ONDZ
DC
2A(0)
ZERO-DIVIDE ERROR ADDRESS
ONRNG
DC
2A(0)
RANGE ERROR ADDRESS
MQCELL BCR 0,0
SVC YYQZ WHEN QUANTUM END NEEDED
DS
1H
UNUSED
MPTBASE DS
A (PERTERM)
PERTERM BASE REGISTER
*
FILE LABEL FOR SAVED WORKSPACE
WFLLIB DS
F
LIBRARY NUMBER
WFLNAME DS
CL12
WORKSPACE NAME
WFLMAN DS
F
MAN NUMBER OF SAVER
WFLPASS DC
XL8'00'
)LOAD )COPY PASSWORD
WFLDATE DS
CL8
DATE SAVED
WFLTIME DS
F
TIME SAVED
LWFLAB EQU *-WFLLIB
LENGTH OF WS LABEL
*
END OF WORKSPACE LABEL
DS
2F
UNUSED
BAKTOG DS
FL1
FLAG -- WE SWALLOWED SOME SYMBOLS IN
*
THIS DIAGRAM, AND CAN'T GET OUT
*
WITHOUT VIOLATING THE NO-BACKUP RULE
*
BIT 0 ( A GLITCH) -- CONTROL IS NOW
*
IN TYPEIN, NOT SYNT. (USED BY ERR)

66640000
74970000
83300000
91630000
00420000
00840000
01260000
01680000
02100000
02520000
02940000
03360000
03780000
04200000
04620000
05040000
05460000
05880000
06300000
06720000
07140000
07560000
07980000
08400000
08820000
09240000
09660000
10080000
10500000
10920000
11340000
11760000
12180000
12600000
13020000
13440000
13860000
14280000
14700000
15120000
15540000
15960000
16380000
16800000
17220000
17640000
18060000
18480000
18900000
19320000
19740000
20160000
20580000
21000000
21420000
21840000
22260000
22680000
23100000

NEXTOG
*
CLASS
PATH
MING
MINGL
DIASTPTR
RFUZZ
AFUZZ
IORIGIN
RNUMBER
UNFUZZ
SPTR
SYL
*
RUNCTL
RCTRABIT
RCQEBIT
RCOUTBIT
RCFNBIT
MFLKBIT
RCOLBIT
OSIGDIG
LLLO
LGCPTR
*
DIAST
DFDTS
DIDTS
OBUFLIM
OBUFPTR
OBUF
FREE
*
*
MANSTAR
DSNXTF
SALVHED
*
FREEDSK
FIRSTENT
*
*
STFREG
*
STCODE
STTRACE
STNXTOG
STCPTR
STFLAGS
STLINE
STFNSPTR
STLINK
STSHADOW

DS

FL1

FLAG -- SYNTAX ANALYZER NEEDS NEXT

SYMBOL FROM CODESTRING
CLASS OF CURRENT SYMBOL
SAVED ADDRESS OF CURRENT DIAG PATH
ADDRESS OF LOWEST GARBAGE IN M
NUMBER OF BYTES OF GARBAGE IN M
POINTER FOR DIAGRAM STACK

23520000
23940000
DC
H'0'
24360000
DS
F
24780000
DC
A(FREE-M)
25200000
DC
F'0'
25620000
DC
F'0'
26040000
DS
0D
26460000
DC
X'00000000000003FF'
26880000
DC
D'1E-13'
27300000
DC
F'1'
INDEX ORIGIN
27720000
DC
F'16807'
RANDOM NUMBER.
28140000
DC
D'.9999999999999'
28560000
DS
F
SYMBOL TABLE POINTER OF CURRENT SYM 28980000
DS
H
CURRENT CODE SYLLABLE (LEFT BYTE
29400000
GARBAGE IF 8-BIT SYLLABLE)
29820000
DS
FL1
END-OF-STATEMENT CONTROL FLAGS
30240000
EQU X'80'
THIS STATEMENT IS A BRANCH
30660000
EQU X'40'
FORCE EXIT FROM QUAD-PRIME LOOP
31080000
EQU X'20'
EXIT TO NEAREST IMM-EX LEVEL
31500000
EQU X'10'
THIS STATEMENT IS IN A FUNCTION
31920000
EQU X'20'
PROTECTED FUNCTION BIT IN M-ENTRY
32340000
EQU X'08'
WE'RE GETTING OUT OF LOCKED FNS
32760000
DS
FL1
UNUSED
33180000
DS
F
UNUSED
33600000
DC
F'10'
SIGNIFICANT DIGITS IN FLOATING OUT 34020000
DS
H
LENGTH OF LAST LINE OUT
34440000
DS
H
VALUE OF OBUFPTR BEFORE LAST CALL OF 34860000
LOUT (FOR QUAD-PRIME I/O)
35280000
DS
500FL1
THE DIAGRAM STACK
35700000
EQU DIAST
DIR 0 -- TIMESTAMP, LAST FULL DUMP 36120000
EQU DIAST+12
DIR 0 -- TIMESTAMP, LAST INC DUMP
36540000
DS
0F
MAKE OBUF START ON A WORD BDY
36960000
DC
H'120'
37380000
DC
H'0'
37800000
DS
CL130
38220000
DS
0F
38640000
EQU *
BASE OF FREE STORAGE IN M
39060000
M-LOCATIONS FOR DIRECTORY SEARCH ONLY
39480000
PARAMETERS FOR MONOLITHIC FREE STORAGE ON PACK
39900000
EQU SVI
40320000
EQU MX
40740000
DS
60A
LIST OF SCATTERED BLOCKS ON LIB PACK.
41160000
FORMAT IS CCHH
DASD 41580000
DS
20F
CFREDSK SETTINGS FOR 20 PACKS
42000000
EQU *
42420000
RELATIVE POSITIONS OF VARIOUS BITS OF FUNCTION-CALL
42840000
INFORMATION IN STACK. VALUE EQUALS OFFSET FROM PARREL. 43260000
EQU 0
POINTER TO PREVIOUS STACK ENTRY
43680000
BYTE 0 = 0
44100000
EQU 4
BASE ADDRESS OF CODESTRING
44520000
EQU 4
BYTE HOLDING TRACE AND STOP BITS
44940000
EQU 9
SAVED COPY OF NEXTOG FOR OUTER FN
45360000
EQU 10
SYLLABLE POSITION WITHIN CODESTRING 45780000
EQU 13
VARIOUS FLAGS RELATING TO THIS STMT 46200000
EQU 14
ACTIVE LINE NUMBER IN THIS FUNCTION 46620000
EQU 16
BST ENTRY POINTER OF FUNCTION NAME 47040000
EQU 20
CURRENTLY UNUSED
47460000
EQU 20
POINTER TO BST ENTRY OF NAME SHADOWED47880000
BY PARAMETER 0 (NONEXISTENT)
48300000

*
STPARAM
STPSBIT
STTRBIT
*
STIMBIT
STSTBIT
STQBIT
STQPBIT
STREMBIT
*
*
*
MLIST
MGARB
MHEAD
*
MCOUNT
*
MLSOS
MLSCT
MFLINES
MFLCLS
MLSORG
MFPARS
MFCODE
*

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

ORG
DS
DS
DS
DS
DS
DS
EQU
DS
EQU
DS
DS
ORG

*
MTYPE
MRANK
MRHO
*
MCSCNT
MCSORG
*
MPNAME
*
MLSTBIT
MGBIT
*
*
SHADOW
*
CDST
CONST
VARB
QUAD
LBR
LPAR
RBR
RPAR
SEMIC
EOS
PER
LARROW

DS
DS
DS
DS
ORG
DS
DS
ORG
DS
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

BYTE 0 = SHADOW
SAVED BST ENTRY OF SHADOWED NAME
PROGRAMMED STOP BIT IN STCODE WORD
TRACE BIT IN STCODE WORD
BITS IN STFLAG BYTE
X'01'
IMMEDIATE-EXECUTION BIT
X'02'
COMPLETE-STATEMENT-SEEN BIT
X'04'
CURRENTLY ACQUIRING INPUT FOR QUAD
X'08'
CURRENTLY ACQUIRING INPUT FOR QUAD'
X'10'
COMMENT LINE (USED ONLY BY TYPEIN)
RELATIVE POSITIONS OF INFORMATION IN M-ENTRIES
ADDRESSES ARE PRESUMABLY USED WITH M-POINTER INDEX MODIFICATION.
M
0B
BYTE CONTAINING LIST BIT
0B
BYTE CONTAINING GARBAGE BIT
A
BACK-POINTER FROM M-ENTRY -- FIRST
WORD OF M-ENTRY.
F
FULLWORD BYTE COUNT OF THIS M-ENTRY
LISTS AND FUNCTIONS
H
OFFSET OF 1ST LIST POINTER (LINE 0)
H
COUNT OF LIST POINTERS IN LIST ENTRY
MLSCT
NUMBER OF LINES IN FUNCTION (HALFWD)
H
NO. OF LOCALS IN FUNCTION
M+12
FIRST LIST POINTER IN LIST M-ENTRY
H
NO. OF PARAMETERS TO FN (HALFWORD)
A
IN FUNCTION DIRECTORY, ADDRESS OF
CODESTRING FOR LINE 0.
MCOUNT+4
VARIABLES AND OTHER DATA ENTRIES
FL1
DATA TYPE (= 1,2,3,4)
FL1
UNUSED
H
4 * RANK
F
FIRST WORD OF DATA ENTRY RANK VECTOR
MCOUNT+4
CODESTRINGS
H
SYLLABLE BYTE COUNT
X
FIRST CODESTRING SYLLABLE
MCOUNT+4
PRINTNAMES
C
FIRST CHARACTER OF LONG PRINT NAME
FOLLOWING BITS ARE IN MLIST (= MGARB (= MHEAD))
X'40'
LIST BIT IN M-ENTRY
X'80'
GARBAGE BIT IN M-ENTRY
24
X'40'
X'20'

CLASSES OF TERMINAL SYMBOLS

1
SHADOWED NONLOCAL IN STACK (NOT
REALLY A TERMINAL)
3
CODESTRING (NOT REALLY A TERMINAL)
4
CONSTANT OR TEMP
5
VARIABLE
VARB
QUAD
6
LEFT BRACKET
7
LEFT PARENTHESIS
8
RIGHT BRACKET
9
RIGHT PARENTHESIS
10
SEMICOLON
11
END OF STATEMENT
12
PERIOD OF MATRIX PRODUCT
13
LEFT ARROW

48720000
49140000
49560000
49980000
50400000
50820000
51240000
51660000
52080000
52500000
52920000
53340000
53760000
54180000
54600000
55020000
55440000
55860000
56280000
56700000
57120000
57540000
57960000
58380000
58800000
59220000
59640000
60060000
60480000
60900000
61320000
61740000
62160000
62580000
63000000
63420000
63840000
64260000
64680000
65100000
65520000
65940000
66360000
66780000
67200000
67620000
68040000
68460000
68880000
69300000
69720000
70140000
70560000
70980000
71400000
71820000
72240000
72660000
73080000
73500000

RARROW
SLSH
OP
NULL
DFN
DFN0
DFNT
GROUP
TERMSYM
*
*
*
CVBTOI
CVBTOF
CVITOB
CVITOF
CVFTOB
CVFTOI
*
*
ESYSTEM
EMFULL
ESYNTAX
EINDEX
ERANK
ELENGTH
EVALUE
ERANGE
EDEPTH
EINT
ENONCE
*
*
*
YYTYO
YYTYI
YYEOS
YYQZ
YYLEMP
YYTRAN
*
YYSDR
YYATOFF
YYRAPE
YYOFF
YYBROAD
YYSOOK
YYLIBZ
YYHI
YYREC
*
YYDEL
YYBOUN
YYRSET
YYTIME
YYOFFH
YYBREL
YYEOD
YYLOG
*

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

14
15
16
17
18
19
20
21
22

RIGHT ARROW
SLASH, BACKSLASH
OPERATOR
NULL OF MATRIX PRODUCT
DEFINED FUNCTION WITH PARAMETERS
DEFINED FUNCTION, NO PARAMETERS
DEFINED FUNCTION TRACE SYMBOL
GROUP NAME
INCREASE TERMSYM IF NEW CLASSES ARE
ENTERED.

73920000
74340000
74760000
75180000
75600000
76020000
76440000
76860000
77280000
77700000
78120000
TYPE CONVERSION CODES FOR FETCH
78540000
5
78960000
6
79380000
7
79800000
8
80220000
9
80640000
10
81060000
81480000
ERROR TYPES
81900000
0
82320000
1
82740000
2
83160000
3
83580000
4
84000000
5
84420000
6
84840000
11
85260000
12
85680000
13
86100000
16
86520000
86940000
APL SUPERVISOR CALL CODES
87360000
0
RESERVED
87780000
1
OUTPUT TO TERMINAL
88200000
2
INPUT FROM TERMINAL
88620000
3
END OF DIRECTORY SEARCH
89040000
4
QUANTUM END
89460000
5
LOAD EMPTY WORKSPACE
89880000
6
TRANSMIT MESSAGE TO ANOTHER PORT
90300000
7
RESERVED
90720000
8
REQUEST SPECIAL DISK OPERATION
91140000
9
TURN OFF ATTENTION BIT
91560000
10
REQUEST ANOMALOUS PROTECT EXCEPTION 91980000
11
SIGN-OFF DISCONNECT PHONE CONNECTION 92400000
12
BROADCAST PA MESSAGE
92820000
13
SIGN ON OKAY
93240000
14
END OF )LIB COMMAND
93660000
15
SETUP )HI MESSAGE
94080000
16
RECEIVE MESSAGES
94500000
17
RESERVED
94920000
18
DELAY FOR TIME INTERVAL
95340000
19
BOUNCE USER OFF SYSTEM
95760000
20
RESET 2702 LINE
96180000
21
TIME OF DAY (CP/67 ONLY)
96600000
22
SIGN OFF HOLD PHONE CONNECTION
97020000
23
INPUT BUFFER RELEASE
97440000
24
INITIATE SHUTDOWN OF APL
97860000
25
TRANSMIT MESSAGE TO RECORDING TERM 98280000
98700000

EXTRN APLMAP
BASE OF SVC-DEFINING CSECT
EXTRN APLSVC
ALL SVC'S = APLMAP-APLSVC
./ ADD
NAME=APLSUPC
MACRO
&L
APLSUPC
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
GBLA &CACNT,&MANHASH,&WSLN,&MINB
GBLB &DOS,&OS,&CP67
C058
*
APLSUP, SUPINI, CONFIG COMMUNICATION REGION
AIF ('&L' EQ '').A5
NO LABEL MEANS DSECT IN OTHER ASSMB
AIF ('&L' EQ 'SUPPARD').A1
AIF ('&L' EQ 'CONFINIT').A4
ENTRY &L
&L
DC
0F'0'
AGO .A2
.A5
ANOP
SUPPARD DSECT
APLSUP EQU 0
AVOID UNDEF FLAG
PERCOREL EQU 8
AVOID UNDEF FLAG
AGO .A6
.A4
ANOP
&L
CSECT
AGO .A3
.A1
ANOP
&L
DSECT
,THIS IS SUPINI
.A6
ANOP
EXPLIM EQU 0
AVOID UNDEF FLAG
.A2
ANOP
PERTERMG EQU 1
AVOID UNDEF FLAG
PERCOREG EQU 1
AVOID ERROR MESS
TERMCOUN EQU 1
AVOID ERROR MESS
PERDISKG EQU 1
AVOID ERROR MESS
PERDISKZ EQU 1
AVOID ERROR MESS
OVERBOOK EQU 2
NOMINAL VALUE, CONFIG CONTROLS
.A3
ANOP
LSUPC
DC
A(VALCON)
FOR VERSION VALIDATION
PTBXLE DC
A(PERTERML)
FOR ITERATION ON PERTERM
DC
A(PERTERMG+PERTERML*(TERMCOUN-1)) LAST PERTERM
DC
A(PERTERMG)
FIRST PERTERM
PDBXLE DC
F'8'
LENGTH OF PERDISK DSECT
MAXARM DC
A(PERDISKZ)
LIMIT OF DISK SWAP SEARCH
ARM
DC
A(PERDISKG)
CURRENT ARM POSITION
DC
A(PERDISKG)
START OF PERDISK
PCBXLE DC
A(PERCOREL)
LENGTH OF PERCORE
DC
A(PERCOREG+(&CACNT-1)*PERCOREL) LAST PERCORE
DC
A(PERCOREG)
FIRST PERCORE
SLOTS
DC
A(&CACNT)
NUMBER OF CORE SLOTS
RRCORE DC
A(PERCOREG)
VARAIBLE USED AS QZA2
TERMMAX DC
A(TERMCOUN)
WLEN
DC
A(&WSLN)
WORKSPACE LENGTH
COPLIM DC
Y(3)
MAX SIMULTANEOUS )LIB OPERATIONS
SYSPARS DC
AL1(B'&DOS.&OS.&CP67.00000',0) SYSTEM PARAMETERS
C058
KMHASH DC
A(&MANHASH)
MANHASH FOR COMPUTING DIRECTORY NUM
KOVERBOK DC
A(OVERBOOK)
ADJUSTED BY SUPINI
REALTIME DC
F'0'
LOW ORDER BIT = 3.33 MILLISECONDS
SVBASE DC
A(MPXSAVE)
BASE REG FOR MPX AND SVC CODE
PTBASE DC
A(0)
PERTERM ADDR OF GUY WE ARE RUNNING
CURRENTM DC
A(0)
WORKSP ADDR OF GUY WE ARE RUNNING

99120000
99540000
01330000
02660000
03990000
05320000
06650000
07980000
09310000
10640000
11970000
13300000
14630000
15960000
17290000
18620000
19950000
21280000
22610000
23940000
25270000
26600000
27930000
29260000
30590000
31920000
33250000
34580000
35910000
37240000
38570000
39900000
41230000
42560000
43890000
45220000
46550000
47880000
49210000
50540000
51870000
53200000
54530000
55860000
57190000
58520000
59850000
61180000
62510000
63840000
65170000
66500000
67830000
69160000
70490000
71820000
73150000
74480000
75810000

APLBASE
FREEBA
FREEBC
ACTKEY
INACTKEY

DC
A(APLSUP)
NON-STANDALONE R14 SETTING
DC
A(0)
HEAD OF FREE BUFFER CHAIN
DC
F'0'
COUNT OF FREE BUFFERS
DC
X'40'
KEY FOR ACTIVE WS AND INTRP
DC
X'30'
KEY FOR INACTIVE WS
DC
H'0'
UNUSED
ALEN
EQU *-PTBXLE
LENGTH OF MOVE
AIF ('&SYSECT' EQ 'APLSUP').AZ
*
FOLLOWING VALUES ARE FOR SUPINI & CONFINIT ONLY
AWSLENR DC
A(WSLENR)
2048*CEIL WSLENGTH DIV 2048
KMINBUF DC
F'&MINB'
MINIMUM TYPEWRITER BUFFERS
KEXPLIM DC
A(EXPLIM)
EXPRESS TIME LIMIT
AIF ('&L' EQ 'CONFINIT').AZ
WSLENR EQU 0*2048
CONFIG WILL DEFINE
MINBUF EQU 0
CONFIG WILL DEFINE
MPXSAVE EQU 1
SUPINI DOESN'T NEED TO KNOW
.AZ
MEND
./ ADD
NAME=ATT
MACRO
&L
ATT &ON=,&OFF=,&RESET=YES,&MPTBASE=,&PAON=,&PAOFF=
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
.*
APL TERMINAL ATTENTION SIGNAL TEST AND RESET MACRO
LCLC &R,&LBL
&R
SETC '&MPTBASE'
&LBL
SETC '&L'
AIF (T'&MPTBASE NE 'O').ATT3
AIF (T'&ON NE 'O' OR T'&OFF NE 'O').ATT13
AIF (T'&PAON EQ 'O' AND T'&PAOFF EQ 'O').ATT3
.ATT13 ANOP
&L
L
1,MPTBASE
&R
SETC '(1)'
&LBL
SETC ' '
.ATT3
AIF (T'&PAOFF EQ 'O' AND T'&PAON EQ 'O').ATT7
&LBL
TM
IOB1-PERTERM(&R),BROADM
&LBL
SETC ' '
AIF (T'&PAON EQ 'O').ATT6
BO
&PAON
.ATT6
AIF (T'&PAOFF EQ 'O').ATT7
BZ
&PAOFF
AIF (T'&PAON NE 'O').ATT10
.ATT7
AIF (T'&OFF EQ 'O' AND T'&ON EQ 'O').ATT8
&LBL
TM
ACTIVE-PERTERM(&R),ATTENM
&LBL
SETC ' '
AIF (T'&OFF EQ 'O').ATT11
BZ
&OFF
AGO .ATT8
.ATT11 AIF ('&RESET' EQ 'YES').ATT12
BO
&ON
MEXIT
.ATT12 BZ
ATTX&SYSNDX
.ATT8
AIF ('&RESET' NE 'YES').ATT9
&LBL
SVCC YYATOFF
.ATT9
AIF (T'&ON EQ 'O').ATT10
B
&ON
.ATT10 ANOP
ATTX&SYSNDX
EQU *
MEND
./ ADD
NAME=CANCEL

77140000
78470000
79800000
81130000
82460000
83790000
85120000
86450000
87780000
89110000
90440000
91770000
93100000
94430000
95760000
97090000
98420000

C049
C049
C049
C049

02380000
04760000
07140000
09520000
11900000
14280000
16660000
19040000
21420000
23800000
26180000
28560000
30940000
33320000
35700000
38080000
40460000
42840000
45220000
47600000
49980000
52360000
54740000
57120000
59500000
61880000
64260000
66640000
69020000
71400000
73780000
76160000
78540000
80920000
83300000
85680000
88060000
90440000
92820000
95200000
97580000

14280000
28560000
5734-XM6 COPYRIGHT IBM CORP. 1969,1970
42840000
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
57120000
ABEND 1500,DUMP
C060 71400000
MEND
85680000
./ ADD
NAME=CCB
MACRO
01560000
&CCBN CCB &SYSXXX,&CCWADD,&OPTIONS,&SENSE
03120000
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
04680000
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
06240000
LCLA &CLASS,&NUM
07800000
LCLB &SNS
09360000
LCLB &DUMMY
C049 10920000
LCLC &UNIT,&CCWAD,&OPTSW,&T
12480000
&T SETC 'L'''
14040000
.* IBM SYSTEM/360 DISK OPERATING SYSTEM
15600000
* 360N-CL-453 CCB
CHANGE LEVEL 3-0
17160000
AIF (T'&CCBN NE 'O').NAMOK
18720000
MNOTE 0,'POSSIBLE ERROR - NAME FIELD BLANK'
20280000
.NAMOK AIF (K'&SYSXXX NE 6).ERR
21840000
AIF ('&SYSXXX'(1,3) NE 'SYS').ERR
23400000
&UNIT SETC '&SYSXXX'(4,3)
24960000
AIF ('&UNIT' LT '000' OR '&UNIT' GT '243').LTRS
26520000
AIF ('&UNIT'(2,1) LT '0' OR '&UNIT'(2,1) GT '9').ERR
28080000
AIF ('&UNIT'(3,1) LT '0' OR '&UNIT'(3,1) GT '9').ERR
29640000
&CLASS SETA 1
PROBLEM PROGRAM UNIT CLASS
31200000
&NUM SETA &UNIT
NUMBER IN CLASS
32760000
AGO .FND
GO CHECK CCWADD ENTRY
34320000
.LTRS AIF ('&UNIT' EQ 'RDRIPTPCHLSTLOGLNKRESSLBRLB'(3*&NUM+1,3)).FND 35880000
&NUM SETA &NUM+1
37440000
AIF (&NUM LE 8).LTRS
39000000
.ERR MNOTE 3,'FIRST OPERAND INVALID - ''FFFF'' GENERATED'
40560000
&CLASS SETA 255
42120000
&NUM SETA 255
SET INVALID VALUE
43680000
.FND ANOP
45240000
&CCWAD SETC '0'
46800000
AIF (T'&CCWADD EQ 'O').CCDER
48360000
&CCWAD SETC '&CCWADD'
49920000
&DUMMY SETB (T'&CCWADD EQ 'W' OR T'&CCWADD EQ 'N' OR
X51480000
T'&CCWADD EQ 'U') TYPE MAY BE CCW, SELF-DEF OR UNDEFC049 53040000
AIF (&DUMMY).CKOPT
C049 54600000
.CCDER MNOTE 0,'POSSIBLE ERROR IN SECOND OPERAND'
56160000
.CKOPT ANOP
57720000
&OPTSW SETC '0'
59280000
AIF (T'&OPTIONS EQ 'O').ASMBL
60840000
AIF (K'&OPTIONS LT 4 OR K'&OPTIONS GT 7).OPTER
62400000
AIF ('&OPTIONS'(1,2) NE 'X''' OR '&OPTIONS'(K'&OPTIONS,1) NE 'X63960000
''').OPTER
65520000
&OPTSW SETC '&OPTIONS'(3,K'&OPTIONS-3)
67080000
AGO .ASMBL
68640000
.OPTER MNOTE 3,'THIRD OPERAND INVALID - X''0000'' ASSUMED'
70200000
.ASMBL ANOP ,
ALL OPERAND OK - ASSEMBLE
71760000
&SNS SETB (T'&SENSE NE 'O')
73320000
AIF (NOT &SNS).R2
74880000
DS
0D
76440000
.R2 ANOP
78000000
&CCBN DC
XL2'0'
RESIDUAL COUNT
79560000
DC
XL2'&OPTSW'
COMMUNICATIONS BYTES
81120000
DC
XL2'0'
CSW STATUS BYTES
82680000
&L
.*
.*
&L

MACRO
CANCEL

DC
DC
DC
DC

AL1(&CLASS)
LOGICAL UNIT CLASS
AL1(&NUM)
LOGICAL UNIT
XL1'0'
AL3(&CCWAD)
CCW ADDRESS
DC
B'00&SNS.00000'
STATUS BYTE
DC
AL3(0)
CSW CCW ADDRESS
AIF (NOT &SNS).R1
CCW 4,&SENSE,0,&T&SENSE
.R1 ANOP
MEND
./ ADD
NAME=CDCPARS
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
CDCPARS DSECT
PARAMETERS FOR CDCOMP, TRCOMP, DSKFMT
PHYSAD DS
XL2
UNIT ADDRESS FOR SIO
*
= X'170' FOR 2314 MAYBE
LOGAD
DS
XL2
SYMBOLIC ADDRESS FOR CCB
*
= X'104' FOR SYS004
TLENF
DS
A (TRACK LENGTH)
HMIN
DS
H
ZERO EXCEPT WHEN SPLIT CYL
HMAX
DS
H NUMBER OF HEADS/CYLINDER, (EXTUP+2)+1=SPLIT CYL DASD
EXTLOW DS
F
CCHH LOWER EXTENT
EXTUP
DS
F
CCHH UPPER EXTENT
CCADJ
DS
F
(2*16)+HMIN-HMAX
CDCFLAGS DS
X
5989
RPS
EQU X'80'
DASD
CDCSWAP EQU X'40'
THIS IS A SWAP FILE IF ON
5989
CDCNDC EQU X'20'
DO NOT DATA CHAIN IF ON
5989
DS
X
UNUSED
5989
TPERWS DS
H
TRACKS PER WORKSPACE
5989
CFREDSK DS
F
CCHH FIRST FREE TRACK
DSLAB
DS
44C
USED BY NOPEN IN VTOC SEARCH
CDCL
EQU *-CDCPARS
*
WARNING.. THE APLDS MACRO MAKES ASSUMPTIONS ABOUT THIS DSECT
./ ADD
NAME=CDINF
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*
INFORMATION ABOUT CURRENT DISK OPERATION
CDDISK DS
A (PERDISK)
CDTERM DS
A (PERTERM)
CDCORE DS
A (PERCORE)
DC
X'00'
HIGH ORDER BYTE OF CDOP HALFWORD
CDOP
DC
X'00'
OPERATION
ONETRK DC
X'80'
ONE-TRACK WORKSPACE FLAG. 0 IF TRUE
NOT1TRK EQU X'80'
NOT ONE TRACK WS
5989
INCORMV EQU X'40'
INCORE MOVE IS REQUIRED
5989
CCPASS DC
X'00'
EXPCSW DC
F'0'
DISK INTERRUPT, EXPECTED CSW
DC
X'0C000000'
ARLIM
DC
A(*-*)
END OF AREA
5989
R4
DC
A(*-*)
SOURCE OR SINK FOR MVC AT RELOC
5989
DC
A(*-*)
SINK OR SOURCE FOR MVC AT RELOC
5989
R5
DC
A(*-*)
SAVES START OF AREA2 IN CDCOMP SETUP 5989
COUNT
DC
H'256'
LENGTH FOR MVC INSTRUCTION
5989
MVCLNGTH DC
H'0'
TOTAL LENGTH OF MOVE
5989
NPCICL EQU X'3F'
*
CCW FLAG BIT ASSIGNMENTS
DC
EQU X'80'

84240000
85800000
87360000
88920000
90480000
92040000
93600000
95160000
96720000
98280000
04000000
08000000
12000000
16000000
20000000
24000000
28000000
32000000
36000000
40000000
44000000
48000000
52000000
56000000
60000000
64000000
68000000
72000000
76000000
80000000
84000000
88000000
92000000
96000000
01250000
02500000
03750000
05000000
06250000
07500000
08750000
10000000
11250000
12500000
13750000
15000000
16250000
17500000
18750000
20000000
21250000
22500000
23750000
25000000
26250000
27500000
28750000
30000000

CC
PCI
SKIP
SLI
TIC
SENSE
SEEK
RDATA
SETSECTR
NOP
ENABLE
DISABLE
*
TLENC

EQU X'40'
EQU X'08'
EQU X'10'
EQU X'20'
EQU X'08'
EQU X'04'
EQU X'07'
IDSK COMMAND
EQU 6
READ DATA COMMAND
5989
EQU X'23'
SET SECTOR COMMAND FOR RPS
DASD
EQU 3
NO OP COMMAND
DASD
EQU X'27'
EQU X'2F'
PARAMETERS FOR 2311 CCW CREATION
DC
Y(CC*256)
HALF OF CCW
DC
Y(TRMAX)
MUST FOLLOW TLENC
DS
0D
*
CCPAR1 IS SUBJECT OF LM * * * * *
CCPAR1 DC
A(0)
ADDRESS OF CORE WORKSPACE
CCWAD
DC
A(CCWAR)
*
CCW CHAIN TO READ FIRST TRACK OF WORKSPACE
RD1ST
CCW SEEK,RD1DA,CC,6
RPSCCW CCW SETSECTR,ZERO,CC,1 WILL BE A NO-OP IF RPS NOT USED DASD
.NORPS2 ANOP
SIGH...
DASD
CCW X'31',RD1DA+2,CC,5
CCW TIC,*-8,0,1
CDCAD
CCW X'06',*-*,DC,SELARGL READ SIZE ARGUMENTS
CCW 0,00,CC+PCI,TRMAX-SELARGL
READ REMAINDER
RD1A
CCW 0,0,X'20',1
RD1A MAY BE EXECUTED AS..
*
CCW TIC,CCWAR+32
NORMAL WS READ
*
CCW 0,GARBAGE,X'20',1 IO TIMING PROBLEM, RECOVERABLE
*
CCW 3,RANDOM,X'20',1
1-TRK READ
CCSKD
DC
X'2A000002'
*
CCSKD IS ADDED TO A SEEK CCW TO GENERATE A SEARCH ID EQ CCW
*
WITH THE PROPER ADDRESS
SELARGL EQU SVI+12-M
INITIAL SEGMENT OF RECORD 1
SELARGDC DC
AL1(DC,0,0,SELARGL) DATA CHAIN AND COUNT FOR CDCAD 5989
NDCCSW DC
A(CDCAD+8)
THE ADDRESS IF NOT DATA CHAINED 5989
DC
X'0C00'
CHANNEL END, DEVICE END
5989
DC
H'0'
NO RESIDUAL COUNT
5989
SELBUSY DC
X'00'
0 WHEN SELECTOR CHANNEL IS IDLE
SELFERR DC
X'00'
1 MEANS CDCOMP FORCED ERROR
*
PHYCYL MUST BE ON A WORD BOUNDARY
DASD
DC
XL2'0'
BB FOR PHYCYL
DASD
PHYCYL DC
XL4'0'
CCHH OF FIRST TRACK
DASD
DC
X'01'
R FOR PHYCYL
CCFIRST DC
X'80'
FIRST WRITE PASS SWITCH
DASD
.NORPS4 ANOP
DASD
USING CDCPARS,4
DASD
CC10
CLI HMAX+1,0
EXECUTED
DASD
DROP 4
DASD
DOP
DS
CL2
DASD
TRMAX
EQU 7200
BYTES PER DISK RECORD (=TRACK)
*
END OF CDINF COPY CODE * * * * *
DASD
./ ADD
NAME=DIRSECT
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*
SPECIAL DISK OPERATION CODES
*
***** EVERYONE MAKES ASSUMPTIONS ON ORDERING *****
XXDROP EQU 0

31250000
32500000
33750000
35000000
36250000
37500000
38750000
40000000
41250000
42500000
43750000
45000000
46250000
47500000
48750000
50000000
51250000
52500000
53750000
55000000
56250000
58750000
60000000
61250000
62500000
63750000
65000000
66250000
67500000
68750000
70000000
71250000
72500000
73750000
75000000
76250000
77500000
78750000
80000000
81250000
82500000
83750000
85000000
86250000
87500000
90000000
91250000
92500000
93750000
95000000
96250000
97500000
98750000
01920000
03840000
05760000
07680000
09600000
11520000

XXSAVE
XXLOAD
XXCOPY
XXADD
XXLIB
XXLEMP
XXOFF
XXDEL
XXLOCK
XXUNLK
XXPASS
PERLIB
LIBNUM
LIBLINK
MANWSQ
MANWSA
CUMCON
CUMCOM
HISNAME
SOPASS
SRALIM
PLMISC
*
LIBAUTOL
LIBLOCK

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
DSECT
DS
DS
DS
DS
DS
DS
DS
DS
DS
DS

2
4
6
8
10
12
14
16
18
20
22

1F
LIB RARY NUMBER
F
POINTS TO PERSAVW ENTRY FOR WS
H
QUOTA FOR )SAVE
H
ACTUAL NUMBER OF SAVED WORKSPACES
1F
CUMULATIVE CONNECTION TIME
1F
CUMULATIVE COMPUTE TIME
CL12
REPLY TO SIGN ON MESSAGE
XL8 '00'
SIGN ON PASS WORD
H 'INFINITY'
CPU EXECUTION TIME LIMIT
H
GARBAGE LIKE AUTO-LOAD FLAG
FLAGS FOR PLMISC
EQU X'80'
AUTOLOAD FLAG
EQU X'40'
LOCKED-OUT FLAG
DS
2F
RESERVED FOR FUTURE ACCOUNTING
MANENTL EQU *-PERLIB
**********************************************************************
*
NOTE ..
*
SEVERAL ROUTINES ASSUME THAT PSLINK AND LIBLINK HAVE THE
*
SAME DISPLACEMENT IN PERSAVW AND PERLIB RESPECTIVELY.
***********************************************************************
*
IF PERLIB CHANGES, ADJUST NEWMAN IN DIRSEAR * * * * * *
*
ENTRY FORMAT, DIRECTORY OF SAVED WORKSPACES
PERSAVW DSECT
PSCYL
DS
F
CCHH OF FIRST TRACK
DASD
PSLINK DS
F
LINK TO NEXT PERSAVW
PSNAME DS
CL12
WORKSPACE NAME
PSMAN
DS
1F
MAN NUMBER FOR SAVE COMMAND
PSPASS DS
CL8
)LOAD )COPY PASSWORD
PSFILE DS
Y
PACK NUMBER FOR MULTIPLE DISK
PSLEN
DS
XL1
NUMBER OF TRACKS
DASD
DS
0F
ALIGN
PSWL
EQU *-PERSAVW
*
END OF DIRSECT COPY * * * * * * * * * * *
./ ADD
NAME=EOJ
MACRO
&L
EOJ
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
L
13,OSLINK
LM
14,12,12(13)
BR
14
MEND
./ ADD
NAME=GETIME
MACRO
&L
GETIME
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
TIME TU

13440000
15360000
17280000
19200000
21120000
23040000
24960000
26880000
28800000
30720000
32640000
34560000
36480000
38400000
40320000
42240000
44160000
46080000
48000000
49920000
51840000
53760000
55680000
57600000
59520000
61440000
63360000
65280000
67200000
69120000
71040000
72960000
74880000
76800000
78720000
80640000
82560000
84480000
86400000
88320000
90240000
92160000
94080000
96000000
97920000
11110000
22220000
33330000
44440000
55550000
66660000
77770000
88880000
12500000
25000000
37500000
50000000
62500000

SRDL 0,39
MEND
./ ADD
NAME=ICALL
MACRO
&LBL
ICALL &A,&X
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
AIF ('&A'(1,1) EQ '(').A1
AIF ('&X' EQ '*').A2
&LBL
L
LKR,=A(&A)
BALR LKR,LKR
MEXIT
.A1
ANOP
&LBL
BALR &A(1),LKR
MEXIT
.A2
ANOP
&LBL
BAL LKR,&A
MEND
./ ADD
NAME=IOBECBD
MACRO
IOBECBD
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
IOBECB DSECT
SPACE 2
IOBFLAG1 DS
C
I/O FLAGS
IOBFLAG2 DS
C
IOBSENS0 DS
C
USED BY SYSTEM
IOBSENS1 DS
C
IOBECBCC DS
C
ECB COMPLETION CODE
IOBECBPT DS
AL3
ADDRESS OF ECB
IOBFLAG3 DS
C
USED BY SYSTEM
IOBCSW DS
7C
LOW ORDER 7 BYTES OF CSW
IOBSTAT EQU IOBCSW+3
IOBSIOCC DS
C
SIO IL AND CC BITS
IOBSTART DS
AL3
START ADDRESS OF CHANNEL PROGRAM
IOBDCB DS
C
USED BY SYSTEM
IOBDCBPT DS
AL3
ADDRESS OF DCB
IOBREPM DS
C
USED BY SYSTEM
IOBRESTR DS
AL3
RESTART ADDRESS FOR ERROR RECOVERY
IOBBCI DS
H
BLOCK COUNT INCREMENT (FOR TAPE)
IOBERRCT DS
H
ERROR COUNT
IOBEXTM DS
C
EXTENT ENTRY
IOBSKPT DS
7C
SEEK ADDRESS(BBCCHHR)
SPACE 2
EVNTCB DS
F
EVENT CONTROL BLOCK.
SPACE 2
&SYSECT CSECT
MEND
./ ADD
NAME=IRB
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
IRB
DSECT
RBTMFLD DS
0CL1
RBPPSAV DS
A
RBAOPSW DS
A
RH OLD PSW DURING ABEND.
RBWCSA DS
C
RBSIZE DS
C
SIZE IN DOUBLEWORDS FOR FREEMAIN.

75000000
87500000
05880000
11760000
17640000
23520000
29400000
35280000
41160000
47040000
52920000
58800000
64680000
70560000
76440000
82320000
88200000
94080000
03120000
06240000
09360000
12480000
15600000
18720000
21840000
24960000
28080000
31200000
34320000
37440000
40560000
43680000
46800000
49920000
53040000
56160000
59280000
62400000
65520000
68640000
71760000
74880000
78000000
81120000
84240000
87360000
90480000
93600000
96720000
05550000
11100000
16650000
22200000
27750000
33300000
38850000
44400000

RBSTAB
RBEP
RBOPSW
RBUSE
RBIQE
RBWCF
RBLINK
RBGRS
RBNEXAV
./ ADD

DS
DS
DS
DS
DS
DS
DS
DS
DS

H
STATUS AND ATTRIBUTE BITS.
A
ENTRY POINT.
D
0CL1
A
A(IQE)
0CL1
WAIT COUNT.
A
16A
0-15.
A
IEQLIST. NOT USED.
NAME=IRETURN
MACRO
&LBL
IRETURN
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&LBL
LM
PR,LKR,0(LR)
BR
LKR
MEND
./ ADD
NAME=LEMP
MACRO
&L
LEMP
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*
SYSTEM DISASTER. LOAD EMPTY WORKSPACE.
&L
SVCC YYLEMP
LOAD EMPTY WORKSPACE
MEND
./ ADD
NAME=MKG
MACRO
&F
MKG &R
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&F
C
&R,MING
BH
*+8
ST
&R,MING
AR
&R,MR
OI
MGARB-M(&R),MGBIT
L
&R,4(0,&R)
A
&R,MINGL
ST
&R,MINGL
MEND
./ ADD
NAME=ON
MACRO
&L
ON
&COND,&BAD
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
LCLC &HOSA
.*
ON
COND,ADDR
PRESETS THE PROGRAM-CHECK
.*
(AND PROGRAMMER-DEFINED CHECK) HANDLER TO TRANSFER CON.*
TROL TO 'ADDR' IF CONDITION 'COND' OCCURS.
.*
'ADDR' MAY BE EITHER AN ADDRESSABLE LOCATION OR AN
.*
ADCON LITERAL (E.G, =A(RER) ).
.*
ON
COND
WITH NO ADDRESS RESETS THE INTERRUPT
.*
ADDRESS TO THE DEFAULT VALUE.
.*
ON'S FOR THE SAME CONDITION CANNOT BE STACKED, AND THERE
.*
IS NO AUTOMATIC REVERT.
AIF (T'&BAD EQ 'O').ON2
&HOSA
SETC '&BAD'(1,1)

49950000
55500000
61050000
66600000
72150000
77700000
83250000
88800000
94350000
11110000
22220000
33330000
44440000
55550000
66660000
77770000
88880000
11110000
22220000
33330000
44440000
55550000
66660000
77770000
88880000
06660000
13320000
19980000
26640000
33300000
39960000
46620000
53280000
59940000
66600000
73260000
79920000
86580000
93240000
02630000
05260000
07890000
10520000
13150000
15780000
18410000
21040000
23670000
26300000
28930000
31560000
34190000
36820000
39450000
42080000
44710000

AIF ('&HOSA' EQ '=').ON1

47340000
LA
0,&BAD
49970000
AGO .ON5
52600000
.ON1
ANOP
55230000
&L
L
0,&BAD
57860000
.ON5
AIF ('&COND' NE 'XOF').ON4
60490000
L
1,=A(X'1000'*X'8000')
63120000
SPM 1
65750000
.ON4
LR
1,LR
68380000
SR
1,MR
71010000
STM 0,1,ON&COND
73640000
MEXIT
76270000
.ON2
AIF ('&COND' NE 'XOF').NSPM
78900000
&L
SR
0,0
81530000
SPM 0
84160000
.NSPM
ANOP
86790000
&L
L
0,=V(DFLT&COND)
89420000
L
1,QR13STK
92050000
STM 0,1,ON&COND
C049 94680000
MEND
97310000
./ ADD
NAME=OPSECT
TITLE 'OPERATOR EXECUTION TEMP STORAGE.'
00800000
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
01600000
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
02400000
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
03200000
OPSECT DSECT
04000000
SPACE
04800000
*
05600000
*
OPERATOR CONTROL ROUTINE STORAGE.
06400000
*
07200000
SPACE
08000000
OPERATOR DS
2F
CURRENT OPERATOR.
08800000
OPINDEX EQU OPERATOR+4
09600000
SPACE
10400000
TYPINFO DS
5F
RESULTS FROM ARTHTP.
11200000
OPRN
EQU TYPINFO
ROUTINE ADDRESS.
12000000
LCTYPE EQU OPRN+4
LH OPERAND FETCH CODE.
12800000
RCTYPE EQU LCTYPE+4
RH OPERAND FETCH CODE.
13600000
RSTYPE EQU RCTYPE+4
RESULT TYPE.
14400000
COMTYP EQU RSTYPE+4
COMPUTE TYPE.
15200000
SPACE
16000000
INCR
DS
F
SVI INCREMENT DURING CLEANUP.
16800000
STOP
DS
2F
TEMP STORE INSTRUCTION.
17600000
LOP
EQU STOP+4
TEMP LOAD INSTRUCTION.
18400000
TEMPRGT DS
FL1
RH TEMP INDICATOR.
19200000
TEMPLFT DS
FL1
LH TEMP INDICATOR.
20000000
LTORRT DS
FL1
INDICATOR OF STORAGE USED.
20800000
LHSCALAR DS
FL1
LEFT SCALAR INDICATOR.
21600000
RHSCALAR DS
FL1
RIGHT SCALAR INDICATOR.
22400000
BLOWN
DS
FL1
BLOWUP INDICATOR.
23200000
FCHSCLR DS
FL1
EXFETCH EXTENSION INDICATOR.
24000000
TEMPIND DS
FL1
INDEX TEMP INDICATOR.
24800000
SPACE
25600000
*
26400000
*
OPERAND INFORMATION.
27200000
*
28000000
SPACE
28800000
*
LEFT OPERAND.
29600000
SPACE
30400000
LHBASE DS
F
M-POINTER.
31200000
&L

LHRANK
LHXRHO
LHTYPE
LHFETCH
LINDX
LCFTYPE
LHORG
LHFROUT
*
RHBASE
RHRANK
RHXRHO
RHTYPE
RHFETCH
RINDX
RCFTYPE
RHORG
RHFROUT
*
INDBASE
INDRANK
INDXRHO
INDTYPE
INDEX
*
RBASE
RRANK
RXRHO
RRTYPE
RESTORE
RESINDX
RESTYPE
RESORG
*
GEARSHFT
TEMPRES
CURRES
STRSHIFT

DS
F
DS
F
DS
F
DS
3F
EQU LHFETCH
EQU LINDX+4
EQU LCFTYPE+4
DS
F
SPACE
RIGHT OPERAND.
SPACE
DS
F
DS
F
DS
F
DS
F
DS
3F
EQU RHFETCH
EQU RINDX+4
EQU RCFTYPE+4
DS
F
SPACE
INDEX.
DS
F
DS
F
DS
F
DS
F
DS
F
SPACE
RESULT.
SPACE
DS
F
DS
F
DS
F
EQU RSTYPE
DS
3F
EQU RESTORE
EQU RESINDX+4
EQU RESTYPE+4
SPACE
BOOLEAN STORE OPERANDS.
SPACE
DS
3F
EQU GEARSHFT
EQU TEMPRES+4
EQU CURRES+4
SPACE

RANK.
NUMBER OF ELEMENTS.
TYPE.
FETCH OPERANDS.
ELEMENT INDEX.
FETCH CODE FROM ARTHTP.
DATA ORIGIN.
SOP LEFT FETCH ROUTINE ADDRESS.

M-POINTER.
RANK.
NUMBER OF ELEMENTS.
TYPE.
FETCH OPERANDS.
ELEMENT INDEX.
FETCH CODE FROM ARTHTP.
DATA ORIGIN.
SOP RIGHT FETCH ROUTINE ADDRESS.
1ST BYTE 0 IF NO INDEX
RANK.
NUMBER OF ELEMENTS.
TYPE.
HOLD INDEX, IF SCALAR.

M-POINTER.
RANK.
NUMBER OF ELEMENTS.
TYPE.
STORE OPERANDS.
ELEMENT INDEX.
TYPE.
DATA ORIGIN.

*
*
*
*

EXECUTION ROUTINE SCRATCH STORAGE.

ROUTINES MAKE ASSUMPTIONS ABOUT ORDERING.

FACTSAVE
BINSAVE
BSIGN
BINOSAVE
DBISAVE
DBINSAVE
FBINSAVE
FTEMP
HOLDRITE

SPACE
DS
DS
DS
DS
DS
DS
DS
DS
DS

F
F
F
F
F
F
F
F
F

32000000
32800000
33600000
34400000
35200000
36000000
36800000
37600000
38400000
39200000
40000000
40800000
41600000
42400000
43200000
44000000
44800000
45600000
46400000
47200000
48000000
48800000
49600000
50400000
51200000
52000000
52800000
53600000
54400000
55200000
56000000
56800000
57600000
58400000
59200000
60000000
60800000
61600000
62400000
63200000
64000000
64800000
65600000
66400000
67200000
68000000
68800000
69600000
70400000
71200000
72000000
72800000
73600000
74400000
75200000
76000000
76800000
77600000
78400000
79200000

REGSAV
RESSIGN
RITEHOLD
SAVEMALL
SAVER
TESTAREA
XORWORD
A
B
BILSAVE
BIRSAVE
BISAVE
C
DBLHOLD
DBLSAVE
DSTORE
DSAVE
DTEMP
LHSAVE
RHSAVE
RSAVE
XTNSHN
P

DS
F
DS
F
DS
F
DS
5F
DS
F
DS
F
DS
F
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
D
DS
FL1
SPACE
NDOPSECT EQU *
./ ADD
NAME=PERTERM
TITLE 'P E R T E R M -- G L O B A L D E F I N I T I O N S'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PERTERM DSECT
*
ALWAYS IN CORE AREA FOR EACH POSSIBLE TERMINAL
*
CONTAINS FLAGS AND POINTERS FOR SCHEDULER AND INTERPRETER.
*
INITIAL TYPEWRITER CCW'S ARE HERE.
PTTYPE DS
XL1
DEVICE TYPE 1052,2741, ETC
*
NOTE THAT PTTYPE=0 MEANS THAT THE 3 FOLLOWING BYTES GIVE THE
*
TRUE PUBENT ADDRESS FOR THIS DEVICE ADDRESS
*
IF PTTYPE & 3 FOLLOWING BYTES = 0, THIS IS A DUMMY ENTRY.
STATE
DS
AL1
STATE OF DEVICE OR TERMINAL
PTUNAD DS
HL1
MPX DEVICE ADDRESS OF TERMINAL
PUSENS DS
HL1
SENSE BYTE STORAGE
SAVCSW DS
FL8
LAST NON-SENSE TERMINATION CSW
SAVSTAT EQU *
PUCCB
DS
A
ADDRESS OF MOST RECENT CCB SETTING
PUTERM EQU *
PUB ONLY
*
PUTERM IS PUB TO PERTERM LINK FOR WAIT
*
PTR POINTS TO EITHER A PERTERM OR A PUBENT BLOCK
PUBENTL EQU *+4-PERTERM
PRECEDING BYTES ARE COMMON TO
*
TERMINALS AND OTHER MPX DEVICES
*
*
FOLLOWING BYTES ARE FOR TERMINALS ONLY
*
INITIAL VALUE IN CONFIGURATION
ACTIVE DC
X'00'
INWAITM+NONINM
MISCB
DC
X'00'
NOWSM
IOB1
DC
X'00'
NSIGNM+DIVERT*?
IOB2
DC
X'00'
Q4WMDM*?+LOEXP*?
*
DUMMY PERTERMS HAVE WORD 0 = 0 AND NSIGNM & LVIDLEM
*
ACTIVE SETTINGS
ATTENM EQU X'80'
ATTENTION SIGNALLED BY TYPIST
OUTWAITM EQU X'40'
OUTPUT BUFFER IS FULL

80000000
80800000
81600000
82400000
83200000
84000000
84800000
85600000
86400000
87200000
88000000
88800000
89600000
90400000
91200000
92000000
92800000
93600000
94400000
95200000
96000000
96800000
97600000
98400000
99200000
00730000
01460000
02190000
02920000
03650000
04380000
05110000
05840000
06570000
07300000
08030000
08760000
09490000
10220000
10950000
11680000
12410000
13140000
13870000
14600000
15330000
16060000
16790000
17520000
18250000
18980000
19710000
20440000
21170000
21900000
22630000
23360000
24090000
24820000

INWAITM
NONINM
LOCKM
MISCM
*
ACTIVEM
*
NOWSM
EXCPWM
WANTON
SDWAIT
REPWAITM
TRAWAITM
CLOKWAIT
BUFFWAIT
*
TRREJ
COPYRM
COPYWM
BROADM
RINGM
NSIGNM
PRIVBIT
*
Q4WMDM
RECMM
LVIDLEM
LOEXP
SHEXP
BOUNCM
PTCORE
PTBFA
PTFBUF
PTLBUF
PTIBUF
PTRBUF
PTABTM
PTICTME
*
PTMTIME
*
*
*
PTSOTM
PTMTIM2
PTMTIM3
PTCPULIM
PTCPULM2
DESBYTE
PTSAD
PTCNT
PDSOP
PTRESP
*
PTCCW1
PTCCW2
PTCCW3

EQU X'20'
AWAITING INPUT FROM TYPIST
EQU X'10'
ZERO MEANS INPUT IS READY
EQU X'02'
INVOLVED IN SAVE
EQU X'01'
VARIOUS SUSPENSION CAUSES
MSICM IS
OR/ MISCB
EQU INWAITM+OUTWAITM+MISCM ALL ZERO MEANS READY TO RUN
MISCB SETTINGS
EQU X'01'
NO WORKSPACE ASSIGNED
EQU X'02'
PSUEDO DOS WAIT,THIS DEVICE
EQU X'04'
TRYING TO SIGN ON
EQU X'08'
WAITING TO DO SPECIAL DISK
EQU X'10'
WAITING FOR REPLY
EQU X'20'
MSGOUT SUSPENSION
EQU X'40'
WAIT FOR TIME INTERVAL
EQU X'80'
WAIT FOR TYPEWRITER BUFFER
IOB1 SETTINGS
EQU X'02'
MSGOUT MACRO REJECTED
EQU X'04'
SINK DURING COPY OPERATION
EQU X'08'
SOURCE FOR COPY OPERATION
EQU X'10'
BROADCAST MESSAGE AWAITING THIS TERM
EQU X'20'
ADDRESSED MESS AWAITING THIS TERM
EQU X'40'
NOT SIGNED ON
EQU X'80'
PRIVLEGED TERMINAL
IOB2 SETTINGS
EQU X'80'
FOUR WIRE MODEM
EQU X'40'
ACCEPT MESSAGES AT ANY TIME
EQU X'10'
IGNORE TYO'S LINE IS DEAD
EQU X'08'
LONG EXP IDENTIFIES EXPRESS LINE
EQU X'04'
SHORT EXP EXPRESS MODE CONNECTION
EQU X'02'
FORCE SIGNOFF SOON
SPACE
DS
A (PERCORE)
CORE AREA ASSOCIATED WITH TERMINAL
DS
A,H
RESERVED
DS
H
ALLOCATED BUFFER COUNT
DS
A
HEAD OF OUTPUT BUFF CHAIN
DS
A
TAIL OF I/O BUFFER CHAIN
DS
A
HEAD OF INPUT BUFFER CHAIN
DS
A
CHAIN TO RELEASE AT UNWZ
DS
1F
ACTUAL BILLING TIME
DS
1F
COMPUTE TIME, THIS INTERVAL
PTICTM IS RESET BY TYI
DS
1F 'REALTIME'
PTMTIME IS USED FOR MEASURING
DURATIONS SUCH AS..
INWAIT = 1 (TYPING TIME)
INWAIT..=0 TO FIRE UP (RESPONSE)
NON-INPUT,NON-RESPONSE TIME
DS
1F
SIGN ON TIME
DS
F
FOR MEASURING TYI TO TYI TIME
DS
F
CUMULATIVE KEYING TIME SINCE SIGNON
DS
2H
CPU TIME LIMIT
EQU PTCPULIM+2
DS
1C
TERM NUMBER OF MESSAGE ADDRESSEE
DS
1X
SAD CCW
DS
1X
MINOR ERROR COUNT, THIS TERMINAL
DS
1X
OPERATION
DS
1C
POLLING RESPONSE 1050 OR 2741
DS
7X
RESERVED
TYPEWRITER CCW CHAIN
DS
D
POLLING CCW'S
DS
D
READ RESPONSE
DS
A
TIC TO FIRST BUFFER

25550000
26280000
27010000
27740000
28470000
29200000
29930000
30660000
31390000
32120000
32850000
33580000
34310000
35040000
35770000
36500000
37230000
37960000
38690000
39420000
40150000
40880000
41610000
42340000
43070000
43800000
44530000
45260000
45990000
46720000
47450000
48180000
48910000
49640000
50370000
51100000
51830000
52560000
53290000
54020000
54750000
55480000
56210000
56940000
57670000
58400000
59130000
59860000
60590000
61320000
62050000
62780000
63510000
64240000
64970000
65700000
66430000
67160000
67890000
68620000

PTMAN
PTMANI
PTDAYSON
*
*
*
PTWSQ
PTWSA

DS
F
MAN NUMBER SIGNED ON THIS TERMINAL.
DS
3C
FIRST THREE CHARACTERS OF HISNAME
DS
C
NUMBER OF MIDNIGHTS SINCE SIGN-ON.
PTWSQ, PTWSA ARE INITIALIZED AT SIGN-ON FROM MANTABLE
PTWSA IS INCREMENTED BY A SAVE OF NEW WORKSPACE, DECR BY DROP
PTWSQ IS CHANGED BY )ADD
DS
H
QUOTA FOR )SAVE
DS
H
ACTUAL NUMBER OF SAVED WORKSPACES
DS
0D
PERTERML EQU *-PERTERM
LENGTH OF DSECT
*
*
PDSDDDD DSECT
PARAMETER AREA FOR SPECIAL DISK
PDSLIB DS
1F
LIBRARY NUMBER
PDSWSN DS
CL12
WORKSPACE NAME
DS
1X
PDSOPA DS
1X
OVERWRITABLE COPY OF SDOP IN TB
DS
1X
PDSTCNT DS
1X
TRACK COUNT FOR )SAVE
PDSPASS DS
CL8
PASSWORD
PDSWSQI DS
H
INCREMENT FOR WORKSPACE QUOTA
PDSCPUL DS
H
CPU TIME LIMIT FOR )ADD
PDSID
DS
0CL78
ID FOR COPY
PDSLEN EQU PDSID-PDSLIB
LENGTH FOR NON-COPY OP
*
*
TYPEWRITER BUFFER
*
PERBUF DSECT
PBCCW
DS
D
CCW ,PBSTAR, ,TBL-(PBSTAR-PERBUF)
PBFLAG EQU PBCCW+5
BUFFER STATUS FLAGS
FORCELF EQU X'01'
PTCCW2 ONLY, SEE UNRZ26
FILLBIT EQU X'02'
TRANSLATED INPUT BUFFER FLAG
LINEZ
EQU X'04'
END OF LINE
LISTZ
EQU X'08'
END OF LIST FOR FREEBUF
FREEBIT EQU X'10'
FREE BUFFER FLAG
KILLFLAG EQU FORCELF+FILLBIT
FORCE MXWCCC INTO MXDCCC
PBTIC
DS
F
TIC TO NEXT BUFFER
PBSTAR DS
CL20
USEFUL PART OF BUFFER
PBLAST EQU *-1
LAST CHAR OF BUFFER
TBL
EQU *-PERBUF
*
END OF PERTERM COPY * * * * * * * * * * * * *
./ ADD
NAME=PROLOG
MACRO
&N
PROLOG &F,&L
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
.**********************************************************************
.*
WARNING -- MKGARB BYPASSES THESE LINKAGE MACROS. BE CAREFUL
.*
IF YOU CHANGE THE LINKAGES.
&N
STM PR,LKR,0(TLR)
BALR PR,0
USING *,PR
LR
LR,TLR
AIF (T'&F NE 'O').SL
LA
TLR,16(0,TLR)
MEXIT
.SL
USING &F-16,LR
LA
TLR,(&L+7-&F)/8*8+16(0,TLR)
MEND

69350000
70080000
70810000
71540000
72270000
73000000
73730000
74460000
75190000
75920000
76650000
77380000
78110000
78840000
79570000
80300000
81030000
81760000
82490000
83220000
83950000
84680000
85410000
86140000
86870000
87600000
88330000
89060000
89790000
90520000
91250000
91980000
92710000
93440000
94170000
94900000
95630000
96360000
97090000
97820000
98550000
05260000
10520000
15780000
21040000
26300000
31560000
36820000
42080000
47340000
52600000
57860000
63120000
68380000
73640000
78900000
84160000
89420000
94680000

./ ADD

NAME=QUEND
MACRO
&L
QUEND
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
EX
0,MQCELL
MEND
./ ADD
NAME=REMCDC
MACRO
&REM
REMCDC
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*
START OF CDCOMP COPY
*
SUBROUTINE TO GENERATE DISC CCW CHAIN
*
R1 = ADDRESS FOR READ OR WRITE CCW
*
R2 = CAW (PLACE TO STORE CCW)
*
R3 = SEEK - SCHIDE WITH ADDRESS
*
R6 = RETURN ADDRESS OF CDCOMP
*
LINK = RETURN ADDRESS OF CDCOMPS AND CDCOMPW
USING CDCPARS,4
DSECT WITH DISK PARAMETERS
EXTRN CCWAR
EXTRN RD1DA
&REM
MVC CCPAR1+1(3),CDCAD+1 LOSE HIGH ORDER BYTE
DASD
*
INITIALIZE CCW GENERATION
MVI CCPASS,0
FIRST AREA MARK
OI
ARLIM+1,EMPTYM
5989
OI
R4+1,EMPTYM
5989
OI
R4+5,EMPTYM
5989
OI
R5+1,EMPTYM
5989
MVI ONETRK,X'80'
SET 1-TRACK SWITCH OFF
SPACE 2
*
THE FOLLOWING ANALYSIS DISTINGUISHES FOUR CASES FOR CDCOMP.
*
IT COMPUTES ARLIM, THE ABSOLUTE ADDRESS OF THE END OF THE
*
FIRST DATA AREA, AND (IN R5) THE ABSOLUTE START ADDRESS OF THE
*
SECOND DATA AREA. THE TABLE SHOWS THE FOUR CASES.
*
*
CASE
ARLIM R5
CRITERIA
*
*
1
MX
SVI
MX GEQ TLEN
*
2
TLEN
SVI
TLEN LEQ SVI LSS WLEN+MX-TLEN
*
3
MX
WLEN+MX-TLEN
SVI GEQ WLEN+MX-TLEN
*
4
TLEN
TLEN
SVI LSS TLEN
*
SPACE 2
5989
* WHEN DATA-CHAINING CANNOT BE USED (CDCNDC = 1)
5989
* THEN THE FOLLOWING SPECIAL ACTIONS ARE TAKEN FOR CASE 1
5989
SPACE 3
5989
* SWAP READ/WRITE
5989
*
1A
TLEN
TLEN
SVI < TLEN + MX - TLEN|MX
5989
*
TREAT AS CASE 4 IFF
5989
*
MX AND SVI FALL INTO
5989
*
THE SAME TRACK MULTIPLE
5989
*
1B
MX
SVI
5989
*
AS FOR CASE 2, LET CONTROL UNIT
5989
*
WRITE ZEROS FROM MX TO TLEN+MX-TLEN|MX
5989
* LIB READ/WRITE
5989
*
IN ORDER TO KEEP THE APL LIBRAY DISKS PORTABLE BETWEEN
5989
*
SYSTEMS, THE DISK FORMAT WILL REMAIN UNCHANGED. INSTEAD 5989

12500000
25000000
37500000
50000000
62500000
75000000
87500000
00230000
00460000
00920000
01150000
01380000
01610000
01840000
02070000
02300000
02530000
02760000
02990000
03220000
03450000
03680000
03910000
04140000
04370000
04600000
04830000
05060000
05290000
05520000
05750000
05980000
06210000
06440000
06670000
06900000
07130000
07360000
07590000
07820000
08050000
08280000
08510000
08740000
08970000
09200000
09430000
09660000
09890000
10120000
10350000
10580000
10810000
11040000
11270000
11500000
11730000
11960000

*
*
*
*
*
*

OF DATA-CHAINING FROM MX TO SVI, THE SMALLER OF THE TWO

SECTIONS ( TRACK BOUNDARY TO MX OR SVI TO TRACK BOUNDARY)
IS MOVED ADJACENT TO THE OTHER SO THE TRACK CAN BE
WRITTEN AS ONE RECORD WITHOUT DATACHAINING

5989
5989
5989
5989
5989
CASE ARLIM
R5
CRITERIA
5989
SPACE 2
5989
*
1C
MX+TLEN-TLEN|MX SVI+TLEN-TLEN|MX
5989
*
TLEN < 2 TIMES TLEN|MX 5989
*
5989
*
1D
MX-TLEN|MX
SVI-TLEN|MX
5989
*
TLEN > 2 TIMES TLEN|MX 5989
*
5989
SPACE 6
END OF SPECIAL NOTES
5989
LM
1,3,CCPAR1
PHYMV
MVC 2(4,3),PHYCYL
MOVE CCHH INTO SEEK SCHIDE AREA DASD
LM
4,5,MX-M(1)
CR
4,5
BH
CCCX
MX GTR SVI, EVIL
A
4,=F'7'
ROUND MX TO DOUBLE-WORD BOUNDARY
N
4,=F'-8'
LTR 2,4
BNH CCCX
MX NEGATIVE
C
5,WLEN
BNL CCCX
GEQ WSLENGTH, EVIL
N
5,=F'-8'
ROUND SVI DOWN TO DOUBLEWORD
L
4,CDCBASE
CDCPARS ADDRESS
5989
L
0,TLENF
5989
STH 0,TLENC+2
5989
SPACE 2
5989
*
MX AND SVI ARE VALID
SPACE 2
5989
*CURRENT REGS
SAME DATA AVAILABLE IN
NEEDED LATER
5989
*
0 TLEN
TLENF OR TLENC+2
*
5989
*
1 M
CCPAR1
*
5989
*
2 MX-M
5989
*
3 SCHIDE ARG,
SCHCCW1
*
5989
*
4 CDCPARS
CDCBASE
*
5989
*
5 SVI-M
*
5989
SPACE 3
5989
CR
2,5
MX=SVI, TREAT AS CASE 4
5989
BNL CCC8
WRITE ENTIRE WS, WITHOUT
5989
*
DATACHAINING FROM MX TO SVI 5989
CR
5,0
BL
CCC8
SVI LSS TLEN, CASE 4
LA
3,0(1,2)
ABSOLUTE MX
5989
ST
3,ARLIM
IS DEFAULT END OF FIRST AREA
5989
SR
2,0
REL MX-TLEN
5989
BP
CCC7X
MX > TLEN
CASE 1
5989
A
2,WLEN
WLEN + MX - TLEN
CR
5,2
BL
CCC9
TLEN LEQ SVI LSS WLEN+MX-TLEN
*
, CASE 2
SPACE 3
5989
* CASE-3
ONE-TRACK WORKSPACE
SVI GEQ WLEN+MX-TLEN
5989
SPACE 2
5989
*
REG-2 CONTAINS START OF AREA 2 FOR DC WRITE
5989
SPACE 3
5989
MVI ONETRK,0
SET 1-TRACK FLAG ON
LR
3,5
SAVE SVI FOR LATER
5989

12190000
12420000
12650000
12880000
13110000
13340000
13570000
13800000
14030000
14260000
14490000
14720000
14950000
15180000
15410000
15640000
15870000
16100000
16330000
16560000
16790000
17020000
17250000
17480000
17710000
17940000
18170000
18400000
18630000
18860000
19090000
19320000
19550000
19780000
20010000
20240000
20470000
20700000
20930000
21160000
21390000
21620000
21850000
22080000
22310000
22540000
22770000
23000000
23230000
23460000
23690000
23920000
24150000
24380000
24610000
24840000
25070000
25300000
25530000
25760000

S
STH
MVC
CLI
BNE

5,WLEN
5,MVCLNGTH
COUNT,C256
DOP+1,RDATA
CCC11

-(WLEN-SVI) LENGTH OF MOVE

SAVE LENGTH FOR MVC LOOP
EACH MVC WILL MOVE 256 BYTES
IS THIS A READ?
WRITE A ONETRACK WS

5989
5989
5989
5989
5989
*
5989
* A READ OF A ONETRACK WORKSPACE.
5989
*
SAVE ADDRESSES FOR MVC AT RELOC
5989
*
(WE NEVER DATACHAIN MX TO SVI FOR READ OF ONETRACK)
5989
*
5989
L
5,WLEN
WORKSPACE LENGTH (END OF DATA)
5989
LR
4,0
TLEN
5989
AR
4,1
ABSOLUTE END OF SINK
5989
STM 4,5,R4
SAVE MVC ADDRESSES UNTIL RELOC
5989
BR
6
SINCE THE WHOLE (ONETRACK)
5989
*
WORKSPACE HAS ALREADY BEEN READ, NO NEED TO
5989
*
BUILD ANY CCW'S HERE.
5989
SPACE 3
5989
*
WRITE A ONE-TRACK WORKSPACE
5989
CCC11
LR
5,2
START OF AREA TWO FOR DC WRITE
5989
TM
CDCFLAGS,CDCNDC
MAY WE DATA CHAIN?
5989
BZ
CCC7
BRANCH YES
5989
TS
CCPASS
ANOTHER PASS NOT NEEDED
5989
LR
5,3
SVI
5989
LR
4,0
TLEN
5989
AR
4,1
M+TLEN
5989
B
CCC10A
5989
SPACE 3
5989
* WE ARE PROCESSING A CASE 1 WORKSPACE
5989
*
5989
CCC7X
TM
CDCFLAGS,CDCNDC CAN WE DO IT THE EASY WAY BY
5989
BZ
CCC7
DATA-CHAINING?
0=YES
5989
AR
2,0
RELATIVE MX, AGAIN
5989
SPACE 3
5989
* HANDLE CASE 1
FOR NO*DATA*CHAINING
5989
SPACE 3
5989
ST
5,R5
SAVE REG5
5989
LA
3,256
MAXIMUM LENGTH OF MVC
5989
C256
EQU *-2 DC H'256' HALFWORD CONSTANT OF 256
5989
SR
5,2
SVI - MX
5989
CR
5,3
256 > SVI-MX
5989
BL
*+6
* TO AVOID DESTROYING DATA IN MVC, 5989
LR
5,3
* EACH MVC WILL MOVE ONLY
5989
STH 5,COUNT
* 256 MIN SVI-MX
BYTES AT A TIME. 5989
LR
5,2
MX
5989
LR
3,4
SAVE CDCPARS ADDRESS
5989
DROP 4
5989
SR
4,4
ZERO FOR DIVIDE
5989
DR
4,0
REG4 IS TLEN RES MX
5989
*
REG5 IS MX DIV TLEN
5989
TM
CDCFLAGS-CDCPARS(3),CDCSWAP IS IT A SWAP OPERATION? 5989
BZ
CCC10B
A LIB OPERATION - SET UP FOR MVC
5989
*
5989
* I/O ON THE SWAP FILE - NO INCORE MOVE NEEDED
5989
*
WRITE FULL WS (CASE4) IF MX AND SVI FALL INTO SAME TRACK 5989
*
OTHERWISE TREAT AS MODIFED CASE 2
5989
*
5989
SR
2,4
MX-TLEN|MX
5989
AR
2,0
TLEN+MX-TLEN|MX
5989
C
2,R5
SVI<TLEN+MX-TLEN|MX
5989

25990000
26220000
26450000
26680000
26910000
27140000
27370000
27600000
27830000
28060000
28290000
28520000
28750000
28980000
29210000
29440000
29670000
29900000
30130000
30360000
30590000
30820000
31050000
31280000
31510000
31740000
31970000
32200000
32430000
32660000
32890000
33120000
33350000
33580000
33810000
34040000
34270000
34500000
34730000
34960000
35190000
35420000
35650000
35880000
36110000
36340000
36570000
36800000
37030000
37260000
37490000
37720000
37950000
38180000
38410000
38640000
38870000
39100000
39330000
39560000

CCC8
WRITE ENTIRE WS, MX AND SVI IN SAME TRACK 5989 39790000
5,R5
RESTORE REGS
5989 40020000
CCC7
TREAT AS (MODIFIED) CASE2
5989 40250000
3
5989 40480000
*-------SET UP TO DO THE INCORE MOVE FOR CASE-1
------ 5989 40710000
*
5989 40940000
*
5989 41170000
* TO MINIMIZE CPU USAGE IN THE INCORE MOVE, THE SMALLEST MOVE
5989 41400000
* POSSIBLE WILL BE MADE:
5989 41630000
*
5989 41860000
*
* THE AREA FROM TRACK BOUNDARY TO MX
TLEN|MX
5989 42090000
*
* THE AREA FROM SVI TO NEXT TRACK BOUNDARY TLEN-TLEN|MX 5989 42320000
*
* THE AREA FROM SVI TO END OF WORKSPACE
WLEN-SVI
5989 42550000
SPACE 2
5989 42780000
* IN THE SETUP FOR THE MOVE ROUTINE, MVCLNGTH IS:
5989 43010000
*
POSITIVE IF THE AREA BELOW MX IS MOVED UP TO SVI.
5989 43240000
*
NEGATIVE IF SVI IS TO BE MOVED DOWN TO MX.
5989 43470000
SPACE 2
5989 43700000
CCC10B SR
0,4
TLEN-TLEN|MX
5989 43930000
SPACE 1
5989 44160000
* REG.4 CONTAINS THE LENGTH OF THE PARTIAL TRACK BELOW MX
5989 44390000
* REG.0 CONTAINS THE LENGTH OF THE PARTIAL TRACK ABOVE SVI
5989 44620000
SPACE 1
5989 44850000
L
5,WLEN
5989 45080000
S
5,R5
WLEN-SVI
5989 45310000
SPACE 1
5989 45540000
* REG.5 CONTAINS THE LENGTH OF SVI TO WLEN
5989 45770000
SPACE 1
5989 46000000
CR
0,5
* SELECT THE SMALLER OF
5989 46230000
BH
*+6
*
SVI TO TRACK MULTIPLE
5989 46460000
LR
5,0
*OR SVI TO WLEN
5989 46690000
*
5989 46920000
* NOW, SELECT THE SHORTEST MOVE, THE SECTION BELOW MX, OR
5989 47150000
*
THE SECTION ABOVE SVI.
5989 47380000
*
5989 47610000
CR
4,5
5989 47840000
BL
*+6
5989 48070000
LNR 4,5
NEGATIVE LENGTH FOR SVI PORTION
5989 48300000
STH 4,MVCLNGTH
SAVE IT FOR LATER
5989 48530000
LCR 4,4
COMPLEMENT FOR BACKWARD ADD BELOW
5989 48760000
L
5,R5
SVI
5989 48990000
AR
5,4
TRUE START OF SECOND AREA
5989 49220000
A
4,ARLIM
TRUE END OF FIRST AREA
5989 49450000
STM 4,5,R4
CORRECTED END OF FIRST,START OF NEXT 5989 49680000
ST
4,ARLIM
END OF FIRST CCW STREAM
5989 49910000
MVI ONETRK,INCORMV
INDICATE A RELOC MOVE NEEDED
5989 50140000
CLI DOP+1,RDATA
ARE WE DOING A WRITE
5989 50370000
BE
CCC7
BRANCH IF THIS IS A READ
5989 50600000
ST
5,R5
FOR USE AT NOMOVE
5989 50830000
AH
5,MVCLNGTH
5989 51060000
CCC10A CLI CDOP,8
CHECK FOR WRITE OF ALT DIRECTORY
5989 51290000
BE
MVCEXIT
IF ALT DONT DO INCORE MOVE AGAIN
5989 51520000
AH
4,MVCLNGTH
5989 51750000
*
5989 51980000
* PREPARE TO DO INCORE MOVE BEFORE WRITE
5989 52210000
*
5989 52440000
LA
0,MVCEXIT
FAKE A RETURN ADDRESS
5989 52670000
TM
MVCLNGTH,X'80' IS MVCLNGTH NEGATIVE ?
5989 52900000
BO
MVCDOWN
IF SO, MOVE TO LOWER ADDRESSES
5989 53130000
*
5989 53360000
NOMOVE

BNL
L
B
SPACE

* MVCLOOP FOR: WRITE - MOVING MX PART UP AGAINST SVI

*
READ - MOVING SVI PART BACK UP WHERE IT BELONGS
*
MVCUP
LH
3,COUNT
GET INCR
LCR 2,3
THIS LOOP NEEDS NEGATIVE INCREMENT
BCTR 3,0
MVC NEED A SHORT COUNT
STC 3,MVCUPX+1
$$$ MODIFY MVC INSTRUCTION
$$$$$
AR
5,1
MAKE SINK ABSOLUTE
AR
5,2
DECREMENT BY LENGTH OF FIRST MOVE
AR
4,2
DITTO
LH
3,MVCLNGTH
LIMIT CHECK IS SOURCE MINUS LENGTH
LNR 3,3
IS POSITIVE FOR WRITES, NEG. FOR READ
AR
3,4
MVCUPX MVC 0(*-*,5),0(4)
AR
5,2
BXH 4,2,MVCUPX
LR
2,0
RETURN ADDRESS IS IN REG 0
BR
2
DO CLEANUP
*
*
CALLED BY BAL 0,MVCREV
*
*
MOVE DATA BACK TO WHERE IT BELONGS IN CORE
*
MVCREV LM
4,5,R4
GET SOURCE-SINK OR SINK-SOURCE
TM
MVCLNGTH,X'80' IS MVCLNGTH NEGATIVE ?
BO
MVCUP
IF SO, MOVE TO HIGHER ADDRESS
*
* MVCLOOP FOR : WRITE - MOVING SVI DOWN TO MX
*
READ - MOVING MX BACK DOWN WHERE IT BELONGS
*
MVCDOWN LA
2,256
INCREMENT FOR BXLE
LH
3,MVCLNGTH
NUMBER OF BYTES TO BE MOVED
LPR 3,3
MAKE SURE ITS POSITIVE
AR
3,4
SINK+LENGTH IS LIMIT ADDRESS
AR
5,1
ABSOLUTE SOURCE FOR MOVE
SR
3,2
DECREMENT TO HANDLE SHORT LAST MOVE
BM
MVCDOWNS
DONT MOVE 256 IF ITS DESTRUCTIVE
SPACE 2
MVCDOWNX MVC 0(256,4),0(5) MOVE 256 AT A TIME
AR
5,2
BXLE 4,2,MVCDOWNX DO IT AGAIN
MVCDOWNS AR
3,2
ADJUST BACK TO REAL LIMIT
SR
3,4
LIMIT - BEGINNING ADR OF THIS MOVE
BZ
MVCDOWNZ
NO LAST MOVE REQUIRED
BCTR 3,0
MVC NEEDS SHORT COUNT
EX
3,MVCDOWNY
ONE MORE TIME
MVCDOWNZ LR
2,0
RETURN ADDRESS IS IN REG 0
BR
2
DO CLEANUP
MVCDOWNY MVC 0(*-*,4),0(5) TARGET OF EXECUTE
SPACE 3
MVCEXIT LH
0,TLENC+2
CLI ONETRK,0
WAS THIS THE ONE TRACK CASE ?
BNE NOMOVE
IF NOT, RE-ESTABLISH REG.5
SPACE 2
CCC8
LR
5,0
TLEN
CCC9
AR
0,1
M + TLEN
ST
0,ARLIM
CCC7
MVI SELFERR,0
INDICATE MX AND SVI ARE VALID
AR
5,1
M + START ADDR, AREA 2
LM
2,3,CCWAD

5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989

53590000
53820000
54050000
54280000
54510000
54740000
54970000
55200000
55430000
55660000
55890000
56120000
56350000
56580000
56810000
57040000
57270000
57500000
57730000
57960000
58190000
58420000
58650000
58880000
59110000
59340000
59570000
59800000
60030000
60260000
60490000
60720000
60950000
61180000
61410000
61640000
61870000
62100000
62330000
62560000
62790000
63020000
63250000
63480000
63710000
63940000
64170000
64400000
64630000
64860000
65090000
65320000
65550000
65780000
66010000
66240000
66470000
66700000
66930000
5989 67160000

L
4,CDCBASE
CDCPARS ADDRESS
USING CDCPARS,4
CHAIN FOR EACH TRACK IS
CCW SEEK,DADDR,CC,6
CCW SCHIDEQ,DADDR+2,CC,K
TIC *-8
DATA MOVING CCW (SEE BELOW)

5989 67390000
5989 67620000
*
67850000
*
68080000
*
68310000
*
68540000
*
68770000
*
69000000
*
DATA MOVING CCW IS EITHER READ DATA OR WRITE DATA. IT WILL
69230000
* SOMETIMES USE DATA CHAINING TO OPERATE WITH NON-CONTIGUOUS AREAS OF 69460000
* CORE. THE TWO AREAS OF A WORKSPACE ARE THE BYTES FROM M TO MX
69690000
* AND THE BYTES FROM SVI TO END OF WORKSPACE. FOR MULTIPLE-TRACK WORK- 69920000
* SPACES, THE LAST TRACK IS FILLED OUT WITH GARBAGE AS NECESSARY.
70150000
* FOR 1-TRACK WORKSPACES, GARBAGE PRECEDES SECOND AREA TO FILL OUT
70380000
* THE TRACK. AFTER 1-TRACK WORKSPACE IS READ IN, SVI AND UP MUST BE
70610000
* RELOCATED. DATA CHAINING IS TOO MARGINAL TO BE USED ON TRACK 1.
70840000
*
71070000
*
71300000
*
IN THE FOLLOWING,
71530000
*
R1 = ABSOLUTE ADDRESS FOR NEXT DATA TRANSFER
71760000
*
R2 = WORKING ADDRESS FOR THIS TRACK'S CCWS
DASD 71990000
*
R3 = ADDRESS OF SEEK, SEARCH INFORMATION BBCCHHR
72220000
*
R4 = BASE ADDRESS OF CDCPARS
72450000
*
R5 = ABSOLUTE STARTING ADDRESS OF SECOND AREA (GENERALLY 72680000
*
SVI + M)
72910000
*
73140000
CCC2
ST
3,0(2)
FIRST WORD OF SEEK
73370000
MVC 4(4,2),=X'40000006'
SECOND WORD OF SEEK
73600000
TS
CCFIRST
IS THIS THE FIRST WRITE PASS
DASD 74060000
BNZ CCC5
NO
DASD 74290000
TM
CDCFLAGS,RPS
WAS RPS SELECTED
DASD 74520000
BZ
CCC5
NO
DASD 74750000
MVC 9(7,2),RPSCCW+1
MOVE IN MOST OF CCW
DASD 74980000
MVI 8(2),SETSECTR
MOVE IN THE COMMAND
DASD 75210000
LA
2,8(2)
BUMP PAST THIS CCW
DASD 75440000
CCC5
EQU *
DASD 75670000
.NORPS1 ANOP
SIGH...
DASD 75900000
A
3,CCSKD
CHANGE SEEK TO SCHIDE
76130000
ST
3,8(2)
FIRST WORD OF SCHIDE
76360000
LA
0,8(2)
ADDRESS FOR TIC
76590000
ST
0,16(2)
TIC BACK TO SCHIDE
76820000
MVC 12(5,2),=X'4000000508' SECOND WORD OF SCHIDE AND TIC 77050000
*
SETUP CCHH FOR NEXT TRACK
77280000
ST
1,24(2)
DATA TRANSFER CCW
77510000
LA
1,1
DASD 77740000
A
1,0(3)
INCREMENT HEAD
DASD 77970000
EX
1,CC10
CLI HMAX+1,0
78200000
BH
*+8
78430000
A
1,CCADJ
INCR CYL, RESET HEAD
78660000
ST
1,8(3)
CCHH NEXT TRACK
78890000
S
3,CCSKD
CHANGE BACK TO SEEK
79120000
L
1,24(2)
RESTORE R1
79350000
*
FOLLOWING INSTRUCTION IS SET BY INITIALIZATION OF THIS LOOP
79580000
MVC 24(1,2),DOP+1
MOVE IN OP CODE (READ OR WRITE) DASD 79810000
MVC 28(4,2),TLENC
2ND WORD OF WD OR RD
80040000
A
1,TLENF
TRACK LENGTH
80270000
C
1,ARLIM
80500000
BL
CCC1
80730000
*
END OF AN AREA
80960000
BE
CCC3
AREA FILLS LAST TRACK
81190000

*
*
CCC6

CCC4

CCC3

*
CCC1
CCEND
CCENDX

*
CCCX

CCCY

*
CCCZ
.DISK
CCCX

DATA CHAIN BETWEEN END AREA 1 AND START AREA 2

L
0,ARLIM
S
0,24(2)
LH
1,28+2(2)
ST
0,28(2)
COUNT FOR FIRST CCW
MVI 28(2),SLI
5989
TM
CDCFLAGS,CDCNDC
MAY WE DATA CHAIN TO SVI?
5989
BO
CCC3
NO
5989
MVI 28(2),DC
SR
1,0
BYTES REMAINING IN TRACK
LA
1,0(1)
DESTROY HIGH ORDER GARBAGE
ST
1,36(2)
DC CCW WORD COUNT
ST
5,32(2)
DC CCW ADDRESS
AR
1,5
NEXT CCW ADDRESS
LA
2,8(2)
SPACE FOR DC WORD
TS
CCPASS
IS THIS END OF SECOND AREA
BC
7,CCEND
YES
OI
28(2),CC
COMMAND CHAIN FLAG
5989
L
0,WLEN
A
0,CCPAR1
M
ST
0,ARLIM
SETUP NEW AREA LIMIT
CR
1,0
CHECK FOR CCW COUNT GTR WLEN-SVI
BL
CCC1
NORMAL CASE
BH
CCC6
LR
1,5
START ADDR, NEXT DATA TRANSFER
TS
CCPASS
IS THIS END OF SECOND AREA
BC
8,CCC4
NO
NI
28(2),SLI
CCW FLAGS
5989
B
CCENDX
EXACTLY FILLS LAST TRACK
ALL FOUR CCW'S FOR TRACK ARE DONE
LA
2,32(2)
ADVANCE CAW
AH
3,=H'8'
NEW SEEK ADDRESS
B
CCC2
DO NEXT TRACK
MVI 28(2),X'10'
NO CHAINING, BUT SKIP DATA
MVC 25(3,2),CCPAR1+1
SKIP CCW ADDR
LA
2,32(2)
ST
2,EXPCSW
FOR USE AT SELNOR
SR
0,0
EXPECT RESIDUAL COUNT OF 0
STH 0,EXPCSW+6
L
0,CCWAD
SELSTAR PARAMETER
BR
6
RETURN
DROP 4
MX OR SVI INVALID, MAY BE DISK READ TROUBLE
AIF ('&SYSECT' EQ 'DISKSECT').DISK
DASD
CLI DOP+1,X'06'
BNE CCCY
WRITE COMMAND
MVI SELFERR,1
FORCE ERROR
BR
6
LA
4,FREE-M
ABANDON THIS WORKSPACE
LR
5,4
WRITE THE WORKSPACE BACK TO SWAP DSK
STM 4,5,MX-M(1)
LA
4,CCCZ
ST
4,FRSAVE-M+36(1)
WE NOW HAVE LEGAL MX, SVI AND SAVED
BR
7
REENTER REMCDC
DASD
PSW POINTING TO A 'LOAD EMPTY' SVC.
LEMP
AGO .SUP
DASD
ANOP
DASD
MVI REJECT-M(1),1
DASD

81420000
81650000
81880000
82110000
82340000
82570000
82800000
83030000
83260000
83490000
83720000
83950000
84180000
84410000
84640000
84870000
85100000
85330000
85560000
85790000
86020000
86250000
86480000
86710000
86940000
87170000
87400000
87630000
87860000
88090000
88320000
88550000
88780000
89010000
89240000
89470000
89700000
89930000
90160000
90390000
90620000
90850000
91080000
91310000
91540000
91770000
92000000
92230000
92460000
92690000
92920000
93150000
93380000
93610000
93840000
94070000
94300000
94530000
94760000
94990000

BR
6
DASD
ANOP
DASD
MEND
./ ADD
NAME=SDREQ
MACRO
&L
SDREQ &BUF
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
LA
0,&BUF
SVCC YYSDR
SPECIAL DISK REQUEST
MEND
./ ADD
NAME=SIGNAL
MACRO
&L
SIGNAL &COND
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
LA
0,ON&COND
L
1,=V(SIGNAL)
BALR 1,1
MEND
./ ADD
NAME=SVCC
MACRO
&N
SVCC &CODE
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
LCLC &X,&C
&X
SETC '&CODE'
&C
SETC '0'
AIF ('&CODE'(1,2) NE 'YY').S2
&C
SETC '&CODE'
&X
SETC 'MAP'
.S2
ANOP
&N
DC
0H'0',AL4(APL&X-APLSVC+X'0A00'*X'10000')
ORG *-2
AIF ('&X' NE 'MAP').YCON
DC
Y(&C)
.YCON
MEND
./ ADD
NAME=SVRAPE
MACRO
&L
SVRAPE
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
SVCC YYRAPE
MEND
./ ADD
NAME=TCOM
MACRO
&L
TCOM &TYPE,&ADDR
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
LCLC &CODE
.*
TERMINAL COMMUNICATION MACRO
.*
FIRST PARAMETER MAY BE ...
.*
SUSPEND
NO MESSAGE, JUST SUSPEND SENDER
.*
RECEIVE
ACCEPT MESSAGES FROM OTHER TERMINALS
.*
DELAY
DELAY FOR REQUESTED TIME INTERVAL
.SUP

95220000
95450000
95680000
11110000
22220000
33330000
44440000
55550000
66660000
77770000
88880000
10000000
20000000
30000000
40000000
50000000
60000000
70000000
80000000
90000000
05550000
11100000
16650000
22200000
27750000
33300000
38850000
44400000
49950000
55500000
61050000
66600000
72150000
77700000
83250000
88800000
94350000
12500000
25000000
37500000
50000000
62500000
75000000
87500000
01610000
03220000
04830000
06440000
08050000
09660000
11270000
12880000
14490000
16100000
17710000

.*
.*
.*
.*
.*
.*
.*
.*
.*
&L

MSG
PA
HI
LOG
BREL
SOOK
OFFH
OFF

SEND MESSAGE TO TERMINAL R1

SEND MESSAGE TO ALL TERMINALS
SET MESSAGE FOR NEW SIGNONS
SEND MESSAGE TO LOG
RELEASE BUFFER CHAIN
SIGN ON OK
SIGN OFF BUT HOLD TELEPHONE LINE
SIGN OFF IMMEDIATELY

DC
0H'0'
AIF ('&TYPE' EQ 'RECEIVE').TC5
&CODE
SETC '&TYPE'
AIF ('&TYPE' EQ 'LOG' OR '&TYPE' EQ 'HI').TC11
AIF ('&TYPE' EQ 'BREL' OR '&TYPE' EQ 'SOOK').TC9
AIF ('&TYPE' EQ 'OFF' OR '&TYPE' EQ 'OFFH').TC2
&CODE
SETC 'TRAN'
AIF ('&TYPE' EQ 'MSG').TC11
AIF ('&TYPE' EQ 'SUSPEND').TC1
&CODE
SETC 'BROAD'
AIF ('&TYPE' EQ 'PA').TC11
&CODE
SETC 'DEL'
AIF ('&TYPE' EQ 'DELAY').TC6
MNOTE 'INCORRECT COMMUNICATION TYPE FOR TCOM'
MEXIT
.TC5
NOP 0
8 BYTE EXPANSION FOR OUTWAITM
*
SVCC YYREC
SVCC YYREC
MEXIT
.TC6
AIF ('&ADDR' EQ '(0)').TC9
AIF ('&ADDR'(1,1) EQ '(').TC8
AIF (T'&ADDR NE 'N').TC7
AIF (&ADDR LT X'1000').TC10 FITS IN A LA
.TC7
L
0,=A(&ADDR)
AGO .TC9
.TC11
AIF ('&ADDR' EQ '(0)').TC9
AIF ('&ADDR'(1,1) EQ '(').TC8
.TC10
LA
0,&ADDR
.TC9
SVCC YY&CODE
MEXIT
.TC8
LR
0,&ADDR(1)
AGO .TC9
.TC1
LA
0,0
THIS IS GLITCH TO SUSPEND
SVCC YY&CODE
MEXIT
.TC2
NOP 0
SVCC YY&CODE
MEND
./ ADD
NAME=TQE
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
TQE
DSECT
TQEFLGS DS
0C
TQETCB DS
A
TQEFLNK DS
A
FORWARD LINK.
TQEBLNK DS
A
BACKWARD.
TQEVAL DS
F
INITIALLY, INTERVAL IN OS TU.
TQELHPSW DS
F
LEFT HALF OF TCER PSW.
TQESAV DS
F
STIMER WORK AREA.
TQESAADR DS
A
R13 CONTENTS ON ENTRY TO TCER.
TQEEXIT DS
A
A(TCER)

3039
3039

C049
C049
C049

19320000
20930000
22540000
24150000
25760000
27370000
28980000
30590000
32200000
33810000
35420000
37030000
38640000
40250000
41860000
43470000
45080000
46690000
48300000
49910000
51520000
53130000
54740000
56350000
59570000
61180000
62790000
64400000
67620000
69230000
70840000
72450000
74060000
75670000
77280000
78890000
80500000
82110000
83720000
85330000
86940000
88550000
90160000
91770000
94990000
96600000
98210000
06660000
13320000
19980000
26640000
33300000
39960000
46620000
53280000
59940000
66600000
73260000
79920000

TQEGRS DS
16F
GRS FROM TCB DURING LIFE OF IRB.
TQEIQE DS
2F
IQE FOR IRB.
./ ADD
NAME=TRCOMP
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
TRCOMP EQU *
*
COMPUTE TRACK COUNT FOR SAVE DIRECTORY SEARCH
*
TRACK COUNT IS
*
CEIL(MAX/TLEN,(TLEN LSS MX+WLEN-SVI)/WLEN MIN (MX MAX TLEN)
*
+WLEN-SVI) DIV TLEN
*
OR IN VAGUE ENGLISH,
*
IF M TO MX IS 1 TRACK OR MORE, TRACK COUNT IS TRACKS
*
NEEDED FOR M TO MX AND SVI TO WLEN.
*
IF SVI IS LESS THAN TRACK LENGTH, TRACK COUNT IS TRACKS
*
NEEDED TO WRITE OUT ENTIRE WORKSPACE.
*
IF M TO MX AND SVI TO WLEN FIT ON ONE TRACK, TRACK COUNT
*
IS 1.
*
IF MX IS LESS THAN TRACK LENGTH AND DATA WON'T FIT ON
*
ONE TRACK, TRACK COUNT IS AS IF MX EQUALLED TRACK LENGTH
*
*
SEE DISCUSSION OF CASES IN CDCOMP.
*
USING CDCPARS,4
*
ASSUME ALL LIBRARY DEVICES ARE OF THE SAME TYPE * * *
LM
0,1,MX
MX, SVI
A
0,=F'7'
ROUND MX TO DOUBLE WORD BOUNDARY
N
0,=F'-8'
N
1,=F'-8'
ROUND SVI DOWN
LR
5,0
L
2,TLENF
L
3,WLEN
SR
1,3
SVI - WLEN
SR
0,1
WLEN+MX-SVI
CR
0,2
VS TLEN
BNH TCOMP1
1-TRACK WORKSPACE
SR
2,5
ROUNDED MX.
BNP *+6
AR
0,2
(WLEN-SVI) + MX MAX TLEN
LR
1,0
CR
1,3
MAYBE FULL WORKSPACE
LR
2,3
BL
*+6
NO
TCOMP1 LR
1,2
A
1,TLENF
ROUND UP FOR DIVIDE
BCTR 1,0
SR
0,0
D
0,TLENF
TRACK COUNT IN R1
*
END OF TRCOMP COPY * * * * * * *
./ ADD
NAME=TYI
MACRO
&L
TYI
.*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
.*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
&L
SVCC YYTYI
MEND
./ ADD
NAME=TYO
MACRO
&L
TYO &TEXT

86580000
93240000
02120000
04240000
06360000
08480000
10600000
12720000
14840000
16960000
19080000
21200000
23320000
25440000
27560000
29680000
31800000
33920000
36040000
38160000
40280000
42400000
44520000
46640000
48760000
50880000
53000000
55120000
57240000
59360000
61480000
63600000
65720000
67840000
69960000
72080000
74200000
76320000
78440000
80560000
82680000
84800000
86920000
89040000
91160000
93280000
95400000
97520000
12500000
25000000
37500000
50000000
62500000
75000000
87500000
11110000
22220000

.*
.*
.*
&L

5734-XM6 COPYRIGHT IBM CORP. 1969, 1970

5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
LA
0,&TEXT
SVCC YYTYO
MEND
./ ADD
NAME=ZSYMBOLS
TITLE 'Z S Y M B O L S -- G L O B A L D E F I N A T I O N S'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
ZILG
EQU 0
DENOTES ILLEGAL CHARACTER
ZEOS
EQU 1
END OF STATEMENT
ZLEOS
EQU 2
END OF STATEMENT CONTAINING LABEL
ZDUM
EQU 3
DUMMY CHARACTER
ZBFZ
EQU 4
END OF BUFFER MARKER
ZFILL2 EQU 5
ZFILL3 EQU 6
ZFCOLON EQU 7
FAKE COLON
ZFPER
EQU 8
FAKE PERIOD
ZECONST EQU 9
FLOATING POINT CONSTANT (E-FORMAT)
ZBCONST EQU 10
BIT CONSTANT
ZICONST EQU 11
INTEGER CONSTANT
ZFCONST EQU 12
FLOATING POINT CONSTANT
ZCCONST EQU 13
CHARACTER CONSTANT
ZLBR
EQU 14
LEFT BRACKET
ZRBR
EQU 15
RIGHT BRACKET
ZLPAR
EQU 16
LEFT PARENTHESIS
ZRPAR
EQU 17
RIGHT PARENTHESIS
ZSEMIC EQU 18
SEMICOLON
ZSLASH EQU 19
SLASH
ZBSLASH EQU 20
BACK SLASH
ZLARROW EQU 21
LEFT ARROW
ZRARROW EQU 22
RIGHT ARROW
ZFE
EQU 23
FAKE E (FOR E-FORMAT NUMBERS)
ZFOVB
EQU 24
FAKE OVERBAR (HIGH MINUS)
ZDIER
EQU 25
DIERESIS (UPSHIFT 1)
ZPLUS
EQU 26
PLUS
ZMINUS EQU 27
MINUS
ZTIMES EQU 28
TIMES
ZDIV
EQU 29
DIVIDE
ZSTAR
EQU 30
STAR
ZMAX
EQU 31
MAXIMUM
ZMIN
EQU 32
MINIMUM
ZMOD
EQU 33
RESIDUE
ZAND
EQU 34
AND
ZOR
EQU 35
OR
ZLT
EQU 36
LESS THAN
ZLE
EQU 37
LESS THAN OR EQUAL
ZEQ
EQU 38
EQUAL
ZGE
EQU 39
GREATER THAN OR EQUAL
ZGT
EQU 40
GREATER THAN
ZNE
EQU 41
NOT EQUAL
ZALPHA EQU 42
ALPHA
ZEPS
EQU 43
EPSILON
ZIOTA
EQU 44
IOTA
ZRHO
EQU 45
RHO
ZOMEGA EQU 46
OMEGA
ZCOMMA EQU 47
COMMA
ZSHRIEK EQU 48
SHRIEK (EXCLAMATION)

33330000
44440000
55550000
66660000
77770000
88880000
00590000
01180000
01770000
02360000
02950000
03540000
04130000
04720000
05310000
05900000
06490000
07080000
07670000
08260000
08850000
09440000
10030000
10620000
11210000
11800000
12390000
12980000
13570000
14160000
14750000
15340000
15930000
16520000
17110000
17700000
18290000
18880000
19470000
20060000
20650000
21240000
21830000
22420000
23010000
23600000
24190000
24780000
25370000
25960000
26550000
27140000
27730000
28320000
28910000
29500000
30090000
30680000
31270000

ZREV
ZBASE
ZREP
ZCIRCLE
ZQUERY
ZNOT
ZUARROW
ZDARROW
ZSUB
ZRSUB
ZCAP
ZCUP
ZUND
ZTRAN
ZHIST
ZNULL
ZQUAD
ZQUADP
ZLOG
ZNAND
ZNOR
ZREM
ZUPGRADE
ZDNGRADE
ZCOLREV
ZCOLSLSH
ZCOLBSLH
ZDOMINO
ZFILL17
ZFILL18
ZFILL19
ZFILL20
ZFILL21
ZFILL22
ZFILL23
ZTDELTA
ZSDELTA
ZA
ZB
ZC
ZD
ZE
ZF
ZG
ZH
ZI
ZJ
ZK
ZL
ZM
ZN
ZO
ZP
ZQ
ZR
ZS
ZT
ZU
ZV
ZW

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108

REVERSAL
CODE (BASE)
DECODE (REPRESENTATION)
CIRCLE
QUERY
NOT
UP- ARROW
DOWN ARROW
SUBSET
RIGHT SUBSET
CAP
CUP
UNDERSCORE
TRANSPOSE
I-BEAM
NULL (SMALL CIRCLE)
QUAD
QUAD-QUOTE
LOG
NAND
NOR
LAMP-COMMENT
UPGRADE
DOWN GRADE
OVERSTRUCK CIRCLE-HYPHEN
OVERSTRUCK SLASH-HYPHEN
OVERSTRUCK BACKSLASH-HYPHEN

TRACE (T DELTA)
PROGRAMMED STOP (S DELTA)

31860000
32450000
33040000
33630000
34220000
34810000
35400000
35990000
36580000
37170000
37760000
38350000
38940000
39530000
40120000
40710000
41300000
41890000
42480000
43070000
43660000
44250000
44840000
45430000
46020000
46610000
47200000
47790000
48380000
48970000
49560000
50150000
50740000
51330000
51920000
52510000
53100000
53690000
54280000
54870000
55460000
56050000
56640000
57230000
57820000
58410000
59000000
59590000
60180000
60770000
61360000
61950000
62540000
63130000
63720000
64310000
64900000
65490000
66080000
66670000

ZX
EQU 109
ZY
EQU 110
ZZ
EQU 111
ZDELTA EQU 112
ZAU
EQU 113
ZBU
EQU 114
ZCU
EQU 115
ZDU
EQU 116
ZEU
EQU 117
ZFU
EQU 118
ZGU
EQU 119
ZHU
EQU 120
ZIU
EQU 121
ZJU
EQU 122
ZKU
EQU 123
ZLU
EQU 124
ZMU
EQU 125
ZNU
EQU 126
ZOU
EQU 127
ZPU
EQU 128
ZQU
EQU 129
ZRU
EQU 130
ZSU
EQU 131
ZTU
EQU 132
ZUU
EQU 133
ZVU
EQU 134
ZWU
EQU 135
ZXU
EQU 136
ZYU
EQU 137
ZZU
EQU 138
ZDELTAU EQU 139
Z0
EQU 140
Z1
EQU 141
Z2
EQU 142
Z3
EQU 143
Z4
EQU 144
Z5
EQU 145
Z6
EQU 146
Z7
EQU 147
Z8
EQU 148
Z9
EQU 149
ZPER
EQU 150
PERIOD
ZOVB
EQU 151
OVERBAR
ZBLANK EQU 152
BLANK
ZQUOTE EQU 153
QUOTE
ZCOLON EQU 154
COLON
ZDEL
EQU 155
DEL (FN DEFN CHAR)
ZCR
EQU 156
CARRIAGE RETURN
ZEOB
EQU 157
END OF BLOCK
ZBS
EQU 158
BACKSPACE
ZLF
EQU 159
LINEFEED
ZPDEL
EQU 160
PROTECTION DEL
ZPFX
EQU 161
CIRCLE-D (PREFIX)
ZBSUC
EQU 162
UPPER CASE BACKSPACE
ZLENGTH EQU 163
LENGTH OF ZSYMBOL TABLE
./ ADD
NAME=APLSAGOR
AGOR
TITLE 'T H E A G O R A N O M I C R O U T I N E S 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969,1970,1972
*
5736-XM6 COPYRIGHT IBM CORP. 1969,1970,1972
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083

67260000
67850000
68440000
69030000
69620000
70210000
70800000
71390000
71980000
72570000
73160000
73750000
74340000
74930000
75520000
76110000
76700000
77290000
77880000
78470000
79060000
79650000
80240000
80830000
81420000
82010000
82600000
83190000
83780000
84370000
84960000
85550000
86140000
86730000
87320000
87910000
88500000
89090000
89680000
90270000
90860000
91450000
92040000
92630000
93220000
93810000
94400000
94990000
95580000
96170000
96760000
97350000
97940000
98530000
99120000
00400000
00800000
01200000
01600000

PRINT OFF
APLDEFN, PERTERM
GETSPACE CSECT
PRINT NOGEN
COPY APLDEFN
COPY PERTERM
TITLE 'T H E A G O R A N O M I C R O U T I N E S 05/11/70'
PRINT ON
GETSPACE CSECT
EXTRN ERROR
*
GETSPACE
*
GET SPACE FOR AN ENTRY IN M.
*CALLED WITH R1 = BYTE COUNT
*
R2 = CREATE TEMP EST ENTRY ON STACK IF R2 = 0
*
RETURNS BASE ADDRESS OF ENTRY IN R1
*
HEADER AND MX ARE ALWAYS ALIGNED ON WORD BOUNDARIES.
PROLOG LOCALS,LE
STM 0,7,GTVH-4
SAVE PARAMS AND CALLER'S REGS
GTV01
LA
4,3
PICK UP NO. OF BYTES,
A
4,GTVH
ROUNDED UP TO A WORD BOUNDARY.
N
4,QFM4
L
1,MX
ADD THAT TO TOP OF CURRENTLY
AR
4,1
OCCUPIED SPACE
L
3,SVI
COMPARE NEW BASE OF FREE STORAGE
LR
2,3
S
3,QF40
(PLUS A LITTLE SLOP)
CLR 4,3
WITH TOP OF INVERTED STACK.
BL
GTV02
DO WE HAVE ENOUGH SPACE -BAL LKR,GCOL
NO. DO A GARBAGE COLLECTION.
B
GTV01
THEN RETRY.
*
*
STORAGE RESERVATION PERFORMED SUCCESSFULLY
GTV02
L
0,GTVE
SHOULD WE CREATE A STACK ENTRY
LTR 0,0
TO GO WITH THIS M-ENTRY -BNE GTV03
NO.
LR
0,1
COPY OLD MX TO R0
O
0,QTMPCLS
OR IN TEMP CLASS TO BUILD EST ENTRY
ST
0,0(2,MR)
AND PUT IT ON TOP OF STACK.
LA
3,36(3)
***** NOTE DEPENDENCY ON S 3,QF40 **
ST
3,SVI
DROP STACK POINTER.
ST
2,MHEAD(1)
STORE STACK POINTER IN FIRST WORD OF
GTV03
ST
4,MX
M-ENTRY, THEN GIVE MX ITS NEW VALUE.
SR
4,1
FIND AGGREGATE BYTE COUNT OF M-ENTRY
ST
4,MCOUNT(1)
AND STORE THIS IN COUNT WORD OF
*
M-ENTRY.
L
0,GTVH-4
LM
2,7,GTVH+4
IRETURN
ALL DONE.
EJECT
ENTRY MKGARB
* *********************************************************************
*
WARNING -- THIS PROGRAM BYPASSES THE LINKAGE MACRO.
*
LOOK CLOSELY IF YOU CHANGE THE LINKAGE.
* *********************************************************************
USING MKLOCLS,14
*
EXCEPT FOR HIGH-ORDER 8 BITS OF R1,
MKGARB LTR 1,1
MKGARB SAVES ALL REGISTERS USED.
BCR 4,15
IGNORE CALL IF POINTER IS INDIRECT.
STM 15,3,MKGSR
MVI MKGHOL,0
BALR 15,0

02400000
02800000
03200000
03600000
04000000
04400000
04800000
05200000
05600000
06000000
06400000
06800000
07200000
07600000
08000000
08400000
08800000
09200000
09600000
10000000
10400000
10800000
11200000
11600000
12000000
12400000
12800000
13200000
13600000
14000000
14400000
14800000
15200000
15600000
16000000
16400000
16800000
17200000
17600000
18400000
18800000
19200000
19600000
20000000
20400000
20800000
21200000
21600000
22000000
22400000
22800000
23200000
23600000
24000000
24400000
24800000
25200000
25600000
26000000
26400000

*
*

MKGT01

*
MKG03
*
*

*
MKG04
*
*

*
*
*
*
*
*
*
MKG07
*

MKG06
*
*
*

USING *,15
N
1,QF24BITS
BZ
MKG06
IGNORE CALL IF ADDRESS IS ZERO.
LA
2,0(1,MR)
ON ENTRY, R1 IS POINTER TO M-ENTRY WHICH IS TO BE MARKED
GARBAGE. IF M-ENTRY IS A LIST, ALL SUBLISTS ARE MARKED TOO.
TM
MGARB-M(2),MGBIT
FOR DEBUGGING, SEE IF THIS IS
BZ
MKGT01
ALREADY GARBAGE.
LA
1,ESYSTEM
IF IT IS, DISASTER.
ICALL ERROR
EQU *
OI
MGARB-M(2),MGBIT
MARK THIS THING GARBAGE.
C
1,MING
IF IT IS LOWER THAN MINIMUM GARBAGE
BH
MKG03
UP TO NOW,
ST
1,MING
STORE ITS ADDRESS.
MING GIVES GCOL A HEAD START.
L
0,MINGL
ADD LENGTH OF THIS M-ENTRY
A
0,MCOUNT(1)
TO MINGL.
ST
0,MINGL
SUPERVISOR MAY USE THIS TO DETERMINE
UTILITY OF A GARBAGE COLLECTION
BEFORE DISK SWAP.
TM
MLIST-M(2),MLSTBIT IS THIS THING A LIST -BZ
MKG07
NO. BYPASS SUBLIST MARKING.
LH
2,MLSCT(1)
THIS IS A LIST. GET COUNT OF
SLL 2,2
ELEMENTS, TIMES FOUR,
AH
2,MLSOS(1)
PLUS OFFSET, TO DETERMINE ADDRESS OF
LAST SUBLIST ENTRY IN THIS LIST.
CH
2,MLSOS(1)
HAVE WE LOOKED AT ALL SUBLISTS -BNH MKG07
YES. ADDRESS OF CURRENT SUBLIST
ENTRY EQUALS OFFSET (I.E. BELOW
FIRST SUBLIST ENTRY).
S
2,QF4
NO. DROP SUBLIST ENTRY ADDRESS.
LA
3,0(2,1)
R3 IS M-RELATIVE SUBLIST ENTRY ADDR
L
0,M(3)
PICK UP SUBLIST ENTRY.
LTR 0,0
IS IT AN M-POINTER -BNP MKG04
NO. EMPTY OR A SYMBOL TABLE POINTER
ST
2,M(3)
YES. SAVE SUBLIST ADDRESS IN JUSTVACATED SUBLIST ENTRY POSITION.
WE FIND OUR WAY BACK FROM SUBLIST
BY USING SUBLIST'S M-HEADER WHICH
POINTS BACK TO THIS POSITION, WHICH
(IN A RELATIVE WAY) POINTS TO M-HEAD
OF THIS LIST.
LR
1,0
R1 IS NOW M-POINTER OF SUBLIST.
BR
15
BACK TO TOP OF MKGARB FOR SUBLIST.
WE ENCOUNTERED A NON-LIST OR REACHED END OF A LIST
C
1,MKGHOL
DOES CURRENT MPTR (R1) EQUAL MPTR WE
CAME IN WITH -BE
MKG06
YES. WRAP UP.
L
1,M(1)
NO. THREAD OUR WAY BACK TO HIGHER
N
1,QF24BITS
L
2,M(1)
LEVEL LIST.
SR
1,2
R2 IS OFFSET FROM MPTR.
B
MKG04
LM
15,3,MKGSR
RELOAD ALL ALTERED REGISTERS
BR
15
AND RETURN.
EJECT
GCOL COMPACTS ENTRIES IN FREE-STORAGE AREA, DELETING ALL
ENTRIES WITH THE GARBAGE BIT ON AND RELOCATING ALL POINTERS

26800000
27200000
27600000
28000000
28400000
28800000
29200000
29600000
30000000
30400000
30800000
31200000
31600000
32000000
32400000
32800000
33200000
33600000
34000000
34400000
34800000
35200000
35600000
36000000
36400000
36800000
37200000
37600000
38000000
38400000
38800000
39200000
39600000
40000000
40400000
40800000
41200000
41600000
42000000
42400000
42800000
43200000
43600000
44000000
44400000
44800000
45200000
45600000
46000000
46400000
46800000
47200000
47600000
48000000
48400000
48800000
49200000
49600000
50000000
50400000

*
LEADING TO OR FROM A RELOCATED ENTRY, INCLUDING MULTIPLE
*
(LIST OR FUNCTION DIRECTORY) POINTERS.
******** GCOL MUST NOT BE INTERRUPTED BY END QUANTUM.
ENTRY GCOL
GCOL
PROLOG GCOLT,GCOLE
STM 0,7,GCOLT
L
6,MING
FIND LOWEST GARBAGE ENTRY
LR
7,6
THROUGHOUT,
*
R4 = BYTE COUNT OF LIVE ENTRY
*
R6 = SOURCE ADDRESS OF LIVE ENTRIES
*
R7 = SINK ADDRESS
*
REENTRY AFTER MOVING LIVE ENTRY OR DELETING GARBAGE
SR
4,4
ST
4,MINGL
SET GARBAGE BYTE COUNT TO ZERO
MVC MING(4),MX
DOING THIS NOW HELPS TO PREVENT
*
ENDLESS LOOPS THROUGH PCSUB AND GCOL
GC01
AR
6,4
ADJUST SOURCE BY GARBAGE BYTE COUNT
GC02
C
6,MING
HAVE WE REACHED END OF USED SPACE -BNL GC09
YES.
L
3,MHEAD(6)
NO. PICK UP HEADER WORDS.
L
4,MCOUNT(6)
LTR 3,3
IS THIS ENTRY GARBAGE -BM
GC01
YES. IGNORE GARBAGE BY SPACING PAST
L
1,M(3)
NO. CHECK FOR VALID POINTER.
LA
0,0(1)
POINTEE MUST POINT BACK TO US
CR
0,6
BNE QF4
IF NOT EQ, FORCE PGM CHECK
2213
AR
6,MR
FOR THE REMAINDER OF ANALYSIS OF
*
THIS M-ENTRY, R6 WILL BE ABSOLUTE.
IC
0,M(3)
ADJUST THE POINTER OF ITEM WHICH
ST
7,M(3)
REFERENCES THIS ENTRY
STC 0,M(3)
TM
MLIST-M(6),MLSTBIT IS THIS ENTRY A LIST -BZ
GC10
NO. GO RELOCATE THIS ENTRY.
LH
2,MLSOS-M(6)
YES. LOAD OFFSET OF FIRST POINTER
LH
5,MLSCT-M(6)
AND COUNT OF LIST POINTERS.
LA
1,0(2,7)
R1 IS REL ADDR OF SINK LIST ENTRY
AR
2,6
MAKE R2 = RELATIVE ADDR
SR
2,MR
OF LIST ENTRY
LTR 5,5
LIST MAY BE EMPTY
BZ
GC10
IT IS. SKIP POINTER-ADJUSTMENT LOOP.
GC07
L
3,M(2)
FOR EACH POINTER IN THIS ENTRY,
LTR 3,3
IF THE POINTER IS NEITHER ZERO
BNP GC08
NOR NEGATIVE (FLAG TO INDICATE THAT
*
POINTED ITEM IS IN BST AND DOES NOT
*
POINT BACK TO US),
IC
0,M(3)
ST
1,M(3)
STC 0,M(3)
GC08
LA
2,4(2)
GET ADDRESS OF NEXT POINTER
LA
1,4(1)
IN SINK AREA ALSO
BCT 5,GC07
AND ADJUST ITS POINTEE.
*
*
ALL POINTERS TO THIS ENTRY HAVE BEEN ADJUSTED.
GC10
LA
0,256
THE REAL GARBAGE COLLECTION.
LA
2,0(7,MR)
R2 IS ABSOLUTE SINK ADDRESS
AR
7,4
PREBUMP R7 TO END OF SINK AREA
S
4,QF257
ADJUST BYTE COUNT FOR MVC
*
AND SHORT LAST MOVE.
BM
GC11
NEXT IS FOR ENTRIES GTR 256 BYTES

50800000
51200000
51600000
52000000
52400000
52800000
53200000
53600000
54000000
54400000
54800000
55200000
55600000
56000000
56400000
56800000
57200000
57600000
58000000
58400000
58800000
59600000
60000000
60800000
61200000
61600000
62000000
62400000
62800000
63200000
63600000
64000000
64400000
64800000
65200000
65600000
66000000
66400000
66800000
67200000
67600000
68000000
68400000
68800000
69200000
69600000
70400000
70800000
71200000
71600000
72000000
72400000
72800000
73200000
73600000
74000000
74400000
74800000
75200000
75600000

LA
*
GC12
*
GC11
*
*
*
*
*
*

1,0(2,4)

R1 IS LIMIT FOR R2 IN BXLE

( = LENGTH - 257 + SINK ADDRESS)
MVC 0(256,2),0(6)
MOVE 256 BYTES AT A TIME
AR
6,0
ADD 256 TO SOURCE ADDRESS
BXLE 2,0,GC12
AND TO SINK, AND BRANCH FOR NEXT
LONG MOVE.
EX
4,GCMVC
FINISH UP MOVE WITH A SHORT MVC.
SR
6,2
ADJUST SOURCE
AR
6,7
TO RELATIVE ADDR OF NEXT ENTRY.
NOTES ON PREVIOUS TWO INSTRUCTIONS ..
R2 = R7 + MR + FLOOR (R4-1) DIV 256
R6' = R6 + FLOOR (R4-1) DIV 256
R7' = R7 + R4
SO R6' + R7' - R2 = R6 + R4 - MR
B

*
*
*
*
GC09

GC19
GC18
*
GCMVC
QFM4
*
*
*
QF4
QF40
QF257
QF24BITS
QTMPCLS

GC02
COLLECTION COMPLETED. CHECK FOR M FULL AND SYSTEM ERROR
GIVE MX AND MING NEW VALUE OF TOP OF
COMPACTED SPACE.
SYSTEM ERROR IF WE DIDN'T HIT MX
ST
7,MX
EXACTLY WITH OUR SOURCE INDEX.
ST
7,MING
LA
1,ESYSTEM
BNE GC19
CR
6,7
DID WE COLLECT ANY GARBAGE AT ALL -BNE GC18
YES. QUIT WITH SATISFACTION.
LA
1,EMFULL
NO. GCOL'S CALLER HAS RUN OUT OF
ICALL ERROR
SPACE.
LM
0,7,GCOLT
IRETURN

MVC 0(0,2),0(6)
EXECUTED MVC
DC
F'-4'
GCOL NEEDS X'00' IN HI ORDER BYTE OF FOLLOWING CONSTANT
TO FORCE PGM CHECK -- EVEN ON MACHINES THAT DON'T
REQUIRE BOUNDARY ALIGNMENT FOR CPU INSTRUCTIONS.
DC
F'4'
DC
F'40'
DC
F'257'
DC
X'00FFFFFF'
DC
AL1(CONST)
DC
FL3'0'
LTORG
LOCALS DSECT
DS
F
GTVH
DS
F
BYTE COUNT FOR M-ENTRY
GTVE
DS
F
SHOULD WE MAKE AN EST ENTRY
DS
5F
LE
EQU *
MKLOCLS DSECT
MKGSR
DS
2F
MKGHOL DS
F
M-POINTER ON ENTRY TO MKGARB
DS
2F
GCOLT
DSECT
DS
8F
REGISTER SAVE
GCOLE
EQU *
END
./ ADD
NAME=APLSAPLM
APLM
TITLE 'APL MOTHER.'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970

2213
2213
2213

76000000
76400000
76800000
77200000
77600000
78000000
78400000
78800000
79200000
79600000
80000000
80400000
80800000
81200000
81600000
82000000
82400000
82800000
83200000
83600000
84000000
84400000
84800000
85200000
85600000
86000000
86400000
86800000
87200000
87600000
88000000
88400000
88800000
89200000
89600000
90000000
90400000
90800000
91200000
91600000
92000000
92400000
92800000
93200000
93600000
94000000
94400000
94800000
95200000
95600000
96000000
96400000
96800000
97200000
97600000
98000000
98400000
00130000
00260000

*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
APLOS
CSECT
COPY APLDEFN
COPY PERTERM
PRINT ON
TITLE 'A P L M O T H E R - INITIATION OF APL.'
*
*
*
THIS ROUTINE ..
*
*
ATTACHES AND RUNS CONCURRENTLY WITH SUPINI ..
*
BUT ..
*
THE INITIATION IS COMPLETELY INTERLOCKED (USING WAIT AND POST)
*
AND EITHER THE MOTHER OR SUPINI IS WAITING ON THE OTHER AT ALL
*
TIMES UNTIL THE LAST POST BEFORE THE LABEL 'MOTHER'.
*
*
*
APL (OS) RUNS WITH TWO TCBS..
MFT
*
TCBMERE - ALWAYS AT THE LIMIT PRIORITY.
*
TCBFILLE - ALTERNATES BETWEEN THE LIMIT PRIORITY AND ZERO.
*
SEE CODE IN APLSUP AT APLSETHI, APLSETLO.
*
*
APL360 TIMER CODE AND MULTIPLEX CODE MUST RUN ON THE
*
MOTHER TCB.
*
APLOS
CSECT
MFT
USING *,15
C045
B
APLOSAVE
SKIP AROUND DEBUGGING AIDS
C045
DC
V(COIBM)
COPYRIGHT NOTICE
C045
DC
V(APLXREF)
THIS IS EASIER ON THE EYEBALLS C045
DROP 15
C045
APLOSAVE STM 14,12,12(13)
CONVENTIONAL SAVE OF REGISTERS C045
BALR 12,0
ESTABLISH ADDRESSING.
USING *,12
AND ALL THAT.
*
ESTABLISH AN OS PROBLEM PROGRAM SAVE AREA.
LA
14,MVTSAVE
SAVE AREA LOCATION.
ST
14,8(13)
SAVE AREA FORWARD CHAIN
K10
ST
13,OSR13-MVTSAVE(14) SAVE AREA BACK CHAIN
K10
LR
13,14
L
2,0(1)
// EXEC PARM LIST ADDRESS.
P062
ST
2,PARAM+8
PASS PARM FIELD ADDRESS TO SINI.P062
MVI PARAM+8,X'00'
TURN OFF DEBUG FLAG.
P062
CLC =H'0',0(2)
ANY PARMS?
P062
BE
ATTACH
NO.
P062
MVI PARAM+8,X'80'
TURN ON DEBUG FLAG.
P062
LR
3,2
SAVE FOR LATER.
P062
LA
4,11
OPERAND LENGTH.
P062
CLI 2(2),C'('
LIST?
P062
BNE NOPAREN
NO
P062
LA
2,1(2)
SKIP OVER LEFT PAREN.
P062
NOPAREN CLC 2(11,2),=C'DEBUG,SPLIT'
P062
BE
SPL
P062
CLC 2(11,2),=C'SPLIT,DEBUG'
P062
BE
SPL
P062
LA
4,5
OPERAND LENGTH.
P062
CLC 2(5,2),=C'DEBUG'
P062
BE
DEB
P062
MVI PARAM+8,X'00'
TURN OFF DEBUG FLAG.
P062
CLC 2(5,2),=C'SPLIT'
P062
BE
SPL
P062

00390000
00780000
00910000
01040000
01170000
01300000
01430000
01560000
01690000
01820000
01950000
02080000
02210000
02340000
02470000
02600000
02730000
02860000
02990000
03120000
03250000
03380000
03510000
03640000
03770000
03900000
04030000
04160000
04290000
04420000
04550000
04680000
04810000
04940000
05070000
05200000
05330000
05460000
05590000
05720000
05850000
05980000
06110000
06240000
06370000
06500000
06630000
06760000
06890000
07020000
07150000
07280000
07410000
07540000
07670000
07800000
07930000
08060000
08190000
08320000

INVPARM WTO

'APL
INVALID OPERAND IN PARM FIELD OF EXEC CARD', X08450000
ROUTCDE=(1,11)
P062 08580000
LA
15,24
RETURN CODE
P062 08710000
B
RETURN
RETURN TO OS.
P062 08840000
DEB
MVI ATTACHH1,0
TURN OFF H1 FLAG FOR ATTACH.
P062 08970000
SPL
SR
2,3
0 OR 1 LEFT.
P062 09100000
AR
2,2
0 OR 2
P062 09230000
LA
2,0(2,4)
MOVE PAST OPERANDS.
P062 09360000
CH
2,0(3)
PROPER LENGTH?
P062 09490000
BNE INVPARM
NO.
P062 09620000
CLI PARAM+8,X'80'
DEBUG ON?
P062 09750000
BNE ATTACH
NO.
P062 09880000
* ENSURE THERE IS 10K FOR DEBUG
P062 10010000
GETMAIN EC,LV=10240,A=GMFM
P062 10140000
LTR 15,15
CORE AVAILABLE?
P062 10270000
BZ
DEBF
YES - FREE IT.
P062 10400000
WTO 'APL
INSUFFICIENT CORE STORAGE',ROUTCDE=(1,11) P062 10530000
LA
15,4
RETURN CODE.
P062 10660000
B
RETURN
RETURN TO OS.
P062 10790000
GMFM
DS
F
P062 10920000
DEBF
FREEMAIN E,LV=10240,A=GMFM
P062 11050000
ATTACH ATTACH SF=(E,ATTACHL),MF=(E,PARAM)
P062 11180000
SPACE
11310000
*
SAVE TCB ADDRESSES.
11440000
ST
1,TCBFILLE
ADDRESS OF DAUGHTER TCB.
11570000
L
1,CVT
CVT POINTER.
11700000
USING CVTD,1
11830000
L
1,CVTTCBP
11960000
DROP 1
12090000
L
1,4(1)
CURRENT TCB ADDRESS.
12220000
ST
1,TCBMEREA
MOTHER TCB ADDRESS.
12350000
*
12480000
*
THE FOLLOWING ENQ IS USED BY THE APL UTILITIES TO DETERMINE
12610000
*
IF APL IS RUNNING.
12740000
*
IF THE UTILITIES ARE RUNNING AT THIS TIME, APL SHOULD BE
12870000
*
BLOCKED UNTIL THEY TERMINATE.
13000000
*
13130000
ENQ (QNAME,RNAME,E,,SYSTEM)
13260000
*
13390000
*
WAIT UNTIL POSTED BY SUPINI AT COMPLETION OF INITIALIZATION. 13520000
*
13650000
SPACE
13780000
WAIT ECBLIST=ECBLIST
K06 13910000
*
14040000
*
WHEN DISPATCHED, SUPINI HAS EITHER COMPLETED INITIALIZATION, 14170000
*
OR HAS GIVEN UP. RETURN CODE TELLS WHICH.
14300000
*
14430000
TM
ECBAPL,X'40'
SEE IF DAUGHTER TERMINATED.
14560000
BO
DETACH1
GIVE UP IF SO.
14690000
L
1,PARAM+4 ATTACH PARAMETER LIST WAS CHANGED BY SINI K05 14820000
MVC ALIST(ALISTZ-ALIST),0(1) MOVE LIST TO MOTHER.
14950000
*
15080000
*
PASS ADDRESSES TO APLSUP.
15210000
*
15340000
*
SUPINI HAS PASSED..
15470000
*
15600000
*
A(ECBINIT)
SUPINI'S ECB.
15730000
*
X'FLGS'
OSFLG FROM SINI
15860000
*
15990000
*
THE FOLLOWING SEQUENCE IN APLSUP IS ASSUMED.
16120000

*
*
*
*
*
*
*
*
*
*
*
*
*
*

*
*
*

*
*
*

*
*
*
*
*
*
*
*

TCBMERE
TCBFILLE
RBMERE
RBFILLE
ECBMERE
ECBFILLE
APLTCXRA

16250000
16380000
16510000
16640000
16770000
16900000
17030000
17160000
L
1,TCBMEREA
ADDRESS OF MOTHER TCB.
17290000
MVC SK(1),TCBPKE(1)
STORAGE KEY OF THIS REGION.
17420000
17550000
L
1,TCBRBP(1)
POINTER TO PRB OF MOTHER
17680000
ST
1,RBMERE
ADDRESS OF MOTHER PRB
17810000
17940000
KEEP DISPATCHING PRIORITY OF DAUGHTER SLIGHTLY LOWER THAN
18070000
MOTHER SO THAT MOTHER WILL ALWAYS BE RUN IN PREFERENCE.
18200000
18330000
L
1,TCBFILLE
ADDRESS OF DAUGHTER TCB
18460000
18590000
L
2,=A(CHAPLOW)
PRIORITY CHANGE VALUES IN APLSUP.
18720000
SR
0,0
18850000
IC
0,TCBDSP(1)
DAUGHTER DISPATCHING PRIORITY
18980000
SH
0,=H'12'
MAKE MINIMUM DPRTY=(0,12)
19110000
BNM *+6
19240000
SR
0,0
LEAVE ZERO IF TOO SMALL.
19370000
STH 0,2(2)
PRIORITY INCREMENT.
19500000
LNR 0,0
19630000
STH 0,0(2)
PRIORITY DECREMENT.
19760000
L
1,TCBRBP(1)
19890000
ST
1,RBFILLE
ADDRESS OF DAUGHTER PRB.
20020000
L
1,APLSGENE
APLSUP GENEOLOGY.
20150000
MVC 0(GENEZ-TCBMEREA,1),TCBMEREA ALL ADDRESSES TO APLSUP.
20280000
SPACE 3
20410000
THE FOLLOWING INSTRUCTION SETS THE ABEND EXIT FOR MOTHER
20540000
TO 'STEP', A ROUTINE IN THIS ASSEMBLY.
20670000
THE ABEND EXIT WILL NOT BE ENTERED ON AN OPERATOR CANCEL.
20800000
STAE STEP
C046 20930000
LTR 15,15
JUST IN CASE
21060000
BNZ STAERR
THATS ALL
21190000
EJECT
K10 21320000
21450000
ENTER SUPERVISOR STATE, DISABLED.
21580000
21710000
L
1,SVOLDPA
LOCN OF APLSUP SVC OLD.
21840000
L
11,ACURRENT
XENOPHOBIC SVC ROUTINE.
21970000
L
11,0(11)
22100000
22230000
NOTE...
22360000
ALL CODE BELOW THIS POINT MUST RUN IN SUPERVISOR STATE,
22490000
ZERO PROTECT KEY, AND DISABLED.
22620000
22750000
SVRAPE
22880000
MVC 0(2,1),=X'0004'
ONE INSTRUCTION WITH KEY OF ZERO.
23010000
23140000
SWAP IO NEW PSWS.
23270000
23400000
MVC OSIONEW(8),IONEWPSW SAVE CURRENT IO NEW PSW.
23530000
L
1,APLIONEW
LOCATION OF APLSUP IO NEW PSW.
23660000
MVC IONEWPSW(8),0(1)
TO LOW CORE.
23790000
MVC 0(8,1),OSIONEW
OS IO NEW PSW TO APLSUP.
23920000

EJECT

K10 24050000
24180000
INITIAL TIMER EVENT.
24310000
24440000
STIMER REAL,APLTCXR,TUINTVL=TWOSEC
24570000
*
THE FOLLOWING CODE OBTAINS THE ADDRESS OF THE TQE
24700000
*
CREATED BY THE INITIAL STIMER, THEN INITIALIZES THE
24830000
*
VARIABLE TQEPSECT IN APLSUP. SETINT USES TQEPSECT TO
24960000
*
REFRESH THE TQE BEFORE CALLING THE TQE ENQUEUE ROUTINE.
25090000
L
1,TCBMEREA
ADDRESS OF MOTHER TCB.
25220000
L
1,120(1)
TCBTME IN MOTHER TCB.
25350000
L
2,ATQEX
A(A(TQE)) IN APLSUP.
25480000
ST
1,0(2)
25610000
MVC 4(TQEGRS-TQEFLGS,2),0(1) TQEPSECT IN APLSUP.
25740000
*
SET TQE FLAG BYTE.
25870000
OI
4(2),X'80'
SET OFF Q FLAG
MFT 26000000
*
MFT 26130000
*
SEVERAL INSTRUCTIONS AT EXIT OF THE TIMER COMPLETION
MFT 26260000
*
EXIT ROUTINE ARE FOR MVT ONLY.
MFT 26390000
*
THEY WILL NOW BE DELETED IF THIS IS MFT
MFT 26520000
*
MFT 26650000
TM
OSFLG,MFT
MFT?
MFT 26780000
BZ
RELSINI
NO CHANGES IF MVT
MFT 26910000
MVC TCXRX(TCXRZ-TCXRF),TCXRF
MFT 27040000
SPACE 3
MFT 27170000
RELSINI EQU *
MFT 27300000
*
MFT 27430000
*
RELEASE SUPINI .
27560000
*
27690000
L
1,ECBINIT
SUPINI'S ECB.
27820000
POST (1)
POSTED.
27950000
TITLE 'SPECIAL EMERGENCY CANCEL COMMAND FOR APL/360-OS ' C046 28080000
*
28210000
* THIS IS REQUIRED BECAUSE THE STAE EXIT DOES NOT RECEIVE CONTROL
28340000
*
FOR OPERATOR CANCEL.
28470000
*
28600000
*
N.B. SAME IS TRUE FOR ANY X22 ABEND AND IF ANY OF THESE
28730000
*
OCCURS, IT WILL MEAN THAT APL HAS NOT BEEN GIVEN A CHANCE
28860000
*
TO RESTORE THE I/O NEW PSW.
28990000
*
29120000
*
A SYSTEM RE-IPL IS NECESSARY TO ENSURE PROPER OPERATION OF
29250000
*
OS/360
29380000
*
29510000
*
BEWARE OF SEEMINGLY CORRECT OPERATION AFTER A X22 ABEND.
29640000
*
SUCH IS A FALSE CONDITION, AND SYSTEM WILL FAIL AS SOON
29770000
*
AS THE I/O INTERRUPT HANDLER THAT STILL REMAINS IN CORE (FROM
29900000
*
THE APL JOB) IS OVERLAID BY OTHER CODE OR DATA.
30030000
*
30160000
*
K11 30290000
REQC
WTOR 'REPLY ''ABEND APL'' TO ABNORMALLY TERMINATE APL.', K11C30420000
REPLY,9,REPLYECB,ROUTCDE=(1,11)
K11 30550000
TITLE 'A P L M O T H E R - CONCURRENT MOTHER TASK.'
30680000
*
30810000
*
REAL MOTHER TASK ..
30940000
*
31070000
*
31200000
*
FUNCTIONS ..
31330000
*
31460000
*
1.
OWNS THE MOTHER TCB (AND THEREFORE THE DAUGHTER TASK)
31590000
*
AND THE FOLLOWING ECBS .. ECBMERE, ECBAPL .
31720000
*
*
*

*
*
*
*
*
*
*
*
*
*
MOTHER
*
*
***
*

2.
RAISES AND LOWERS THE PRIORITY OF THE DAUGHTER TASK
ON REQUEST FROM APLSUP.
THIS IS DONE HERE RATHER THAN IN APLSUP TO ELIMINATE THE
POSSIBILITY OF A TASK SWITCH WHILE IN APLSUP. A TASK SWITCH
MAY OCCUR IN MOTHER.
3.
MAY EXECUTE CONCURRENTLY WITH THE DAUGHTER TASK
(WHICH, AT TIMES, IS APLSUP), AND REFERENCES GLOBAL VARIABLES.
WAIT ECBLIST=ECBLIST = ECBMERE,ECBAPL,REPLYECB
XC
ECBMERE,ECBMERE

C046
C046

DISPATCHED BY EXINT, MPXINT, OR SHUTDOWN.

NOTE.. R10 WILL BE DESTROYED IN APLSUP.

TM
ECBAPL,X'40'
SEE IF APL TERMINATED
BO
DETACH
BRANCH IF SO.
TM
REPLYECB,X'40' HAS THE OPERATOR REQUESTED A CANCEL?
BO
CANCEL
CLC CHAPCODE,=H'0'
SEE IF APLSUP REQUESTED A CHAP.
BE
MOTHER
BRANCH IF NOT.
LH
0,CHAPCODE
OTHERWISE,
MVC CHAPCODE(2),=H'0' RESET CHAPCODE,
CHAP (0),TCBFILLE
AND CHANGE DAUGHTER PRIORITY.
B
MOTHER
SPACE 3
CANCEL OC
REPLY(9),=CL9' '
FOLD TO UPPER CASE
WTO MF=(E,REPLYWTO) PUT OPERATORS REPLY ON SMB'S
CLC REPLY(9),=C'ABEND APL'
BE
CANCELIT
XC
REPLY(9),REPLY CLEAR REPLY BUFFER
XC
REPLYECB,REPLYECB
B
REQC
TELL HIM HOW TO SPELL IT
SPACE 2
REPLYWTO DS
0F
DC
AL2(REPLYZ-*),XL2'8000'
DC
CL8'APL'
MESSAGE PREFIX
REPLY
DC
CL9' '
REPLYZ EQU *
DC
XL4'00000020' ROUTCDE=(11)
REPLYECB DC
F'0'
ECB FOR FAKE OPERATOR CANCEL
TITLE 'A P L M O T H E R - APL TERMINATION.'
*
*
APL TERMINATION, RESTORE IO NEW PSW AND DETACH APL.
*
DETACH BAL 14,RSTR
RESTORE THE I/O NEW PSW
DETACH1 CLC ECBAPL+1(3),=FL3'21'
* RETURN CODES ARE:
*
0 NORMAL APL SHUTDOWN
*
4 INSUFFICIENT CORE STORAGE
*
8 VERSION MISMATCH
*
12 TIMER NOT INCREMENTING
*
16 BLDL FOR APPENDAGES FAILED.
*
24 INVALID OPERAND IN PARM FIELD OF EXEC CARD
*
20 NOT OS-MVT OR OS-MFT-ATTACH
*
BNL ABEND
B. IF INVALID COMPLETION CODE
*
(OR IF SUBTASK ABENDED.)
TM
ECBAPL+3,X'03'
IS CC A MULTIPLE OF 4?

K03
K11
K11

K11
K11
K11
K11
K11
K11
K11
K11
K11
K11
K11
K11
K11
K11

K02
K03
K03
K03
K03
K03
P062
K03
K03
K03
K03

31850000
31980000
32110000
32240000
32370000
32500000
32630000
32760000
32890000
33020000
33150000
33280000
33410000
33540000
33670000
33800000
33930000
34060000
34190000
34320000
34450000
34580000
34710000
34840000
34970000
35100000
35230000
35360000
35490000
35620000
35750000
35880000
36010000
36140000
36270000
36400000
36530000
36660000
36790000
36920000
37050000
37180000
37310000
37440000
37570000
37700000
37830000
37960000
38090000
38220000
38350000
38480000
38610000
38740000
38870000
39000000
39130000
39260000
39390000
39520000

BNZ ABEND
DETACH TCBFILLE
*
*
*
GOTOOS
RETURN
*
*
*
*
*
*
*
*
*
*
ABEND

ABEND2F
*
*
ABENDMSG
SAB
UAB
ABENDMSZ
*
*
STAERR
CANCELIT
*
*
*
*
*
*
*
*
*

K03 39650000
LET OS GET RID OF THE TCB FOR DAUGHTER K03 39780000
39910000
NORMAL TERMINATION OF APL.
40040000
40170000
DEQ (QNAME,RNAME,,SYSTEM) RELEASE APL UTILITY.
40300000
LH
15,ECBAPL+2
PUT SUBTASK RETURN CODE INTO R15
K03 40430000
L
13,OSR13
RESTORE REGS
P062 40560000
RETURN (14,12),RC=(15)
RETURN TO OS, RETURN CODE IN R15 K03 40690000
SPACE 3
40820000
40950000
ABNORMAL TERMINATION OF APL.
41080000
APL HAS EITHER ..
41210000
1.
ABENDED: PROGRAM CHECK IN SUPERVISOR STATE
41340000
APLSOPEN
C046 41470000
APLSSINI
C046 41600000
UGH IN APLSASUP
41730000
2.
TERMINATED FROM SUPINI WITH A RETURN-CODE
K03 41860000
GREATER THAN 20.
K03 41990000
42120000
SPACE
42250000
UNPK SAB(3),ECBAPL+1(2) UNPACK SYSTEM COMPLETION CODE C047 42380000
OI
SAB+2,C'0'
'FIX' SIGN
C047 42510000
TR
SAB(3),HEXTAB
CONVERT TO PRINTABLE HEX
C047 42640000
LA
14,X'FFF'
MASK FOR USER COMPLETION CODE C047 42770000
N
14,ECBAPL
EXTRACT
C047 42900000
CVD 14,ABEND2F
INTO PACKED DECIMAL
C047 43030000
UNPK UAB(4),ABEND2F+5(3) UPACK
C047 43160000
OI
UAB+3,C'0'
SET PROPER ZONE BITS.
C047 43290000
WTO MF=(E,ABENDMSG)
SEND WORD TO OPERATOR
C047 43420000
ABEND 1000,DUMP
FINI
C047 43550000
SPACE 3
C047 43680000
DS
D
TEMP FOR CVD AT 'ABEND'
C047 43810000
WTO 'ABNORMAL APL SUBTASK TERMINATION, S=***, U=****', C047 43940000
ROUTCDE=(1,11)
C047 44070000
DC
0F'0',AL2(ABENDMSZ-ABENDMSG),XL2'8000' WITH ROUTCDE C047 44200000
DC
CL8'APL'
C047 44330000
DC
C'ABNORMAL APL SUBTASK TERMINATION, S='
C047 44460000
DC
C'***'
SYSTEM COMPLETION CODE
C047 44590000
DC
C', U='
C047 44720000
DC
C'****',C'.'
USER COMPLETION CODE
C047 44850000
DC
X'00008020'
ROUTCDE=(1,11)
C047 44980000
SPACE 3
45110000
NON-ZERO RETURN CODE FROM STAE
45240000
45370000
LA
15,1100(15)
BUILD ABEND CODE
45500000
ABEND (15)
45630000
SPACE 3
45760000
ABEND 1020,DUMP,STEP OPERATOR REQUESTED 'ABEND APL'
45890000
DROP 12
46020000
TITLE 'A P L M O T H E R - TIMER COMPLETION EXIT ROUTINE.' 46150000
46280000
TIMER COMPLETION EXIT ROUTINE.
46410000
THIS CODE MUST BE IN SUPERVISOR STATE, KEY OF ZERO, DISABLED. 46540000
46670000
46800000
A REQUEST BLOCK (TQE) FOR THIS ROUTINE IS ALWAYS ON
46930000
THE MOTHER TCB. IT IS POSSIBLE TO ALSO HAVE A TQE FOR IT
47060000
ON THE DAUGHTER TCB.. E.G. WHEN SETINT IS CALLED FROM QZA3.
47190000
WHEN A TIMER QUEUE ELEMENT EXISTS ON BOTH TCBS, THE
47320000

*
*
*
*
*
*
*
*
*
*
*
*
*
APLTCXR
*
*
*
*

* 1.
* 2.

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

* 3.
NOPOST

* 4.
*
*

DUE TIME FOR THE DAUGHTER WILL BE LESS THAN OR EQUAL THE
47450000
TIME DUE FOR THE MOTHER.
47580000
THE RELATIONSHIP IS A FAIRLY COMPLEX FUNCTION OF APL LOADING. 47710000
47840000
47970000
1.
GOTO 3 IF ECBMERE NE WAIT
48100000
2.
POST ECBMERE
48230000
3.
GOTO 0 IF ECBAPL = COMPLETE
48360000
4.
GOTO 0 IF EXINTLK NE 0
48490000
5.
APLEXOLD IS RBMERE.(RBOPSW).
48620000
6.
RBMERE.(RBOPSW). IS X'00040000',A(EXINT)
48750000
48880000
49010000
STM 13,12,8(13)
OS PROVIDES A STANDARD SAVE AREA
K06 49140000
ALTHOUGH NON-STANDARD, SAVING REG.13 AS ABOVE K06 49270000
SHOULD NOT CAUSE ANY TROUBLE, SINCE THIS SAVE K06 49400000
AREA WILL NOT BE CHAINED TO ANYTHING ELSE.
K06 49530000
K06 49660000
LR
7,13
SAVE 13 SO REGISTERS CAN BE RESTORED K06 49790000
LR
8,15
POST WIPES A LOT OF REGS
MFT 49920000
USING APLTCXR,8
MFT 50050000
50180000
TM
ECBMERE,X'80'
SEE IF MOTHER IS WAITING.
50310000
BZ
NOPOST
BRANCH IF NOT.
50440000
50570000
L
1,RBMERE
MAKE SURE KEY IS KEY OF REGION.
50700000
USING IRB,1
50830000
OC
RBOPSW+1(1),SK
REGION'S STORAGE KEY.
50960000
51090000
POST THE MOTHER TASK -- THE BRANCH ENTRY IS USED.
51220000
K06 51350000
REGISTERS 0-9 ARE TRANSPARENT IN MVT
MFT 51480000
REGISTERS 0-8 ARE TRANSPARENT IN MFT
MFT 51610000
K06 51740000
REGISTERS 10-13,15 ARE *VOLATILE*
K06 51870000
K06 52000000
REG. REQUIRED DATA ( PARAMETERS FOR POST )
K06 52130000
K06 52260000
R10 - ZERO (POST CODE).
52390000
R11 - ECBMERE
52520000
R12 - TCBMERE
52650000
R14 - RETURN ADDRESS.
52780000
R15 - POST ROUTINE ENTRY ADDRESS.
52910000
53040000
SR
10,10
ZERO POST CODE.
53170000
LA
11,ECBMERE
MOTHER ECB.
53300000
L
12,TCBMEREA
MOTHER TCB.
53430000
L
15,CVT
CVT POINTER.
53560000
USING CVTD,15
53690000
L
15,CVT0PT01
53820000
DROP 15
53950000
BALR 14,15
54080000
54210000
L
1,RBMERE
MOTHER PRB.
54340000
MVC RBOPSW(2),=X'0004' DISABLED,KEY 0,SUP.STATE,
3054 54470000
TM
ECBAPL,X'40'
SEE IF APL IS STILL RUNNING.
54600000
BO
TCXRX
BRANCH IF APL NOT RUNNING
MFT 54730000
54860000
54990000
THE FOLLOWING TEST ALLOWS THE TIMER COMPLETION EXIT ROUTINE
55120000

*
*
*

TO BE ENTERED MORE OFTEN THAN APLSUP TIMER CODE.

L
TS
BC

2,=A(EXINTLK)
TEST AND SET INTERLOCK.
0(2)
4,TCXRX
BRANCH IF LAST INTERRUPT STILL
OUTSTANDING.

L
MVC

2,EXTOLD
0(8,2),RBOPSW

*
* 5.

APLSUP EXTERNAL OLD.

* 6.
MVC RBOPSW,EXINTPSW
* FOR MVT ONLY
MFT
*
RESET RBDYN FLAGS IN TQE ALIAS IRB SO THAT EXIT (SVC 3) WILL
*
NOT ATTEMPT TO RETURN IT TO FREE QUEUE SPACE.
TCXRX
L
1,TCBMEREA
MFT
L
1,0(1)
NI
RBSTAB+1,X'F9'
DONT LET EXIT FREE TQE/IRB
*
OR SAVE AREA
* ABOVE 3 INSTRUCTIONS FOR MVT ONLY
MFT
TCXRF
LM
13,12,8(7)
RETRIEVE ALL REGS. INCLUDING 13
MFT
BR
14
AND RETURN TO MVT.
TCXRZ
EQU *
MFT
DROP 8,1
MFT
EJECT
MFT
TITLE 'A P L M O T H E R - INTERFACE.'
*
TASK ABEND EXIT ROUTINE (STAE)
*
RESET THE IO NEW PSW TO ITS VALUE BEFORE INITIALIZATION,
*
DEQ FOR RUN OF APL UTILITY, AND LEAVE.
SPACE 3
*
REGISTER CONTENTS AT ENTRY TO STEP
*
*
0 ACTIVE I/O FLAG
*
1 104 BYTE STAE WORK AREA OR ABEND CODE
*
2
*
*
. TO ** UNPREDICTABLE
*
12
*
*
13 ADDRESS OF SUPERVISOR PROVIDED SAVE AREA
*
14 RETURN ADDRESS
*
15 E.P. OF STAE EXIT (I.E. A(STEP))
*
DS
0D
FOR EASY IAR STOPPING.
STEP
LR
12,15
USING STEP,12
STM 13,14,STSAV
*
L
11,ACURRENT
XENOPHOBIC SVC ROUTINE
L
11,0(11)
SVRAPE
BAL 14,RSTR
RESTORE THE I/O NEW PSW
K02
DEQ (QNAME,RNAME,,SYSTEM)
LM
13,14,STSAV
DROP 12
SR
15,15
INDICATE NO RESTART.
BR
14
TO SVC 3
TITLE 'PSW RESTORE SUBROUTINE (MODIFIED LMB CONVENTION)' K02
*
K02
*
K02
* THIS ROUTINE SEARCHES THE PSW CHAIN (ASSUMING THE MODIFIED LMB K02
*
CONVENTION WAS BEING USED) AND MODIFIES THE I/O NPSW CHAIN K02

55250000
55380000
55510000
55640000
55770000
55900000
56030000
56160000
56290000
56420000
56550000
56680000
56810000
56940000
57070000
57200000
57330000
57460000
57590000
57720000
57850000
57980000
58110000
58240000
58370000
58500000
58630000
58760000
58890000
59020000
59150000
59280000
59410000
59540000
59670000
59800000
59930000
60060000
60190000
60320000
60450000
60580000
60710000
60840000
60970000
61100000
61230000
61360000
61490000
61620000
61750000
61880000
62010000
62140000
62270000
62400000
62530000
62660000
62790000
62920000

*
TO REMOVE APL FROM THE CHAIN.
*
* DESTROYS 14,15; USES MVTSAVE AS REGISTER SAVE AREA
*
RSTR
BALR 15,0
ESTABLISH TEMPORARY ADDRESSIBILITY
USING *,15
STM 12,3,MVTSAVE+12 USE STANDARD SAVE AREA IN A
*
NON-STANDARD WAY
*
*
* CHECK TO SEE IF THE PSW NEEDS TO BE RESTORED
*
I.E. HAS IT EVER BEEN STOLEN, OR
*
HAS IT ALREADY BEEN RESTORED.
*
THE ABOVE CONDITION IS POSSIBLE IF THERE IS AN ABEND
*
CONDITION THAT IS FIRST RECOGNIZED BY THE CHECK ON
*
THE ABEND CODE AT DETACH1
*
OR IF THERE WAS A NON-ZERO RETURN CODE FROM STIMER
*
NC
OSIONEW,OSIONEW
IS THIS ZERO?
BCR 8,14 BZR
B. IF NOT STOLEN
LR
12,15
DROP 15
USING RSTR+2,12
*
* REGISTER USAGE
*
*
0
ADDRESS OF E.P. FOR APL INTERRUPT HANDLER
*
1
POINTER TO NPSW BEING EXAMINED
*
2
LOOP PROTECTION COUNTER
*
3
CVT
*
*
12
BASE
*
14
RETURN ADDRESS
*
15
CONSTANT (-12) AND POINTER TO APL-SAVED NPSW
*
LA
2,16
LOOP PROTECT COUNTER; ASSUME NO MORE
*
THAN 16 TASKS STOLE THE I/O NEW PSW
L
1,APLIONEW
THIS IS ADDRESS OF STOLEN PSW WHICH
*
OCCUPIES THE 8 BYTES PREDEEDING THE E.P.
*
TO THE APL I/O INTERRUPT HANDLER
LA
0,8(1)
GET ADDRESS OF E.P.
LH
15,=H'-12'
GET CONSTANT USED IN LOOP
LA
1,IONEWPSW-4 PRIME THE PUMP
L
3,CVT
USING CVTD,3
B
RSTRLQQP
SKIP COMPARE FOR =C'PSW'
SPACE 2
RSTRLOOP AR
1,15
BACK UP THE PSEUDO NPSW ADDRESS
CLC 0(3,1),=CL3'PSW' DOES IT SAY 'PSW'?
BNE RSTRERR
RSTRLQQP CL
0,8(1)
HAVE WE FOUND OURSELVES
BE
RSTRIT
*
* ERROR CHECKING
*
TM
11(1),X'03'
IS NEXT ON FULL WORD BOUNDARY
BNZ RSTRERR
B. IF NOT FULL WORD BOUNDARY
*
L
1,8(1)
GET THIS PORTION OF THIS PSW FOR
*
USE AS THE NEW PSW POINTER

K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02
K02

63050000
63180000
63310000
63440000
63570000
63700000
63830000
63960000
64090000
64220000
64350000
64480000
64610000
64740000
64870000
65000000
65130000
65260000
65390000
65520000
65650000
65780000
65910000
66040000
66170000
66300000
66430000
66560000
66690000
66820000
66950000
67080000
67210000
67340000
67470000
67600000
67730000
67860000
67990000
68120000
68250000
68380000
68510000
68640000
68770000
68900000
69030000
69160000
69290000
69420000
69550000
69680000
69810000
69940000
70070000
70200000
70330000
70460000
70590000
70720000

K02
K02
K02
K02
DOES THIS EXCEED CORE SIZE
K02
K02
FEWER THAN 16 THIEVES?
K02
*
K02
*
K02
* AT LEAST ONE PROGRAM CURRENTLY RUNNING
K02
* DID NOT FOLLOW THE MODIFIED LMB CONVENTION
K02
*
K02
*IN ORDER TO AVOID ABENDING, WE WILL TAKE RELATIVELY DRASTIC ACTION K02
*
K02
RSTRERR AR
15,0
K02
MVC IONEWPSW(8),4(15) JAM IT BACK, SOMEONE MAY HAVE
K02
*
GOTTEN STRANDED
K02
B
RSTREX
K02
SPACE 3
K02
*
K02
* BY SCANNING THE PSW'S IN THE CHAIN OF STOLEN PSW'S WE
K02
*
HAVE FOUND THE PSW THAT POINTS TO US.
K02
*
IT WILL BE REPLACED BY THE PSW WE HAVE STOLEN,
K02
*
THEREBY REMOVING APL FROM THE CHAIN
K02
*
K02
RSTRIT AR
15,0
K02
MVC 4(8,1),4(15) TAKE APL OUT OF THE CHAIN OF PSW THIEFS K02
SPACE 2
K02
RSTREX XC
OSIONEW,OSIONEW
CLEAR THE 'SWITCH'
K02
LM
12,3,MVTSAVE+12
PSW RESTORE IS COMPLETE
K02
BR
14
K02
SPACE 3
K02
DROP 3,12
K02
TITLE '
C O N S T A N T S
ETC.'
*
*
PARAMETER LISTS FOR ATTACH
K05
*
K05
PARAM
DC
A(TOLIST,ALIST) SECOND WORD IN LIST IS CHANGED BY K05
*
SUPINI
K05
DC
A(X'800000') ADDRESS OF EXEC PARM FIELD GOES HERE
DC
A(SELPCIX,SELCE,SELXEN) APL APPENDAGES
EXTRN SELPCIX,SELCE,SELXEN
*
K06
*
MULTIPLE WAIT ECBLIST
K06
*
K06
ECBLIST DC
A(ECBMERE)
ECB POSTED BY APL SUBTASK FOR CHAP
K06
DC
A(REPLYECB)
FAKE OPERATOR CANCEL
K11
DC
X'80',AL3(ECBAPL) POSTED BY OS IF SUBTASK TERMINATES K06
*
K06
SPACE 3
K20
*
CONSTANTS ETC.
*
ALIST
DS
0F
ADDRESS LIST PASSED BY SUOINI.
ECBINIT DS
F
POINTER TO SUPINI'S ECB.
OSFLG
DC
X'00'
MVT/MFT FLAGS
MFT
MFT
EQU X'20'
MFT
MVT
EQU X'10'
MFT
KEY2
DC
X'00'
ACTKEY
MFT
ALISTZ EQU *
APLSGENE DC
A(TCBMERE)
APLSUP GENEOLOGY LIST.
*?
*?

SPACE
C
BNH
SPACE
C
BNL
BCT

1
1,CVTNUCB
RSTRERR
1
1,CVTMZ00
RSTRERR
2,RSTRLOOP

IS THIS IN DYNAMIC CORE AREA?

B. IF IN NUCLEUS OR SQS

70850000
70980000
71110000
71240000
71370000
71500000
71630000
71760000
71890000
72020000
72150000
72280000
72410000
72540000
72670000
72800000
72930000
73580000
73710000
73840000
73970000
74100000
74230000
74360000
74490000
74620000
74750000
74880000
75010000
75140000
75270000
75400000
75530000
75660000
75790000
75920000
76050000
76180000
76310000
76440000
76570000
76700000
76830000
76960000
77090000
77220000
77350000
77480000
77610000
77740000
77870000
78000000
78130000
78260000
78390000
78520000
78650000
78780000
78910000
79040000

APLIONEW DC
A(HOSTIOP)
APLSUP IO NEW PSW.
SVOLDPA DC
A(SVOLDPSW)
APLSUP SVC OLD PSW.
EXTOLD DC
A(EXOLDPSW)
APLSUP EXTERNAL OLD PSW.
SPACE
EXTRN ATQE
ATQEX
DC
A(ATQE)
MVTSAVE DC
18F'0'
OS PROBLEM PROGRAM SAVE AREA.
OSR13
EQU MVTSAVE+4
SPACE
*
THE FOLLOWING EIGHT WORDS ARE THE SUBJECT OF AN MVC.
TCBMEREA DS
F
ADDRESS OF MOTHER'S TCB.
TCBFILLE DS
F
ADDRESS OF DAUGHTER TCB.
RBMERE DS
F
ADDRESS OF MOTHER PRB.
RBFILLE DS
F
ADDRESS OF DAUGHTER PRB.
DC
A(ECBMERE)
ADDRESS OF MOTHER ECB.
ECBFILLE DC
F'0'
DAUGHTER ECB.
GENEZ
EQU *
SPACE
ECBAPL DC
F'0'
ECB FOR ATTACH.
ECBMERE DC
F'0'
MOTHER ECB.
EXINTPSW DC
X'FF040000'
EXINTA DC
A(EXINT)
ENTRY POINT FOR APLSUP EXTERNAL
OSIONEW DC
XL8'00'
OS I/O NEW PSW
TWOSEC DC
A(2*300*128)
TWO SECOND INTERVAL.
ENTRY CHAPCODE
CHAPCODE DC
H'0'
SK
DC
X'00'
STORAGE KEY OF REGION.
QNAME
DC
C'APLOS360'
RNAME
DC
C'LIBRARIES'
STSAV
DS
2F
SPACE 3
ATTACHL ATTACH SF=L,EP=APLSINIT,ECB=ECBAPL,LPMOD=8,HIARCHY=1
SPACE 2
ATTACHH1 EQU ATTACHL+4
POINT TO HIARCHY FLAG BYTE
SPACE 3
ATTACHD DSECT
SPACE 2
*
THESE TWO EXPANSIONS OF ATTACH ARE SHOWN TO ALLOW
*
THE DEBUGGER TO DETERMINE THE POSSIBLE STATES OF
*
THE ATTACHH1 FIELD IN THE ATTACH PARAMETER LIST
SPACE 2
ATTACH SF=L,EP=APLSINIT,ECB=ECBAPL,LPMOD=8,HIARCHY=0
SPACE 2
ATTACH SF=L,EP=APLSINIT,ECB=ECBAPL,LPMOD=8
APLOS
CSECT
SPACE 3
HEXTAB EQU *-C'0'
DC
CL16'0123456789ABCDEF'
EJECT
*
*
ADDRESS LIST FOR SUPINI.
*
*
REQUIRED BECAUSE EXTERNAL REFFERENCES BETWEEN
*
ATTACHING AND ATTACHED PROGRAMS ARE NOT RESOLVED.
*
*
NOTE ...
SUPINI ASSUMES ORDERING.
*
SPACE
TOLIST DS
0A
ASUPPARS DC
A(SUPPARS)

3054
INTS
MFT

P062
P062
P062
P062
P062
P062
P062
P062
P062
P062
P062
P062
P062
P062
P062
P062

79170000
79300000
79430000
79560000
79690000
79820000
79950000
80080000
80210000
80340000
80470000
80600000
80730000
80860000
80990000
81120000
81250000
81380000
81510000
81640000
81770000
81900000
82030000
82160000
82290000
82420000
82550000
82680000
82810000
82940000
83070000
83200000
83330000
83460000
83590000
83720000
83850000
83980000
84110000
84240000
84370000
84500000
84630000
84760000
84890000
85020000
85150000
85280000
85410000
85540000
85670000
85800000
85930000
86060000
86190000
86320000
86450000
86580000
86710000
86840000

ACONFINI
ATYI1052
AHISTKI
ASWAPPAR
ACONFSWA
AHTAB
ADIRTAB
ALIBPZ
ALIBPARS
AAPLSDCB
AZSYMDAT
APCSUB
MOMMY
ASVOLDPS
ASVINT
LISTLENG
ACURRENT
ASTEP

DC
A(CONFINIT)
DC
A(TYI1052)
DC
A(HISTKILL)
DC
A(SWAPPARS)
DC
A(CONFSWAP)
DC
A(HTAB)
DC
A(DIRTAB)
DC
A(LIBPZ)
DC
A(LIBPARS)
DC
A(APLSDCBS)
DC
A(ZSYMDATE)
DC
A(PCSUB)
DC
A(ECBMERE)
DC
A(SVOLDPSW)
DC
A(SVINT)
EQU *-TOLIST
CHECK AGAINST LIST IN SUPINI.
DS
A
SUPINIT FILLS IN. DON'T MOVE.
DC
A(STEP)
EJECT
EXTRN APLINIT
EXTRN APLSDCBS
EXTRN CHAPLOW
EXTRN CONFINIT
EXTRN CONFSWAP
EXTRN CURRENTM
EXTRN DIRTAB
EXTRN EXINT
EXTRN EXINTLK
EXTRN EXOLDPSW
EXTRN HISTKILL
EXTRN HOSTIOP
EXTRN HTAB
EXTRN LIBPARS,LIBPZ
EXTRN PCSUB
EXTRN SUPPARS
EXTRN SVINT
EXTRN SVOLDPSW
EXTRN SWAPPARS
EXTRN TCBMERE
EXTRN TYI1052
EXTRN ZSYMDATE
SPACE
TCBRBP EQU 0
DISPLACEMENT OF PRB ADDRESS IN TCB.
TCBPKE EQU 28
DISPLACEMENT OF STORAGE KEY IN TCB.
TCBDSP EQU 35
DISPATCHING PRIORITY BYTE IN TCB.
IONEWPSW EQU 120
LOCATION OF REAL IO NEW PSW.
SPACE
LTORG
COPY TQE
COPY IRB
CVTD
DSECT
CVT
EQU 16
LOCATION OF CVT POINTER
CVT
DCBD DSORG=XA
END
./ ADD
NAME=APLSAPPN
APPENDAG CSECT
USING *,15
IOS SETS UP R15
L
15,ADDR
WHERE TO GO NEXT
BR
15

86970000
87100000
87230000
87360000
87490000
87620000
87750000
87880000
88010000
88140000
88270000
88400000
88530000
88660000
88790000
88920000
89050000
89180000
89310000
89440000
89570000
89700000
89830000
89960000
90090000
90220000
90350000
90480000
90610000
90740000
90870000
91000000
91130000
91260000
91390000
91520000
91650000
91780000
91910000
92040000
92170000
92300000
92430000
92560000
92690000
92820000
92950000
93080000
93210000
93340000
93470000
93600000
93730000
93860000
93990000
12500000
25000000
37500000
50000000

BR14
ADDR

BR
14
BACK TO IOS
DC
A(BR14)
NORMALLY, JUST GO BACK TO IOS
END
./ ADD
NAME=APLSARTH
ARTH
TITLE 'ARITHMETIC TYPE TABLES
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&OP
ARTHTYPE &TYPE1,&TYPE2,&TYPE3,&TYPE4
ORG ARTHTAB+4*Z&OP+2
DC
AL1(&TYPE1)
AIF (T'&TYPE2 EQ 'O').OMIT2
DC
AL1(&TYPE2)
AGO .TRY3
.OMIT2 DC
AL1(&TYPE1)
.TRY3
AIF (T'&TYPE3 EQ 'O').OMIT3
DC
AL1(&TYPE3)
AGO .TRY4
.OMIT3 AIF (T'&TYPE2 EQ 'O').USE13
DC
AL1(&TYPE2)
AGO .TRY4
.USE13 DC
AL1(&TYPE1)
.TRY4
AIF (T'&TYPE4 EQ 'O').OMIT4
DC
AL1(&TYPE4)
MEXIT
.OMIT4 AIF (T'&TYPE3 EQ 'O').USE24
DC
AL1(&TYPE3)
MEXIT
.USE24 AIF (T'&TYPE2 EQ 'O').USE14
DC
AL1(&TYPE2)
MEXIT
.USE14 DC
AL1(&TYPE1)
MEND
*
MACRO
&OP
DYADICOP &FIX,&FLOAT
ORG DYADTAB+8*Z&OP+4
DC
A(&FIX)
AIF ('&FIX' EQ 'EXERROR').NOX
EXTRN &FIX
.NOX
AIF (T'&FLOAT EQ 'O').UFIX
DC
A(&FLOAT)
AIF ('&FLOAT' EQ 'EXERROR').NOFX
EXTRN &FLOAT
.NOFX
MEXIT
.UFIX
DC
A(&FIX)
MEND
*
MACRO
&OP
MONADOP &FIX,&FLOAT
ORG MONADTAB+8*Z&OP+4
DC
A(&FIX)
AIF ('&FIX' EQ 'EXERROR').NOX
EXTRN &FIX
.NOX
AIF (T'&FLOAT EQ 'O').UFIX
DC
A(&FLOAT)
AIF ('&FLOAT' EQ 'EXERROR').NOFX
EXTRN &FLOAT
.NOFX
MEXIT

62500000
75000000
87500000
00230000
00460000
00690000
00920000
01150000
01380000
01610000
01840000
02070000
02300000
02530000
02760000
02990000
03220000
03450000
03680000
03910000
04140000
04370000
04600000
04830000
05060000
05290000
05520000
05750000
05980000
06210000
06440000
06670000
06900000
07130000
07360000
07590000
07820000
08050000
08280000
08510000
08740000
08970000
09200000
09430000
09660000
09890000
10120000
10350000
10580000
10810000
11040000
11270000
11500000
11730000
11960000
12190000
12420000
12650000
12880000

.UFIX

DC
A(&FIX)
MEND
SPACE
MACRO
OPTYPE &MTYPE,&DTYPE,&MNDX,&DNDX
LCLB &MX,&DX
ORG INDICTR+2*Z&OP+1
AIF (T'&MNDX EQ 'O').MNO
SETB ('&MNDX' EQ 'INDEXED')
AIF (T'&DNDX EQ 'O').DNO
SETB ('&DNDX' EQ 'INDEXED')
AGO .TYPES
ANOP
SETB (&MX)
AIF (T'&DTYPE EQ 'O').DNOT
DC
AL1(&MTYPE+&MX*X'80',&DTYPE+&DX*X'80')
MEXIT
ANOP
DC
AL1(&MTYPE+&MX*X'80',&MTYPE+&DX*X'80')
MEND
MACRO
IDEL &OP,&TYPE,&FU1,&FU2,&FU3
ORG IDENTS+Z&OP*8
USING *,9
&FU1 &FU2,&FU3
DC
A(&TYPE)
MEND

13110000
13340000
13570000
13800000
&OP
14030000
14260000
14490000
14720000
&MX
14950000
.MNO
15180000
&DX
15410000
15640000
.DNO
15870000
&DX
16100000
.TYPES
16330000
16560000
16790000
.DNOT
17020000
17250000
17480000
17710000
17940000
18170000
18400000
18630000
18860000
19090000
*
19320000
PRINT OFF
APLDEFN, ZSYMBOLS
19780000
ARTHTYP CSECT
20010000
COPY APLDEFN
20240000
COPY ZSYMBOLS
20470000
PRINT GEN
20700000
TITLE 'ARITHMETIC TYPE TABLES
05/11/70' 20930000
PRINT ON,NOGEN
21160000
ARTHTYP CSECT
21390000
*
21620000
*********************************************************************** 21850000
*
22080000
*
ARTHTP
22310000
*
22540000
*********************************************************************** 22770000
*
23000000
*
23230000
*
DETERMINE COMPUTE TYPE, RESULT TYPE, FETCH CODES, AND
23460000
*
EXECUTION ROUTINE ADDRESS.
23690000
*
23920000
*
R0 - 0 - COMPUTE TYPE.
24150000
*
- TYPE - FORCE RESULT TO THIS TYPE.
24380000
*
24610000
SPACE
24840000
ENTRY ARTHTP
25070000
EXTRN ERROR
25300000
EXTRN EXERROR
25530000
ARTHTP PROLOG
25760000
SPACE
25990000
LTR 2,2
SEE IF THERE'S AN LH OPERAND.
26220000
BZ
*+8
BRANCH IF NOT.
26450000
LA
1,1(1)
OTHERWISE, INCREMENT OP BY 1.
26680000
AR
1,1
THEN MAKE IT A WORD INDEX.
26910000

SR
5,5
LA
6,ARTHTAB(1)
CHECK FOR CHARACTER TYPE ALLOWED.
TM
0(6),NOCHAR
BZ
CHAROK
BRANCH IF SO.
C
2,OC4
OTHERWISE, EXAMINE TYPES.
BE
RNGEROR
RANGE ERROR IF CHAR.
C
3,OC4
RIGHT HAND.
BE
RNGEROR
CHAROK SR
5,5
IC
5,ARTHTAB(1)
PICK UP COMPUTE TYPE.
N
5,=F'127'
REMOVE CHARACTER FLAG.
SR
4,4
AND IC
4,ARTHTAB+1(1)
RESULT TYPE.
N
4,=F'127'
REMOVE CHARACTER FLAG.
LTR 0,0
SEE IF A RESULT TYPE IS SPECIFIED.
BZ
NOFORCE
BRANCH IF NOT.
FORCE
LR
5,0
PICK UP GIVEN TYPE.
LR
4,0
MAKE COMPUTE TYPE THE SAME.
NOFORCE C
5,OC4
SEE IF COMPUTE TYPE IS RESTRICTED.
BNH CRTYPE
BRANCH IF SO.
LR
5,3
MOVE IN RIGHT TYPE, OTHERWISE.
CR
5,2
COMPARE TO LEFT TYPE.
BNL *+6
BRANCH IF HIGHER OR EQUAL.
LR
5,2
OTHERWISE, MOVE IN LEFT TYPE.
C
5,OC1
SEE IF CTYPE IS BOOLEAN.
BH
CRTYPE
BRANCH IF NOT.
LA
5,2
OTHERWISE, MAKE IT INTEGER.
CRTYPE C
4,OC4
SEE IF RESULT TYPE IS RESTRICTED.
BNH *+6
BRANCH IF SO.
LR
4,5
OTHERWISE, IT'S CTYPE.
LTR 2,2
SEE IF THERE'S AN LH TYPE.
BZ
GETRHCT
BRANCH IF NOT.
CR
2,5
OTHERWISE, SEE IF CONVERSION IS NEED
BE
GETRHCT
BRANCH IF NOT.
SLA 2,2
OTHERWISE, GET CONVERSION CODE.
AR
2,5
IC
2,FTCHTYP-5(2)
PICK UP FETCH CODE.
GETRHCT CR
3,5
SEE IF RIGHT MUST BE CONVERTED.
BE
ARTHEXT
BRANCH IF NOT.
SLA 3,2
OTHERWISE, PICK UP FETCH CODE.
AR
3,5
IC
3,FTCHTYP-5(3)
GOT IT.
SPACE
*
*
NOW, PICK UP ROUTINE ADDRESS.
*
SPACE
ARTHEXT S
1,OC2
REMOVE POSSIBLE EARLIER INCREMENT.
O
1,OC2
AR
1,1
MAKE OP DOUBLE WORD INDEX.
C
5,OC3
SEE IF CTYPE IS FLOAT.
BNE *+8
BRANCH IF NOT.
LA
1,4(1)
OTHERWISE, INCREMENT INDEX.
LA
6,DYADTAB
PICK UP TABLE POINTER.
LTR 2,2
SEE IF OP IS DYADIC.
BNZ *+8
BRANCH IF SO.
LA
6,MONADTAB
OTHERWISE, PICK UP MONADIC TABLE.
L
1,0(6,1)
PICK UP ROUTINE ADDRESS.
LTR 1,1
CHECK FOR ZERO.
BZ
ZEROADD
BRANCH IF SO.

27140000
27370000
27600000
27830000
28060000
28290000
28520000
28750000
28980000
29210000
29440000
29670000
29900000
30130000
30360000
30590000
30820000
31050000
31280000
31510000
31740000
31970000
32200000
32430000
32660000
32890000
33120000
33350000
33580000
33810000
34040000
34270000
34500000
34730000
34960000
35190000
35420000
35650000
35880000
36110000
36340000
36570000
36800000
37030000
37260000
37490000
37720000
37950000
38180000
38410000
38640000
38870000
39100000
39330000
39560000
39790000
40020000
40250000
40480000
40710000

IRETURN
SPACE
SPACE
*
*
*
*
ZEROADD
RNGEROR
*
*
*
OC1
OC2
OC3
OC4
OC5
OC11
FTCHTYP
*

*
BOOLR
FIXR
FLTR
CHARR
DONTCARE
NOCHAR
ZLAST
*
*
ARTHTAB
PLUS
MINUS
TIMES
DIV
STAR
MAX
MIN
MOD
AND
OR
LT
LE
EQ
GE
GT
NE
EPS
IOTA
RHO

,OTHERWISE, RETURN.

40940000
41170000
41400000
41630000
IF WE FIND A ZERO ADDRESS, WE ASSUME THE OPERATOR HAS NOT YET 41860000
BEEN IMPLEMENTED AND GIVE A NONCE ERROR.
42090000
42320000
SPACE
42550000
LA
1,ESYNTAX
42780000
ICALL ERROR
43010000
SPACE
43240000
LA
1,ERANGE
43470000
ICALL ERROR
43700000
EJECT
43930000
44160000
CONSTANTS AND TABLES.
44390000
44620000
DC
F'1'
44850000
DC
F'2'
45080000
DC
F'3'
45310000
DC
F'4'
45540000
DC
F'5'
45770000
DC
F'11'
46000000
DC
FL1'1,5,6,13,7,2,8,13,9,10,3,13,13,13,13,4'
46230000
46460000
TITLE 'ARITHMETIC TYPE TABLE
05/11/70' 46690000
PRINT GEN
46920000
PRINT NOGEN
47150000
47380000
EQU 1
47610000
EQU 2
47840000
EQU 3
48070000
EQU 4
48300000
EQU 5
48530000
EQU X'80'
48760000
EQU ZA-1
THIS MUST BE GT MAX OPERATOR SYMBOL. 48990000
49220000
49450000
SPACE
49680000
EQU *
49910000
SPACE
50140000
ARTHTYPE DONTCARE+NOCHAR
50370000
ARTHTYPE DONTCARE+NOCHAR
50600000
ARTHTYPE DONTCARE+NOCHAR
50830000
ARTHTYPE FLTR+NOCHAR
51060000
ARTHTYPE FLTR+NOCHAR
51290000
ARTHTYPE DONTCARE+NOCHAR,FIXR,DONTCARE+NOCHAR
51520000
ARTHTYPE DONTCARE+NOCHAR,FIXR,DONTCARE+NOCHAR
51750000
ARTHTYPE DONTCARE+NOCHAR
51980000
ARTHTYPE BOOLR+NOCHAR
52210000
ARTHTYPE BOOLR+NOCHAR
52440000
ARTHTYPE DONTCARE+NOCHAR,,,BOOLR
52670000
ARTHTYPE DONTCARE+NOCHAR,,,BOOLR
52900000
ARTHTYPE DONTCARE,,,BOOLR
53130000
ARTHTYPE DONTCARE+NOCHAR,,,BOOLR
53360000
ARTHTYPE DONTCARE+NOCHAR,,,BOOLR
53590000
ARTHTYPE DONTCARE,,,BOOLR
53820000
ARTHTYPE FIXR,BOOLR,DONTCARE
54050000
ARTHTYPE FIXR,,DONTCARE
54280000
ARTHTYPE DONTCARE,FIXR,DONTCARE
54510000

COMMA
SHRIEK
REV
BASE
REP
CIRCLE
QUERY
NOT
UARROW
DARROW
TRAN
HIST
LOG
NAND
NOR
COLREV
UPGRADE
DNGRADE
DOMINO
LAST

ARTHTYPE DONTCARE
ARTHTYPE FLTR+NOCHAR
ARTHTYPE DONTCARE
ARTHTYPE DONTCARE+NOCHAR
ARTHTYPE DONTCARE+NOCHAR
ARTHTYPE FLTR+NOCHAR
ARTHTYPE DONTCARE+NOCHAR,,FIXR+NOCHAR
ARTHTYPE BOOLR+NOCHAR,,DONTCARE
ARTHTYPE DONTCARE
ARTHTYPE DONTCARE
ARTHTYPE DONTCARE
ARTHTYPE DONTCARE
ARTHTYPE FLTR+NOCHAR
ARTHTYPE BOOLR+NOCHAR
ARTHTYPE BOOLR+NOCHAR
ARTHTYPE DONTCARE
ARTHTYPE DONTCARE+NOCHAR,FIXR
ARTHTYPE DONTCARE+NOCHAR,FIXR
ARTHTYPE FLTR+NOCHAR
ARTHTYPE DONTCARE
TITLE 'DYADIC OPERATOR ROUTINE TABLE
05/11/70'
SPACE
DYADTAB DC
0F'0'
ENTRY DYADTAB
RTNTAB EQU DYADTAB
PLUS
DYADICOP EXADD,EXFAD
MINUS
DYADICOP EXSUB,EXFSB
TIMES
DYADICOP EXMPY,EXFMP
DIV
DYADICOP EXFDP
STAR
DYADICOP EXEXP
MAX
DYADICOP EXMAX,EXDMAX
MIN
DYADICOP EXMIN,EXDMIN
MOD
DYADICOP EXFRES,EXRES
AND
DYADICOP EXAND
OR
DYADICOP EXOR
LT
DYADICOP EXLSTH,EXDLSTH
LE
DYADICOP EXLSTHEQ,EXDLSTHE
EQ
DYADICOP EXEQUAL,EXDEQUAL
GE
DYADICOP EXGRTHEQ,EXDGRTHE
GT
DYADICOP EXGRTH,EXDGRTH
NE
DYADICOP EXNOTEQU,EXDNOTEQ
EPS
DYADICOP EXEPS
IOTA
DYADICOP EXIOTA
RHO
DYADICOP EXRHO
COMMA
DYADICOP EXCATEN
SHRIEK DYADICOP EXBINOM
REV
DYADICOP EXDCIRSL
BASE
DYADICOP EXBASE
REP
DYADICOP EXREP
CIRCLE DYADICOP EXCIRCLE
QUERY
DYADICOP EXRANDOM
NOT
DYADICOP EXERROR
UARROW DYADICOP EXTAKE
DARROW DYADICOP EXLEAVE
TRAN
DYADICOP EXTRAN
HIST
DYADICOP EXCEINTF
LOG
DYADICOP EXDLOG
NAND
DYADICOP EXNAND
NOR
DYADICOP EXNOR
*** FOLLOWING STATEMENT PRODUCES A HARMLESS ASSEMBLY ERROR ************

54740000
54970000
55200000
55430000
55660000
55890000
56120000
56350000
56580000
56810000
57040000
57270000
57500000
57730000
57960000
58190000
58420000
58650000
58880000
59110000
59340000
59570000
59800000
60030000
60260000
60490000
60720000
60950000
61180000
61410000
61640000
61870000
62100000
62330000
62560000
62790000
63020000
63250000
63480000
63710000
63940000
64170000
64400000
64630000
64860000
65090000
65320000
65550000
65780000
66010000
66240000
66470000
66700000
66930000
67160000
67390000
67620000
67850000
68080000
68310000

COLREV
UPGRADE
DNGRADE
DOMINO
LAST

DYADICOP EXDCIRSL
68540000
DYADICOP EXERROR
68770000
DYADICOP EXERROR
69000000
DYADICOP EXDMATD
69230000
DYADICOP EXERROR
69460000
TITLE 'MONADIC OPERATOR ROUTINE TABLE
05/11/70' 69690000
MONADTAB DC
0F'0'
69920000
ENTRY MONADTAB
70150000
COMTBL EQU MONADTAB
70380000
SPACE
70610000
PLUS
MONADOP EXMADD,EXMFAD
70840000
MINUS
MONADOP EXMSUBT,EXMFSB
71070000
TIMES
MONADOP EXMMPY,EXMFMP
71300000
DIV
MONADOP EXMFDP
71530000
STAR
MONADOP EXMEXP
71760000
MAX
MONADOP EXCEIL,EXDCEIL
71990000
MIN
MONADOP EXFLOOR,EXDFLOOR
72220000
MOD
MONADOP EXABS,EXDABS
72450000
AND
MONADOP EXERROR
72680000
OR
MONADOP EXERROR
72910000
LT
MONADOP EXERROR
73140000
LE
MONADOP EXERROR
73370000
EQ
MONADOP EXERROR
73600000
GE
MONADOP EXERROR
73830000
GT
MONADOP EXERROR
74060000
NE
MONADOP EXERROR
74290000
ALPHA
MONADOP EXERROR
74520000
EPS
MONADOP EXERROR
74750000
IOTA
MONADOP EXMIOTA
74980000
RHO
MONADOP EXMRHO
75210000
OMEGA
MONADOP EXERROR
75440000
COMMA
MONADOP EXRAVEL
75670000
SHRIEK MONADOP EXFACT
75900000
REV
MONADOP EXMREV
76130000
BASE
MONADOP EXERROR
76360000
REP
MONADOP EXERROR
76590000
CIRCLE MONADOP EXMCIRC
76820000
QUERY
MONADOP FRANDOM,DRANDOM
77050000
NOT
MONADOP EXNOT
77280000
UARROW MONADOP EXERROR
77510000
DARROW MONADOP EXERROR
77740000
TRAN
MONADOP EXMTRAN
77970000
HIST
MONADOP EXMHIST
78200000
LOG
MONADOP EXMLOG
78430000
NAND
MONADOP EXERROR
78660000
NOR
MONADOP EXERROR
78890000
*** FOLLOWING STATEMENT PRODUCES A HARMLESS ASSEMBLY ERROR ************ 79120000
COLREV MONADOP EXMREV
79350000
UPGRADE MONADOP EXUPGRD
79580000
DNGRADE MONADOP EXDNGRD
79810000
DOMINO MONADOP EXMMATD
80040000
LAST
MONADOP EXERROR
80270000
PRINT NOGEN
80500000
TITLE 'OPERATOR TYPE TABLE
05/11/70' 80730000
SCALAROP EQU 1
80960000
ODDOP
EQU 2
81190000
INDEXED EQU X'80'
81420000
SPACE
81650000
ENTRY OPTAG
81880000
ENTRY INDICTR
82110000

INDICTR
OPTAG
PLUS
MINUS
TIMES
DIV
STAR
MAX
MIN
MOD
AND
OR
LT
LE
EQ
GE
GT
NE
EPS
IOTA
RHO
COMMA
SHRIEK
REV
BASE
REP
CIRCLE
QUERY
NOT
UARROW
DARROW
TRAN
HIST
LOG
NAND
NOR
COLREV
UPGRADE
DNGRADE
DOMINO
LAST

IDENTS

EQU *
EQU INDICTR
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE ODDOP,,,INDEXED
OPTYPE SCALAROP
OPTYPE ODDOP,,INDEXED
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE SCALAROP
OPTYPE SCALAROP,ODDOP
OPTYPE SCALAROP,ODDOP
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE SCALAROP
OPTYPE ODDOP,,INDEXED
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE ODDOP
OPTYPE ODDOP
TITLE 'IDENTITY ELEMENTS
ENTRY IDENTS
DC
0F'0'
EQU *-8*ZPLUS
IDEL PLUS,2,LA,0,0
IDEL MINUS,2,LA,0,0
IDEL TIMES,2,LA,0,1
IDEL DIV,2,LA,0,1
IDEL STAR,2,LA,0,1
IDEL MAX,3,LD,0,MINF
IDEL MIN,3,LD,0,PINF
IDEL MOD,2,LA,0,0
IDEL LT,1,LA,0,0
IDEL LE,1,L,0,BIT0
IDEL EQ,1,L,0,BIT0
IDEL GE,1,L,0,BIT0
IDEL GT,1,LA,0,0
IDEL NE,1,LA,0,0
IDEL AND,1,L,0,BIT0

82340000
82570000
82800000
83030000
83260000
83490000
83720000
83950000
84180000
84410000
84640000
84870000
85100000
85330000
85560000
85790000
86020000
86250000
86480000
86710000
86940000
87170000
87400000
87630000
87860000
88090000
88320000
88550000
88780000
89010000
89240000
89470000
89700000
89930000
90160000
90390000
90620000
90850000
91080000
91310000
91540000
05/11/70' 91770000
92000000
92230000
92460000
92690000
92920000
93150000
93380000
93610000
93840000
94070000
94300000
94530000
94760000
94990000
95220000
95450000
95680000
95910000

IDEL OR,1,LA,0,0
IDEL SHRIEK,2,LA,0,1
IDEL NAND,0,LA,0,0
NO IDENTITY
IDEL NOR,0,LA,0,0
NO IDENTITY
IDEL LOG,0,LA,0,0
NO IDENTITY
IDEL CIRCLE,0,LA,0,0
NO IDENTITY
ORG
DC
0D'0'
MINF
DC
X'FFFFFFFFFFFFFFFF'
PINF
DC
X'7FFFFFFFFFFFFFFF'
BIT0
EQU MINF
LTORG
END
./ ADD
NAME=APLSASUP
ASUP TITLE 'A P L S U P M A C R O D E F I N I T I O N S
'
*
5734-XM6 COPYRIGHT IBM CORP. 1969,1970,1972
*
5736-XM6 COPYRIGHT IBM CORP. 1969,1970,1972
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&L
BAIL
&L
L
2,=A(MVTPOST)
POST DAUGHTER
BALR 1,2
MEXIT
MEND
SPACE
MACRO
&L
COMRG
MNOTE 7,'ENVIRONMENT CONFUSION.'
MEND
SPACE 1
MACRO
&L
MODNOTE
.*
FLAG DECISIONS DEPENDENT ON 4 WIRE MODEMS.
&L
DC
0AL1(Q4WMDM)
DECISION POINT FOR 4 WIRE MODEM.
MEND
SPACE 1
MACRO
&L
SATSUB
&L
BAL LINK,SATPSUB
PURGE POSSIBLE INTERVAL EVENT.
BAL LINK,SATSUB
SET ATTENTION.
MEND
SPACE 1
MACRO
LOWCORE
APLSUP START 0
APLLOW EQU *
LOWCORE DSECT
USING OURLOW,0
OURLOW DS
0D
DS
D
C043
PINHEDD DS
D
DOUBLEWORD PINHED FOR PSW'S
DS
2F
DS
2D
PCOLDPSW DC
D'0'
C063
MCOLDPSW DC
D'0'
C063
IOOLDPSW DC
D'0'
C063
CSW
DC
D'0'
C063
CAW
DC
F'0'
C063
LOC76
DC
F'0'
C063
LOC80
DC
F'70000'

96140000
96370000
96600000
96830000
97060000
97290000
97520000
97750000
97980000
98210000
98440000
98670000
98900000
00010000
00020000
00030000
00040000
00050000
00060000
00090000
00100000
00110000
00130000
00140000
00150000
00160000
00230000
00240000
00250000
00260000
00270000
00280000
00290000
00300000
00310000
00320000
00330000
00340000
00350000
00360000
00370000
00380000
00390000
00420000
00470000
00520000
00530000
00540000
00550000
00560000
00570000
00640000
00660000
00670000
00680000
00690000
00700000
00710000
00720000

SYSTOD
EXNEWPSW
SVNEWPSW
PCNEWPSW
MCNEWPSW
IONEWPSW

*
*
*
QZA7
*
*
*

DC
DS
DS
DS
DS
DC
DS
MEND
SPACE
MACRO
QZA7

F'0'
D
D
D
D
0D'0',X'00040000',A(IOINT)
256C
DIAGNOSTIC SCANOUT AREA
1

MVT WAIT. WILL ONLY BE ISSUED ON THE DAUGHTER PRB.

OI

SETHILO,SHLSTOPH

WAIT 1,ECB=ECBFILLE

STOP SETHI/SETLO LOOP AT NEXT

HIGH PRIORITY
WAIT UNTIL POSTED BY ..
EXINT, MPXINT, OR SELINT.

3064
3064

WAIT 1,ECB=ECBFILLE
DC
0AL4(ALLON)
WAIT LEAVES US ENABLED.
3064
MVI ECBFILLE,0
RESET WAIT AND POST FLAGS
3064
SPACE 2
3064
NI
SETHILO,NOT-SHLSTOPH WITHDRAW REQUEST TO STOP LOOP 3064
TM
SETHILO,SHLACTIV
IS LOOP STILL ACTIVE?
3064
BO
QZA0
IF SO, WE'RE DONE HERE
3064
SPACE 1
3064
* APLSETHI/APLSETLO LOOP IS NO LONGER ACTIVE.
3064
* WE'LL ASSUME SUBTASK WAS LEFT AT HIGH PRIORITY, AS WE REQUESTED 3064
*
3064
L
2,=A(BOUNSUB)
A CONVENIENT EXISTING ADCON
3064
USING BOUNSUB,2
TELL ASSEMBLER
3064
LM
2,3,LOWLIM
TIME INTERVAL AT HIGH PRIORITY 3064
DROP 2
3064
BAL 5,ENQIE
GET REALTIME, AND ENQUEUE INTERVAL 3064
OI
SETHILO,SHLACTIV
INDICATE LOOP IS ACTIVE
3064
B
QZA0
GO TO SCHEDULER
3064
MEND
SPACE 1
MACRO
QZE1
QZE1
CLI SELBUSY,1
TEST FOR SELECTOR CHANNEL BUSY
BE
QZE3
SEE IF OS THINKS SELBUSY IS 1
DASD
BL
QZE2
COMPLETELY FREE
MVI SELBUSY,1
MAKE BUSY, APPENDAGE COULD NOT DO
NI
SWITCHES,NOT-SELAPENT RESET THE APPENDAGE ENTRY SW DASD
L
1,=A(SELSTAR)
ADDRESSABILITY
DASD
USING SELSTAR,1
DASD
MVI SELCNT+1,0
CLEAR ERROR COUNTER.
DASD
DROP 1
DASD
*
EXCP DSKIOB
EXCP ON DIFFERENT DCB
EXCP DSKIOB
EXCP ON DIFFERENT DCB
B
QZA2
NOW BUSY, DON'T TRY TO INITIATE
MEND
SPACE
MACRO
EXITPC
SVTIME EQU SVILG
INTERPRETER GETS IT'S OWN TIME
SVEXITPC EQU SVILG
DOS HANDLES EXIT PC
MEND
SPACE 1

00730000
00820000
00830000
00850000
00860000
00880000
00890000
00950000
00960000
00970000
00980000
01120000
01130000
01140000
01150000
01160000
01170000
01180000
01190000
01200000
01210000
01220000
01230000
01240000
01250000
01260000
01270000
01280000
01290000
01300000
01310000
01320000
01330000
01340000
01350000
01360000
01370000
01380000
01390000
01400000
01420000
01440000
01500000
01510000
01600000
01610000
01620000
01630000
01640000
01650000
01660000
01670000
01680000
01690000
01700000
01710000
01810000
01910000
01920000
01930000

MACRO
SELEXIT

01940000
01950000
*
02030000
*
IF THE SELECTOR OPERATION DID NOT RESULT IN AN ERROR
02040000
*
OR IN ANOTHER OPERATION STARTING (IE SELBUSY = 0 OR 2),
02050000
*
AND THE DAUGHTER TASK IS WAITING AT QZA7, POST.
02060000
*
02070000
*
IMPORTANT ASSUMPTION.
02080000
*
THE PRIORITY OF THE DAUGHTER TASK IS ASSUMED
02090000
*
NEVER TO EXCEED THAT OF THE MOTHER, SO THAT THE POST
02100000
*
BELOW WILL NEVER SET UP A TASK SWITCH. A LATENT TASK SWITCH 02110000
*
MAY BE FATAL IF THE SELECTOR CHANNEL INTERRUPT CAME WHILE
02120000
*
EXECUTING IN THE APL SCHEDULER.
02130000
DROP 14
02140000
USING APLLOW,9
02150000
SELEXIT LR
9,14
14 GETS LOST BY POST.
02160000
CLI SELBUSY,1
TEST CURRENT SELECTOR STATUS.
02170000
BE
SELEXITZ
BRANCH IF RESTARTING.
02180000
BH
SELZPOST
BRANCH IF SELEXCP HAS BEEN CALLED. 02190000
* WHEN ABANDONING A COMMAND CHAIN, IT IS WISE TO INITIALIZE THE IOB.
02200000
* OTHERWISE, IOS MAY ATTEMPT ERROR RECOVERY AFTER HAVING DEQUEUED THE 02210000
* RQE OR SOMETHING.
02220000
MVC DSKIOB+IOBFLAG1-IOBD(2),APLFLAGS
02230000
MVC DSKIOB+IOBSENS0-IOBD(2),ZERO
02240000
MVC DSKIOB+IOBFLAG3-IOBD(8),ZERO
02250000
MVI DSKIOB+IOBECBCC-IOBD,X'7F' NOTE CC ...
02260000
SELZPOST BAIL
02270000
*
02280000
*
RETURN TO IOS FROM CHANNEL END APPENDAGE.
02290000
*
02300000
*
0(14) NORMAL RETURN - SPECIFIES SYSTEM ACTION.
02310000
*
INCLUDING DEQUEUE AND ERROR RECOVERY.
02320000
*
4(14) NOT COMPLETE (NO POST), BUT REQUEST ELEMENT IS
02330000
*
MADE AVAILABLE.
02340000
*
8(14) NOT COMPLETE (NO POST), RETRY CHAIN.
02350000
*
12(14) NOT COMPLETE, REQUEST ELEMENT NOT MADE AVAILABLE.
02360000
*
02370000
*
THE RETURN HAS BEEN STORED IN THE SAVED R10.
02380000
*
SEE SELEXCP.
02390000
*
02400000
SELEXITZ RESET UGHSW,APPENDG
2217 02410000
SELUGH MVC CSW(8),MVTCSW
RESTORE REAL CSW.
2217 02420000
LM
0,15,APLSAVE
RESTORE IOS' REGISTERS.
02430000
SR
9,9
GUARANTEE ZERO R9.
02440000
B
0(10,14)
RETURN TO IOS.
02450000
DROP 9
02460000
USING APLLOW,14
02470000
SPACE
02480000
MEXIT
02490000
MEND
02540000
SPACE 1
02550000
MACRO
02560000
&L
SVTOMX
02570000
*
SETUP FOR BRANCH TO MULTIPLEX AND RETURN VIA R15
02580000
&L
STM 0,15,MPXSAVE
SAVE REGISTERS OVER MPX EXECUTION
02590000
MVI DELZFLG,2
FLAG FOR MPXEXIT
02600000
MEND
02610000
SPACE 1
02620000
MACRO
02630000
MPXEXIT
02640000

*
RESOLVE MPX CALLER BY DELZFLG.. 0=MPXINT, 1=IEMPX, 2=INITMOP
MPXEXIT CLI DELZFLG,1
BE
EXTIME
RETURN TO TIMER CODE
2217
BH
MXRET1
*
RETURN FROM MULTIPLEX INTERRUPT
RESET UGHSW,MPXIO
2217
SPACE
*
*
MVT MPXEXIT.
*
* 1.
C020
* 2.
MVTTCBP IS MXCVTTCB
C020
* 3.
GOTO MXZ1 IF RESCH=0
* 4.
RESCH IS 0
* 5.
POST01 0,ECBFILLE,TCBFILLE
* 6. MXZ1:
C020
* 7.
GOTO MXRET2 IF NOT OR/MXOLDPSW.(PP,WAIT).
C020
* 8.
GOTO MXRET4 IF =/MVTTCBP
C020
* 9. MXRET3: CSW IS CAW IS 0
C020
*
GOTO IOREJ
C020
*10. MXRET4: GOTO MXRET3 IF MXOLDPSW.(WAIT).
C020
*11. MXRET2: GOTO MXOLDPSW
C020
SPACE 3
C020
*
RESTORE ALL VALUES SAVED AT MPXINT.
*
SPACE
* 1.
* 2.
SPACE 2
C020
**------------SEE COMMENTS AT MPXINT -------------------- C020
**
THE FOLLOWING CODE BACKS OFF DEBUGGING AID INSERTED AT
C020
**
MPXINT.
C020
SPACE 2
C020
L
15,CVT
CVT POINTER
C020
L
3,CVTTCBP(15) ADDRESS OF NEXT,CURRENT TCB POINTE C020
MVC 0(8,3),MXCVTTCB RESTORE GLOBAL VALUE
C020
**------- SEE NOTE ABOVE FOR DESCRIPTION OF PRECEEDING CODE
C020
SPACE 2
C020
* 3.
CLI RESCH,0
SEE IF APL BECAME FEASIBLE.
BE
MXZ1
BRANCH IF NOT.
* 4.
MVI RESCH,0
* 5.
*
BAIL
C020
BAIL
*
*
ENTER MVT DISPATCHER IF INTERRUPT CAME IN WAIT STATE.
*
*
* 6.
MXZ1
EQU *
C020
*
* 7.
TM
MXOLDPSW+1,3
WAIT + PROBLEM STATE.
BZ
MXRET2
BRANCH IF NEITHER.
*
* 8.
CLC 0(4,3),4(3)
TASK SWITCH REQUIRED ?
3572
BE
MXRET4
NO, SAME GUY GETS CONTROL AGAIN
3572

02660000
02670000
02680000
02690000
02700000
02710000
02850000
02860000
02870000
02880000
02890000
02900000
02910000
02920000
02930000
02940000
02950000
02960000
02970000
02980000
02990000
03000000
03010000
03020000
03030000
03040000
03050000
03060000
03070000
03080000
03090000
03100000
03110000
03120000
03130000
03140000
03150000
03160000
03170000
03180000
03190000
03200000
03210000
03220000
03230000
03240000
03250000
03260000
03270000
03280000
03290000
03300000
03310000
03320000
03330000
03340000
03350000
03360000
03370000
03380000

*
* 9.
*
C020
* A TASK SWITCH IS CALLED FOR, GO TO IOS AND LET IT HANDLE IT
C020
*
C020
MXRET3 XC
CSW(12),CSW
CLEAR CSW & CAW
3572
*
IOS SHOULD IGNORE THE 'MODIFIED'
3572
*
INTERRUPT THAT WILL BE PASSED ON
3572
*
3572
B
IOREJ
PASS IT DOWN THE LINE
3572
*
C020
* 10.
C020
*
C020
MXRET4 TM
MXOLDPSW+1,2
IF IN WAIT STATE, THEN
C020
BO
MXRET3
. LET OS HANDLE IT.
C020
*
C020
* 11.
C020
*
C020
MXRET2 MVC PINHEDD(8),MXOLDPSW RETURN TO INTERRUPTEE
C020
LM
0,15,APLSAVE
RESTORE REGS
LPSW PINHEDD
MXRET1 LM
0,15,MPXSAVE
SVTOX (INITMOP) CALLED MPX CODE
BR
LINK
RETURN TO SVC CODE
MEND
SPACE 1
MACRO
SELEXCP
SPACE
*
IN MVT, SELEXCP HANDLES BOTH START AND RESTART.
*
IF DSKECB IS COMPLETE, THE CALL IS FROM THE SCHEDULER AND
*
AN EXCP MAY BE ISSUED.
*
IF DSKECB IS NOT COMPLETE, THE CALL IS FROM AN APPENDAGE ...
*
IF THE NEW REQUEST IS FOR THE DCB WHICH JUST ENDED, RETURN TO
*
IOS 8(14), TO REQUEST RE-EXCP.
*
IF THE NEW REQUEST IS FOR A DIFFERENT DCB, SETSELBUSY SO THAT
*
THE SCHEDULER WILL ISSUE AN EXCP, THEN RETURN 0(14).
*
*
NOTE.. EXCP WILL NORMALLY BE ISSUED ONLY ON THE DAUGHTER TCB.
*
THUS, SELECTOR CHANNEL IO GOES AT THE PRIORITY OF THE DAUGHTER
*
TASK.
*
SELEXCP L
2,=A(SELSTAR)
SETUP ADDRESSABILITY
K DASD
USING SELSTAR,2
K DASD
MVI SEEKAD+1,EMPTYM
WIPEOUT OLD SEEKAD
DASD
MVI SELCNT+1,0
CLEAR ERROR COUNTER
K DASD
NI
SWITCHES,NOT-SELAPENT RESET THE APPENDAGE ENTRY SW DASD
SELEXCP2 ST
0,DSKIOB+IOBSTART-IOBD-1 CCW CHAIN(CAW)
K DASD
ST
0,DSKIOB+IOBRESTR-IOBD RESTART CCW ADDRESS.
L
2,CDCBASE
BASE REGISTER FOR DISK PARAMETERS
USING CDCPARS,2
LR
9,0
5989
L
9,0(9)
FIRST HALF OF FIRST CCW.
*
- WHICH MUST BE A SEEK.
MVC DSKIOB+IOBSEEK-IOBD+3(5),2(9)
*
SEEK ADDRESS FOR STAND ALONE SEEK.
LA
8,DCBL
LENGTH OF DCB.
LH
9,LOGAD
MVT VERSION, USED AS INDEX INTO DCB
*
TABLE.
MR
8,8
DISPLACEMENT INTO DCB TABLE.
EXTRN APLSDCBS

03390000
03400000
03410000
03420000
03430000
03440000
03450000
03460000
03470000
03480000
03490000
03520000
03530000
03540000
03550000
03560000
03570000
03580000
03600000
03610000
03620000
03640000
03650000
03660000
03670000
03680000
03690000
04080000
04090000
04100000
04110000
04120000
04130000
04140000
04150000
04160000
04170000
04180000
04190000
04200000
04210000
04220000
04230000
04240000
04250000
04260000
04270000
04280000
04290000
04300000
04310000
04320000
04330000
04340000
04350000
04360000
04370000
04380000
04390000
04400000

A
ST
RESET
CLI
BNH
NI
MVC

9,=A(APLSDCBS)
BASE OF DCB TABLE.
9,DCBNEXT
DCB ADDRESS FOR NEXT EXCP.
DCBIFLG AS DESCRIBED UNDER EXCP IN IOS PLM.
49(9),X'40'
*+8
49(9),3
DSKIOB+IOBFLAG1-IOBD(2),APLFLAGS NORMAL IOBFLAG1 AND 2.

*
*
*
*

THE FOLLOWING FIELDS ARE RESET AS RECOMMENDED BY

C28-6550-5 S/360 OS SYSTEM PROGRAMMERS GUIDE.

MVC DSKIOB+IOBSENS0-IOBD(2),ZERO SENSE BYTES.

MVC DSKIOB+IOBFLAG3-IOBD(8),ZERO
IOBFLAG3 AND IOBCSW.
MVI DSKIOB+IOBECBCC-IOBD,0 ECB CONDITION CODE.
ECB COMPLETE BIT WILL BE ON IF FROM SCHEDULER.
TM
DSKECB,X'40'
SEE IF REQUEST WAS FROM SCHEDULER.
MVI DSKECB,0
RESET ECB FLAGS.
BO
SELST1
BRANCH IF FROM SCHEDULER.

*
*
*
*

MVT DOES NOT ALLOW ANY SVC'S FROM A CHANNEL END APPENDAGE.
IT WILL PROVIDE A RESTART ON THE SAME DCB.

CLC DCBNEXT+1(3),DSKIOB+IOBDCBPT-IOBD SEE IF SAME DCB.

DCBAMVC MVC DSKIOB+IOBDCBPT-IOBD(3),DCBNEXT+1 DCB ADDRESS TO IOB.
MVI SELBUSY,2
ASK SCHEDULER TO DO EXCP.
BCR 7,LINK
EXIT IF DIFFERENT DCB.
MVI APLSAVE+3+4*10,8
OTHERWISE, SET 8(14) RETURN TO MVT.
MVI SELBUSY,1
TO INDICATE A RESTART.
BR
LINK
*
ISSUE EXCP.
SELST1 EX
0,DCBAMVC
MOVE DCB ADDRESS TO IOB.
MVI SELBUSY,1
MARK I/O STARTED.
ST
15,S15FOSXC
SAVE R15 OVER EXCP
2543
*
EXCP DSKIOB
EXCP DSKIOB
L
15,S15FOSXC
RE-LOAD R15
2543
BR
LINK
RETURN TO CALLER.
DROP 2
MEND
SPACE 1
MACRO
SELINT
SELINT EQU *
CLI CSW+5,PCICSW
PCI, PURE AND SIMPLE
BE
SELPCI
MEND
SPACE 1
MACRO
SELSTAR
SPACE
*
MVT .. SELEXCP PERFORMS BOTH START AND RESTART.
SELSTAR EQU *
C022
B
SELEXCP2
K DASD
MEND
SPACE 1
MACRO
SELTIME
DRNOW1 L
10,=A(SELSTAR)
B
SELEXIT-2
BALR LINK,10
MEND

04410000
04420000
04430000
04440000
04450000
04460000
04470000
04480000
04490000
04500000
04510000
04520000
04530000
04540000
04550000
04560000
04570000
04580000
04590000
04600000
04610000
04620000
04630000
04640000
04650000
04660000
04670000
04680000
04690000
04700000
04710000
04720000
04730000
04740000
04750000
04760000
04770000
04780000
04790000
04800000
04810000
04820000
04940000
04960000
04970000
04980000
04990000
05000000
05010000
05390000
05400000
05410000
05420000
05430000
05440000
05450000
05460000
05690000
05700000
05710000

SPACE
MACRO
SELACT
SELACT EQU *
DISK RETRY ROUTINES FOLLOW
MEND
SPACE 1
MACRO
&L
IEBRN &ADR,&INT
&L
DC
0F'0'
IEBASE SETTING
DC
AL1(IETBRN)
EVENT TYPE = BRN
DC
AL3(&ADR)
BRANCH TO &INT
DC
A(&INT)
AFTER &INT TIME HAS ELAPSED
MEND
SPACE 1
MACRO
&X
UGH &C
GBLA &UGHCTR
LCLC &CC
&UGHCTR SETA &UGHCTR+1
AIF (T'&C EQ 'O').UNCOND
&CC
SETC '&C'(1,1)
AIF ('&CC' EQ 'N').STRIP
&CC
SETC 'N'.'&C'
NEGATE THE REQUESTED CONDITION
AGO .GO
.STRIP ANOP
&CC
SETC '&C'(2,7)
STRIP THE N FROM THE REQUESTED COND
.GO
ANOP
&X
B&CC *+8
AGO .UGH
.UNCOND ANOP
AIF (T'&X EQ 'O').UGH
&X
DS
0H
.UGH
ANOP
UGH&UGHCTR BAL 14,UGH
MEND
SPACE 1
MACRO
&L
IETGEN &A
.*
CREATE IETAB ENTRIES
&L
DCY IE&A
IET&A
EQU *-2-IETAB
CODE FOR IEBASE BYTE ZERO
MEND
*
SPACE 1
MACRO
&L
TUSSIG &STATUS,&SIG
GBLA &TUSSC
GBLB &NOLAB
GBLC &TUSSG
.*
CREATE AN ENTRY IN STATUS SENSE TO SIGNAL MAP
AIF (&NOLAB).SS1
AIF (T'&L EQ 'O').SS2
TUSSLC &L
DEFINE LENGTH
.SS2
ORG &TUSSG+&TUSSC
&L
DC
AL1(&STATUS)
SEARCH ARGUMENT
ORG *-1+TUSSL
DC
AL1(&SIG)
RESULT OF SEARCH
.SS1
ANOP
&TUSSC SETA &TUSSC+1
MEND

K01
K01
K01
K01
K01
K01
K01
K01
K01
K01
K01
K01
K01
K01
K01
K01

05720000
05730000
05740000
05760000
06460000
06470000
06480000
06490000
06500000
06510000
06520000
06530000
06540000
06550000
06560000
06570000
06590000
06600000
06610000
06620000
06630000
06640000
06650000
06660000
06670000
06680000
06690000
06700000
06710000
06720000
06730000
06740000
06750000
06760000
06770000
06780000
06790000
06800000
06810000
06820000
06830000
06840000
06850000
06860000
06870000
06880000
06890000
06900000
06910000
06920000
06930000
06940000
06950000
06960000
06970000
06980000
06990000
07000000
07010000
07020000

SPACE 1
MACRO
&L
SELSIG &SENSE,&DRAD
.*
DISK SENSE TO ACTION MAP
&L
TUSSIG &SENSE,&DRAD-SELACT
MEND
SPACE 1
MACRO
&L
TUSGEN
GBLA &TUSSC
GBLB &NOLAB
GBLC &TUSSG
&TUSSC SETA 0
AIF (T'&L EQ 'O').TUS1
.*
GENUINE CALL OF TUSGEN
&L
EQU *
&TUSSG SETC '&L'
&NOLAB SETB 0
AGO .TUS2
.TUS1
ANOP
.*
LENGTH COMPUTATION CALL OF TUSGEN
&NOLAB SETB 1
.TUS2
ANOP
.*
CALLS OF TUSSIG FOLLOW IIIIIIIIIIIIIIIIIIIIIIIIIIII
*
SENSE BYTES FOR 1050, 2741, AND TS41
SE1050 TUSSIG INTREQ+COMREJ,SGINTR
TUSSIG OVERRUN+DATAC+EQUIPC+LOSTDATA,SGMIN
TUSSIG TIMEOUT,SGMIN
*
SENSE BYTES FOR AMBIGUOUS DEVICE
SEAMBIG TUSSIG INTREQ+COMREJ,SGINTR
TUSSIG OVERRUN+DATAC+EQUIPC+LOSTDATA,SGMIN
TUSSIG TIMEOUT,SGTIME
SE1052 TUSSIG EQUIPC+DATAC+INTREQ,SGMIN
*
TABLE FOR UE1050 USE
UECCWI TUSSIG 2,SGMIN
READ
TUSSIG X'0A',SGMIN INHIBIT
TUSSIG 1,255
WRITE, SIO DIAG1
TUSSIG ENABLE,SGTIME HIO
TUSSIG 6,SGTIME
HIO ON PREPCCW
.*
CALLS OF TUSSIG PRECEDE IIIIIIIIIIIIIIIIIIIIIIIII
AIF (NOT &NOLAB).TUS3
.*
LENGTH COMPUTATION CALL
TUSSL
EQU &TUSSC
LENGTH OF DSECT
MEXIT
.TUS3
TUSSLC
MEND
SPACE 1
MACRO
TUSSLC &L
GBLA &TUSLCM,&TUSSC
GBLC &TUSLCP
LCLC &LC1
.* COMPUTE LENGTH OF PREVIOUS TABLE
AIF ('&TUSLCP' EQ '&LC1').SS1
&LC1
SETC '&TUSLCP.X'
&LC1
EQU &TUSSC-&TUSLCM
.SS1
ANOP
&TUSLCP SETC '&L'
&TUSLCM SETA &TUSSC
MEND

07030000
07040000
07050000
07060000
07070000
07080000
07090000
07100000
07110000
07120000
07140000
07150000
07160000
07170000
07180000
07190000
07200000
07210000
07220000
07230000
07240000
07250000
07260000
07270000
07280000
07290000
07300000
07310000
07320000
07330000
07340000
07350000
07360000
07480000
07490000
07500000
07510000
07520000
07530000
07540000
07550000
07560000
07570000
07580000
07590000
07600000
07610000
07620000
07630000
07640000
07650000
07660000
07670000
07680000
07690000
07700000
07710000
07720000
07730000
07740000

SPACE 1
MACRO
SSA &STE,&SIG,&ACT
.*
MAKE AN ENTRY IN STATE,SIGNAL TO ACTION MAP
ORG MXSSAG+&STE+&SIG
DC
AL1((&ACT-ACTBASE)/2)
DC
0AL1(ACTBASE+511-&ACT)
*
IF PRECEDING ASSEMBLES IN ERROR, ACTION IS NOT WITHIN THE
*
REQUIRED 512 BYTES OF ACTBASE, AND THE TABLE IS BLOWN.
MEND
SPACE 1
MACRO
MPDVX &NUM
LCLC &A,&B
DX&NUM DC
AL1(SE&NUM.X)
Q&NUM
EQU DX&NUM-PERDEVXG
AIF ('&NUM' EQ 'TS41').A1
MPDVY &NUM
AGO .A2
.A1
MPDVY 2741,NUM2=TS41
.A2
AIF ('&NUM' EQ 'AMBIG').A3
&A
SETC 'TYO&NUM'
&B
SETC 'TYI&NUM'
EXTRN &A,&B
DC
A(&A,&B)
TRANSLATE TABLES FOR &NUM
MEXIT
.A3
ANOP
DC
2A(EMPT3) AMBIG TRANSLATE TABLE=PROGRAM CHECK
C020
MEXIT
MEND
SPACE 1
MACRO
MPDVY &NUM,&NUM2=2741
DC
AL3(SE&NUM.)
ORIGIN OF SENSE BYTE TABLE
DC
A(UE&NUM.)
UNIT EXCEPTION ROUTINE
AIF ('&NUM' EQ '2741').A1
DC
A(MXR&NUM.)
READ CCW SETUP ROUTINE
MEXIT
.A1
DC
AL1(RST&NUM2.-INPOLL) ADDRESS OF RESEND TEXT
DC
AL3(MXR2741)
MEND
SPACE 1
MACRO
&L
PHGEN &INF,&DIV,&NDX
.*
GENERATE HISTOGRAMS TABLE
.*
CHANGE COMMENTS AT HISTCOMP WHEN CHANGING HISTOGRAMS
.*
&INF IS MAXIMUM VALUE AND MUST BE LESS THAN X'FFFFFF'
.*
&DIV IS NUMBER OF ENTRIES IN HISTOGRAM
.*
&NDX IS NUMBER FOR USE WITH ZHIST OPERATOR
PERH&L DC
A(&DIV-1,&INF/(&DIV-1),HTAB&L) PERHIST
HDIR
CSECT ,
HISTOGRAM DIRECTORY
ORG HBASE+8*&NDX
DC
A(HTAB&L,4+(&DIV+1)/2*4) ADDRESS,LENGTH
HTAB
CSECT ,
HISTOGRAM TABLES
HTAB&L DC
((&DIV+3)/2)F'0'
SPACE FOR THIS HIST TABLE
&SYSECT CSECT
MEND
SPACE 1
MACRO
DEREL

07750000
07760000
07770000
07780000
07790000
07800000
07810000
07820000
07830000
07840000
07850000
07860000
07870000
07890000
07900000
07910000
07920000
07930000
07940000
07950000
07970000
07980000
07990000
08000000
08010000
08020000
08030000
08040000
08050000
08080000
08090000
08100000
08110000
08120000
08130000
08140000
08150000
08160000
08170000
08180000
08190000
08200000
08210000
08220000
08250000
08260000
08270000
08280000
08290000
08300000
08310000
08320000
08330000
08340000
08350000
08360000
08380000
08390000
08400000
08410000

.*

&L
&L

.SVCZ1
.SVINT
.*
.*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
.OSSVC
.*
*
*
SVINT

MACRO TO FIX UP RELATIVE Y CONSTANTS

AR
10,14
MEND
SPACE 1
MACRO
DCY &A
DC
Y(&A-APLLOW)
APLSUP LIVES IN HIGH CORE
MEND
SPACE 1
MACRO
SVINT &X
AIF ('&X' EQ 'SA').SVCZ1
AGO .SVINT
AGO .SVCZ
ANOP
GENERATE SVC INT HANDLER FOR EITHER SYSTEM
STATEMENTS NEEDED ONLY FOR EXECUTED SVCS ARE FLAGED

EX

APL SUPERVISOR CALL INTERFACE

ALL SVC REQUESTS IN THE INTERPRETER ARE MADE VIA THE SVCC
MACRO. THIS MACRO MAPS ALL APL SVC'S TO A SINGLE SVC CODE,
FOLLOWED BY A HALFWORD YYCODE. THE FOLLOWING ROUTINE MAPS
THE YYCODE INTO THE SVC OLD PSW, AND ADJUSTS THE INSTRUCTION
LENGTH CODE. IN THE CASE OF AN EXECUTED SVCC, THE YYCODE
IS IN A HALFWORD FOLLOWING THE SVC INSTRUCTION.
THE ACTUAL SVC CODE IS DESIGNATED IN THE APL CONFIGURATION,
AND IS RESOLVED BY THE LINKAGE EDITOR AS THE DIFFERENCE
BETWEEN THE EXTERNAL SYMBOLS "APLMAP" AND "APLSVC".
AGO .OSSVC
ANOP
OS APL SVC ENTRY
APL SVC'S ARE PASSED TO US FROM THE TYPE-I SVC ROUTINES

BALR MR,0
FOR ADDRESSING CURRENTM
USING *,MR
L
MR,CURRENTM
INTERPRETER MAY HAVE LOST MR
DROP MR
STM 0,15,REGSV-M(MR)
BALR 2,0
TEMPORARY BASE REGISTER
USING SVINTR1,2
SVINTR1 EQU *
.SVC3
AGO .SVCD
.SVCD
L
1,SVOLDPSW+4
ADDRESS HALF OF OLD PSW
LH
3,0(0,1)
PICK UP YYCODE (JUNK IF EXEC SVC)
AH
1,=H'2'
INCREMENT IAR
BM
SVINTR2
BRANCH IF EXECUTED SVC
EX
*
*
MAPPED SVC - INCREMENT IAR BEYOND YYCODE
ST
1,SVOLDPSW+4
UPDATED IAR
XI
SVOLDPSW+4,X'C0'
UPDATE ILC TO INDICATE 4 BYTE INSTR
AGO .SVCJ
.SVCJ
ANOP
SVINTR4 LM
MR,14,SVBASE
STANDARD ADDRESSABILITY FOR MPX/SVC
USING MPXSAVE,MR
USING APLLOW,14
DROP 2
SVINTR5 STC 3,SVOLDPSW+3
REPLACE INTR CODE WITH YYCODE

08430000
08450000
08470000
08480000
08490000
08500000
08560000
08570000
08580000
08590000
08600000
08620000
08630000
08640000
08650000
08660000
08670000
08690000
08700000
08710000
08720000
08730000
08740000
08750000
08760000
08770000
08780000
08790000
08800000
08810000
08820000
08830000
09270000
09280000
09290000
09300000
09310000
09320000
09330000
09340000
09350000
09360000
09370000
09380000
09390000
09430000
09440000
09450000
09460000
09470000
09480000
09490000
09500000
09510000
09570000
09580000
09590000
09600000
09610000
09620000

SET

2217 09640000
09650000
VALIDATE YYCODE AND ENTER PROPER SVC ROUTINE.
09660000
CLI SVOLDPSW+3,SVMAX
VALIDATE SVC CODE
09670000
BH
SVILG
ILLEGAL SVC
09680000
LH
2,SVOLDPSW+2
PICK UP SVC YYCODE
09690000
AR
2,2
09700000
LH
10,SVCTAB(2)
09710000
*
DEREL ,
DERELATIVIZE
09720000
DEREL ,
DERELATIVIZE
09730000
BR
10
09740000
DROP MR
09750000
DROP 14
09770000
*
EX 09790000
*
EXECUTED MAPPED SVC, LOCATE SVC TO PICK UP YYCODE
EX 09800000
USING SVINTR1,2
EX 09810000
SVINTR2 AH
1,=H'-6'
POINT TO EXECUTE INSTRUCTION
EX 09820000
MVN SVINTEX+1(1),1(1) INDEX REGISTER $$$$$ PROG MODIF EX 09830000
MVC SVINTEX+2(2),2(1) BASE AND DISPL $$$$$ PROG MODIF EX 09840000
DROP 2
EX 09850000
LM
0,3,0(MR)
RESTORE USER REGISTERS
EX 09860000
SVINTEX LA
4,*-*(*-*,*-*)
FAKE EX $$$$$ PROG MODIFIED $$$ EX 09870000
LH
3,2(0,4)
PICK UP YYCODE
EX 09880000
AGO .SVCG
09890000
.SVCG
ANOP
EX 09940000
BALR 2,0
EX
09950000
USING *,2
EX
09960000
LM
MR,14,SVBASE
STANDARD ADDR FOR MPX/SVC
EX 09970000
USING APLLOW,14
EX 09980000
DROP 2
EX 09990000
B
SVINTR5
GO PLANT YYCODE IN SVOLDPSW
EX 10000000
DROP 14
EX 10010000
AGO .SVCZ
10020000
.SVCZ
MEND
10130000
SPACE 1
10140000
MACRO
10150000
SVEXIT
10160000
*
10180000
*
RETURN TO INTERPRETER FROM SVCC CALL
10190000
SVEXIT L
1,CURRENTM
10200000
RESET UGHSW,SVC
2217 10210000
MVC PINHEDD(8),SVOLDPSW
10260000
LM
0,15,REGSV-M(1)
10270000
LPSW PINHEDD
10280000
MEND
10290000
SPACE 1
10300000
MACRO
10310000
SVRAPEIT
10320000
*
10340000
*
VIOLATE MACRO -- REQUEST ANOMALOUS PROTECT EXCEPTION
10350000
*
10360000
SVRAPE SSM ALLOFF
INHIBIT SEL CHAN INT WITH MR WRONG 10370000
L
2,SVOLDPSW+4
POINT TO INSTRUCTION TO EXECUTE
10380000
MVC PINHEDD(6),0(2)
MOVE TO PREFIX STORAGE
10390000
LM
0,15,REGSV
ALL 16 REGISTERS.
10400000
EX
0,PINHEDD
10410000
BALR 14,0
TEMPORARY ADDRESSABILITY
10430000
USING *,14
10440000
SVRAPE2 SH
14,SVRPCON
ADJUST BACK TO APLLOW
10450000
USING APLLOW,14
10460000
*
*

UGHSW,SVC

LM
STM
ST

MR,13,SVBASE
0,MR-1,REGSV
15,REGSV+60

RESTORE BASE REGISTERS

K10 10490000
GIVE SAVED REGS VALUE SET BY EXECUTED K10 10500000
INST (EXCEPT FOR REGS HE HAS
10560000
*
NO BUSINESS ALTERING)
10570000
L
2,SVOLDPSW+4
RESTORE OLD PSW TO R2
10580000
SR
1,1
ADD INSTRUCTION LENGTH TO R2
10590000
IC
1,0(0,2)
DETERMINE FROM 1ST 2 BITS OF OP
10600000
SRL 1,6
10610000
IC
1,SVRPTAB(1)
10620000
AR
2,1
NEXT INSTRUCTION ADDRESS
10630000
ST
2,SVOLDPSW+4
10640000
MEND
10650000
SPACE 1
10660000
MACRO
10670000
QZACT &SETPAN
2219 10680000
AIF ('&SETPAN' EQ 'SETPAN').A2S
2219 10720000
AGO .A2OS
10730000
.A2OS
ANOP
2219 10770000
*
TTIMER
10780000
TTIMER
10790000
AGO .A2C
2219 10800000
.A2S
ANOP
2219 10810000
*
2219 10820000
*
TTIMERS ,
GET CPU TIME REMAINING
2219 10830000
TTIMERS ,
GET CPU TIME REMAINING
2219 10840000
.A2C
ANOP
2219 10850000
S
0,TTERM
THIS IS CPU TIME USED
2219 10860000
LPR 0,0
COMPENSATE FOR BACKWARDS SUBTRACT
2219 10880000
SRL 0,7
OS TU TO APL TU.
10890000
MEND
10900000
SPACE 1
10910000
MACRO
10920000
QAACT
10930000
LCLC &L
2219 10950000
*STYIZ2 TTIMER ,
SAMPLE THE CPU TIMER
2219 11080000
STYIZ2 TTIMER ,
SAMPLE THE CPU TIMER
2219 11090000
CL
0,=A(PANICINT*256) IS REMAINING INTERVAL ENOUGH?
2219 11100000
BH
STYIZ3
IF YES, DON'T RE-ISSUE THE STIMER
2219 11110000
*
2219 11120000
* CPU TIMER IS GETTING LOW, RE-ISSUE IT
2219 11130000
*
2219 11140000
LA
1,=A(12*60*60*300*128) 12 HOURS IN OS TIMER UNITS 2219 11150000
MVC TIMEHI,0(1)
INITIALIZE TIMEHI FOR APLSETHI/LO
3064 11160000
* NOTE: THE ABOVE INSTRUCTION MAY CAUSE A DISTORTION
2219 11170000
*
IN THE SHARING OF CPU TIME BETWEEN APL AND
2219 11180000
*
BACKGROUND. EVERY "HALFDAY", APL MAY RUN AT
2219 11190000
*
HIGH PRIORITY FOR AN ADDITIONAL "PANICINT"
2219 11200000
*
TIME INTERVAL.
2219 11210000
*
STIMER TASK,TUINTVL=(1) SET CPU TIMER FOR HALFDAY
2219 11220000
STIMER TASK,TUINTVL=(1) SET CPU TIMER FOR HALFDAY
2219 11230000
B
STYIZ2
LOOK AT THE TIMER VALUE AGAIN. 2219 11240000
SPACE 1
2219 11250000
&L
SETC 'STYIZ3'
2219 11260000
&L
ST
0,TTERM
FOR USE AT QUANTUM END (AND SETPAN) 2219 11280000
MEND
11290000
SPACE 1
11300000
MACRO
11310000
SETPAN
11320000
SETPAN L
2,RBFILLE
EXAMINE DAUGHTER RESUME PSW
2219 11450000
TM
RBOPSW+1(2),1 DON'T GIVE APLSUP A PROGRAM CHECK 2219 11460000

BZ

RE-ENQUEUE SETPAN
2219 11470000
MAKE CERTAIN THAT INTRP HAS HAD
2219 11480000
QZACT SETPAN
SUFFICIENT TIME TO RESPOND TO QUEND 2219 11500000
QZACT SETPAN
2219 11510000
C
0,PANLIM+4
CHECK CPU TIME FOR THIS QUANTUM
11520000
BL
SETBELL1
GIVE INTRP MORE TIME
2219 11540000
*
5997 11550000
* BECAUSE A PROGRAM CHECK WHILE IN THE PIE ROUTINE CAUSES AN ABEN 5997 11560000
*
5997 11570000
L
1,TCBFILLE
INTERPRETER'S TCB
5997 11580000
L
1,TCBPIE(,1) INTERPRETER'S PIE
5997 11590000
TM
0(1),X'80'
IS PIE ACTIVE?
5997 11600000
BO
SETBELL0
YES,TRY AGAIN LATER
5997 11610000
*
5997 11620000
OI
RBOPSW+5(2),EMPTYM FORCIBLY TERMINATE QUANTUM
2219 11630000
B
EXTIM2
2219 11740000
MEND
11750000
SPACE 1
11760000
MACRO
11770000
SETHILO
11780000
*
SET BACKGROUND TO HIGH PRIORITY
11800000
USING APLSETLO,PTR
11810000
ENTRY APLSETLO
FOR CONFIG.
11820000
*
11840000
*
*** ADAPTIVE ALGORITHM FOR PRIORITY ALLOCATION. ***
11850000
*
11860000
*
THIS ALGORITHM IS SUBJECT TO THE FAILINGS OF ALL ADAPTIVE
11870000
*
ALGORITHMS, INCLUDING INSTABILITY. HOWEVER, WE CAN MAKE THE 11880000
*
FOLLOWING TWO ASSERTIONS ..
11890000
*
1.
A. THIS IS NOT A FEEDBACK ALGORITHM.
11900000
*
B. THE RESPONSE TIME FAR EXCEEDS THE WAVE LENGTH
11910000
*
OF THE INPUT.
11920000
*
2.
SINCE THE ALGORITHM DOES NOT DISPATCH RESOURCES, BUT
11930000
*
MODIFIES PRIORITIES FOR RESOURCES, INSTABILITY WON'T
11940000
*
HURT. AT WORST, UNDER HEAVY COMPETITION FROM OTHER
11950000
*
PARTITIONS OR TASKS, POOR RESPONSE MAY RESULT WHEN
11960000
*
THE NUMBER OF USERS SIGNED ON IS SMALL BUT INCREASING
11970000
*
RAPIDLY. THE 1 TO 1 MINIMUM RATIO SHOULD MINIMIZE THIS 11980000
*
PROBLEM IF MAXQUAN IS RELATIVELY SMALL.
11990000
*
12000000
*
HILIM.. IS THE DURATION OF APL LOW PRIORITY.
12010000
*
ASSUMPTION.. HILIM DURATION IS MAXQUAN.
12020000
*
LOWLIM.. IS THE DURATION OF APL HIGH PRIORITY.
12030000
*
POSO .. IS +/SIGNED ON APL.
12040000
*
MAXQUAN .. IS THE NORMAL CPU QUANTUM FOR APL USERS.
12050000
*
12060000
*
12070000
*
ALGORITHM..
12080000
* 1.
T IS (FLOOR POSO DIV PPERQ)-PPERN
12090000
* 2.
GOTO ASL1 IF T LT 0
12100000
* 3.
LOWTIME IS MAXQUAN
12110000
* 4.
HIGHTIME IS MAXQUAN TIMES T+1
12120000
* 5. GOTO ASL2
12130000
* 6. ASL1..
HIGHTIME IS MAXQUAN
12140000
* 7.
LOWTIME IS MAXQUAN TIMES -T
12150000
* 8. ASL2..
12160000
*
12170000
APLSETLO LM
2,3,POSO
+/SIGNEDON
3064 12180000
.* R3 IS LOADED WITH A SMALL POSITIVE NUMBER, SO THAT THE DIVIDE 3064 12190000
.*
WILL GIVE CONSISTENT RESULTS. IDEALLY, R3 SHOULD BE 0, BUT 3064 12200000
*
*

SETBELL0

.*
.*

SLIGHT ERROR INTRODUCED SHOULD NOT BE SIGNIFICANT, AND IT

3064
TAKES LESS CORE.
3064
D
2,PPERQ
SCALED FLOOR POSO DIV PPERQ
S
3,PPERN
T
SRA 3,16
UNSCALED
L
2,QUANLIM+4
MAXQUAN
BM
ASL1
ST
2,LOWTIME
MAXQUAN
LA
3,1(3)
T+1
MR
2,2
MAXQUAN TIMES T+1
ST
3,HIGHTIME
B
ASL2
ASL1
ST
2,HIGHTIME
MAXQUAN
LPR 3,3
MR
2,2
MAXQUAN TIMES -T
ST
3,LOWTIME
ASL2
EQU *
*
3064
*
TTIMERS ,
SAMPLE OUR CPU TIMER
3064
TTIMERS ,
SAMPLE OUR CPU TIMER
3064
*
3064
LCR 1,0
-CURRENT TIMER VALUE
3064
AL
1,TIMEHI
TIMER VALUE WHEN WE CHAPPED UP
3064
TM
SETHILO,SHLSTOPH
IS A REQUEST TO STOP CYCLE PENDI3064
.*
IF THERE IS, WE NEED NOT INSIST ON OUR FULL
3064
.*
SHARE OF HIGH PRIORITY TIME.
3064
BNZ ASL2S
YES
3064
SRL 1,7
OS TO APL TIMER UNITS
3064
LM
2,3,LOWLIM
INTERVAL EVENT FOR TIMING HIGH APL
3064
SR
3,1
SUBTRACT WHAT WE ALREADY USED, AND
3064
BP
ASLZ2
RE-ENQUEUE THE REMAINING TIME IFF
3064
* WE DID NOT GET ENOUGH TIME AT HIGH PRIORITY
3064
SLL 1,7
APL TO OS TIMER UNITS
3064
*
3064
*
LOWER PRIORITY OF DAUGHTER TASK TO ZERO.
*
3064
* CREATE HISTOGRAM FOR CPU TIME AT HIGH PRIORITY
3064
*
3064
ASL2S
ST
0,TIMEHI
CPU TIME AT SWITCH TO LOW PR 3064
*
NOTE: REG1 WAS SET UP BY TTIMERS ABOVE.
3064
*
LR
HISTVAL,1
3064
LA
PHR,PERHHCPU HIGH PRIORITY HISTOGRAM
3064
BAL LINK,HISTCOMP
3064
LH
0,CHAPLOW
DISPATCHING PRIORITY DECREMENT
3586
LM
2,3,HILIM
DSETLOW EVENT
B
ASL3
*
*
SET BACKGROUND TO LOW PRIOITY
USING APLSETHI,PTR
*
RAISE DAUGHTER TASK TO LIMIT PRIORITY.
*APLSETHI TTIMERS ,
SAMPLE OUR CPU TIMER
3064
APLSETHI TTIMERS ,
SAMPLE OUR CPU TIMER
3064
*
3064
* CREATE HISTOGRAM OF CPU TIME AT LOW PRIORITY
3064
*
3064
L
HISTVAL,TIMEHI
CPU TIME AT SETLO
3064
ST
0,TIMEHI
SAVE FOR USE BY APLSETLO
3064
SLR HISTVAL,0
CPU TIME AT LOW PRIORITY
3064
LA
PHR,PERHLCPU LOW PRIORITY HISTOGRAM
3064
BAL LINK,HISTCOMP
3064

12210000
12220000
12230000
12240000
12250000
12260000
12270000
12280000
12290000
12300000
12310000
12320000
12330000
12340000
12350000
12360000
12370000
12390000
12400000
12410000
12420000
12430000
12440000
12450000
12460000
12470000
12480000
12490000
12500000
12510000
12520000
12530000
12540000
12550000
12560000
12570000
12580000
12590000
12600000
12610000
12620000
12630000
12640000
12650000
12720000
12730000
12740000
12750000
12760000
12840000
12850000
12860000
12870000
12880000
12890000
12900000
12910000
12920000
12930000
12940000

LH
0,CHAPHI
DISPATCHING PRIORITY INCREMENT
3064
LM
2,3,LOWLIM
DSETHI EVENT
3586
ASL3
BALR PTR,0
ESTABLISH ADDRESSIBILITY
3586
USING *,PTR
3586
L
1,ACHAPCDE
CHAP VALUE LOCATION IN APLM
3586
NC
0(2,1),0(1)
IS CHAPCODE CURRENTLY ZERO?
3586
BZ
ASLZ
AS IT SHOULD BE.
3586
* IF CHAPCODE IS NON-ZERO,WE MISSED ATLEAST ONE CHAP.
3586
* I.E. MOTHER HAS NOT BEEN DISPATCHED SINCE CHAP
3586
*
WAS LAST SET.
3586
CH
0,0(1)
EQUAL?
3586
UGH E
CAN'T BE
3586
SR
0,0
IGNORE THIS CHAP
3586
LH
5,ASLCTR
COUNT HOW OFTEN
3586
LA
5,1(5)
WE HAVE MISSED
3586
STH 5,ASLCTR
ONE CHAP
3586
ASLZ
STH 0,0(1)
SAVE NEW CHAP CODE
3586
XI
SETHILO,SHLCUR
3064
*
STOP CYCLE AT HIGH PRIORITY?
3064
TM
SETHILO,SHLSTOPH+SHLCUR
3064
BO
APLSETNO
YES, SO DON'T ENQUEUE TIMER EVENT
3064
DROP PTR
3064
ASLZ2
L
0,REALTIME
3064
BAL 5,ENQIET
B
EXTIM2
SPACE 2
3064
APLSETNO NI
SETHILO,NOT-SHLSTOPH-SHLACTIV
SET FLAGS TO
3064
*
INDICATE THAT THE APLSETHI/SETLO LOOP HAS BEEN STOPPED
3064
B
EXTIM2
3064
SPACE 3
3064
* CPU TIME AT HIGH PRIORITY
3064
SPACE 2
3064
* 1/300 SECONDS PER UNIT
3064
*HCPU
PHGEN 300*128,300,16
3064
HCPU
PHGEN 300*128,300,16
3064
SPACE 3
3064
* CPU TIME AT LOW PRIORITY
3064
*
3064
* 1/300 SECONDS PER UNIT
3064
*LCPU
PHGEN 300*128,300,17
3064
LCPU
PHGEN 300*128,300,17
3064
EXTRN CHAPCODE
3064
ENTRY CHAPLOW
ASLCTR DC
H'0'
COUNT MISSED CHAPS
3586
ACHAPCDE DC
A(CHAPCODE)
PRIORITY CHANGE VALUE IN MOTHER.
CHAPLOW DC
H'-255'
CHAPHI DC
H'255'
PPERQ
DC
F'65536000'
PORTS PER ADDITIONAL QUANTUM
PPERN
DC
F'32768'
PRIORITY PROPORTION WITH NO USERS
*
INITIAL PROPORTIONS ARE 50 PERCENT TO APL
MEXIT
MEND
SPACE 1
MACRO
SVINIT
*
*
NOTE THAT THE FOLLOWING CODE IS OVERLAID BY HI & PA BUFFERS
*
ENTERED FROM SUPINI TO START EXECUTION
*
NOTE THAT BROADBF COUNT SHOULD = 0 FOR OPFNS USE
*

12950000
12960000
12970000
12980000
12990000
13000000
13010000
13020000
13030000
13040000
13050000
13060000
13070000
13080000
13090000
13100000
13110000
13120000
13130000
13140000
13150000
13160000
13170000
13230000
13270000
13330000
13340000
13350000
13360000
13370000
13380000
13390000
13400000
13410000
13420000
13430000
13440000
13450000
13460000
13470000
13480000
13490000
13500000
13510000
13520000
13530000
13540000
13560000
13570000
13580000
13590000
13650000
13660000
13670000
13680000
13700000
13710000
13720000
13730000
13740000

USING SVINIT,10
13750000
USING MPXSAVE,MR
13760000
USING APLLOW,14
K01 13780000
SVINIT MVC SVCTAB+2*YYQZ,SVINIT1 SETUP PROPER TABLE ENTRY
13800000
LM
0,5,REGSV-M(PXR)
LOAD ITBREGS SETUP BY SIPINI
13810000
BALR LINK,4
CREATE CHAIN OF FREE TYPEWRITER BUFS 13860000
TIME TU
3060 13880000
ST
1,OSDATE
INITIALIZE THE DATE
3060 13890000
B
QUEND
ENTER SCHEDULER
13910000
SVINIT1 DCY QUEND
4 QUANTUM END
13920000
LTORG
14000000
DROP 10,MR
14010000
*
14020000
ORG BROADBF
14030000
DC
H'0'
INITIAL PA LENGTH = 0 FOR OPFNS
14040000
MEXIT
14060000
MEND
14090000
SPACE
14100000
MACRO
14110000
&L
CLIS &A,&S
14120000
.*
CLI WITH RELOCATABLE MASK.
14130000
&L
DC
0H'0',AL4((0-X'6B00')*X'10000'+&S-APLSVC)
14140000
ORG *-2
14150000
DC
S(&A)
BASE, DISPLACEMENT.
14160000
MEND
14170000
SPACE 1
14180000
MACRO
14190000
PTSET &BYTE
NOTE IMPLICIT SETTING OF PT BITS
14200000
AIF ('&BYTE' NE 'ACTIVE').P2
14220000
DC 0AL1(ATTENM+OUTWAITM+INWAITM+NONINM+LOCKM+MISCM)
14240000
MEXIT
14250000
.P2
AIF ('&BYTE' NE 'MISCB').P3
14280000
DC 0AL1(NOWSM+EXCPWM+WANTON+SDWAIT+REPWAITM+TRAWAITM+CLOKWAI*14300000
T+BUFFWAIT)
14310000
MEXIT
14320000
.P3
AIF ('&BYTE' NE 'IOB1').P4
14350000
DC
0AL1(TRREJ+COPYRM+COPYWM+BROADM+RINGM+NSIGNM+PRIVBIT)
14370000
MEXIT
14380000
.P4
AIF ('&BYTE' NE 'IOB2').P5
14410000
DC 0AL1(Q4WMDM+RECMM+LVIDLEM+LOEXP+SHEXP+BOUNCM)
14430000
MEXIT
14440000
.P5
MEND
14460000
MACRO
2217 14470000
&L
SET &SW,&MASK
2217 14480000
&L
OI
&SW,&MASK
2217 14490000
AIF ('&SW' NE 'UGHSW').NOUGHSW
2217 14500000
MVC UGHSWTRC(L'UGHSWTRC),UGHSWTRC+1
2217 14510000
.NOUGHSW ANOP
2217 14520000
MEND
2217 14530000
MACRO
2217 14540000
&L
RESET &SW,&MASK
2217 14550000
&L
NI
&SW,X'FF'-&MASK
2217 14560000
MEND
2217 14570000
SPACE 1
2219 14580000
MACRO
2219 14590000
&L
TTIMERS
14600000
*
2219 14780000
*
SINCE WE ARE EXECUTING UNDER TCBMERE , WE KNOW
2219 14790000
*
THAT THE TQE FOR TCBFILLE IS NOT ON THE QUEUE
2219 14800000
*
2219 14810000

&L

L
1,TCBFILLE
ADDRESS OF SUBTASK TCB
2219
L
1,TCBTME(,1) ADDRESS OF TQE, IF ANY
2219
LTR 0,1
IS THERE A TQE? ZERO IF NOT
2219
BZ
*+8 ******* RETURN 0 IF NO TQE
2219
USING TQE,1
2219
L
0,TQEVAL
TIME REMAINING
2219
DROP 1
2219
MEND
2219
SPACE 1
2219
SPACE 1
PRINT ON
TITLE 'A P L S U P P R E F I X S T O R A G E
05/11/70'
LCLA &TEMPA
LCLC &TEMPC1,&TEMPC2
LOWCORE
, DSECT VS CSECT
SPACE 3
PERDEVXG CSECT
DS
1F
PREVENT PTTYPE OF ZERO
*
HDIR CSECT MUST BE DEFINED BEFORE HTAB, BECAUSE EXMHIST MUST
*
BE ABLE TO CHECK IF HTAB WAS OMITTED & IS REFERENCED.
HDIR
CSECT ,
HISTOGRAM DIRECTORY
DC
A(HDIRZ-HBASE)
END OF TABLE
HBASE
EQU *
*
MAXQUAN EQU 30
= 100 MILSEC
PANICINT EQU 20*MAXQUAN
WAIT A BIT BEFORE WE PANIC
* IF THE INTERPRETER IS IN LCS, PANICINT PROBABLY SHOULD BE LARGER K10
LIRSINT EQU 10*300
10 SEC TIMEOUT FOR DATA SET NOT READY
WIRSINT EQU 150
HALF SECOND
TWOSEC EQU 600
TWO SECOND MPX DELAY
MINQUAN EQU 9*MAXQUAN
DOS TO APL RATIO
MINUTE EQU 60*300
ONE MINUTE IN APL CLOCK UNITS
HOUR
EQU 60*MINUTE
OFFHLIM EQU 1*MINUTE
SIGN OFF HOLD LIMIT
EXPLIM EQU 8*MINUTE
EXPRESS TERMINAL CONNECT DURATION
F
EQU 256
FOR 32 BIT ADCON DEFINITION
NOT
EQU X'FF'
FOR USE IN BUILDING COMPLEMENT MASKS C022
ALL
EQU X'FF'
2217
IDLMAX EQU 10
MAXIMUM READ IDLES FOR 2741 OR 2740
SELERMX EQU 20 ERRORS SAME TRACK, ASSUME NON RECOVERABLE
TIMEFUZ EQU 1
FORCED ERROR IN SETINT CALLS
CPMAXBUF EQU 20
INPUT BUFFER ALLOCATION
COPY APLDEFN
DROP MR
CONCEAL EQU WFLLIB
MEMAD
EQU REGSV+4*MR
LINK
EQU 15
SIGR
EQU 5
PTR
EQU MR+1
PERTERM BASE REGISTER
PXR
EQU PTR+1
PERDEVX OR M BASE REG IN MPX,SVC
HISTVAL EQU 1
MUST BE AN ODD REGISTER
PHR
EQU 3
HISTCOMP BASE REGISTER
*
COPY ZSYMBOLS
COPY DIRSECT
COPY PERTERM
TBLM1
EQU TBL-1
*
APLSUP CSECT
TITLE 'A P L - M V T
I N T E R F A C E'

14820000
14830000
14840000
14850000
14860000
14870000
14880000
14890000
14900000
14910000
14920000
14930000
14960000
14970000
14990000
15000000
15010000
15020000
15030000
15040000
15060000
15070000
15080000
15100000
15110000
15130000
15180000
15190000
15200000
15210000
15220000
15230000
15240000
15250000
15260000
15270000
15280000
15290000
15300000
15310000
15320000
15330000
15340000
15350000
15360000
15370000
15380000
15390000
15410000
15460000
15470000
15480000
15490000
15500000
15520000
15540000
15550000
15560000
15570000
15600000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*LOOP
*
*
*
*
*
*
*
*
*
*

MVT TIMER INTERFACE.

APLSUP TIMER CODE ALWAYS RUNS ON THE MOTHER TCB.
THE TIMER COMPLETION EXIT ROUTINE RESIDES IN THE REAL MOTHER
TASK AND CONSISTS OF THE FOLLOWING ..
1.
2.
3.
4.
5.

GOTO 3 IF ECBMERE NE WAIT.

POST ECBMERE
EXOLDPSW IS RBMERE.(RBOPSW).
RBMERE.(RBOPSW). IS X'00040000',A(EXINT)
GOTO OS

THE REAL MOTHER TASK CONSISTS OF THE FOLLOWING.

WAIT ECB=ECBMERE
B
LOOP
THE FOLLOWING OCCURS AT EXRET.
1.
GOTO 3 UNLESS (ECBFILLE = WAIT) AND RESCH NE 0
2.
POST ECBFILLE
3.
LPSW EXOLDPSW
NOTE - EXOLDPSW IS THE MOTHER PRB RESUME PSW AFTER STEP 1 OF
THE TIMER COMPLETION EXIT ROUTINE.
ENTRY EXINT

*
*
*
EXINTPSW
EXINT
*
*
*
*
*

AT ENTRY, STORAGE KEY IS EITHER ZERO OR THAT OF REGION.

NOTE... MOTHER'S R10 IS DESTROYED.
DC
0D'0',X'00040000',A(EXTIME)
EQU *

3054
3054
IONEWPSW (LOCATION X'78') IS USED BY SSM BELOW SINCE
3054
WE DO NOT HAVE ADDRESSABILITY. FIRST BYTE OF IONEWPSW
3054
SHOULD ALWAYS BE ZERO.
3054
3054
SSM IONEWPSW
DISABLE ALL INTERRUPTS
3054
DC
0AL4(ALLOFF)
SO DISABLE CAN BE FOUND IN XREF 3054
ST
10,PINHEDD
SAVE REG ACROSS BALR
3054
BALR 10,0
ADDRESSABILITY
3054
USING *,10
STM 0,15,APLSAVE
KEY HERE SHOULD MATCH.
MVC APLSAVE+40(4),PINHEDD
SAVE REG 10 IN APLSAVE
3054
L
14,APLBASE
DROP 10
USING APLLOW,14
MVI EXINTLK,X'80'
INICATE WE ARE NOW IN EXINT
3572
SET UGHSW,EXTERNAL
2217
LPSW EXINTPSW
THIS IS REALLY B EXTIME

*
*
*
EXRET

RETURN FROM EXTERNAL INTERRUPT.

*
*
*

IF RESCH IS NON-ZERO, AND APL IS WAITING AT QZA7,

POST DAUGHTER TASK.

RESET UGHSW,EXTERNAL
CLI RESCH,0
BE
EXRET2
SPACE

2217
SEE IF DISPATCHING REQUIRED.
2217
BRANCH IF NO TASK SWITCH REQUIRED.

15610000
15620000
15630000
15640000
15650000
15660000
15670000
15680000
15690000
15700000
15710000
15720000
15730000
15740000
15750000
15760000
15770000
15780000
15790000
15800000
15810000
15820000
15830000
15840000
15850000
15860000
15870000
15880000
15890000
15900000
15910000
15920000
15930000
15940000
15950000
15960000
15970000
15980000
15990000
16000000
16010000
16020000
16030000
16040000
16050000
16060000
16070000
16080000
16090000
16100000
16110000
16120000
16130000
16140000
16150000
16160000
16170000
16180000
16190000
16200000

16210000
SPACE
16220000
MVI RESCH,0
16230000
BAIL
16240000
*
DISPATCH MOTHER TASK, WHICH WILL IMMEDIATELY WAIT.
16250000
EXRET2 MVI EXINTLK,0
16260000
MVC PINHEDD(8),EXOLDPSW
3054 16270000
LM
0,15,APLSAVE
16280000
LPSW PINHEDD
3054 16290000
EJECT
17250000
SVINT ,
APL SVC PASSED/STOLEN FROM HOST
17260000
EJECT
17270000
*
17280000
DC
0F'0',C'PSWI'
FOR THE SWAPPING CONVENTION
17290000
HOSTIOP DC
X'00040000',A(IOINT)
THE PSW
17300000
IOINT
ST
1,PINHEDD
C043 17310000
BALR 1,0
17320000
USING *,1
17330000
STM 0,15,APLSAVE
17340000
MVC APLSAVE+4(4),PINHEDD
C043 17350000
LM
MR,14,SVBASE
LOAD MR AND 14
17360000
USING MPXSAVE,MR
17370000
DROP 1
17380000
USING APLLOW,14
17390000
LH
1,IOOLDPSW+2
17400000
BAL 3,IODADV
17410000
CLC IOOLDPSW+2(1),MPXCHANL
5991 17420000
BE
MPXINT
17430000
*
REJECT I/O INTERRUPT; PASS ON TO NEXT INTERCEPTOR OR HOST
17440000
IOREJ
MVC PINHEDD(8),HOSTIOP PASS INTERRUPT TO HOST
17450000
LM
0,15,APLSAVE
17460000
LPSW PINHEDD
17470000
DROP MR
17480000
DROP 14
17490000
*
17500000
EJECT
17730000
*
17740000
*
MVT SELECTOR CHANNEL END APPENDAGES.
17750000
*
17760000
*
*** NOTE *** NO SVC'S MAY BE ISSUED FROM AN OS END APPENDAGE. 17770000
*
17780000
*
ON ENTRY ..
17790000
*
17800000
*
R1
ADDRESS OF REQUEST ELEMENT.
17810000
*
R2
ADDRESS OF IOB.
17820000
*
R3
ADDRESS OF DEB.
17830000
*
R4
ADDRESS OF DCB.
17840000
*
R7
ADDRESS OF UCB
17850000
*
R14 OS RETURN ADDRESS.
17860000
*
R15 ENTRY POINT (LOADED BY IOS)
17870000
*
17880000
*
ABNORMAL END APPENDAGE.
17890000
*
ENTERED ON OR/UC, CHAINCHK, PROGCHK, PROTCHK .
17900000
*
17910000
*
IOS HAS OBTAINED SENSE WHICH IS NOW IN THE UCB.
17920000
*
THE ERROR CSW IS IN THE IOB.
17930000
*
17940000
ENTRY HOSTIOP
17950000
ENTRY SELXEN
17960000
USING SELXEN,15
17970000

*
ABNORMAL APPENDAGE ENTRY.
* IF AN UNSOLICITED INTERRUPT ACCURS, IOS MAY 'INTERCEPT' AN EXCP AND
* ENTER THE APPENDAGE WITH A CC OF X'7E'. . IN THIS CASE, WE REJECT
* THE INTERRUPT AND REQUEST A RESTART.
SELXEN CLI IOBECBCC-IOBD(2),X'7E'
BE
8(14)
REQUEST RESTART.
OI
SWITCHES,SELAPENT NOTE THAT WE ENTERED APPENDAGE DASD
MVC MVTCSW(8),CSW
SAVE REAL CSW.
MVC CSW+1(7),IOBCSW-IOBD(2) MOVE CSW FROM IOB TO LOW CORE.
SPACE
BAL 15,SELCOMN
ENTER COMMON APPENDAGE CODE, AND
C022
*
SET UP NEW BASE REGISTER
C022
* NOTE ASSUMPTION THAT SELPCIX IMMEDIATELY FOLLOWS THIS BAL
C022
SPACE 3
C022
USING SELPCIX,15
SPACE
*
*
MVT NORMAL END APPENDAGE.
*
*
ENTERED ON ..
*
(CE OR CE AND UE OR IL) AND NO OTHER STATUS.
*
(DE IS IGNORED).
SELCE
EQU SELXEN
NORMAL APPENDAGE ENTRY.
*
*
MVT PCI APPENDAGE.
*
ENTERED ON PCI.
*
SPACE
ENTRY SELCE
ENTRY SELPCIX
SELPCIX MVC MVTCSW(8),CSW
PCI APPENDAGE ENTRY.
*
PCI
TM
CSW+5,X'7F'
PCI
BZ
SELCOMN
PCI
PCISTOP NOP 0
PCI
ENTRY PCISTOP
PCI
LH
9,PCISTOP+2
COUNT HOW OFTEN
PCI
LA
9,1(9)
WE HAVE PCI WITH AN ERROR
PCI
STH 9,PCISTOP+2
IN THE HALF WORD AT PCISTOP+2
PCI
*
PCI
*
SINCE PCI APPENDAGE CANNOT ASK FOR EXCP RESTART,
PCI
*
WE WILL WAIT FOR THE ABNORMAL END APPENDAGE TO HANDLE
PCI
*
THIS ERROR CONDITION.
PCI
*
PCI
SR
9,9
FOR IOS
PCI
BR
14
RETURN TO IOS.
PCI
*
PCI
SELCOMN SR
10,10
INITIALIZE RETURN.
2217
STM 0,15,APLSAVE
2217
L
14,APLBASE
ESTABLISH APLSUP ADDRESSING.
DROP 15
USING APLLOW,14
SET UGHSW,APPENDG
2217
B
SELINT
COMMON ROUTINE.
*
*
*
OURDISK IS NORMALLY EQUAL TO WORKDISK
DIRCYL DC
F'-1'
DIRECTORY DISK ADDRESS
DASD
ALTCYL DC
F'-1' PHYSICAL ADDRESS OF SECOND COPY OF DIRECTORY DASD
EJECT

17980000
17990000
18000000
18010000
18020000
18030000
18040000
18050000
18060000
18070000
18080000
18090000
18100000
18110000
18120000
18130000
18140000
18150000
18160000
18170000
18180000
18190000
18200000
18210000
18220000
18230000
18240000
18250000
18260000
18270000
18280000
18290000
18300000
18310000
18320000
18330000
18340000
18350000
18360000
18370000
18380000
18390000
18400000
18410000
18420000
18430000
18440000
18450000
18460000
18470000
18480000
18490000
18500000
18510000
19400000
19410000
19430000
19440000
19450000
19470000

ENTRY PCBXLE
19490000
ENTRY PTBXLE
19530000
SUPPARS APLSUPC
19550000
*
19560000
VALCON EQU ALEN+3
19640000
*
19660000
EXTRN MPXCUTAB
19710000
AMXCUT DC
A(MPXCUTAB)
19720000
PERDEVB DC
A(PERDEVXG)
FOR DEVXCC
19730000
*
19740000
UGHSWTRC DC
XL7'00'
2217 19750000
UGHSW
DC
X'00'
2217 19760000
MPXIO
EQU 1
2217 19770000
SVC
EQU 2
2217 19780000
EXTERNAL EQU 4
2217 19790000
APPENDG EQU X'38'
2217 19800000
TITLE 'UGH CATASTROPHIC (BUT RECOGNIZED) SYSTEM FAILURE.' K01 19810000
SPACE 3
START OF UGH ROUTINE
K01 19820000
*
IN ORDER FOR US TO ARRIVE HERE,
K01 19830000
*
R14 MUST HAVE BEEN POINTING TO APLLOW;
K01 19840000
*
HOWEVER,
K01 19850000
*
R14 WAS WIPED BY THE BAL THAT GOT US HERE;
K01 19860000
*
ALL OTHER REGISTERS ARE STILL AS THEY WERE.
K01 19870000
*
WE WILL NOW SAVE ALL REGISTERS AND LOW CORE, (AT UGHS)
K01 19970000
*
FOR DEBUGGING PURPOSES.
K01 19980000
DROP 14
K01 19990000
ENTRY UGHS
SUG 20000000
UGH
STH MR,2(14)
SAVE RIGHT-HALF OF MR
K01 20010000
SRL MR,16
GET LEFT-HAND OF REGISTER
K01 20020000
STH MR,0(14)
SAVE LEFT-HALF OF REGISTER
K01 20030000
BALR MR,0
K01 20040000
USING *,MR
ESTABLISHING ADDRESSIBILITY
K01 20050000
*
K01 20060000
*
TO PRESERVE APLSUP ADDRESSIBILITY, THE REMAINDER OF THE UGH
K01 20070000
*
CODE IS IN HIGH CORE.
K01 20080000
*
K01 20090000
L
MR,=A(UGHS) ADDRESS OF UGH ROUTINE
K01 20100000
DROP MR
K01 20110000
BR
MR
GO TO UGH PROCESSING ROUTINE
K01 20120000
TITLE 'S E L E C T O R C H A N N E L A N D G L O B A L S UX20140000
B R O U T I N E S'
20150000
USING APLLOW,14
20170000
*
20190000
EXTIME BAL LINK,CORTIME COMPUTE TIME OF DAY
20200000
MVI IESW,1
PROCRASTINATE SETTING TIMER
20210000
ENTRY EXTIM2
FOR USE BY MAKFR MACRO IN CONFIG
20220000
EXTIM2 L
1,=A(X'7FFFFF')
ARBITRARY SPECIFIC VALUE
3064 20230000
CLI IEHED+1,EMPTYM
INTERVAL EVENT QUEUE EMPTY Q
20240000
BE
EXTIM5
YES. SET TIMER TO ARBITRARY VALUE. 20250000
USING IEBLOCK,3
20260000
L
3,IEHED
20270000
L
1,IETIME
20280000
S
1,REALTIME
:1 = EVENT IME - REALTIME
20290000
BNH EXTIM4
TRIGGER THIS EVENT
20300000
*
SET TIMER TO TIME TILL EVENT IS DUE
20310000
EXTIM5 MVI IESW,0
ALLOW SETTING OF TIMER
20320000
BAL LINK,SETINT
20330000
B
EXRET
20340000
*
REMOVE EVENT FROM LIST AND TRIGGER IT
20350000
EXTIM4 MVC IEHED,IELINK
20360000

*
*
*
*
*

IEBRN
IETAB

*
*
*
*
*
*
*
ENQIE
ENQIET

ENQ3

ENQ4

*
*

MVC IELINK,HD3FR
PUT EVENT BLOCK ON 3 WORD
ST
3,HD3FR
FREE SPACE LIST
EXAMINE IEBASE TO DETERMINE NEXT ACTION
CONVENTIONS FOR IEBASE ARE:
WORD IS SPLIT 8,24
8 BITS DETERMINE EVENT TYPE
24 BITS ARE PARAMETER FOR TRIGGERED ROUTINE
USING MPXSAVE,MR
L
MR,SVBASE
ESTABLISH MPX BASE REG
SR
10,10
EVENT TYPE CODE REGISTER
IC
10,IEBASE
MVI IEBASE,0
CLEAR HIGH ORDER BYTE OF PTR
L
PTR,IEBASE
LH
10,IETAB(10)
EVENT ADDRESS
DEREL ,
DERELATIVIZE
BR
10
DROP 3
BR
PTR
BRANCH TO NON-PTR ROUTINE
IETGEN MPX
MUST BE FIRST EVENT TYPE
IETGEN SOHK
SIGN OFF HOLD KILL
IETGEN CLOK
BREAK CLOCK WAIT
IETGEN BRN
BRANCH TO IEBASE
IETGEN SZUG
EXPRESS TERMINAL AUTOMATIC BOUNCE
DROP MR
ENQIE ENQUEUES INTERVAL TIMER EVENTS
R2 = IEBASE SETTING FOR USE AT EXTIM4 (DESCRIBES EVENT)
R3 = INTERVAL TO ELAPSE FROM TIME ENQIE IS CALLED TO
WHEN EVENT IS DESIRED
TWO ENTRANCES, EQIE NORMAL, ENQIET REALTIME IN R0,SSM ALLOFF
R5 = RETURN
BAL LINK,CORTIME
CLI HD3FR+1,EMPTYM CHECK FOR FREE SPACE
UGH E
NO MORE LIST SPACE
AR
3,0
IETIME SETTING = REALTIME+INTERVAL
L
1,HD3FR
USING IEBLOCK,1
MVC HD3FR,IELINK
ST
2,IEBASE
ST
3,IETIME
LA
4,IEHED+IEBLOCK-IELINK
LR
2,4
ADVANCE
CLI IELINK+1-IEBLOCK(2),EMPTYM
L
4,IELINK-IEBLOCK(2)
BE
ENQ4
END OF IE LIST
C
3,IETIME-IEBLOCK(4)
BH
ENQ3
CONTINUE SEARCH
ST
4,IELINK
INSERT INTO QUEUE
ST
1,IELINK-IEBLOCK(2)
C
1,IEHED
SEE IF IN SERTION IS TOP OF LIST
BCR 7,5 BNER
NO, RETURN TO CALLER
L
1,IETIME
NEW EVENT IS SOONEST
DROP 1
SR
1,0
RECOMPUTE INTERVAL
BCR 4,5 BMR
AVOID NEGATIVE TIMER
LA
1,TIMEFUZ(1)
LR
LINK,5
DECREASE INTERVAL TIMER SETTING
B
SETINT
PRGIE REMOVES AN EVENT FROM INTERVAL TIMER QUEUE

20370000
20380000
20390000
20400000
20410000
20420000
20430000
20440000
20450000
20460000
20470000
20480000
20490000
20500000
20510000
20520000
20530000
20540000
20550000
20560000
20570000
20580000
20590000
20600000
20610000
20620000
20630000
20640000
20650000
20660000
20670000
20680000
20690000
20700000
20710000
20720000
20730000
20740000
20750000
20760000
20770000
20780000
20790000
20800000
20810000
20820000
20830000
20840000
20850000
20860000
20870000
20880000
20890000
20900000
20910000
20920000
20930000
20940000
20950000
20960000

*
*
PRGIE
PRG2

PRG1
*
*
*
*
SETINT

R1= IEBASE VALUE TO BE PURGED

LINK = RETURN
LA
4,IEHED+IEBLOCK-IELINK
LR
2,4
ADVANCE
CLI IELINK+1-IEBLOCK(2),EMPTYM
BCR 8,LINK
EVENT NOT FOUND.
L
4,IELINK-IEBLOCK(2)
C
1,IEBASE-IEBLOCK(4)
BNE PRG2
MVC IELINK-IEBLOCK(4,2),IELINK-IEBLOCK(4) DEQUEUE
MVC IELINK-IEBLOCK(4,4),HD3FR
SALVAGE BLOCK
ST
4,HD3FR
BR
LINK

R1 IS NEW TIMER VALUE

R0 ON EXIT IS NEW TIME OF DAY
R2 IS DISTURBED
SSM ALLOFF
TM
IESW,1
EXTERNAL INTERRUPT IN PROCESS?
BO
SETINTZ
YES. DON'T SET ALARUM YET.
SLL 1,7
MULTIPLY BY 128 (OS UNITS)
LR
0,1
HOLD INTERVAL VALUE.
L
1,ATQE
USING TQE,1
L
2,CVT
GET ADDRESS OF CVT
STM 14,13,LAMSAVE
*
THESE TESTS ARE MADE HERE TO INSURE THAT A TQE IS NOT ENQ'D 3572
* IF THE PREVIOUS TQE HAS EXPIRED AND HAS NOT BEEN PROCESSED YET 3572
* BY EXINT. IN THIS CASE THE ENQ IS IGNORED AND CONTROL RETURNED 3572
* TO THE CALLER.
3572
TM
TQEFLGS,X'80'
IS TQE ON THE QUEUE?
3572
BO
INTLKCHK
NO-CHECK INTERLOCK BEFORE DEQ 3572
CLI EXINTLK,X'00'
INTERLOCK SHOULD NOT BE ON IF 3572
UGH NE
TQE IS ON THE QUEUE. IF SO,UGH 3572
L
10,CVTTPC(2)
ADDR. OF OS PSEUDO CLOCKS
3572
L
2,CVTQTD00(2)
TQE DEQ RTN.
BALR 2,2
USING *,2
LM
14,2,LAMSAVE
DROP 2
B
SETINTOQ
ENQ TQE
3572
INTLKCHK CLI EXINTLK,X'80'
PREVIOUS TQE BEING PROCESSED? 3572
BNE SETINTZ
NO-DO NOT ENQ
3572
L
10,CVTTPC(2)
ADDR. OF OS PSEUDO CLOCKS
3572
SETINTOQ MVC TQE(TQEGRS-TQEFLGS),TQEPSECT
ST
0,TQEVAL
INTERVAL.
L
2,CVTQTE00(2)
A(IEAQTE00) = TQE ENQ RTN.
BALR 2,2
USING *,2
LM
14,13,LAMSAVE
DROP 2,1
*
SETINTZ L
0,REALTIME
BR
LINK
LAMSAVE DS
16F
SPACE 2
EJECT
*
NOTES ON USE OF BRANCH ENTRY TO TQE ENQ AND DEQ ROUTINES.
*
THE BRANCH INTERFACE MUST BE USED BECAUSE AN INITIATOR
*
WAITING FOR SQA WILL BE DISPATCHED

20970000
20980000
20990000
21000000
21010000
21020000
21030000
21040000
21050000
21060000
21070000
21080000
21090000
21100000
21110000
21120000
21130000
21140000
21150000
21170000
21560000
21570000
21580000
21590000
21600000
21610000
21620000
21630000
21640000
21650000
21660000
21670000
21680000
21690000
21700000
21710000
21720000
21730000
21740000
21750000
21760000
21770000
21780000
21790000
21800000
21810000
21820000
21830000
21840000
21850000
21860000
21870000
21880000
21890000
21900000
21910000
21920000
21930000
21940000
21950000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

IF WE ISSUE A STIMER.
(WHEN THE SVRB IS DEQUEUED)
INITIATORS ARE USUALLY ENABLED, AND
MAY ALLOW A MULTIPLEX INTERRUPT
TO BE TAKEN BEFORE WE ARE READY FOR
IT.
R1 IS A(TQE) HIGH ORDER BIT MUST BE SET PROPERLY IN TQE.
ON (INDICATING OFF QUEUE) FOR ENQ.
OFF FOR DEQ.
R2 IS RETURN ADDRESS.
R10 MUST POINT TO THE PSEUDO CLOCKS.
(BECAUSE DEQ ENTRY MAY NEED IT).
IF YOU MODIFY THIS INTERFACE, TAKE PAINS TO ENSURE THAT WE DO
NOT LOSE THE IRB IN THE TCER.
CURRENT METHOD IS TO SET RBSTAB+1
NI RBSTAB+1,X'F9'

SPACE 2
OSDATE DS
F
CORTIME SSM ALLOFF
GET TIME OF DAY.
ST
15,S15FOS
TIME TU
OS TIME SVC. TIME RETURNS IN R0.
SRL 0,7
X 128 TO GET SECONDS DIV 300.
A
0,DAYSUP
NUMBER OF DAYS SINCE INITIATION.
C
1,OSDATE
BE
CORTIMEZ
ST
1,OSDATE
* NOTE: APL MAY GET SLEEPY FOR A WHILE IF CLOCK IS SET,
* BUT ABOVE SHOULD PREVENT DISASTER.
*
IN SECONDS DIV 300.
*
IF THE MVT OPERATOR SETS CLOCK WHILE APL IS RUNNING,
*
STRANGE THINGS WILL HAPPEN.
L
1,DAYSUP
ASSUME IT IS MIDNIGHT.
A
1,K24HOURS
AND INCREMENT THE NUMBER OF DAYS
ST
1,DAYSUP
SINCE INITIATION.
A
0,K24HOURS
ADJUST TIME OF DAY.
CORTIMEZ L
15,S15FOS
RECOVER R15.
ST
0,REALTIME
BR
LINK
NOTE THAT SYSTEM MASK IS NOT RESTORE
*
EJECT
KH255
DC
H'255'
CONSTANT FOR TYOSUB,ETC.
ALLOFF EQU KH255
ALLON
EQU KH255+1
POINT TO X'FF'
K10
*
*
*
IO INTERRUPT ANALYSIS
*
SELECTOR CHANNEL ROUTINES NEVER USE MR
SELINT
CLI CSW+5,0
BNE SELCS
CHANNEL STATUS
CLI CSW+4,CE+DE
BE
SELNOR
NORMAL END (CE,DE)
*
UNUSUAL DEVICE STATUS ON SEL CHAN INTERRUPT
TM
CSW+4,UC+UE
BZ
SELEXIT
2221
SELDS4 L
10,=A(SELSTAR)
BAL LINK,SELRTRY-SELSTAR(10)

21960000
21970000
21980000
21990000
22000000
22010000
22020000
22030000
22040000
22050000
22060000
22070000
22080000
22090000
22100000
22110000
22120000
22130000
22140000
22150000
22160000
22170000
22180000
22190000
22200000
22210000
22220000
22230000
22240000
22250000
22260000
22270000
22280000
22290000
22300000
22310000
22320000
22330000
22340000
22350000
22360000
22380000
22390000
22430000
22440000
22450000
22460000
22470000
22480000
22490000
22500000
22510000
22520000
22530000
22540000
22550000
22560000
22580000
22690000
22700000

*
SELCS

*
*
*
*

SELEXIT

EQU
TM
BZ
TM
BZ

*
PCI
CSW+5,IL+PRC+CDC+CCC+ICC+CHC
SELCS1
PROGRAM CHECK
CSW+5,PC+PRC+CDC+CCC+ICC IL AND CHAIN CHK RETRYABLE 5994
SELDS4
RETRY FROM LAST SEEK.
5994
DASD
BAD CHANNEL STATUS
DASD
DASD
REQUEST OS ERROR RECOVERY
DASD
SELEXIT
-- OR AT LEAST A LOGOUT
DASD
SELBUSY MUST BE 1
DASD
DASD

B
*
*
*
* PCI WAS DELAYED UNTIL END OF READ AND PROG CHECK RESULTED
SELCS1 TM
CSW+5,PCICSW
PCI AND PC ?
2540
*
IF PCI IS SET, WE HAVE NOT BUILT
5989
*
THE REMAINING CCW CHAIN
5989
BNO SELCS1C
IF PCI IS NOT SET, WE HAVE BUILT
5989
*
THE CCW CHAIN, BUT THE CHANNEL BEAT US TO THE
5989
*
TIC. WE NOW CHECK FOR CCCX FORCED ERROR
5989
SELCS1B EQU *
5989
BAL 6,CDCOMP
SETUP CCW CHAIN
SELCS1C CLI SELFERR,1
CHECK FOR CCCX FORCED ERROR
5989
BE
SELDS4
READ ERROR DETECTED BY CDCOMP
CLI ONETRK,0
DID FIRST TRACK CONTAIN ENTIRE WS -BE
SELNOR2
YES, TREAT AS NORMAL READ END 5989
L
0,=A(CCWAR+32)
CAW SETTING
SELTIME ,
C022
*
*
PCI ON SELECTOR CHANNEL, SETUP CCW CHAIN FOR SUBSEQUENT TRACKS
SELPCI BAL 6,CDCOMP
CLI SELFERR,1
CDCOMP MAY HAVE DETECTED ERROR
BE
SELEXIT
RETRY FROM SELCS1 AT PROG CHECK
CLI ONETRK,0
CHECK FOR ONE TRACK WORKSPACE.
BE
SELSNOP
*
NOTE THAT COMMAND CODE IN RD1A REMAINS ZERO UNTIL AFTER LAST
*
BYTE OF ADDRESS HAS BEEN STORED. MODEL 40 TIMING PROBLEMS
*
ARE POSSIBLE IF LITERAL A(CCWAR+32) IN FOLLOWING L 0,=
*
IS REPLACED BY CCW
TIC,CCWAR+32
L
0,=A(CCWAR+32)
SEEK CCW FOR SECOND TRACK
ST
0,RD1A
MVI RD1A,TIC
KILL CHANNEL PROG CHECK
B
SELEXIT
*
READING FIRST AND ONLY TRACK OF WORKSPACE
SELSNOP MVI RD1A,3
IONOP
MVC EXPCSW(8),NOPCSW
B
SELEXIT
*
*
GOOD END OF DISK OPERATION
SELNOR CLI SELBUSY,1
CHECK FOR RE-ENTRY OF APPENDAGE.
BNE SELEXIT
IGNORE UNREQUESTED INTERRUPT.
CLC CSW+1(7),EXPCSW+1
2540
UGH NE
SOMEBODY IS WRONG
CLC EXPCSW+1(3),NDCCSW+1 WAS THIS A NON DATA CHAINED OP 5989
BE
SELCS1B
YES
5989
CLI CDOP,6
IS THE OPERATION A SAVE
5989
BNE SELNOR2
NO, MOVE NOT NECESSARY
5989
CLI ONETRK,INCORMV WAS THE DATA MOVED IN CORE ?
5989

22710000
22720000
22770000
22800000
22810000
22830000
22840000
22860000
22870000
22880000
22890000
22900000
22910000
22920000
22970000
22990000
23000000
23010000
23020000
23030000
23040000
23050000
23060000
23070000
23080000
23090000
23100000
23110000
23120000
23140000
23150000
23170000
23180000
23190000
23200000
23210000
23220000
23230000
23240000
23250000
23260000
23270000
23280000
23290000
23300000
23310000
23320000
23330000
23340000
23360000
23370000
23380000
23390000
23400000
23410000
23420000
23430000
23440000
23450000
23460000

BNE
L
USING
LM
DROP
LA
N
N
SR
LH
LPR
CR
BNL

SELNOR2
1,CCPAR1
M,1
2,3,MX
1
2,7(,2)
2,=F'-8'
3,=F'-8'
3,2
2,MVCLNGTH
2,2
3,2
SELNOR2

NO, WE DONT HAVE TO MOVE IT BACK

ADDRESS OF WORKSPACE

5989
5989
5989
GET MX AND SVI
5989
5989
ROUND MX TO A DOUBLE-WORD BOUNDARY 5989
5989
ROUND SVI TO A DOUBLE-WORD BOUNDARY 5989
GET THE LENGTH OF THE GARBAGE AREA 5989
GET THE LENGTH OF THE MOVE
5989
MAKE IT POSITIVE
5989
WAS THE MOVE DESTRUCTIVE ?
5989
NO, MOVE BACK NOT NECESSARY
5989
*
5989
*
FIX UP THE DAMAGED WS
5989
*
5989
L
7,=A(REMCDC) ESTABLISH ADDRESSABILITY
5989
USING REMCDC,7
FOR REMCDC CODE
5989
BAL 0,MVCREV
GO MOVE THE DATA BACK
5989
DROP 7
5989
SELNOR2 EQU *
5989
LH
2,CDOP-1
MVI SELBUSY,0
MARK IDLE
LH
10,CDZTAB(2)
GET INTERRUPT SUBROUTINE ADDRESS
DEREL ,
DELATIVIZE
BALR LINK,10
COROUTINE TYPE LINKAGE
SELEXIT
,RETURN FROM SELINTERRUPT
CDZTAB DCY RSELSUB
0 NORMAL WRITE
DCY SELRDZ
2 NORMAL READ
DCY SELDRZ
4 DIRECTORY READ
DCY WWZSAVE
6 SAVE, WORKSPACE WRITE
DCY DIR3RD
8 AFTER WRITE OF ALT DIRECTORY
DCY SELLDZ
10 LOAD COPY, WORKSPACE READ
DCY DIR4TH
12 AFTER DIR3RD DIRECTORY READ
DCY DIR2ND
14 DIRECTORY WRITE, PRIMARY COPY
DCY SELWSK
16 COPKILL GLITCH
*
SELEXCP
*
*
*
*
*
R0 IS CAW SETTING, R1 IS DEVICE ADDRESS
*
TYPICAL CALL
*
L
0,CAW SETTING
*
BAL 5,SIOSUB
*
B
STARTED
SIO WITH CC ZERO
*
STATUS STORED
SIOSUB ST
0,CAW
MVC CSW,ZERO
CLEAR CSW
BAL 3,IODADV
RECORD CAW AND STATUS
USING IODBUG,2
MVC IODCAW(4),CAW
MVI IODSIO,X'FF'
MARK AS SIO
SIO2
SIO 0(1)
*
IO STARTED WITH ZERO STATUS
SIO4
BCR 8,5
RETURN TO CALLER
BC
2,SIO2
TRY AGAIN IF BUSY
BC
4,SIO5
STATUS STORED
*
DEVICE NOT OPERATIONAL (SELECT IN RETURNED)

23470000
23480000
23490000
23500000
23510000
23520000
23530000
23540000
23550000
23560000
23570000
23580000
23590000
23600000
23610000
23620000
23630000
23640000
23650000
23660000
23670000
23680000
23700000
23740000
23750000
23760000
23770000
23790000
23800000
23810000
23820000
23830000
23840000
23850000
23860000
23870000
24220000
24230000
24240000
24250000
24260000
24270000
24280000
24290000
24300000
24310000
24320000
24330000
24340000
24350000
24360000
24370000
24380000
24390000
24400000
24410000
24420000
24430000
24440000
24450000

ASSUME TRANSIENT ERROR ON BUS OUT

SIO 0(1)
BC
14,SIO4
SUCCESS
*
TWICE IN A ROW
DEVDEAD MVC CSW+3(2),=AL2(265+UC) FORCE ENTRY TO UC ROUTINE
OC
IODDSCS-1(3),CSW+3
B
4(5)
INDICATE ERROR
*
STATUS RETURNED
SIO5
CLI CSW+4,CUB2702
*
CHECK TO SEE IF STATUS IS 2702 CU BUSY
MVC IODDSCS,CSW+4
STATUS BYTES
BE
SIO2
YES, KEEP TRYING
TM
CSW+4,BSY+CE
BC
12,4(5)
ANALYZE STATUS
*
BUSY AND CHANNEL END, SCHEDULING ERROR
*
DEVICE WAS REALLY BUSY, THIS IS SUPERVISOR ERROR
UGH ,
WORKSPACE MUST BE ON DISK
DROP 2
EJECT
*
*
MAINTAIN BUFFER OF OLD IO STATUS INFO
*
THIS SUBROUTINE IS NOT REENTRANT * * * * * * *
*
IODBUG DSECT
*
*
I/O INTERRUPT ENTRY
*
IODUNAD DS
H X'0CUU'
DEVICE ADDRESS
IODCSW DS
0DL8
CSW ON INTERRUPT
DS
X
SENSE BYTE (MPX SENSING ONLY)
DS
AL3
COMMAND ADDRESS
DS
H
STATUS
DS
H
RESIDUE BYTE COUNT
*
*
SIO ENTRY
*
ORG IODBUG
DS
H X'0CUU'
DEVICE ADDRESS
IODCAW DS
FL4
CAW
IODDSCS DS
H
STATUS BYTES
IODSIO DC
X'FF'
SIO FLAG
DC
X'00'
*
*
DISK ERROR ENTRY
*
ORG IODBUG
IODCDOP DS
H X'OCUU'
OPERATION & DEVICE ADDRESS
IODSENSE DS
0DL8
DS
FL4
SENSE DATA
DS
HL2
CC OF SEEK ADDRESS
DC
X'FE'
DISK ERROR CODE
DC
X'0'
H OF SEEK ADDRESS
*
*
IEMPX ENTRY
*
ORG IODBUG
DS
H X'0CUU'
DEVICE ADDRESS
IODCCB DS
FL4
PUCCB
IODTYPE DS
H
PTTYPE & STATE
IODIE
DC
X'FD'
IEMPX FLAG

24460000
24470000
24480000
24490000
24500000
24510000
24520000
24530000
24540000
24550000
24560000
24570000
24580000
24590000
24600000
24610000
24620000
24630000
24640000
24650000
24660000
24670000
24680000
24690000
24700000
24710000
24720000
24730000
24740000
24750000
24760000
24770000
24780000
24790000
24800000
24810000
24820000
24830000
24840000
24850000
24860000
24870000
24880000
24890000
24900000
24910000
24920000
24930000
24940000
DASD 24950000
24960000
DASD 24970000
24980000
24990000
25000000
25010000
25020000
25030000
25040000
25050000

DC
*
*
*

IODHIO
*
APLSUP
*
IODADV

X'00'

HIO ENTRY
ORG
DS
DS
ORG
DC

IODBUG
H X'0CUU'
DL8
IODCSW+6
X'FC'

DEVICE ADDRESS
CSW
HIO FLAG

CSECT
USING
L
LA
C
BL
L
STH
NC
CLC
BE
LA
BR
ST
MVC
STH
BR
DROP

IODBUG,2
2,IODCON
2,10(2)
ENTRY LENGTH
2,IODCON+8
*+8
2,IODCON+4
BUFFER WRAPAROUND
1,IODTRASH
SIFT OUT DESIRED CHANNEL/CU/DEVICE
IODTRASH(2),IODSIFT ENTRIES AND IGNORE OTHERS
IODTRASH(2),IODSIFT+2
*+10
2,IODTRASH
CALL REJECTED, PROVIDE TRASH AREA
3
2,IODCON
IODCSW,CSW
1,IODUNAD
3
2

*
ENTRY IODCON
IODCON REFERENCED BY EXMHIST
IODCON DC
A(IODBUGG,IODBUGG,IODBUGZ) IODADV PARAMETERS
*
INDEX
START
END
IODSIFT DC
H'0'
MASK OF PART OF IO ADDR TO COMPARE
DC
H'0'
IO ADDRESS TO COMPARE FOR
IODTRASH DC
5H'0'
DUMMY IODBUG AREA
EXTRN IODBUGG,IODBUGZ
IODEBUG TABLE IS ASSEMBLED INTO
*
APLSCONF FOR FLEXIBILITY.
*
*
SENSE BYTE ANALYSIS
* TUSCH IS REENTRANT
*
R2 IS SENSE BYTE FOR ANALYSIS
*
TABLES ARE FROM TUSGEN MACRO
USING PERDEVX,PXR
TUSCH
SR
0,0
L
1,PXSENC
IC
0,PXSENC
SR
SIGR,SIGR
UNRECOGNIZED, ASSUME NORMAL END
UCB1
EX
2,UCB3
EXAMINE SENSE MASKS
BC
7,UCB2
DESIRED CONDITION
LA
1,1(1)
TRY NEXT BYTE
BCT 0,UCB1
BR
LINK
UCB2
IC
SIGR,TUSSL(1)
GET SIGNAL BYTE
*
SIGNAL BYTE HAS BEEN PLACED IN SIGR
BR
LINK
AND DELIVER
UCB3
TM
0(1),0
SUBJECT OF EXECUTE
DROP PXR
*
*
SENSE DATA ROUTINE FOR ANY CHANNEL

25060000
25070000
25080000
25090000
25100000
25110000
25120000
25130000
25140000
25150000
25160000
25170000
25180000
25190000
25200000
25210000
25220000
25230000
25240000
25250000
25260000
25270000
25280000
25290000
25300000
25310000
25320000
25330000
25340000
25350000
25360000
25370000
25380000
25390000
25400000
25410000
25420000
25430000
25440000
25450000
25460000
25470000
25480000
25490000
25500000
25510000
25520000
25530000
25540000
25550000
25560000
25570000
25580000
25590000
25600000
25610000
25620000
25630000
25640000
25650000

*
*
GETSEN

SUBROUTINE TO DO SENSE IO FOR MPX

GETSEN EXPECTS CAW SETTING IN R0,UNIT ADDRESS IN R1
BAL 5,SIOSUB
B
4(LINK)
STATUS RETURNED FROM SIO WITH SENSE IO COMMAND
TM
CSW+4,BSY+DE
BO
GETSEN
NOTES ON PRECEDING INSTRUCTION. CODE AT SIO5 HAS CHECKED FOR
CHANNEL END ABSENT. IT IS ASSUMED THAT THE STATUS OF 'BUSY,DE,UC'
WAS PRECEDED BY AN INTERRUPT WITH 'CE,UC'.
CLI CSW+4,SM+BSY
CONTROL UNIT BUSY
BE
GETSEN
ASSUME 2314 FAULT

25660000
25670000
25680000
25700000
*
25750000
25760000
25770000
*
25780000
*
25790000
*
25800000
25810000
25820000
*
25830000
*
SIO STATUS DOES NOT CONTAIN BUSY BIT.
25840000
BR
LINK
ASSUME BUS OUT CHECK
25850000
EJECT
26000000
*
DIRECTORY READ END
26010000
*
LINK= SELEXIT
26030000
SELDRZ BAL 6,MAKCYL
GUARANTEE EXISTENCE OF EMPTY CYLINDR 26040000
SDSWRSET EQU *
FOLLOWING MVC IS EXECUTED
26050000
MVC SDQZSW(8),QZNOP
RESET SDQZSW & RSELSW
26060000
BAL 6,RELOCT
RELOCATE AND SET MPTBASE
26070000
USING M,5
26080000
CLI SDOP,XXLEMP
26090000
BE
SELDRZ1
SIGN ON IS SPECIAL CASE
26100000
MVC SDQZSW,=A(EXECDSER) DO HOUSEKEEPING AT QUEND
26110000
*
PERTERM, PERCORE HOUSEKEEPING WILL BE DONE BY EXECDSER
26120000
B
RINGSUB
TERMINATE QUANTUM
26130000
*
26140000
*
SIGN-ON OR LOAD-EMPTY
26150000
SELDRZ1 LM
1,2,CDTERM
PREPARE TO SCAN SIGNON MESSAGE
26160000
USING PERTERM,1
26170000
USING PERCORE,2
26180000
ST
2,PTCORE
26190000
MVC PCTERM+1(3),CDTERM+1
26200000
EXTRN TYPEIN
26210000
MVC FRSAVE+36(4),=A(TYPEIN) TO PROCESS SIGN-ON MESSAGE
26220000
MVI ACTIVE,ATTENM+NONINM ASSUME SIGN ON
26230000
PTSET ACTIVE
26240000
*
ATTENM AND NSIGNM WILL RESET NONINM AT SVTYI3 TO DELIVER
26250000
*
INPUT (HOPEFULLY SIGNON COMMAND) AT STYIZ
26260000
TM
IOB1,NSIGNM
SIGN ON VS. LOAD EMPTY WORKSPACE
26270000
BO
SELDRZ2
SIGNON
26280000
EXTRN NEWWS
26290000
MVC FRSAVE+36(4),=A(NEWWS) PRINT MESSAGE
26300000
LA
0,FREE-M(0)
LOAD EMPTY OP, LOSE DIRECTORY
26310000
ST
0,MX
26320000
MVI ACTIVE,NONINM
NORMAL SETTING
26330000
PTSET ACTIVE
26340000
SELDRZ2 MVI MISCB,0
26350000
PTSET MISCB
26360000
B
SDKILLA
TERMINATE SPECIAL DISK OPERATION
26370000
DROP 1,2
26380000
*
26390000
*
26400000
*
LOAD, COPY END OF READ FROM LIBRARY OF SAVED WORKSPACE
26410000
SELLDZ MVI CDCBASE+1,EMPTYM
FORCE PROG CK IF NOT SET BEFORE USE 26420000
EXTRN SDRET
26430000
L
5,CCPAR1
BASE FOR FOLLOWING INSTRUCTION.
26440000
MVC FRSAVE+36(4),=A(SDRET) RETURN FROM SPECIAL DISK
26450000

BAL 6,RELOCT
RELOCATE AND SET MPTBASE
DROP 5
RZX3
LM
1,3,CDDISK
END OF DISK READ
USING PERDISK,1
USING PERTERM,2
USING PERCORE,3
MVC PCTERM+1(3),PDTERM+1
MVC PCQUONT,ZERO
MVI PDTERM+1,EMPTYM
ST
3,PTCORE
FOR UNRZ3 AND SPECIAL DISK
DROP 1,2,3
RINGSUB L
1,CURRENTM
SIGNAL INTRP QUANTUM END DESIRED
C
1,=A(SCHSAVE)
BUT DON'T SIGNAL SCHEDULER
P062
BCR 8,LINK
P062
MVC MQCELL-M(4,1),QZSVC
BR
LINK
*
*
NORMAL WORKSPACE READ COMPLETION
SELRDZ BAL 6,RELOC
RELOCATE STACK AND REGISTERS
*
TRY TO CONTRACT CURRENTLY USED DISK REGION
*
R1 = MAXARM, R2 = ARM, R3 = FIRST CYLINDER
LM
0,3,PDBXLE
CLR 1,2
TEST ARM=MAXARM
BNE RZX3
SR
1,0
CLI PDTERM+1-PERDISK(3),EMPTYM
BC
8,RZX2
FOUND AN INTERIOR HOLE
BXLE 3,0,*-8
B
RZX3
NO INTERIOR HOLE
RZX2
ST
3,ARM
MOVE HYPOTHETICAL ARM
LCR 2,0
CHANGE HOLE SEARCH DIRECTION
AR
1,0
START 1 SLOT HIGH
CLI PDTERM+1-PERDISK(1),EMPTYM
BNE *+8
NOT EMPTY, STOP SCAN
BXH 1,2,*-8
ST
1,MAXARM
NEW LIMIT OF DISC REGION
B
RZX3
SET POINTERS
*
*
*
PRINT GEN
DUMMY
DSECT
*
SAMPLE CALL OF LINKAGE MACROS
*
PROLOG
*
PROLOG LOCAL,LOCALZ
*
ICALL UNRZ
*
IRETURN
*
LOCAL
DSECT ,
SAMPLE R13 STACK DSECT
LOCALA DS
D
LOCALB DS
F
LOCALZ EQU *
*
DROP PR,LR
*
APLSUP CSECT

26460000
26470000
26480000
26490000
26500000
26510000
26520000
26530000
26540000
26550000
26560000
26580000
26590000
26600000
26610000
26620000
26630000
26650000
26660000
26670000
26680000
26690000
26700000
26710000
26720000
26730000
26740000
26750000
26760000
26770000
26780000
26790000
26800000
26810000
26820000
26830000
26840000
26850000
26860000
26870000
26880000
26890000
26900000
26910000
26920000
26930000
26940000
26950000
26960000
26970000
26980000
26990000
27000000
27010000
27020000
27030000
27040000
27050000
27060000
27070000

*
*
*
*
*
*
RELOCT
RELOC

SVMV2

STMV1
STMV8
STMV2

*
STMV3

STMV4
*
STMV5
STMV6
*
*

STMV7
*
*
*

ASSUMPTIONS ABOUT PROLOG MACRO ============================

LR AND TLR ARE ADJACENT
LR IS BACKWARD LINK
SAVED LR OF OUTERMOST LEVEL IS ZERO
RELOCATE WORK SPACE, R6 IS RETURN
USING M,5
RELOCT IS USED FOR NEW WORKSPACES FROM LOAD, COPY, DIRECTORY
L
5,CCPAR1
MVC MPTBASE,CDTERM
MVI MPTBASE,0
L
1,CCPAR1
WORKSPACE ADDRESS
5989
CLI ONETRK,INCORMV
IS A MOVE NECESSARY?
5989
MVI ONETRK,NOT1TRK
RESET THE SWITCH
5989
BH
SVMV2
NO MOVE REQUIRED
5989
L
7,=A(REMCDC) ESTABLISH ADDRESSABILITY
5989
USING REMCDC,7
FOR REMCDC CODE
5989
BAL 0,MVCREV
GO MOVE THE DATA BACK
5989
DROP 7
5989
L
4,CCPAR1
WORKSPACE ADDRESS
5989
LR
5,4
5989
S
4,MEMAD
PREVIOUS CORE ADDRESS
5989
LR
0,5
A
0,WLEN
TOP OF THIS WORKSPACE
LA
1,M+4*12
B
STMV2
STM 2,3,4(1)
UPDATE SAVED R13,R14
LR
1,2
LM
2,3,4(1)
R13,R14
AR
3,4
LTR 2,2
VALIDATE R13
BZ
STMV5
NEW R13 ZERO -- END OF LIST
BM
STMV3
NEW R13 NEGATIVE -- ERROR
AR
2,4
RELOCATE BY (NEW M) - (OLD M)
CLR 2,0
BNL STMV3
NEW R13 GEQ NEWMR+WLEN
EX
2,STMV4
CLI =X'03',0
BZ
STMV1
ZERO = 4 REMAINDER NEW MR
R13 IS INVALID
MVC M+4*LR(8),ZERO
CLEAR R13,R14
EXTRN EREXSUP
ROUTINE TO PRINT ERROR MESSAGE AND CALL TYPIN
MVC FRSAVE+36(4),=A(EREXSUP)
B
STMV6
CONTINUE
TM
=X'03',0
TEST FOR DIVISIBILITY BY FOUR
END OF RELOCATION LOOP
ST
3,8(1)
RELOCATED R14
ST
5,MEMAD
FOR USE NEXT TIME THIS WORKSPACE IS
PROCESSED BY THE PRECEDING LOOP
SET PSW STORAGE KEY
SR
1,1
IC
1,ACTKEY
EX
1,STMV7
OR ACTIVE KEY WITH MP BITS
MVI FRSAVE+32,X'FF'
SYSTEM MASK
DC
0AL4(ALLON)
DASD
BR
6
MVI FRSAVE+32+1,X'05' AMWP = MP
DROP 5
READ SELECT
EMPTY SLOT EXISTS IN CORE
FIND A WORKSPACE ON DISK TO READ
USING PERDISK,2

27080000
27090000
27100000
27110000
27120000
27130000
27140000
27150000
27160000
27170000
27180000
27190000
27200000
27210000
27220000
27230000
27240000
27250000
27260000
27270000
27300000
27310000
27320000
27330000
27340000
27350000
27360000
27370000
27380000
27390000
27400000
27410000
27420000
27430000
27440000
27450000
27460000
27470000
27480000
27490000
27500000
27510000
27520000
27530000
27540000
27550000
27560000
27570000
27580000
27590000
27600000
27610000
27620000
27630000
27640000
27650000
27660000
27670000
27680000
27690000

USING PERTERM,3
EX
0,SDSWRSET
RESET SDQZSW & RSELSW
LR
5,LINK
LINK IS RETURN FOR RSELSUB TOO
BAL LINK,SDKILLA
SELECT ANOTHER LEMP TERMINAL MAYBE
LR
LINK,5
DO SOME DISK READ
RSELSUB EQU *
L
1,RSELSW
BR
1
EITHER RSEL0 OR RSDIR
*
READ SELECT OF DIRECTORY
RSDIR
MVI CDOP,4
SELDRZ AT SEL INTERRUPT
L
3,SDT
L
5,ASDPAR
FROM THE LIBRARY NUMBER IN COMMAND
L
5,PDSLIB-PDSDDDD(5)
CLI SDOP,XXLEMP
BNE RSDIR1
LH
5,PTCORE+2
PARAMETER FROM SVLEMP
TM
MISCB,WANTON
IF OFFSUB WAS EXECUTED ON A MPX INTR
BZ
RSDIR2
SDOP STARTED AT LEMP OR SDK3), WE
*
RECOVER BY KILLING THIS SPECIAL DISK
*
OP AND GOING TO START OF RSELSUB
RSDIR1 SR
4,4
D
4,KMHASH
GET DESIRED DIRECTORY NUMBER
SLL 4,3
GET DISK ADDRESS OF PRIM AND ALT
A
4,ADIRTAB
DIRECTORIES FOR THIS DIR READ
MVC DIRCYL(8),0(4)
DIRECTORY AND ALTERNATE
DASD
MVC PHYCYL(4),DIRCYL
DASD
LA
2,SDT+PERDISK-PDTERM ADDR OF DUMMY PERDISK
MVC CDCBASE,LIBBASE
CHANGE TO LIBRARY DISK
NI
MISCB,255-NOWSM
FOR WSLOSEC
B
RSELSTAR
RSEL0
LA
4,2
LM
0,2,PDBXLE
RSEL3
BXLE 2,0,RSEL2
*
UNSUCCESSFUL SEARCH
*
END OF SWEEP, CHANGE READ SELECT ALGORITHM
LH
3,ALG1
LTR 3,3
BL
RSEL5
SH
3,ALG1+2
MVI RSEL1+1,ACTIVEM
PROG MODIFICATION $$$$$$$
BCT 4,RSEL6
PREVENT INFINITE LOOP
BAL 6,MAKCYL
ARM MUST POINT TO EMPTY CYLINDER
BR
LINK
RSEL5
AH
3,ALG1+4
ALG1 LESS THAN 0 CASE
MVI RSEL1+1,ACTIVEM+NONINM PROG MODIFICATION $$$$$$$$$$
RSEL6
STH 3,ALG1
L
2,ARM+4
RESET ARM AND RESCAN
RSEL2
CLI PDTERM+1,EMPTYM
BE
RSEL7
EMPTY CYLINDER
L
3,PDTERM
RSEL1
TM
ACTIVE,ACTIVEM
MASK IS ALTERED $$$$$$$$$$$$$$$$$
BC
7,RSEL3
*
MOVE THIS WORKSPACE TO CORE
ST
2,ARM
READ FROM THIS CYLINDER.
BAL 4,FINDSWAP
SET UP DISK ADDRESS
MVI CDOP,2
FOR SELNOR SWITCH
RSELSTAR STM 2,3,CDDISK
MVI DOP+1,X'06'
READ DATA PROG MOD $$$$$$$$$$$$$
USING CDCPARS,4
5989
L
4,CDCBASE
5989
RSDIR2

27700000
27710000
27720000
27730000
27740000
27750000
27760000
27770000
27780000
27790000
27800000
27810000
27820000
27830000
27840000
27850000
27860000
27870000
27880000
27890000
27900000
27910000
27920000
27930000
27940000
27950000
27960000
27970000
27980000
27990000
28000000
28010000
28020000
28030000
28040000
28050000
28060000
28070000
28080000
28090000
28100000
28110000
28120000
28130000
28140000
28150000
28160000
28170000
28180000
28190000
28200000
28210000
28220000
28230000
28240000
28250000
28260000
28270000
28280000
28290000

TM
CDCFLAGS,CDCNDC
MAY WE DATA CHAIN
BO
RSELDCN
NO
MVC CDCAD+4(4),SELARGDC RESET CDCAD TO DATA CHAIN
L
0,CDCAD
AH
0,CDCAD+6
ST
0,CDCAD+8
DC ADDRESS
L
0,TLENF
SETUP FIRST TRACK READ
SH
0,CDCAD+6
STH 0,CDCAD+6+8
TRMAX-SELARGL
DRP4
MVI RD1A,0
FORCE CHANNEL PROG CHECK
L
3,RD1ST
MVC 2(4,3),PHYCYL
SETUP CCHH FOR SEEK, SCHIDEQ
MVI RPSCCW,NOP
RESET TO NO OP COMMAND
TM
CDCFLAGS,RPS
SHOULD SET SECTOR BE USED
BZ
DRP5
NO
MVI RPSCCW,SETSECTR
MOVE IN SET SECTOR COMMAND
DRP5
EQU *
DROP 4
LA
0,RD1ST
CAW SETTING
B
SELEXCP
ISSUE START IO
USING CDCPARS,4
RSELDCN MVC CDCAD+4(4),TLENF
READ THE WHOLE FIRST RECORD
MVC EXPCSW(8),NDCCSW
EXPECT NORMAL END AFTER 1 TRACK
B
DRP4
GO FINISH SET-UP AND START IT
DROP 4
RSEL7
BXLE 2,0,RSEL2
*
MAXARM POINTS TO AN EMPTY WORKSPACE
SR
1,0
ST
1,MAXARM
B
RSEL3
DROP 2,3
*
*
MAKE CERTAIN AN EMPTY CYLINDER EXISTS ON DISK
MAKCYL LM
0,3,PDBXLE
LR
2,3
ARM IS MINARM
MAKC2
CLI PDTERM+1-PERDISK(2),EMPTYM
BE
MAKC1
FOUND AN EMPTY CYLINDER
BXLE 2,0,MAKC2
LR
1,2
NEW MAXARM VALUE
MAKC1
STM 1,2,MAXARM
ARM NOW POINTS TO EMPTY CYL
BR
6
*
*
LOCATE SWAPPARS AND SET UP SEEK ADDRESS
USING PERDISK,2
FINDSWAP SR
0,0
IC
0,PDXTENT
PICK UP SWAP EXTENT INDEX
A
0,SWAPBASE
ADD START OF SWAP TABLE
ST
0,CDCBASE
SAVE FOR FUTURE REFERENCE
MVC PHYCYL,PDDA
CYLINDER,HEAD (CCHH)
BR
4
RETURN
DROP 2
*
*
*
CDCOMP
USING PERCORE,5
USING PERDISK,4
CDCOMPW MVI PCTERM+1,EMPTYM
MARK CORE SLOT EMPTY
LR
2,4
PERDISK ADDRESS
BAL 4,FINDSWAP
SET UP DISK ADDRESS
DROP 4

5989 28300000
5989 28310000
5989 28320000
28330000
28340000
28350000
28360000
28370000
28380000
28390000
28400000
DASD 28410000
DASD 28430000
DASD 28440000
DASD 28450000
DASD 28460000
DASD 28470000
DASD 28490000
28500000
28510000
5989 28520000
5989 28530000
5989 28540000
5989 28550000
5989 28560000
28570000
28580000
28590000
28600000
28610000
28620000
28630000
28640000
28650000
28660000
28670000
28680000
28690000
28700000
28710000
28720000
28730000
28740000
28750000
28760000
28770000
28780000
28790000
DASD 28800000
28810000
28820000
28830000
28850000
28870000
28880000
28890000
28900000
28910000
28920000
28930000

MVI CDOP,0
WRITE OPERATION
CDCOMPS MVI DOP+1,X'05'
SAVE ENTRY POINT, PROG MODIFICATIO$$$
NI
CCFIRST,0
SET FIRST WRITE PASS SWITCH
DASD
MVC CDCAD+1(3),PCADDR ACTUAL CORE ADDRESS
DROP 5
CDCOMP2 LA
6,SELEXCP
EXIT VIA SIO SUBROUTINE
CDCOMP STM 6,7,CDSAVE
DASD
L
7,=A(REMCDC)
DASD
BALR 6,7
DASD
LM
6,7,CDSAVE
DASD
BR
6
DASD
COPY CDINF
DASD
RDHA
EQU X'1A'
READ HOME ADDRESS
*
SCHEDULER SWITCHES SET BY SPECIAL DISK ROUTINES
OPNUM
DC
X'FF'
NUMBER OF OPERATOR'S TERMINAL
DELZFLG DC
X'00'
CONTROLS MPXEXIT
SHUTDOWN DC
X'00'
ONE=SYSTEM SHUT DOWN IN PROGRESS
SWITCHES DC
AL1(QZSW1)
ASSORTED SWITCHES
C022
QZSW1
EQU X'01'
SEE SVTYI AND QUEND
C022
SELAPENT EQU X'02'
APPENDAGE ENTRY SWITCH
DASD
RESCH
DC
X'00'
3064
POSO
DC
F'0'
PLUS OVER SIGNED ON
FSHARE DC
F'10'
FAIR SHARE OF TYPEWRITER BUFFERS
ENTRY COPSINK
REFERENCED BY PCSB
2550
COPSINK DC
A(EMPT3)
COPY SINK PERTERM ADDRESS
COPSOUR DC
A(AUXTERM)
COPY SOURCE PERTERM
SSKALGN DC
X'00FFF800'
TO ALIGN SSK TARGET.
ASDPAR DC
A(SDPAR)
POINTER TO GENUINE PDSDDDD
EXTRN SDPAR
DEFINED IN DIRECTORY SEARCH
EXTRN AUXTERM
OPTERM DC
A(AUXTERM)
AUXILIARY TERMINAL IS NEVER SIGNEDON
SDQZSW DC
A(QZD0)
QUANTUM END WITH SEL CHAN IDLE
RSELSW DC
A(RSEL0)
READ SELECTION SUBROUTINE
GETDIR DC
A(MAKHOL,RSDIR) SWITCH SETTINGS TO READ DIRECTORY
*
NORMAL SETTINGS FOR SCHEDULER SPECIAL DISK SWITCHES
QZNOP
DC
A(QZD0)
RSELNOP DC
A(RSEL0)
SDT
DC
A(EMPT3,0,SWAPPARS) TERMINAL DOING SPECIAL DISK OP
HDCORE EQU SDT+4
TEMP STORE OF PTCORE(SDT) DURING SD OP
CDCBASE EQU HDCORE+4
CDCPARS BASE REG, APLSUP & DIRSEAR
EXTRN DIRTAB
ADIRTAB DC
A(DIRTAB)
TABLE OF DIRECTORY DISK ADDRESSES
*
*
LIBNOW DC
H'0'
NUMBERS OF )LIB'S IN PROGRESS
LIBLIM EQU COPLIM
DC
X'00'
HIGH-ORDER BYTE OF SDOP HALFWORD
SDOP
DC
C'*'
CURRENT SPECIAL DISK OPERATION
QZSVC
SVCC YYQZ
NOPR
BCR 0,0
DUMY
DC
AL1(ACTIVEM,0,0)
THOROUGH SUSPENSION
ENTRY EXINTLK
C022
EXINTLK DC
X'00'
INTERLOCK WITH T.C.E.R.
C022
DSZEXIT DC
A(*-*)
KX24M
DC
X'00FFFFFF'
CLEAR HIGH ORDER BYTE
ZERO
DC
2F'0'
DSZON REQUIRES EIGHT BYTES
CDSAVE DS
2F
R6 AND R7 DURING REMCDC
DASD
DUMINACT EQU DUMY+PERTERM-ACTIVE DUMINACT IS USED AS A PERTERM
*
SIGNED OFF. NOBODY SETS BITS IN IOB1(DUMINACT) SO OKAY.
*
AREA DURING LIBRARY DIRECTORY PRINTING. ALL GENUINE

28940000
28950000
28970000
28990000
29000000
29010000
29030000
29040000
29050000
29060000
29070000
29080000
29090000
29100000
29120000
29140000
29150000
29160000
29170000
29180000
29190000
29250000
29260000
29270000
29280000
29290000
29300000
29320000
29330000
29350000
29360000
29380000
29390000
29400000
29410000
29420000
29430000
29440000
29450000
29460000
29470000
29480000
29510000
29520000
29530000
29540000
29550000
29560000
29580000
29590000
29640000
29660000
29670000
29690000
29700000
29710000
29720000
29730000
29740000
29750000

*
WORKSPACES WHICH HAVE BEEN STASHED ON DISK FOR LIB
*
PRINT HAVE PDTERM = DUMINACT.
************** DUMINACT MUST BE 16 BEFORE AL1(ACTIVEM) **************
IESW
DC
X'00'
PROCRASTINATE SETTING TIMER
FSWAP
DC
X'00'
UNRZ TO SCHED COMMUNICATION
*
FSWAP OFTEN AVOIDS NECESSITY TO COMPUTE AND/NONINM. FSWAP
*
ALSO HAS THE EFFECT OF PROLONGING THE WINDOW CREATED BY
*
HSCNT OVERFLOWING.
ALG1
DC
H'1,1,1'
CONTROLS DISK READ SELECTION ALGOR
DIRSMAN DC
F'0',5H'0'
RESULT OF DIRECTORY SEARCH
DIRSRES EQU DIRSMAN+4
DSFILE EQU DIRSRES+4
PACK FOR WS READ OR WRITE
DIRSWSQ EQU DIRSRES+6
WSQ, WSA FOR DIR4TH
DIRCHANG DC
X'00'
DIRSRES + 10
DASD
SPACE 2
3064
* SETHILO SWITCH/FLAGS FOR APLSETHI/APLSETLO
3064
*
3064
SHLFLAGS DC
AL1(SHLACTIV+SHLCUR) APLSETHI/APLSETLO STATUS
3064
SETHILO EQU SHLFLAGS
PSEUDONYM
3064
SPACE 1
3064
SHLACTIV EQU B'00000010'
1 - SETHI/SETLO LOOP IS ACTIVE
3064
*
0 - SETHI/SETLO LOOP IS STOPPED
3064
SHLCUR EQU B'00000001'
1 - APL CURRENTLY AT HIGH PRIORITY 3064
*
0 - APL CURRENTLY AT LOW PRIORITY 3064
SHLSTOPH EQU B'00110000'
STOP LOOP AT HIGH PRIORITY
3064
SPACE 1
3064
*RESERVED
B'X...XX..'
RESERVED
3064
SPACE 2
3064
QZPRG
DC
F'0'
EVENT TO PURGE AT QUANTUM END
QUANLIM IEBRN SETBELL,MAXQUAN
PANLIM IEBRN SETPAN,PANICINT
EXTRN FREE3
CSECT IN CONFIG
IEHED
DC
A(FREE3+12)
HD3FR
DC
A(FREE3)
INITIALLY IT HAS ONE ELEMENT
EXTRN LIBPARS
EXTRN SWAPPARS
*
SWAPBASE AND LIBBASE POINT TO CDCPARS DSECT
LIBBASE DC
A(LIBPARS)
SWAPBASE DC
A(SWAPPARS)
TTERM
DC
F'0'
USED TO MEASURE COMPUTE TIME
MXTEM12 DS
3F
*
DOUBLE WORD ALIGNMENT AREA *************
NOPCSW DC
A(RD1A+8,X'0C00'*X'10000'+1)
MXOLDPSW DS
1D
COPY OF IOOLDPSW
MPXCSW DS
1D
TIMEHI DC
F'0'
CPU TIMER VALUE AT LAST CHAP REQUEST 3064
ENTRY SVINT
ENTRY SVOLDPSW
ENTRY EXOLDPSW
FOR MVT MOTHER.
SVOLDPSW DS
D
APLSUP SVC OLD PSW.
EXOLDPSW DS
D
APLSUP EXT OLD PSW.
DELPSW DC
H'4'
USED TO SIMULATE MPX INT.
5991
EXTRN MPXCH
5991
MPXCHANL DC
AL3(MPXCH-APLSVC)
5991
ORG *-1
5991
DC
A(EXTIME)
INTERRUPT AND GENERATE SGDELZ
DC
H'255,0'
HALF OF DUMMY CSW
DC
F'0'
ZERO IS EIGHT BYTES
*
STORED CCW ADDRESS IN DUMMY CSW IS SIGNAL TO STATUS BYTE
*
DECODER THAT THIS IS DELAY END.

29760000
29770000
29780000
29790000
29810000
29820000
29830000
29840000
29850000
29860000
29870000
29880000
29890000
29900000
29920000
29930000
29940000
29950000
29960000
29970000
29980000
29990000
30000000
30010000
30020000
30030000
30040000
30050000
30070000
30080000
30090000
30130000
30140000
30150000
30170000
30180000
30190000
30200000
30210000
30270000
30280000
30290000
30310000
30330000
30340000
30360000
30370000
30380000
30390000
30400000
30410000
30430000
30440000
30450000
30460000
30470000
30480000
30490000
30500000
30510000

APLSAVE DS
16F
REGISTER SAVE AREA
SPACE
*
IOB USED FOR ALL SELECTOR CHANNEL IO.
SPACE
IOBD
DSECT
, DEFINE IOB.
IOBFLAG1 DS
X
IO FLAGS 1.
IOBFLAG2 DS
X
IO FLAGS 2.
IOBSENS0 DS
X
FIRST SENSE BYTE.
IOBSENS1 DS
X
SECOND SENSE BYTE.
IOBECBCC DS
X
COMPLETION CODE.
IOBECBPT DS
XL3
ECB ADDRESS.
IOBFLAG3 DS
X
IO ERROR FLAGS.
IOBCSW DS
XL7
SEVEN LOW ORDER BYTES OF LAST CSW.
IOBSIOCC DS
X
SIO CONDITION CODE.
IOBSTART DS
XL3
ADDRESS OF CHANNEL PROGRAM.
IOBDCB DS
X
RESERVED.
DASD
IOBDCBPT DS
XL3
ADDRESS OF DCB.
IOBRESTR DS
XL4
PURGE CHAIN/CCHH/COMMAND, CHANNEL PR
IOBINCAM DS
XL2
USE VARIES.
IOBERRCT DS
XL2
NO. OF ERROR RETRIES.
IOBSEEK DS
XL8
STAND ALONE SEEK ADDRESS.
*
FORM IS
MBBCCHHR
*
WHERE
M IS DEB EXTENT NUMBER.
IOBDZ
EQU *
END OF IOB DEFINITION.
SPACE
*
IOBFLAG1 SETTINGS.
IOBF1DC EQU X'80'
DATA CHAINING.
IOBF1CC EQU X'40'
COMMAND CHAINING.
IOBF1ER EQU X'20'
ERROR ROUTINE IN CONTROL.
IOBF1RP EQU X'10'
DEVICE IS TO BE REPOSITIONED.
IOBF1CRC EQU X'08'
CYCLIC REDUNDANCY CHECK IS NEEDED.
IOBF1PE EQU X'04'
EXCEPTIONAL CONDITION.
*
IF IOBF1PE IS SET ON RETURN FROM AN ERROR ROUTINE,
*
-- PERMANENT ERROR.
IOBF1UR EQU X'02'
IOB UNRELATED (NON-SEQUENTIAL).
IOBF1RS EQU X'01'
RESTART (0 MEANS START).
SPACE
*
IOBFLAG2 SETTINGS.
IOBF2HIO EQU X'80'
HALT I/O HAS BEEN ISSUED.
IOBF2SR EQU X'40'
SENSE REQUIRED WHEN DEVICE IS FREE.
IOBF2IP EQU X'20'
IOB HAS BEEN PURGED.
IOBF2HA EQU X'10'
HOME ADDRESS IS TO BE READ.
IOBF2X08 EQU X'08'
INTERNAL IOS FLAG.
IOBF2X04 EQU X'04'
INTERNAL IOS FLAG.
IOBF2X02 EQU X'02'
INTERNAL IOS FLAG.
IOBF2X01 EQU X'01'
QSAM - ERROR RECOVERY
*
WITH THREE BUFFERS.
*
BTAM - RESETPL MACRO WAS USED.
SPACE
APLSUP CSECT
ENTRY ATQE
ATQE
DS
F
TQEPSECT DS
8F
MOTHER GIVES US A COPY OF HER TQE.
DS
0F
WORD ALLIGNMENT.
DSKIOB DC
(IOBDZ-IOBD)X'00' DISK IOB.
ORG DSKIOB+IOBECBPT-IOBD
DC
AL3(DSKECB)
ECB ADDRESS.
ORG
DSKECB DC
0F'0',X'40',AL3(0) DISK EVENT CONTROL BLOCK
C023
SPACE

30530000
30650000
30660000
30670000
30680000
30690000
30700000
30710000
30720000
30730000
30740000
30750000
30760000
30770000
30780000
30790000
30800000
30810000
30820000
30830000
30840000
30850000
30860000
30870000
30880000
30890000
30900000
30910000
30920000
30930000
30940000
30950000
30960000
30970000
30980000
30990000
31000000
31010000
31020000
31030000
31040000
31050000
31060000
31070000
31080000
31090000
31100000
31110000
31120000
31130000
31140000
31150000
31160000
31170000
31180000
31190000
31200000
31210000
31220000
31230000

*
*
*

MVT RELATED DEFINITIONS.

SPACE
ENTRY TCBMERE

*
*
2543
S15FOSXC DC
A(EMPT3)
SAVE R15 IN SELEXCP
2543
S15FOS DC
A(EMPT3)
SAVE R15
2543
MVTCSW DS
CL8
CSW SAVE AREA.
**------THE ORDER OF THE NEXT SIX WORDS IS ASSUMED BY
C022
*
REAL MOTHER TASK.
DON'T CHANGE IT.
TCBMERE DS
F
ADDRESS OF MOTHER TCB.
TCBFILLE DS
F
ADDRESS OF DAUGHTER TCB.
RBMERE DS
F
ADDRESS OF MOTHER PRB.
RBFILLE DS
F
ADDRESS OF DAUGHTER PRB.
ECBMERE DS
F
ADDRESS OF MOTHER ECB.
ECBFILLE DC
F'0'
DAUGHTER ECB.
**------SEE NOTE ABOVE
C022
SPACE
MXCVTTCB DS
2F
SAVE AREA FOR CVTTCBP.
DCBNEXT DS
F
NEXT DCB FOR SELEXCP.
ENTRY DAYSUP
ENTRY REALTIME
DAYSUP DC
F'0' NUMBER OF DAYS SINCE INITIATION IN SECONDS DIV 300.
K24HOURS DC
F'25920000'
24 HOURS IN SECONDS DIV 300.
APLFLAGS DC
AL1(IOBF1DC+IOBF1CC+IOBF1UR,0) APL SETTING OF IOBFLAG1,
*
AND IOBFLAG2.
SPACE
*
EQUATES.
SPACE
CVT
EQU 16
LOCATION OF CVT POINTER.
CVTTCBP EQU 0
DISPLACEMENT OF CVTTCBP IN CVT.
CVTBTERM EQU 52
ADDRESS OF ABTERM.
2217
CVTQTE00 EQU 104
ENQ BRANCH ENTRY.
CVTQTD00 EQU 108
DEQ BRANCH ENTRY.
CVTTPC EQU 88
DISP. IN CVT OF ADDR OF OS PSEUDO CLOCKS
RBOPSW EQU 16
DISP OF RESUME PSW IN PRB.
TCBPIE EQU 4
OFFSET OF P.I.E.
5997
TCBTME EQU 120
DISP OF TQE PTR IN TCB
2219
CVT0PT01 EQU 152
DISP OF POST ADDR IN CVT.
UCBFL5 EQU 1
DISP OF ALLOC CHAN MASK IN UCB. DASD
UCBCHA EQU 4
DISP OF CHANNEL/UNIT ADR IN UCB DASD
UCBSNS EQU 22
DISP OF SENSE BYTES IN UCB.
DCBL
EQU 72
LENGTH OF APL DCB.
DCBDEB EQU 44
THE ADDRESS OF THE DEB FROM DCB DASD
DEBUCB EQU 32
THE ADDRESS OF THE UCB FROM DEB DASD
USING PERTERM,4
DROPZ BASE REGISTERS
USING PERCORE,5
*
INVALID SPECIAL DISK OP
DSZBAD L
4,SDT
INDICATE TO INTERPRETER THAT
OI
IOB1,TRREJ
DIRSEAR PRINTED ERROR MESSAGE
B
DROPZ2
3598
*
END OF DIRECTORY WRITE DROP OR SAVE
DROPZ
ST
LINK,SDQZSW
RESET SWITCH
3598
DROPZ2 LM
4,5,SDT
&HDCORE
3598
L
3,PTCORE
DIRECTORY CORE SLOT
MVI PCTERM+1-PERCORE(3),EMPTYM
ST
5,PTCORE
RECONNECT WORKSPACE
MVC PCTERM+1(3),SDT+1 AND TERMINAL

31240000
31250000
31260000
31270000
31280000
31290000
31300000
31310000
31320000
31330000
31340000
31350000
31360000
31370000
31380000
31390000
31400000
31410000
31420000
31430000
31440000
31450000
31460000
31470000
31480000
31490000
31500000
31510000
31520000
31530000
31540000
31550000
31560000
31570000
31580000
31590000
31600000
31610000
31620000
31630000
31640000
31650000
31660000
31670000
31680000
31690000
31700000
31760000
31770000
31780000
31790000
31800000
31810000
31820000
31830000
31840000
31850000
31860000
31870000
31880000

*
SDKILLA
*
SDKILL
*
*
*
SDK1

SDK2
*
SDK3

*
*
*
*
POSOM

POSO2

*
*
*
*
*
*
*
*
*
* HIST
*
* 0
*
* 1
*
* 2
*

DROP 4,5
SDKILLA SHOULD ONLY BE EXECUTED WHEN SELCHANNEL IS IDLE
MVI CDCBASE+1,EMPTYM
FORCE PROG CK IF NOT SET BEFORE USE
TERMINATE A SPECIAL DISC OPERATION
L
1,SDT
DESUSPEND TERMINAL OF SD OP
NI
ACTIVE-PERTERM(1),255-LOCKM
MVI SDT+1,EMPTYM
FOLLOWING LOOP DESUSPENDS TERMINALS WHICH ARE AWAITING
A SPECIAL DISC OPERATION AND SEARCHES FOR A TERMINAL WHICH
IS TRYING TO SIGN ON.
LM
0,2,PTBXLE
USING PERTERM,2
TM
MISCB,WANTON+SDWAIT
BZ
SDK2
IGNORE THIS TERMINAL
NI
MISCB,255-SDWAIT
BNZ SDK3
SIGN ON ENQUEUED
NI
ACTIVE,255-MISCM ASSUME OLD MISCB=SDWAIT
BXLE 2,0,SDK1
BR
LINK
START SIGN ON PROCESS
ST
2,SDT
MVC SDQZSW(8),GETDIR GET DIRECTORY INTO CORE
MVI SDOP,XXLEMP
BR
LINK
DROP 2
PLUS OVER SIGNED ON MAINTENANCE
R0 IS EITHER +1 OR -1
LINK = RETURN
A
0,POSO
ST
0,POSO
BCR 8,LINK
AVOID DIVIDE BY ZERO
L
1,KOVERBOK
R1=TOTAL BUFFER COUNT TIMES OVERSR
0,0
BOOK FACTOR
FAIR SHARE IS 20 MIN FLOOR R1 DIV PLUS / SIGNEDON
D
0,POSO
CH
1,POSO2
COMPARE WITH MAX ALLOWED VALUE
BL
*+8
LA
1,20
MAXIMUM OUTPUT BUFFER ALLOCATION
EQU *-2
FOR CH ABOVE
ST
1,FSHARE
BR
LINK
EJECT
C022
HISTOGRAM COMPUTATION
WHENEVER APL IS RUNNING, HISTOGRAM STATISTICS ARE COLLECTED
BY APLSUP. THEY CAN BE ACCESSED FROM APL FUNCTIONS VIA THE
MONADIC IBEAM OPERATOR (EXMHIST).
IF IT IS DESIRED TO SAVE CORE BY EXCLUDING THE HISTOGRAM
TABLES, REMOVE THE INCLUDE OF THE CSECT HTAB FROM THE LNKEDT.
SCALE

I N F O R M A T I O N

C041

SPECIAL DISK OPERATION FREQUENCY (SCALE IS SPD CODE)

PERCNT

FRACTION OF ELAPSED TIME USED FOR SERVICE

60/SEC

SYSTEM REACTION TIME (FROM EOB TO EXECUTION)

2547

31890000
31900000
31910000
31920000
31930000
31940000
31950000
31960000
31970000
31980000
31990000
32000000
32010000
32020000
32030000
32040000
32050000
32060000
32070000
32080000
32090000
32100000
32110000
32120000
32130000
32150000
32160000
32170000
32180000
32190000
32200000
32210000
32220000
32230000
32240000
32250000
32260000
32270000
32280000
32290000
32300000
32310000
32320000
32330000
32340000
32360000
32370000
32380000
32390000
32400000
32410000
32420000
32430000
32440000
32450000
32460000
32470000
32480000
32490000
32500000

* 3
*
* 4
*
* 5
*
* 6
*
* 7
*
* 8
*
* 9
*
* 10
*
* 11
*
* 12
*
* 13
*
* 14
*
* 15
*
* 16
*
* 17
*
PERHIST
PHINF
PHSCALE
PHORG
APLSUP

1 SEC

USER KEYING TIME

60/SEC

COMPUTE TIME

---

TRANSFER VECTOR OF ABSOLUTE ADDRESSES FOR OPFNS USE

1 MIN

CONNECT TIME FOR EACH SESSION

.2 SEC

CPU TIME FOR EACH SESSION

1 BYTE

RAW INPUT CHARACTER COUNT

1 SEC

INPUT ARRIVAL TIME (FROM EOB TO EOB)

1 BYTE

INTERNAL OUTPUT LINE LENGTH

2 BUFF

FREE BUFF COUNT AT STYONO

1 BUFF

PTBFA AT STYONO

2547

250 BYTES GARBAGE IN WS AT SWAP WRITE

250 BYTES ACTIVE SIZE OF WS AT SWAP WRITE
APL TU

CPU TIME PER QUANTUM (IN 1/300 SECONDS)

APL TU

CPU TIME AT HIGH PRIORITY

APL TU

CPU TIME AT LOW PRIORITY

2219
2219
3064
3064
3064
3064

DSECT
DS
F
VALUE OF INFINITY, THIS HISTOGRAM
DS
F
DIVISOR OF READING
DS
F
START OF VALUE STORAGE AREA
CSECT
USING PERHIST,PHR
*
PARAMETERS TO HISTCOMP ARE IN REGISTERS: HISTVAL & PHR
*
HISTCOMP IS RE-ENTRENT EXCEPT FOR CALLS OF SAME TABLE.
ENTRY HISTKILL
SO THAT SUPINI CAN MODIFY IT $$$$$$$
HISTCOMP NOPR 0
SUPINI MAY MODIFY TO BR LINK $$$$$$
HISTKILL EQU HISTCOMP
LTR HISTVAL,HISTVAL
BNL *+6
SR
HISTVAL,HISTVAL
NEGATIVE VALUE NOT ALLOWED
SR
HISTVAL-1,HISTVAL-1
D
HISTVAL-1,PHSCALE SCALE READING
LR
HISTVAL-1,HISTVAL
S
HISTVAL-1,PHINF
MAKE SURE READING IS IN RANGE
BM
HISTOK
*
IF READING IS NOT IN RANGE,
L
HISTVAL,PHORG
PRESERVE ITS VALUE IN A FULL WORD
A
HISTVAL-1,0(HISTVAL) COUNTER (FOR CALCULATING MEAN),
ST
HISTVAL-1,0(HISTVAL) AND ASSUME INFINITY.
L
HISTVAL,PHINF
HISTOK AR
HISTVAL,HISTVAL
MAKE SCALED READING A HALFWORD INDEX
A
HISTVAL,PHORG
ADD TABLE ORG, GIVING COUNTER ADDR
LH
PHR,4(HISTVAL)
LA
PHR,1(PHR)
INCREMENT COUNTER
STH PHR,4(HISTVAL)
BR
LINK

32510000
32520000
32530000
32540000
32550000
32560000
32570000
32580000
32590000
32600000
32610000
32620000
32630000
32640000
32650000
32660000
32670000
32680000
32690000
32700000
32710000
32720000
32730000
32740000
32750000
32770000
32780000
32790000
32800000
32820000
32830000
32840000
32850000
32860000
32870000
32880000
32890000
32900000
32910000
32920000
32930000
32940000
32950000
32960000
32970000
32980000
32990000
33000000
33010000
33020000
33030000
33040000
33050000
33060000
33070000
33080000
33090000
33100000
33110000
33120000

DROP PHR
*
LEMP

*
*
*
*
SSKSUB

SSKS1
*
TYOSUB
*
*
*
DEVXCC

USING PERTERM,PTR
SSM ALLOFF
REQUEST TO LOAD EMPTY WORKSPACE
MVI ACTIVE,MISCM
FORCE SUSPENSION
PTSET ACTIVE
MVI MISCB,WANTON+NOWSM
PTSET MISCB
CLI SDT+1,EMPTYM
BCR 7,LINK BNER
SPECIAL DISK OPERATION GOING ON NOW
ST
PTR,SDT
SIGN ON IS SPECIAL DISK OP
MVC SDQZSW(8),GETDIR
MVI SDOP,XXLEMP
BR
LINK
USING PERTERM,PTR
SUBROUTINE TO SET STORAGE KEYS IN ONE WORKSPACE
R3 = NEW KEY
R6 = WS ORIGIN
LINK = RETURN
LA
4,2048
PROTECT BLOCK SIZE
N
6,SSKALGN
2K BOUNDARY AND ZERO TOP BYTE.
LR
5,6
A
5,WLEN
END OF WS ADDR
BCTR 5,0
IN CASE 0=SSKINC RESIDUE WLEN
SSK 3,6
BXLE 6,4,SSKS1
BR
LINK
L
8,=A(REMTYO)
MOST OF TYO IS ABOVE MPXSAVE BASE RE
BR
8
TYOSUB IS CALLED FROM SCHEDULER
DEVXCC IS CALLED BY TYOSUB, THEREFORE DEVXCC MUST BE IN LOW CO
COMPUTE BASE REGISTER TO ADDRESS PERDEVX
SR
6,6
IC
6,PTTYPE
A
6,PERDEVB
BR
1
RETURN ADDRESS IS R1, RESULT IS IN R6

*
*
*
SET CPU TIME LIMIT TO ONE SECOND FOR DOUBLE ATTENTION AND BOUN
*
R5 = RETURN
SHCPUSUB EQU *
TM
IOB1,COPYRM
DON'T TERMINATE COPY SINK
BCR 7,5 BNZR
LM
0,1,PTABTM+(PTICTME-PTICTME)
AR
0,1
ADD PTICTME TO PTABTM BEFORE ZEROING
SR
1,1
ACCOUNTING WILL BE OKAY BUT COMPUTE
*
TIME PER TYI HISTOGRAM WILLL NOT
*
INCLUDE PREVIOUS PTICTME VALUE
STM 0,1,PTABTM
SET PTICTME TO ZERO FOR QZM2 COMPARE
LA
0,10
ONE SECOND TIME LIMIT
STH 0,PTCPULIM
ALLOW ONE SECOND
BR
5
*
DROP PTR
DC
0D'0'
ALIGN LTAR LIKE LTORG DOES
C022
LTAR
DC
40F'0'
SPACE FOR LITERALS
C022
LTARZ
EQU *
FOR OVERRUN CHECK
PATCH
DC
12D'0'
SPACE FOR PATCHES
C022
ENTRY PATCH
K10

33130000
33140000
33150000
33160000
33170000
33180000
33190000
33200000
33210000
33220000
33230000
33240000
33250000
33260000
33270000
33280000
33290000
33300000
33310000
33320000
33330000
33340000
33350000
33360000
33370000
33380000
33390000
33400000
33410000
33420000
33430000
33440000
33450000
33460000
33470000
33480000
33490000
33500000
33510000
33520000
33530000
33540000
33560000
33570000
33590000
33600000
33610000
33620000
33630000
33640000
33650000
33660000
33670000
33680000
33690000
33700000
33720000
33770000
33780000
33790000

05/11/70' 33800000
33810000
33820000
33830000
A) QUANTUM TERMINATION
33840000
CODE FROM QUEND TO QZA0 IS CONCERNED WITH END OF TIME SLICE
33850000
FOR A PARTICULAR TERMINAL. FLOATING REGISTER SAVE, TIME
33860000
ACCOUNTING, STATISTICS, ETC. ARE PERFORMED HERE.
33870000
33880000
B) PERIODIC SCAN OPERATIONS
33890000
CODE FROM QZA0 TO QZA2 IS A SCAN TO INITIATE VARIOUS TASKS.
33900000
THIS CODE PERFORMS TASKS REQUESTED BY VARIOUS INTERRUPT
33910000
ROUTINES. THE SCANNING CODE IS MOSTLY EXECUTED WITH INTERRUPT 33920000
ENABLED AND HAS THE ADVANTAGE OF BEING EXECUTED FAIRLY FRE33930000
QUENTLY (SEVERAL TIMES PER SECOND). SCANNING FUNCTIONS
33940000
INCLUDE DISK ERROR LOGGING, RECEPTION OF MESSAGES TO THE
33960000
OPERATOR, SPECIAL DISK MOPUP AND SWAP INITIATION.
33970000
34050000
C) TASK DISPATCHING
34060000
CODE FROM QZA2 TO QZB2 ATTEMPTS TO FIND AN ACTIVE APL TERMINAL 34070000
IN CORE. THE CODE AT QZA3 PASSES CONTROL TO THE INTERPRETER. 34080000
34090000
D) WAIT STATE
34100000
QZA7 IS REACHED WHEN SCHEDULER CAN FIND NO USEFUL WORK.
34110000
ANOTHER PARTITION OR THE WAIT STATE IS ENTERED UNTIL SOMETHING 34120000
HAPPENS AT WHICH TIME THE PERIODIC SCAN AT QZA0 IS STARTED.
34130000
34140000
E) SWAPPING WRITE SCHEDULER
34150000
CODE FROM QZB2 TO EXECDSER DECIDES IF SWAP OPERATION IS
34170000
DESIRABLE NOW. IF SO, A WRITE OR POSSIBLY A READ IS INITIATED 34180000
34190000
F) DIRECTORY SEARCH INITIATION
34200000
CODE AT EXECDSER IS PART OF SPECIAL DISK AND IS ENTERED WHEN 34210000
A DIRECTORY HAS BEEN BROUGHT INTO CORE. NORMALLY THE TASK
34220000
REQUIRING AN EXECUTION OF THE DIRECTORY SEARCH ROUTINE IS
34230000
FORCED INTO EXECUTION.
34240000
34260000
START OF SCHEDULER
34270000
DS
0F
ALIGN QUEND & SCHSAVE
34280000
QUEND
BAL MR,QUEND1
SETTING MR TO SCHSAVE
34290000
USING SCHSAVE,MR
34300000
SCHSAVE DS
16F
REGISTER STORAGE (SCHEDULER)
34310000
*
END OF QUANTUM
34320000
USING PERTERM,PTR
SVINT LOADED FOR US
34330000
USING M,PXR
SVINT LOADED
34340000
QUEND1 STD 0,FRSAVE
34350000
STD 2,FRSAVE+8
34360000
STD 4,FRSAVE+16
34370000
STD 6,FRSAVE+24
34380000
PSWSAVE MVC FRSAVE+32(8),SVOLDPSW
34390000
BAL LINK,CORTIME
READ CLOCK
34400000
RESET UGHSW,SVC
2217 34410000
LA
MR,SCHSAVE
TO ALLOW ALL INTERRUPTS
34420000
ST
MR,CURRENTM
FOR MPXEXIT
34430000
L
1,QZPRG
34440000
BAL LINK,PRGIE
PURGE SETBELL OR SETPAN
34450000
QZACT
34460000
LR
6,PXR
34470000
IC
3,INACTKEY
RESET STORAGE KEY FOR THIS WS
34480000
BAL LINK,SSKSUB
TO INACTIVE KEY
34490000
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

TITLE 'A P L S U P S C H E D U L E R
SCHEDULER FUNCTIONS...
ENTERED AT QUEND (OR QZA0 VIA QZA7)

*
*
*
*

R0 IS DURATION OF LAST QUANTUM IN TRECENTISECONDS

GATHER CPU-TIME PER QUANTUM
LR
LR
LA
BAL

*
*

*
*
*

QZM0
*
*
*
QZM1
*
QZM2

*
*
*
*
*
*
*
*

2,0
SAVE FOR LATER USE
HISTVAL,0
PHR,PERHQCPU
LINK,HISTCOMP STUFF AWAY CPU/QUANTUM

2219
2219
2219
2219
2219
2219
2219
2219
2219

LR
0,2
PUT IT BACK FOR CODE BELOW
SSM ALLON
A
0,PTICTME
LR
2,0
LR
HISTVAL,0
TM
SWITCHES,QZSW1 HAS SVTYI SET SWITCH TO ZERO?
C022
BO
QZM1
B. IF NOT
C022
QUANTUM TERMINATED BY TYI. R0 NOW CONTAINS COMPUTE TIME
REQUIRED TO SERVICE THE PREVIOUS TYI
A
0,PTABTM
TOTAL COMPUTE TIME SINCE SIGNON
ST
0,PTABTM
SR
0,0
LA
PHR,PERHGRND
BAL LINK,HISTCOMP
LR
0,2
L
2,REALTIME
S
2,PTMTIM2
SET AT STYIZ
R2 GIVES ELAPSED TIME FROM FINISH OF PREVIOUS TYI (STYIZ) TO
INTERPRETER EXECUTING ANOTHER TYI. THE 1050 MAY STILL BE RECEIVING OUTPUT.
LA
PHR,PERHELFR
CLR 0,2
BNL QZM0
AVOID DIVIDE BY ZERO
SR
HISTVAL,HISTVAL
SRDA HISTVAL-1,8
COMPUTE TRUE QUOTIENT TIMES 2*23
DR
HISTVAL-1,2
B
*+8
L
HISTVAL,0(PHR)
SCALED 1.0
BAL LINK,HISTCOMP
QUOTIENT IS FRACTION OF AVAILABLE MACHINE TIME USED TO
SERVICE PREVIOUS TYI. IF THIS EXCEEDS (1 DIV +/SIGNEDON)
HE GOT MORE THAN HIS SHARE
OI
SWITCHES,QZSW1 RESET SWITCH
C022
SR
1,1
ZERO COMPUTE TIME
ST
1,PTICTME
FORCE ATTENTION AND CPU TIME LIMIT CODE.
TM
PTCPULIM,EMPTYM
CHECK FOR A TIME LIMIT.
BO
QZM3
BRANCH IF NO TIME LIMIT.
SR
0,0
TURN TIMER-UNIT CPU TIME INTO
D
0,LMB30
0.1 SEC UNITS.
SH
1,PTCPULIM
SUBTRACT TYI-TO-TYI CPU LIMIT
NOTES ... WE CAN'T BE MORE THAN A FEW TENTHS OF A SECOND
OVER THE CPU LIMIT OR WE WOULD HAVE CAUGHT IT AT
THE LAST QUEND. HENCE R1 IS SMALL IF POSITIVE.
THE FOLLOWING COMPARISON FORCES ATTENTION IFF
(PTICTME GEQ PTCPULIM) AND ONATTN NEQ 0
TO AVOID FORCING ATTENTION IF ATTN ON-CONDITION
IS DISABLED.
CL
1,ONATTN
R1 GUARANTEED LARGER IF NEGATIVE
BNL QZM3
R1 ALSO LARGER IF ONATTN DOESN'T
CONTAIN AN INTERP ENTRY ADDRESS.

34500000
34510000
34520000
34530000
34540000
34550000
34560000
34570000
34580000
34590000
34600000
34610000
34620000
34630000
34640000
34650000
34660000
34670000
34680000
34690000
34700000
34720000
34730000
34740000
34750000
34760000
34770000
34780000
34790000
34800000
34810000
34820000
34830000
34840000
34850000
34860000
34870000
34880000
34900000
34910000
34920000
34930000
34940000
34950000
34960000
34970000
34980000
34990000
35000000
35010000
35030000
35040000
35050000
35060000
35070000
35080000
35090000
35100000
35110000
35120000

ACTIVE,255-ATTENM REMOVE ATTENTION FLAG.

PTCPULIM(2),PTCPULM2 RESTORE CPU LIMIT IN CASE OF
DOUBLE ATTN WHICH SETS 2-SEC LIMIT
IN PTCPULIM.
MVC FRSAVE+37(3),=AL3(BGATTN) FORCE ENTRY TO BGATTN AT START
OF NEXT QUANTUM.
EXTRN BGATTN
PRECEDING CODE IS OVERHEAD CONCERNED WITH ENDING QUANTA
DROP PXR,PTR
FOLLOWING CODE IS SCHEDULING ALGORITHM
EQU *
LAST QUANTUM END CODE
EQU *
START PERIODIC SCAN
L
5,OPTERM
DC
0AL4(DUMINACT)
WHEN NO OPR, OPTERM=A(DUMINACT)
TM
IOB1-PERTERM(5),BROADM+RINGM
BZ
QZE1
NO MESSAGE FOR OPERATOR
ST
5,PTBASE
TM
ACTIVE-PERTERM(5),INWAITM
BNZ QZE1
SVCC YYREC
RECEIVE MESSAGES FOR OPERATOR.
QZE1
SPACE 2
DASD
IF THE ABNORMAL END APPENDAGE RETURNED TO IOS FOR RECOVERY
DASD
AND IOS ERROR RECOVERY FAILED, THE ECB WILL BE POSTED BY IOS DASD
BUT SELBUSY WILL STILL BE 1 BECAUSE IOS DOES NOT RE-ENTER
DASD
THE ABNORMAL END APPENDAGE AFTER ERROR RECOVERY FAILURE.
DASD
THIS WILL NOT HAPPEN FREQUENTLY, BUT WHEN IT DOES, WE WISH
DASD
TO NOTIFY THE APL OPERATOR AND TAKE APPROPRIATE ACTION.
DASD
DASD
TM
DSKECB,X'40' IF EXCP IS NOT COMPLETED,
DASD
BZ
QZA2
SEEK AN ACTIVE USER IN CORE
DASD
IOS HAS POSTED US WITH AN ERROR COMPLETION CODE
DASD
CALL ERROR RECOVERY
DASD
DASD
WE COUNT ON HAVING GONE THROUGH SELRTRY AT LEAST ONCE
DASD
L
10,=A(SELSTAR)
DASD
XC
DCBNEXT,DCBNEXT TELL SELEXCP WE'RE IN THE SCHEDULER DASD
LA
LINK,QZE1
DASD
B
SELRTR2-SELSTAR(10) PERFORM ERROR RECOVERY RECOVERY DASD
DASD
L
10,SDQZSW
SPECIAL DISK OP SWITCH
BALR LINK,10
USUALLY TO QZD0
POSSIBLE SETTINGS OF SDQZSW ARE
QZD0, MAKHOL, EXECDSER, CONTDSER, DROPZ
C011

QZMRST
*
*
QZM4
*
*
*
QZM3
QZA0

*
*
*
*
*
*
*
QZE3
*
*
*
*

*
QZE2
*
*
*
*
QZD0
QZD3

QZD2
*
*
*
*

NI
MVC

COMPUTE
OR / ACTIVE AND NOT INCORE
USING PERDISK,3
LM
0,3,PDBXLE
USING PERTERM,4
CLI PDTERM+1,EMPTYM
BZ
QZD2
EMPTY DISK AREA.
L
4,PDTERM
TM
ACTIVE,ACTIVEM
BC
8,QZD1
AN ACTIVE USER IS ON DISK
BXLE 3,0,QZD3
DROP 3,4
NO ACTIVE USER ON DISK, LEAVE SELECTOR CHANNEL IDLE
SEARCH FOR AN ACTIVE USER IN CORE
SEARCH STARTS WITH SLOT AFTER THE CURRENT SLOT

35180000
35190000
35200000
35210000
35220000
35230000
35240000
35250000
35260000
35270000
35280000
35290000
37330000
37340000
37350000
37360000
37370000
37380000
37390000
37400000
37410000
37430000
37440000
37450000
37460000
37470000
37480000
37490000
37500000
37510000
37520000
37530000
37540000
37550000
37560000
37570000
37580000
37590000
37600000
37610000
37630000
37640000
37650000
37660000
37670000
37680000
37690000
37700000
37860000
37870000
37880000
37890000
37900000
37910000
37920000
37930000
37940000
37950000
37960000
37970000

QZA2

LM
0,4,PCBXLE
USING PERCORE,4
USING PERTERM,5
BXLE 4,0,QZA5
LR
4,2
TM
PCTERM+1,EMPTYM
BC
7,QZA4
SLOT IS EMPTY
L
5,PCTERM
TM
ACTIVE,ACTIVEM+LOCKM
BC
8,QZA3
RUN THIS GUY
BCT 3,QZA6
EXAMINE ALL SLOTS
NO ACTIVE USER IN CORE
WE ARE WASTING CPU TIME.
IF AN ACTIVE USER IS ON DISK, A PREVIOUS CHOICE AS TO WHICH
WORKSPACE TO WRITE OUT MAY HAVE BEEN WRONG. NO ACTIVE USER
ON DISK EXONERATES US.
LM
2,4,PCBXLE
INCREMENT PCQUONT (/ALL/) BY 1
USING PERCORE,4
.
LH
1,PCQUONT
TO PREVENT TROUBLE WITH LOCKM
LA
1,1(0,1)
AND PCQUONT = 0 DURING COPY WHEN
STC 1,PCQUONT+1
INCORE = 2.
BXLE 4,2,QZA8
DROP 4

37980000
38020000
38030000
QZA6
38040000
38050000
QZA5
38060000
38070000
38080000
38090000
38100000
QZA4
38110000
*
38120000
*
38130000
*
38140000
*
38150000
*
38160000
38170000
38180000
QZA8
38190000
38200000
38210000
38220000
38230000
*
38240000
QZA7
,NO APL USER WANTS SERVICE
38250000
*
38260000
CONTDSER L
4,RRCORE
QUANTUM ENDS IN DIRECTORY SEARCH ARE 38270000
USING PERCORE,4
38280000
L
5,SDT
IGNORED AND SWAPPING IS INHIBITED
38290000
*
FIRE UP THE INTERPRETER
38300000
QZA3
LH
1,PCQUONT
INCREASE COUNT
38310000
LA
1,1(1)
38320000
STC 1,PCQUONT+1
COUNT RESIDUE 256
38330000
ST
4,RRCORE FOR NEXT TIME AT QZA2
38340000
ST
5,PTBASE
CURRENT PERTERM AREA
38350000
MVI PTBASE,0
REMOVE HIGH ORDER GARBAGE
38370000
SSM ALLOFF
* * * * * * *
38380000
MVC CURRENTM+1(3),PCADDR
38390000
DROP 4
38400000
LM
2,3,QUANLIM
QUANTUM LIMIT EVENT
38410000
ST
2,QZPRG
FOR PURGE AT QUEND
38420000
BAL 5,ENQIE
QUEND MAY PURGE
38430000
L
5,PTBASE
RESTORE BASE REGISTER
38450000
L
2,CURRENTM
38470000
USING M,2
38480000
MVC MQCELL,NOPR
38540000
LD
0,FRSAVE
38550000
LD
2,FRSAVE+8
38560000
LD
4,FRSAVE+16
38570000
LD
6,FRSAVE+24
38580000
*
R0 STILL CONTAINS REALTIME
38590000
TM
ACTIVE,NONINM
COMPUTE HISTOGRAM
38600000
BZ
STYIZ0
IF AWAITING INPUT
38610000
STYIZ1 ST
0,PTMTIME
38620000
QAACT
,QUANTUM ACTIVATION ACCOUTING
38630000
LR
6,2
R6 IS PCADDR, THIS WS
38640000
IC
3,ACTKEY
ACTIVE KEY
38650000
BAL LINK,SSKSUB
SET STORAGE KEY
38660000
LM
0,15,REGSV
38670000
LPSW FRSAVE+32-M(MR)
ENTER INTERPRETER
38680000

*
*
*
STYIZ0

*
*
*
*

*
QZB2
*

*
*
QZB4

*
*
*
MAKHOL
QZD1

QZB1

QZB3
*
*
*
*

38690000
38700000
FIRST QUANTUM AFTER TYPIST SEND EOB OF TYI
38710000
TM
IOB1,COPYRM+COPYWM COPY TERMINALS REMAIN HIGH
38720000
BNZ STYIZ1
PRIORITY AND GET NO HISTOGRAMS
38730000
OI
ACTIVE,NONINM
SET TO LOW PRIORITY
38740000
LR
HISTVAL,0
38800000
S
HISTVAL,PTMTIME
GIVING RESPONSE TIME
38810000
ST
0,PTMTIME
TO MEASURE COMPUTE TIME
38820000
FINISH TYI
38830000
INFORMATION DELIVERED TO INTERPRETER AT TYI
38840000
PTIBUF POINTS TO CHAIN OF TRANSLATED BUFFERS
38850000
LA
PHR,PERHRES
RESPONSE TIME HISTOGRAM
38860000
BAL LINK,HISTCOMP
38870000
HISTOGRAM ON REACTION TIME **************************
38880000
L
0,REALTIME
38890000
B
STYIZ2
38900000
DROP 2,5
38910000
38920000
USING PERTERM,3
38930000
USING PERCORE,2
38940000
LR
5,2
CORE SLOT OF INACTIVE TERMINAL
38950000
AN INACTIVE SLOT HAS BEEN FOUND, SEARCH FOR EMPTY SLOT
38960000
BXH 2,0,QZB5
NO MORE SLOTS
38970000
TM
PCTERM+1,EMPTYM
38980000
BC
8,QZB2+2
38990000
FOUND AN EMPTY SLOT
39000000
EMPTY SLOT EXISTS, SKIP WRITE
39010000
ST
2,CDCORE
FAKE A PRIOR WRITE
39020000
SSM ALLOFF
39030000
MVC CDCAD+1(3),PCADDR-PERCORE(2)
39040000
BAL LINK,RSELSUB
SELECT DISK AREA AND START READ
39050000
SSM ALLON
RESTORE SYSTEM MASK
39060000
B
QZA2
SELECTOR CHANNEL IS NOW BUSY
39070000
39080000
FOLLOWING CODE CHECKS FOR AN EMPTY SLOT IN CORE. IF THERE IS 39090000
NO SLOT, IT SEARCHES FOR A WORKSPACE TO WRITE OUT TO DISK.
39100000
ST
LINK,SDQZSW
TURN OFF SDQZSW
39110000
MVI FSWAP,1
FORCE SWAP
39120000
B
*+8
39130000
STM 0,3,SCHTEM
LOCATES FIRST ACTIVE USERS ON DISK 39140000
LM
0,2,PCBXLE
39150000
LA
5,1
CAUSE PROGCHECK AT QZB5 R5 NOT CHANG 39160000
LCR 4,0
MAXIMUM QUONT VALUE
39170000
TM
PCTERM+1,EMPTYM
39180000
BC
7,QZB4
FOUND AN EMPTY SLOT
39190000
L
3,PCTERM
39200000
TM
ACTIVE,ACTIVEM
39210000
BC
7,QZB2
SLOT IS INACTIVE
39220000
TEST FOR MAXIMUM RESIDENCE IN CORE
39230000
CH
4,PCQUONT
39240000
BH
QZB3
39250000
LH
4,PCQUONT
NEW MAXIMUM
39260000
LR
5,2
CORE SLOT OF NEW MAX
39270000
BXLE 2,0,QZB1
39280000
DROP 2,3
39290000
NO EMPTY OR SUSPENDED USER IN CORE
39300000
TRADITIONALLY APL SWAPPING WAS INITIATED WHENEVER THERE WAS AN 39310000
ACTIVE USER ON DISK. THE FOLLOWING LOGIC SERVES TO INHIBIT
39320000
SWAPPING UNDER HEAVY COMPUTE LOAD CONDITIONS. SWAPPING IS
39330000

*
*
*
*

ALWAYS INITIATED IF A USER WITH INPUT READY IS ON THE DISK.

SWAPPING MAY BE INITIATED LESS FREQUENTLY (EVERY TENTH
PASSAGE THROUGH SCHEDULER WITH DISK IDLE) IF ALL USERS IN CORE
ARE ACTIVE AND NO USER IN CORE IS SUSPENDED.
CLI FSWAP,1
UNRZ,MAKHOL FORCED SWAP FLAG
MVI FSWAP,0
BE
QZB5
DISK CONTAINS EITHER A USER WITH
INPUT READY OR AN ACTIVE USER WHO SHOULD HAVE BEEN
BROUGHT IN WITH PREVIOUS SWAP.
TR
HCSCNT(1),HCSTR
COUNT MODULO TEN
CLI HCSCNT,0
BE
QZB5
FORCE ACTIVE USER OUT AND BRING IN
ANOTHER HEAVY COMPUTE.
COMPUTE (AND/NONINM) AND INITIATE SWAP ONLY IF THIS IS ZERO.
LM
0,3,SCHTEM
SKIP INACTIVE USERS
USING PERDISK,3
AT LOW ORDER END OF DISK
USING PERTERM,2
CLI PDTERM+1,EMPTYM
BE
QZF2
L
2,PDTERM
TM
ACTIVE,NONINM
BZ
QZB5
INPUT READY
BXLE 3,0,QZF1
DROP 2,3
AVOID SWAP EVEN THOUGH DISK CONTAINS AN ACTIVE USER.
B
QZA2

39340000
39350000
39360000
39370000
39380000
39390000
39400000
*
39410000
*
39420000
39430000
39440000
39450000
*
39460000
*
39470000
39480000
39490000
39500000
QZF1
39510000
39520000
39530000
39540000
39550000
QZF2
39560000
39570000
*
39580000
39590000
*
39600000
USING PERCORE,5
SLOT TO WRITE TO DISC
39610000
*
INTIATE NORMAL DISK WRITE
39620000
QZB5
L
4,PCTERM
39630000
SSM ALLOFF
UNRZ COULD CAUSE TROUBLE HERE
39640000
STM 4,5,CDTERM
39650000
MVI PTCORE+1-PERTERM(4),EMPTYM
39660000
L
4,ARM
39670000
CLI PDTERM+1-PERDISK(4),EMPTYM CHECK FOR ALLOCATION ERROR
39680000
BE
QZB6
CYLINDER IS EMPTY, GOOD
39690000
BAL 6,MAKCYL
CREATE AN EMPTY CYLINDER
39700000
LR
4,2
NEW VALUE OF ARM
39710000
QZB6
ST
4,CDDISK
39720000
MVC PDTERM+1-PERDISK(3,4),PCTERM+1
39730000
BAL LINK,CDCOMPW
COMPUTE CHAIN AND SIO
39740000
SSM ALLON
REENABLE INTERRUPTS
39750000
L
4,CDCAD
ADDRESS OF MR
39770000
L
HISTVAL,MINGL-M(4) HISTOGRAM OF TOTAL AMOUNT OF MARKED 39780000
LA
PHR,PERHGARB
GARBAGE IS WS AT SWAP WRITE
39790000
BAL LINK,HISTCOMP
39800000
LM
3,4,MX-M(4) SVI
HISTOGRAM OF SIZE OF ACTIVE WS
39810000
SR
4,3
(INCLUDING MARKED GARBAGE) AT SWAP 39820000
L
HISTVAL,WLEN
WRITE
39830000
SR
HISTVAL,4
39840000
LA
PHR,PERHWSIZ
39850000
BAL LINK,HISTCOMP
39860000
B
QZA2
39880000
DROP 5
39890000
*
PREPARE TO SEARCH OR PRINT DIRECTORY OF SAVED WORKSPACES
39900000
*
EXECDSER IS ENTERED VIA SDQZSW
39910000
EXECDSER MVC SDQZSW,=A(CONTDSER) IGNORE QEND FROM DIRSEAR
39920000
L
4,CDCORE
DIRECTORY SLOT
39930000
L
5,SDT
39940000
USING PERTERM,5
39950000

USING PERCORE,4
MVC HDCORE+1(3),PTCORE+1 REMEMBER TRUE WORKSPACE LOCATION
ST
4,PTCORE
MVC PCTERM+1(3),SDT+1
MVI ACTIVE,NONINM
NOT TYIZ
PTSET ACTIVE
L
1,CDCAD
MR OF DIRECTORY
USING M,1
NI
FRSAVE+33,254
FORCE SUPVR STATE SO PROGCHECK=HALT
MVC FRSAVE+36(4),=V(DIRSEAR) SETUP ENTRY POINT IN PSW
MVC REGSV+7*4(8),HDCORE & CDCBASE
CLI SDOP,XXLIB
LIBRARY OP AT QZ WITH DIRECTORY IN CORE
BNE QZA3
SEARCH DIRECTORY
EX
0,SDSWRSET
DIRECTORY SEARCH IS FINISHED
SSM ALLOFF
* * * * * * * * * * * * *
L
4,ARM
ST
4,CONCEAL
USED AT SVLIBZ
STM 4,5,CDDISK
MVC PDTERM+1-PERDISK(3,4),=AL3(DUMINACT)
L
5,HDCORE
TRUE WORKSPACE IS FORCED TO DISK
ST
5,CDCORE
MVI CDCBASE+1,EMPTYM
FORCE PROG CK IF NOT SET BEFORE USE
BAL LINK,CDCOMPW
COMPUTE CHAIN AND SIO
SSM ALLON
BAL LINK,SDKILL
THUS ENDING SPECIAL DISK OP
B
QZA0
DROP 1,4,5
EXECDSER END

*
*

*
*
*
ELFR
*
RES
*
GRND
*
GARB
*
WSIZ

USING PERDEVX,PXR
USING PERTERM,PTR
USING MPXSAVE,MR
END OF SCHEDULER BASE REGISTER -----------------FRACTION OF ELAPSED TIME USED FOR SERVICE
PRINT GEN
PHGEN X'800000',101,1
SCALED 1.0 MAX
PHGEN 1205,242,2

REACTION TIME PER INPUT

PHGEN 605,122,4

COMPUTE TIME PER INPUT

PHGEN 50250,202,13

GARBAGE IN WS AT SWAP

QCPU

PHGEN
SPACE
PHGEN
SPACE

50250,202,14
ACTIVE SIZE OF WS AT SWAP
2
2219
PANICINT,PANICINT,15 CPU-TIME IN APL TU (1/300 SEC)2219
2
2219

*
LMB30
SCHTEM
HCSCNT
HCSTR
*
*

DC
DC
DC
DC

F'30'
4F'0'
X'01'
RESIDUE TEN COUNTER GOOD ON M91
9AL1(1+*-HCSTR),AL1(0) MODULO TEN TRANS TABLE

TITLE 'M P X A N D S V C R O U T I N E S
05/11/70'
MULTIPLEXOR CHANNEL ROUTINES
ENTRY MPXSAVE
FOR CONFINIT SVBASE INITIALIZATION
MPXSAVE DS
16F
REGISTER SAVE AREA
*

39960000
39970000
39980000
39990000
40000000
40010000
40020000
40030000
40040000
40050000
40060000
40070000
40080000
40090000
40100000
40110000
40120000
40130000
40140000
40150000
40160000
40170000
40180000
40190000
40200000
40210000
40220000
40230000
40270000
40280000
40290000
40300000
40310000
40320000
40330000
40370000
40380000
40390000
40400000
40410000
40420000
40430000
40440000
40450000
40460000
40470000
40480000
40490000
40500000
40510000
40520000
40540000
40550000
40560000
40580000
40590000
40600000
40610000
40620000
40630000

*
*
*
*
*
*
*
*
*
*
MPXINT

MPXA0

*
*
*
*
*

ROUTINE TO COMPUTE PERTERM OR PUB ADDRESS FROM DEVICE ADDRESS

(MULTIPLEXOR CHANNEL ONLY)
FORMAT OF EIGHT BYTE MPXCUTAB ENTRY IS..
DC
Y(MULTIPLIER)
EITHER PUBENTL OR PERTERML
DC
X'UU'
LOWEST ADRESS FOR CONTROL UNIT
DC
X'UU'
HIGHEST ADDRESS FOR CONTROL UNIT
DC
A(ENTRY ORIGIN FOR THIS CONTROL UNIT)
THERE ARE SIXTEEN ENTRIES (256 DIV 16)
MVC
SR
IC
LA
NR
XR
SRL
A
USING
MH
A
BZ

MXOLDPSW(16),IOOLDPSW
4,4
4,MXOLDPSW+3
DEVICE ADDRESS
PTR,X'0F'
PTR,4
4,PTR
4,1
CONTROL UNIT TIMES 8
4,AMXCUT
MPXCUTAB,4
PTR,MPXCUTAB
PTR,MPXCUTAB+4
IOREJ
NOT OUR INTERRUPT
TEST FOR DEVICE ADDRESS OUT OF RANGE
CLC MXOLDPSW+3(1),MPXCUTAB+3
BH
IOREJ
CLC MXOLDPSW+3(1),MPXCUTAB+2
BL
IOREJ
DROP 4
CLI PTTYPE,0
CHECK FOR INDIRECT ENTRY
BNE MPXA0
L
PTR,PTTYPE
TRUE PERTERM OR PUBENT.
LTR PTR,PTR
CHECK FOR DUMMY PERTERM.
BZ
IOREJ
BRANCH F SO.
SET UGHSW,MPXIO
SPACE

5991
5991

2217

MVT MPXINT.

MULTIPLEX CODE, WHEN ENTERED FROM MPXINT,

C020
PRETENDS TO RUN UNDER MOTHER TCB.
C020
SPACE 2
C020
* 1.
MXCVTTCB IS CVTTCBP
C020
* 2.
CVTTCBP IS 2 RHO TCBMERE
C020
SPACE 2
C020
**------- THE FOLLOWING CODE IS INCLUDED AS A DEBUGGING AID,
C020
**
SO THAT ANY CATASTROPHIC ERRORS IN THE MULTIPLEX
C020
**
CODE CAN EASILY BE TRACED TO APL.
C020
*
C020
* 1.
C020
*
C020
L
1,CVT
C020
L
1,CVTTCBP(1)
POINTER TO NEXT AND CURRENT TCB'S.
MVC MXCVTTCB(8),0(1)
SAVED.
*
C020
* 2.
C020
*
C020
*
POINT TO APL IN CASE WE BLOW IT
C020
MVC 0(4,1),TCBMERE
OUR MOTHER TASK IS NEXT
MVC 4(4,1),TCBMERE
AND CURRENT.
**
C020

40640000
40650000
40660000
40670000
40680000
40690000
40700000
40710000
40720000
40730000
40740000
40750000
40760000
40770000
40780000
40790000
40800000
40810000
40820000
40830000
40840000
40850000
40860000
40870000
40880000
40890000
40900000
40910000
40920000
40930000
40940000
40950000
40960000
40970000
40990000
41000000
41010000
41020000
41030000
41040000
41050000
41060000
41070000
41090000
41100000
41110000
41120000
41130000
41140000
41150000
41160000
41170000
41180000
41190000
41200000
41210000
41220000
41230000
41240000
41250000

**------- SEE NOTE ABOVE FOR DESCRIPTION OF PRECEEDING CODE

C020
SPACE 3
C020
MVI MSERR,0
TURN OFF SIO ERROR MARK
MVI DELZFLG,0
MARK AS MPXINT ENTRY
*
*
MULTIPLEX CODE STARTS HERE. IT ACTS LIKE A SUBROUTINE.
*
DELZFLG IS EXAMINED AT MPXEXIT TO DETERMINE EXIT PATH.
*
*
EXAMINE STATUS BYTES
MSIOERR TM
STATE,QIEBIT ENTER HERE WITH STATUS
BZ
MPXA3
NO ENQUED IE
LR
1,PTR
BAL LINK,PRGIE
TIMER EVENT NOT NEEDED
MPXA3
NI
STATE,255-QIEBIT-DVBUSY
BAL 1,DEVXCC
COMPUTE DEVICE TYPE BASE REG
LR
PXR,6
DEVICE TYPE BASE REGISTER
TM
MPXCSW+5,255-IL
IGNORE INCORRECT LENGTH
BNZ MPXCS
ANALYZE CHANNEL STATUS
*
CHANNEL STATUS IS OK, CHECK DEVICE STATUS
CLI STATE,SENSING
BE
MPXA1
MPXA4
MVC SAVCSW,MPXCSW
MOVE CSW TO PERTERM
B
MPXA2
MPXA1
MVC IODSENSE-IODBUG(1,2),PUSENS MOVE SENSE BYTE TO IODTAB
*
ASSUME R2 PRESERVED FROM IOINT.
MPXA2
EQU *
SR
SIGR,SIGR
ASSUME NORMAL END
TM
MPXCSW+4,ATT+SM+CUE+UC+UE
BNZ MXDS1
TM
MPXCSW+4,CE+DE
BNZ ANALSIG
CHANNEL END,DEVICE END SIGNE=0
MXDS1
TM
MPXCSW+4,UC
TEST FOR UNIT CHECK
BNZ MPXUC
TM
MPXCSW+4,UE
TEST FOR UNIT EXCEPTION
BNZ MPXUE
*
ASSUME 1052 ATTENTION (REQUEST KEY)
*
1052-7 UNIT EXCEPTION IS CANCEL KEY
UE1052 LA
SIGR,SGINTR
SIGNAL INTERVENTION REQUIRED
B
ANALSIG
MPXUE
L
2,PXUEAD
UNIT EXCEPTION ANALYSIS
BR
2
VARIES WITH DEVICE TYPE
*
*
UNIT CHECK ON MPX DEVICE
MPXUC
UNPK MXTEM12(3),STATE(2) ISOLATE BOTTOM DIGIT OF STATE
CLI MXTEM12+1,X'F0'+PROCR (SENSING GIVES = COMPARE)
BE
MSERR2
PRESERVE SAVSTAT
*
MSERR = 0
STATUS FROM INTERRUPT
*
MSERR = 1
STATUS FROM SIO
MSERR
EQU *+1
PROG MODIFICATION $$$$$$$$$$$$$$$$
TM
MPXCSW+3,C'*'
SIO SETS TO ONE IF CC 3
BO
GEMIN
SIGNAL MINOR ERROR ON CC3
HIDESTAT MVC SAVSTAT,STATE
SAVE CURRENT STATE
MSERR2 LA
0,PUSENS
COMPUTE SENSE CCW
ST
0,MSENCCW
MVI MSENCCW,SENSE
LA
0,MSENCCW
LH
1,MPXCHANL
CHANNEL ADDRESS
5991
IC
1,PTUNAD
DEVICE ADDRESS
BAL LINK,GETSEN
DO SENSE IO
B
MSENFAIL
INDICATE FAILURE OF SENSE IO

41260000
41270000
41300000
41310000
41320000
41330000
41340000
41350000
41360000
41370000
41380000
41390000
41400000
41410000
41420000
41430000
41440000
41450000
41460000
41470000
41480000
41490000
41500000
41510000
41520000
41530000
41540000
41550000
41560000
41570000
41580000
41590000
41600000
41610000
41620000
41630000
41640000
41650000
41660000
41670000
41680000
41690000
41700000
41710000
41720000
41730000
41740000
41750000
41760000
41770000
41780000
41790000
41800000
41810000
41820000
41830000
41840000
41850000
41860000
41870000

*
*
ANALSEN
*
*
*
*
ANALSIG

ANS1
*
*
*
*
*
*
*
*
MXSIOOK
*
*
*
*
*
UE2702
UE1050
UEAMBIG
UE2741

UEIB1

GEMIN
UEIB2
*
*
ACTBASE
UNDSA

START IO INSTRUCTION FOR SENSE IO WAS OKAY

MVI STATE,SENSING
INDICATE SENSE IO IS CURRENT OP
B
MPXEXIT

41880000
41890000
41900000
41910000
MVC STATE,SAVSTAT
RESTORE STATE
41920000
IC
2,PUSENS
ANALYZE SENSE BYTE
41930000
BAL LINK,TUSCH
SEARCH TUS
41940000
CHECK FOR SIGNALS WHICH HAVE AN ACTION WHICH IS
41950000
INDEPENDENT OF DEVICE TYPE OR STATE
41960000
NOW COMPUTE AN ACTION BASED UPON DEVICE TYPE, STATE, AND
41970000
CURRENT SIGNAL
41980000
MVC ANS1+3(1),STATE
41990000
NI
ANS1+3,X'0F'
CLEAN OUT GARBAGE
42000000
L
2,=A(MXSSAG)
42010000
USING MXSSAG,2
42020000
SR
1,1
42030000
IC
1,MXSSAG(SIGR)
42040000
DROP 2
42050000
PRECEDING IC DEPENDS UPON THE EXISTENCE OF A USING
42060000
STATEMENT FOR MXSSAG. (IE. DISPLACEMENT MUST BE ZERO.)
42070000
IT RESULTS IN THE ADDITION OF THE CURRENT STATE TO THE
42080000
SIGNAL BYTE IN SIGR FOR USE AS AN INDEX INTO THE TABLE
42090000
CREATED BY THE SSA MACRO CALLS. ACTION BYTE IS IN R1
42100000
AR
1,1
42110000
ASSUMES THAT ENTRIES ARE WITHIN 512 BYTES
42120000
BC
15,ACTBASE(1)
42130000
42140000
42150000
OI
STATE,DVBUSY
MARK AS STARTED
42160000
MPXEXIT
42170000
42180000
42190000
1050 UNIT EXCEPTION ANALYSIS
42200000
ASSUMES UNIT EXCEPTION MUST BE EITHER NEGATIVE RESPONSE TO
42210000
POLL OR EOT SENT
42220000
SR
SIGR,SIGR
ASSUME NORMAL END
42230000
EQU UE2702
42240000
EQU UE2702
42250000
EQU UE2702
42260000
CLI PTRESP,CRD
42270000
BE
ANALSIG
EOT (CRC) IN MESSAGE
42280000
L
1,SAVCSW
42290000
SH
1,=H'8'
LOOK AT FINAL COMMAND
42300000
LA
0,UECCWIX
42310000
L
2,=A(UECCWI)
42320000
CLC 0(1,1),0(2)
42330000
BE
UEIB2
42340000
LA
2,1(2)
TRY NEXT ENTRY
42350000
BCT 0,UEIB1
42360000
LA
SIGR,SGMIN
MYSTERY COMMAND
42370000
B
ANALSIG
SIGNAL MINOR ERROR
42380000
IC
SIGR,TUSSL(2)
FOR ANALSIG
42390000
CLI TUSSL(2),255
WRITE IS SPECIAL CASE
42400000
CHECK FOR 2702 ERROR OF ENDING WRITE COMMAND WITH UNIT EXCEPT 42410000
BNE ANALSIG
42420000
BAD UNIT EXCEPTION, TRY TO CLEAR BY ISSUING READ COMMAND
42430000
L
0,ADIAG1
RESET RCV CTL BIT IN OLD 2702
42440000
B
MXSIO
42450000
EQU *
42460000
UGH
,
AVOID UNDEFINED
42470000

UNRTC
*
*
*
UNDIS
*
*
*
UNRINT

EQU

UNDSA

42480000
42500000
SSA SECAWN,SGTIME,UNDIS
42510000
SSA PROCR,SGTIME,UNDIS
42520000
UGH
, UNRECOVERABLE DEVICE ERROR
42530000
42540000
INTERVENTION REQUIRED DURING READ OPERATION
42550000
SSA READS,SGINTR,UNRINT
42560000
LA
BA,PTIBUF
42570000
BAL LINK,FREEBQ
RELEASE INPUT BUFFERS
42580000
MVI PTFBUF+1,EMPTYM
AVOID DOUBLE RELEASE
42590000
*
SSA WRITES,SGINTR,SETWIRS
42600000
*
SSA WRITES,SGTIME,SETWIRS
42610000
SETWIRS SATSUB
SET ATTENTION.
42620000
CLI PTTYPE,Q103A
42630000
BH
SETIDLE
NOT A 2702 DEVICE
42640000
MODNOTE
42650000
*
DIALUP AND FOUR WIRE MODEMS HANDLED THE SAME.
42660000
MVI STATE,WIRS
42670000
LA
0,PREPCCW
42680000
ST
0,PUCCB
42690000
LA
3,WIRSINT
42700000
BAL 5,SDSUB1
ENQ HIO FOR PREPARE
42710000
B
MXSION
42720000
*
42730000
*
INTERVENTION REQUIRED IN LIRS
42740000
*
SSA LIRS,SGINTR,UNLIRINT
42750000
UNLIRINT EQU *
BAM12 42760000
TM
PUSENS,COMREJ
2703 EC 307067 GIVES COMREJ WHEN
42770000
BO
SETDROPD
DATA SET READY DROPS
42780000
TR
PTCNT,LIRSINC
TRANSLATE TO INCREMENT PTCNT
42790000
CLI PTCNT,6
TEST FOR TEN SECONDS, OLD STYLE
42800000
BNL SETDROPD
EC 307067 MAKES THIS REDUNDANT
42810000
B
UNSD
RETRY IN TWO SECONDS
42820000
*
42830000
*
TIMER EVENT WHILE IN LIRS
42840000
*
SSA LIRS,SGDELZ,UNLIRDZ
42850000
UNLIRDZ TM
STATE,DVBUSY
SETLIRSC VS. UNLIRINT DELAY
42860000
BZ
SETLIRSC
DELAY WAS FROM UNLIRINT
42870000
MVI PTCNT,0
RESET INTERVENTION REQ COUNT
42880000
CLI PTTYPE,Q1050
CARRIER DETECT IS UP NOW
42890000
BL
MPXEXIT
WAIT FOR KEYBOARD TO LOCK
42900000
MVI PTRESP,0
FOR UE RESOLUTION AFTER HIO
42910000
MVI STATE,LISTEN+DVBUSY ASSUME OUTPUT IS PENDING, NO HARM 42920000
*
IF IT IS NOT, SO DO HIO ON SPECULATION
42930000
*
SSA WIRS,SGDELZ,UNHIO
42940000
*
SSA LISTEN,SGDELZ,UNHIO
42950000
UNHIO
BAL LINK,HIOSUB
HIO
42960000
B
MPXEXIT
42970000
*
42980000
*
TALK-DATA DETECTED IN LISTEN STATE
42990000
*
SSA LISTEN,SGINTR,SETLIRSA
43000000
SETLIRSA SATSUB
SET ATTENTION.
43010000
*
IN TALK-DATA SEQUENCE. WAIT FOR DATA BEFORE DOING READ OR WRI 43020000
*
SSA WIRS,SGINTR,SETLIRS
43030000
SETLIRS B
SETLIRSB
BULK IS OUT OF PSEUDO BASE REG RANG 43040000
*
43050000
*
43060000
*
ASSUME SIGN ON ATTEMPT HAS ENDED
43070000
UNKILL EQU *
43080000

BAL LINK,OFFSUB
PURGE WORKSPACE
CLI PTTYPE,Q103A
BH
SETIDL2
NOT 270X
*
FOUR WIRE MODEMS AND 103F,3976 MODEMS BEHAVE DIFFERENTLY.
*
POWER OFF AT TERMINAL DOES NOT CAUSE IBM LIMITED DISTANCE
*
MODEM TO END READ TYPE COMMAND WITH INTERVENTION REQUIRED.
*
OPPOSITE IS TRUE FOR 103F,3976.
*
SINCE WE KNOW AT THIS POINT THAT NO USER IS SIGNED ON,
*
WE MAKE THE 103F,3976 ASSUMPTION, WHICH IS THAT INSUFFICIENT
*
TIME HAS ELAPSED FOLLOWING THE ENABLE TO ALLOW THE MODEM
*
TO TURN ON, OR ENABLE WAS MISSING.
*
REISSUE ENABLE AND SAD.
*
SSA TODROP,SGNE,UNKILL1
*
SSA TODROP,SGTIME,UNKILL1
*
SSA TODROP,SGMIN,UNKILL1
*
SSA TODROP,SGINTR,UNKILL1
*
SSA TODROP,SGDELZ,UNKILL1
UNKILL1 CLI STATE,READS
IN THE READ STATE, PTFBUF POINTS
BNE *+8
TO SAME CHAIN AS PTIBUF
MVI PTFBUF+1,EMPTYM
PREVENT DOUBLE RELEASE
L
10,=A(MXDCCC)
DISCONNECT HW OR DIALUP LINE
BR
10
RETURNS TO MXSION
*
*
2741 ATTENTION IN LISTEN STATE
*
SSA LISTEN,SGNE,UN2741BF
UN2741BF SATSUB
SET ATTENTION AND ENTER IDLE STATE
*
*
SSA WIRS,SGNE,SETIDLE
*
SSA WIRS,SGTIME,SETIDLE
*
SSA WIRS,SGMIN,SETIDLE
*
SSA LIRS,SGNE,SETIDLE
*
SSA LIRS,SGMIN,SETIDLE
*
SSA LIRS,SGTIME,SETIDLE
*
SSA LISTEN,SGTIME,SETIDLE
*
SSA LISTEN,SGMIN,SETIDLE
*
SSA IDLE,SGNE,SETIDLE
*
SSA IDLE,SGMIN,SETIDLE
*
SSA IDLE,SGDELZ,SETIDLE
*
SSA IDLE,SGTIME,SETIDLE
SETIDLE MVI STATE,IDLE
CLI PTFBUF+1,EMPTYM
BNE UNWZ
WRITE TO TERMINAL
B
SETIDL2
*
UNSOP
MVC SAVSTAT,STATE
MVI STATE,PROCR
AWAIT OPERATOR INTERVENTION
B
MPXEXIT
*
*
INDIRECT ENTRY TO MULTIPLEXOR END OF READ (TYI) ROUTINE
*
SSA READS,SGNE,UNRZA
UNRZA
L
10,=A(UNRZ)
BR
10
REAL END OF READ IS UP IN THE SKY
*
*
SSA IDLE,SGINTR,UNSAT
UNSAT
SATSUB
1052,SET ATTENTION.
B
MPXEXIT
*
*
INTERVENTION REQUIRED IN PROCR STATE
*
SSA PROCR,SGINTR,UNPINT
UNPINT EX
0,ANALSEN
RESTORE STATE FROM SAVSTAT

43100000
43110000
43120000
43140000
43150000
43160000
43170000
43180000
43190000
43200000
43210000
43220000
43230000
43240000
43250000
43260000
43270000
43280000
43290000
43300000
43310000
43320000
43330000
43340000
43350000
43360000
43370000
43380000
43390000
43400000
43410000
43420000
43430000
43440000
43450000
43460000
43470000
43480000
43490000
43500000
43510000
43520000
43530000
43540000
43550000
43560000
43570000
43580000
43590000
43600000
43610000
43620000
43630000
43640000
43650000
43660000
43670000
43680000
43690000
43700000

43710000
43720000
NON-UNIT CHECK INTERRUPT IN PROCRASTINATE STATE.
43730000
A SIO FOR SENSE COMMAND OR EXCP ACTIVITY WAS PROCRASTINATED. 43740000
SSA PROCR,SGNE,UNPRO
43750000
SSA PROCR,SGMIN,UNPRO
43760000
SSA PROCR,SGDELZ,UNPRO
43770000
CLI STATE,SENSING
43780000
BE
ANALSEN
SENSE IO WAS FINISHED
43790000
TM
STATE,SENREQ
RETRY SIO OF SENSEIO NOW
43800000
BO
MPXUC
OLD INT WAS CE,UC SENSE COM STATUS 43820000
B
UNPRO1
BAM4 43850000
*
43900000
*
READ RETRY -- ALTER 2741 POLLING SEQUENCE TO PRINT RESEND
43910000
*
SSA READS,SGMIN,UNRRT
43920000
*
SSA READS,SGDELZ,UNRRT
43930000
UNRRT
MVC KRC2741(1),PXRSTA CHARACTER SET DEPENDENT
43940000
MVI KRC2741+2,LRSTXT
43950000
BAL LINK,MXRCCC
RECOMPUTE CHAIN
43960000
MVC KRC2741(4),KRC2741A RESTORE 2741 CCW PARAMETERS
43970000
B
MXSION
RETRY READ
43980000
*
43990000
*
MINOR ERROR WHILE WRITING TO TERMINAL
44000000
*
SSA WRITES,SGMIN,UNWCNT
44010000
UNWCNT TR
PTCNT,ERINC
INCREMENT ERROR COUNT
44020000
CLI PTCNT,0
ERINC COUNTS MOD RETRY COUNT
44030000
BE
UNWFAIL
44040000
*
44050000
*
RETRY ON TYPEWRITER
44060000
*
SSA WRITES,SGDELZ,UNRWC
44070000
UNRWC
EQU *
44080000
CLI MSERR,1
TEST FOR ERROR FROM SIO
44090000
BNE MXSIOQ
WAS I O INTERRUPT, RETRY NOW
44100000
B
UNSD
DELAY BEFORE NEXT SIO
44110000
*
44120000
*
ANOTHER ITERATION ... THIS ONE FOR 2703 EC 307050
44130000
*
ENABLE ENDS WITH TIME OUT IF CARRIER DETECT DOES NOT
44140000
*
COME UP WITHIN 28 SECONDS OF ANSWER.
44150000
*
WE END UP AT UNKILL IF THIS HAPPENS.
44160000
*
44170000
*
SSA READS,SGTIME,UNRTIME
44180000
UNRTIME CLI PTCCW1,ENABLE
44190000
BNE UNRTIM1
FIRST COMMAND WAS NOT ENABLE
44200000
*
44210000
*
TIME OUT IN READ STATE ON NON DIAL UP LINES ...
44220000
*
MAY HAPPEN WHEN A TERMINAL HAS BEEN SWITCHED OFF, BUT
44230000
*
NO INTERVENTION REQUIRED IS INDICATED.
44240000
*
TREAT AS INTERVENTION REQUIRED.
44250000
*
44260000
TM
IOB2,Q4WMDM
44270000
BO
UNQ4WDIE
44280000
LA
1,PTCCW1+8
44290000
C
1,SAVCSW
WAS TIMEOUT ON COMMAND IN PTCCW1 -- 44300000
BE
UNRINT
GET TO UNKILL IF SO.
44310000
*
44320000
*
TIMEOUT IN READ STATE, MUST BE PTTYPE=QAMBIG
44330000
UNRTIM1 LA
1,PTCCW3
44340000
MVI PTCCW1,1
FOR UNKILL LINE ADAPTER CHECK.
44350000
C
1,SAVCSW
44360000
BNE UNRINT
ORDINARY TIMEOUT, HANGUP LINE
44370000
*
*
*
*
*
*
UNPRO

UE1052

*
READ RESPONSE TIMED OUT, CHANGE POLLING SEQ
* UNRTIME ATTEMPTS TO RESOLVE TYPE OF A NEWLY CONNECTED TERMINAL
*
WHICH HAS NOT YET RESPONDED TO A POLL. UEAMBIG WILL
*
CONTINUE TO POLL UNTIL THE AMBIGUITY OF TERMINAL TYPE
*
(1050 VS. 2741) IS RESOLVED.
CLI PTCCW1+7,1
BE
*+8
PREV POLLING SEQ WAS 2741. TRY 1050
UNRRTA MVI PTTYPE,Q2741
POLL WITH SINGLE CRC
BAL LINK,MXRCCC
MVI PTTYPE,QAMBIG
FOR INTERRUPT ANALYSIS
MVI PTCCW1+8,X'02'
ALLOW TIMEOUT
B
MXSION
WITH ALTERNATE POLLING SEQUENCES
*
*
*
NORMAL END OF WRITE MPX
*
SSA WRITES,SGNE,UNWZ
UNWZ
L
8,=A(MXWCCC)
P056
CLI SHUTDOWN,0
IS SHUTDOWN IN PROGRESS?
P056
BCR 8,8 BER
NO, COMPUTE WRITE CCW CHAIN.
P056
CLI PTTYPE,QAMBIG
ARE WE STILL SIGNED ON?
P056
BCR 7,8 BNER
YES, COMPUTE WRITE CCW CHAIN. P056
OI
IOB2,LVIDLEM
END OF DISABLE,FLAG AS DOWN
P056
B
MPXEXIT
AND LEAVE IT THAT WAY.
P056
*
ISSUE START I/O ON MPX CHANNEL
MXSIOQ EQU *
MXSION L
0,PUCCB
CCW ADDRESS
MXSIO
MVI PTRESP,0
FOR DEVICES WITH A PERTERM
MXSIOE EQU *
NON-PERTERM ENTRY POINT
N
0,KX24M
CLEAR HIGH ORDER BYTE
LH
1,MPXCHANL
CHANNEL ADDRESS
5991
IC
1,PTUNAD
DEVICE ADDRESS
MXSIO2 BAL 5,SIOSUB
B
MXSIOOK
SIO OKAY
MVC MPXCSW(8),CSW
STATUS WAS STORED
CLI MPXCSW+4,BSY+DE
BUSY + DEVICE END
BE
MXSIO2
RETRY SIO IMMEDIATELY
TM
MPXCSW+4,BSY
BUSY
BO
UNSOP
MVI MSERR,1
INDICATE SIO STATUS,NOT INTERRUPT
B
MSIOERR
*
*
NON-UNIT CHECK INTERRUPT IN PROCR STATE NOT FROM LIRS STATE
UNPRO1 EQU *
BAM4A
EX
0,ANALSEN
RESTORE STATE FROM SAVSTAT
B
MXSION
*
*
TRIED THREE TIMES IN WRITE STATE
UNWFAIL MVI PTCNT,0
CLEAR ERROR COUNT
L
1,PUCCB
CLI 0(1),DISABLE
BE
UNRWC
INFINITE RETRY COUNT ON DISABLE
CLI PTRESP,CRN
1050 WITH RCV ALARM, MAYBE
BE
UNRWC
NEGATIVE RESPONSE TO ADDRESSING
CLI 0(1),X'17'
2223
BE
UNRWC
2223
B
UNWZ
IGNORE ERRORS
*
*
SETIDL2 TM
IOB2,LVIDLEM
LEAVE IDLE FLAG
BO
MPXEXIT
LEAVE 2703 COMMAND FREE

44380000
44390000
44400000
44410000
44420000
44430000
44440000
44450000
44460000
44470000
44480000
44490000
44500000
44510000
44520000
44530000
44550000
44560000
44570000
44580000
44590000
44600000
44610000
44680000
44720000
44770000
44780000
44790000
44800000
44810000
44820000
44830000
44840000
44850000
44860000
44870000
44880000
44890000
44900000
44910000
44960000
44970000
45010000
45020000
45030000
45050000
45060000
45070000
45080000
45090000
45100000
45110000
45120000
45130000
45140000
45150000
45160000
45170000
45180000
45190000

TM
ACTIVE,INWAITM
BZ
SETIDL4
TM
IOB1,COPYRM
BO
SETIDL4
NOT REALLY AWAITING INPUT
BAL LINK,MXRCCC
ENTER READ STATE
B
MXSIOQ
UNLOCK KEYBOARD
SETIDL4 MVI STATE,IDLE
SETIDL5 CLI PTTYPE,Q103A
ENTER HERE TO PRESERVE QIEBIT
BH
MPXEXIT
NOT A 2702 DEVICE
MODNOTE
*
MODEMS TREATED LIKE DIALUP.
XI
STATE,IDLE-LISTEN STATE IS LISTEN
LA
0,PREPCCW
B
MXSIO
*
*
ABONDON A FOUR WIRE MODEM DUE TO MYSTERY TROUBLE
UNQ4WDIE MVI STATE,IDLE
MARK DEAD
B
MPXEXIT
*
*
SENSE IO DIDN'T WORK, RETRY AT NEXT INTERRUPT
MSENFAIL MVI STATE,PROCR+SENREQ
*
*
DELAY FURTHER RETRY ATTEMPTS ON THIS DEVICE FOR LESS THAN TWOS
UNSD
LA
5,MPXEXIT
SET 2 SEC DELAY AND EXIT TO MPX
SDSUB
LA
3,TWOSEC
STANDARD DELAY
SDSUB1 LR
2,PTR
EVENT WILL BE SGDELZ
OI
STATE,QIEBIT
FOR PURGE AT MSIOERR
B
ENQIE
*
*
ATTENTION SETTING ROUTINE FOR 270X DEVICES
SATSUB TM
IOB1,COPYRM+NSIGNM CHECK FOR SPECIAL CASE
BNZ SAT3
AVOID NORMAL ATTN
TM
ACTIVE,ATTENM
CHECK FOR ATTENTION ALREADY SET.
BZ
SAT6
BRANCH IF NOT.
BAL 5,SHCPUSUB
SET CPU LIMIT TO ONE SECOND
*
OF CPU TIME AND THEN FORCE ATTENTION
SAT6
CLI DESBYTE,0
AVOID DESUSPEND IF TERMINAL IS IN
BE
SAT5
TRAWAIT AND SENDING TO LOG
MVI DESBYTE,X'FF'
MARK AS NO MESSAGES
NI
ACTIVE,LOCKM
PTSET ACTIVE
OI
ACTIVE,ATTENM
MVI MISCB,0
PTSET MISCB
SAT5
EQU *
MVI RESCH,1
FORCE ENTRANCE TO GENERAL EXIT
*
IF TERMINAL WAS TRYING TO SEND A MESSAGE (TRAWAIT SET),
*
PTIBUF POINTS AN UNRELEASED BUFFER STRING. NEXT TYI WILL
*
RELEASE.
*
IF PTRBUF POINTS TO AN OUTPUT LINE, RECHAIN PTRBUF BUFFERS TO
*
TOP OF PTFBUF CHAIN FOR RELEASE OR RETRY.
SAT8
CLI PTRBUF+1,EMPTYM
BE
SAT7
EASY TO PREFIX IOTA ZERO
L
BA,PTRBUF
EVENTUAL FIRST BUFFER
USING PERBUF,BA
LR
0,BA
B
*+8
L
BA,PBTIC
SEARCH FOR END OF LIST
TM
PBFLAG,LISTZ
BZ
*-8

45200000
45210000
45220000
45230000
45240000
45250000
45260000
45270000
45280000
45290000
45300000
45310000
45320000
45330000
45340000
45350000
45360000
45370000
45380000
45390000
45400000
45410000
45420000
45430000
45440000
45450000
45460000
45470000
45480000
45490000
45500000
45510000
45520000
45530000
45540000
45550000
45560000
45570000
45580000
45600000
45640000
45650000
45660000
45670000
45680000
45700000
45720000
45730000
45740000
45750000
45760000
45770000
45780000
45790000
45800000
45810000
45820000
45830000
45840000
45850000

SAT7

SAT3
*
*
*
SATPSUB

*
*
SETDROPD

*
*
*
SETLIRSB

SETLIRSC
*
*
*
*
*
*
MPXPC

MVC
CLI
BE
NI
DROP
ST
MVI
TM
BCR
LA
B
TM
BO
B
THIS

PBTIC,PTFBUF
45860000
PTFBUF+1,EMPTYM
45870000
*+8
PRESERVE LISTZ BIT
45880000
PBFLAG,255-LISTZ
45890000
BA
45900000
0,PTFBUF
SET TO OLD PTRBUF
45910000
PTRBUF+1,EMPTYM
45920000
IOB2,RECMM
SETIDLE WILL RETRY
45930000
1,LINK BOR
THE FORMER PTRBUF LINE
45940000
BA,PTFBUF
RELEASE OUTPUT BUFFERS
45950000
FREEBQ
45960000
MISCB,NOWSM
ATTN BEFORE SIGN-ON TEST
45970000
UNKILL
FOR THE NOVICE USER
45980000
SAT8
COPY MODE, CLEANUP TYPEWRITER BUFFER 45990000
ASSUMES COPY WILL END EVENTUALLY
46000000
46010000
PURGE SVDEL TIMER EVENT.
46020000
TM
MISCB,CLOKWAIT
SEE IF SVDEL EVENT PENDING.
46030000
BCR 8,LINK
NRAMCH OUT IF NOT.
46040000
L
1,KIETCLOK
HI ORDER BYTE FOR PURGE
46050000
OR
1,PTR
IEBASE SETTING
46060000
NI
MISCB,255-CLOKWAIT TURN OFF CLOCK WAIT
46070000
BNZ PRGIE
PURGE EVENT
46080000
NI
ACTIVE,255-MISCM
NO BITS ON IN MISCB, RESET MISCM
46090000
B
PRGIE
PURGE EVENT.
46100000
46110000
270X LINE HAS DROPPED. LEAVE COMMAND FREE UNTIL DISCONNECT TI 46120000
MVI STATE,IDLE
MARK IDLE
46130000
L
10,=A(BOUNSUB)
SET FORCM TO INHIBIT SVTYI
46140000
BALR 8,10
46150000
TM
IOB2,BOUNCM
ZERO IF NOWS AND NSIGNM
46160000
BZ
UNKILL
YES, DROP LINE NOW
46170000
OI
IOB2,LVIDLEM
FLAG FOR SVTYO
46180000
MVI RESCH,1
CAUSE A RESCHEDULE
C023 46190000
B
MPXEXIT
46200000
46210000
LIRS STATE IS USED TO AWAIT DATA CARRIER DETECT DURING TALK- 46220000
DATA SEQUENCE
46230000
MVI STATE,LIRS
46240000
MVI PTCNT,0
WILL USE TO MEASURE TEN SECONDS
46250000
LA
0,PREPCCW
PREPARE FOR 1050
46260000
CLI PTTYPE,Q1050
46270000
BE
*+8
USE PREPARE COMMAND TO DETECT TALKZ 46280000
LA
0,LIRS2741
2741 POWERON RESET RECOVERY
46290000
ST
0,PUCCB
46300000
BAL 5,SDSUB
ENQ TWOSEC MPX EVENT
46310000
B
MXSION
46320000
SEQUENCE FOR 2741 IS..
46330000
CCW INHIBIT,CREP,CC+SLI+SKIP,INFINITY
46340000
CCW WRITE,KCRD,SLI,1
46350000
46360000
46370000
LOG AND IGNORE MPX CHANNEL PROGRAM CHECKS (IN CHANNEL PROG)
46390000
MVC SAVCSW,MPXCSW
SAVE BAD CSW
46400000
UNPK MPXCTA(3),PTUNAD(2)
46410000
TR
MPXCTA(2),HEXTAB
46420000
MVI MPXCTA+2,ZCR
RESTORE CARRIAGE RETURN
46430000
LA
3,MPXPCT
POINT TO TO COUNT
46440000
BAL LINK,NUINS
EDIT AND STACK
46450000
B
MPXEXIT
DON'T TOUCH BAD DEVICE
46460000

*
MPXCS

TM
MPXCSW+5,255-IL-PCICSW SORT OUT PCI AND OTHERS
BNZ MPXPC
NASTY BITS ARE ON
TM
MPXCSW+4,CE
CHANNEL END TEST
BO
MPXA4
IGNORE PCI
OI
STATE,DVBUSY
CLI STATE,READS+DVBUSY PCI OUTSIDE READ STATE
BNE MPXEXIT
IGNORE FOR NON READ STATE
*
PCI ON MULTIPLEXOR READ
*
ALLOCATE ONE MORE BUFFER AND TRANSLATE ONE BUFFER
MREADPCI MVI MPXCSW,TIC
SEE IF RACE IS ALREADY LOST BY
L
2,MPXCSW
CHECKING FOR DISCARD BEING
SH
2,=H'8'
CURRENT BUFFER
C
2,RNBCON+4
BE
MXRPCI1
THE RACE IS LOST
BAL LINK,GETBUF
GET ANOTHER INPUT BUFFER
B
MRPCI3
NO BUFFER AVAILABLE
BAL LINK,RNEWB3
INITIALIZE NEW BUFFER BEFORE TIC
BAL LINK,RNEWBUF
LINK TO CHAIN
MRPCI2 EQU *
C
2,PTCCW3
BE
MPXEXIT
NOTHING TO TRANSLATE YET
CLI PTTYPE,QAMBIG
BE
MPXEXIT
NO TRANSLATE TABLE
BAL LINK,RTRBUF
TRANSLATE ONE BUFFER
B
MPXEXIT
MRPCI3 L
1,MSPCI2
COUNT THE NUMBER OF NO BUFFER
LA
1,1(1)
AVAILABLE AT PCI CONDITIONS
ST
1,MSPCI2
FOR DEBUGGING AND EVALUATION USE
B
MRPCI2
TRANSLATE THIS ONE
MXRPCI1 LA
BA,PTIBUF
DISCARD INPUT BUFFERS
BAL LINK,FREEBQ
B
MPXEXIT
AWAIT FINAL INTERRUPT
*
*
RTRBUF IS USED TO TRANSLATE A FILLED BUFFER TO ZSYMBOLS.
*
EARLY 2741 LINE FEED DETECTION IS DONE TO AVOID RACE
*
CONDITION BETWEEN UNRZ27 AND INLINE. RTRBUF ADVANCES PTFBUF
*
BEFORE TRANSLATING AND EXITS WITH R4=PTFBUF
USING PERBUF,4
RTRBUF L
4,PTFBUF
L
4,PBTIC
POINT TO UNTRANSLATED BUFFER
ST
4,PTFBUF
L
BA,TYITAD
TR
PBSTAR,0(BA)
TRANSLATE INPUT
MVI PBFLAG,FILLBIT
THIS IS FOR INLINE
MVI PBLAST,ZBFZ
THIS IS FOR INLINE
CLI PTTYPE,Q2741
BCR 2,LINK BHR
NOT 2741 OR TS41
CLI PBLAST-1,ZEOB
THIS IS EARLY 2741 LF DETECTOR
BCR 7,LINK BNER
NOT EOB
*
CHANNEL END WILL ARRIVE SHORTLY, BUT INLINE MAY BE CHURNING
CLI PBLAST-2,ZCR
BCR 8,LINK BER
FOUND CARRIAGE RETURN
MVI PBLAST-1,ZLF
TELL INLINE AND UNRZ27
BR
LINK
DROP 4
*
SVINT SA
PRINT NOGEN
SVCTAB DCY SVILG
0 RESERVED
BAM22

46510000
46520000
46530000
46540000
46550000
46560000
46570000
46580000
46590000
46600000
46610000
46620000
46630000
46640000
46650000
46660000
46670000
46680000
46690000
46700000
46710000
46720000
46730000
46740000
46750000
46760000
46780000
46790000
46800000
46850000
46860000
46870000
46880000
46890000
46900000
46910000
46920000
46930000
46940000
46950000
46960000
46970000
46980000
47040000
47050000
47060000
47070000
47080000
47090000
47100000
47110000
47120000
47130000
47140000
47150000
47160000
47170000
47180000
47190000
47200000

DCY SVTYO
1 TYO
DCY SVTYI
2 TYI (INPUT TO INTERPRETER)
DCY SVDSZ
3 END OF DIRECTORY SEARCH
DCY SVINIT
4 NORMALLY QUANTUM END, INIT IS TEMP
DCY SVLEMP
5 LOAD EMPTY WORKSPACE
DCY SVTRAN
6 TRANSMIT A MESSAGE
DCY SVILG
7 RESERVED
BAM22
DCY SVSDREQ
8 REQUEST DIRECTORY OPERATION
DCY SVATOFF
9 TURN OFF ATTENTION BIT
DCY SVRAPE
10 REQUEST ANOMOLOUS PROTECT EXCEPTI
DCY SVOFF
11 SIGN OFF AND DIAL DISCONNECT
DCY SVBROAD
12 BROADCAST MESSAGE
DCY SVSOOK
13 SIGN ON OKAY
DCY SVLIBZ
14 END OF )LIB COMMAND
DCY SVSOM
15 )HI SETS SIGN ON MESSAGE
DCY SVRECM
16 RECEIVE MESSAGES
DCY SVEXITPC
17 RETURN FROM PCSUB
DCY SVDEL
18 DELAY FOR A WHILE
DCY SVBOUNC
19 FORCE SIGN OFF OF SOME TERMINAL
DCY SVRESET
20 ATTEMPT TO RESTART 2702 LINE
DCY SVTIME
21 TIME OF DAY (CP/67 ONLY)
DCY SVOFFH
22 SIGN OFF HOLD
DCY SVBREL
23 INPUT BUFFER RELEASE
DCY SVEOD
24 INITIATE SYSTEM SHUTDOWN
DCY SVLOG
25 MESSAGE TO LOG TRANSMISSION
PRINT GEN
SVMAX
EQU (*-SVCTAB-2)/2
MAXIMUM SVC CODE
SVILG
OI
SVOLDPSW+5,X'C0'
CAUSE PROGRAM CHECK
P035
B
SVEXIT
AFTER EXIT
STYOBAD EQU SVILG
MAJOR TYO TROUBLES
*
USING M,PXR
SVTYI1 LA
8,SETIDL2
TO INITIATE READ
BAL LINK,INITMOP
POKE MPX CODE
B
QUEND
END OF TYI INITIATION
*
*
SET OUTWAIT OR BUFFWAIT
SETBUFWQ CLI PTFBUF+1,EMPTYM
OUTWAIT IS PREFERRED BECAUSE TERMBNE SETOUTW
*
WHEN WAIT IS BROKEN
*
PLACE A TERMINAL IN BUFFER WAIT
SETBUFW ST
PTR,STBFW1
L
1,BUFWLEND
ADDRESS TO MAKE INSERTION
C
1,BFLEMAX
BH
BACK6
BUFFER WAIT QUEUE OVERFLOW
MVC 0(4,1),STBFW1+1
MOVE 3BYTE PTR+EMPTYM TO QUEUE
AH
1,=H'3'
INCREASE END POINTER
ST
1,BUFWLEND
OI
MISCB,BUFFWAIT
OI
ACTIVE,MISCM
B
BACK6
BACKUP OVER SVC AND LOAD
SETOUTW OI
ACTIVE,OUTWAITM
WAIT FOR SOEMP THIS TERM
*
BACK6
LH
0,=H'-6'
RE-ISSUE SVC & PRECEEDING LA
SVWAIT2 TM
SVOLDPSW+4,X'80'
IF 4-BYTE SVCC OR EXECUTED SVC,
BZ
*+8
BACK UP ANOTHER 2 BYTES
AH
0,=H'-2'
A
0,SVOLDPSW+4
ADJUST IAR IN SVC OLD PSW
ST
0,SVOLDPSW+4
B
QUEND
EXIT TO SCHEDULER

47210000
47220000
47240000
47250000
47260000
47270000
47280000
47290000
47390000
47400000
47420000
47430000
47440000
47450000
47460000
47470000
47480000
47490000
47500000
47510000
47520000
47530000
47540000
47550000
47560000
47690000
47700000
47710000
47720000
47730000
47740000
47750000
47760000
47770000
47780000
47790000
47800000
47810000
47820000
47830000
47840000
47850000
47860000
47870000
47880000
47890000
47900000
47910000
47920000
47930000
47940000
47950000
47960000
47970000
47980000
47990000
48000000
48010000
48020000
48030000

*
*
*
*
*
*
*
INITMWR
*
INITMOP

HIOSUB

FREEH

*
INITM1
*
*
*
*
*
*
*
MXRCCC

MXRCC0
MXRCC1

INITMWR IS A SUBROUTINE TO INITIATE A MULTIPLEXOR WRITE

OPERATION. IT IS CALLED BY SVC ROUTINES WHICH HAVE CALLED
TYOINS TO ATTACH OUTPUT BUFFERS TO A TERMINAL. IF
DEVICE STATE IS IDLE (UNLIKELY EXCEPT FOR 1052) MULTIPLEXOR
CODE IS CALLED AS A SUBROUTINE TO DO A SIO. OTHERWISE A HIO
WILL BE ISSUED TO END THE PREPARE COMMAND.
L
8,=A(MXWCCC)
MULTIPLEX ENTRY POINT
ENTER AT INITMOP FOR NON-WRITE FUNCTIONS IN MPX
CLI STATE,IDLE
BE
INITM1
GET INTO MULTIPLEX COE
CLI STATE,DVBUSY+LISTEN HIO ONLY FOR PREPARE
BCR 7,LINK
PRESENT CCW WILL END AUTOMATICALLY
MVI PUCCB,X'FF'
SET HIO FLAG
LH
1,MPXCHANL
CHANNEL ADDRESS
5991
TCH 0(1)
AVOID HIO ON BURST MODE OPERATION
BC
2,*-4
BECAUSE IT IS PROBABLY FOR ANOTHER
IC
1,PTUNAD
MVC CSW,ZERO
ST
LINK,CSW
LINK IS USEFUL ANALYSIS AID
HIO 0(1)
TM
CSW+4,CUB2702
270X REJECTED HIO
BO
FREEH
HIT IT AGAIN.
BAL 3,IODADV
RECORD HIO IN IODBUG TABLE
USING IODBUG,2
MVI IODHIO,X'FC'
HIO FLAG
DROP 2
BR
LINK
2702 IS STILL BUSY
STATE IS IDLE, ENTER MPX CODE
SVTOMX
,
SETUP FOR MPXEXIT
BR
8
ENTER MULTIPLEX CODE

ROUTINE TO CHANGE OUTPUT CCW CHAIN TO INPUT CCW CHAIN

READ CCW CHAINS
ST
LINK,MXTEM12
LA
BA,PTIBUF
BAL LINK,FREEBQ
BAL 1,DEVXCC
BAL LINK,GETBUF
B
RNOBUF
BA POINTS TO BUFFER
ST
BA,PTIBUF
LA
1,PTCCW2
BAL LINK,RNEWB1
USING PERBUF,BA
MVI PBCCW,X'0A'
LA
0,PTCCW2
ST
0,PTFBUF
MVI STATE,READS
L
2,PXMXR-PERDEVX(6)
EX
0,0(2)
EQU *
MVI PTCCW2+4,DC
STC 2,PTCCW2
SRL 2,8
STC 2,PTCCW1+7

SAVE RETURN
RELEASE PREVIOUS INPUT BUFFER
FIRST INPUT BUFFER
FOR INLINE EVENTUALLY
LINK BUFFER INTO COMMAND CHAIN
1052 READ KEYBOARD
FOR RTRBUF FIRST CALL
SPECIAL ROUTINE ADDRESS
LOAD R2 OR BRANCH
COMMON TO ALL 270X DEVICES
BYTE 3 = COMMAND CODE
BYTE 2 = COUNT

48040000
48050000
48060000
48070000
48080000
48090000
48100000
48110000
48120000
48130000
48140000
48150000
48160000
48170000
48180000
48190000
48200000
48210000
48220000
48230000
48240000
48250000
48260000
48270000
48280000
48290000
48300000
48310000
48320000
48330000
48340000
48350000
48360000
48370000
48380000
48390000
48400000
48410000
48420000
48430000
48440000
48450000
48460000
48470000
48480000
48490000
48500000
48510000
48520000
48530000
48540000
48550000
48560000
48610000
48620000
48630000
48640000
48650000
48660000
48670000

MXRCC2
MXRCC4
*
MXR2741
MXR1050
MXRAMBIG

MXR1052
*
RNOBUF
RNOBUF1

*
KSOHK
*
*
SVOFFH

*
SVOFFH1

*
*
*
*
*

SRL
L
SRDL
AR
ST
MVI
LA
ST
BAL
ST
L
BR

2,8
3,INPCON
2,8
2,3
2,PTCCW1
PTCCW2+5,FORCELF
BA,PTCCW1
BA,PUCCB
LINK,CORTIME
0,PTMTIME
LINK,MXTEM12
LINK

48680000
48690000
48700000
48710000
48720000
FOR UNRZ26 2741 LF DETECTION
48730000
INITIAL CAW
48740000
48750000
TIME FOR HISTOGRAMS
48760000
48770000
48780000
48790000
48800000
L
2,KRC2741
48810000
L
2,KRC1050
48820000
B
*+4
48830000
L
2,KRCAMW
ASSUME NON-ENABLE CASE
48840000
CLI PTCCW1,DISABLE
UNLESS PREIOUS COMMAND WAS DISABLE 48850000
BNE MXRCC1
48860000
L
2,KRCAME
WE NEED AN ENABLE
48870000
CLI SHUTDOWN,0
MAYBE WE SHOULD LEAVE LINE DISABLED 48940000
BE
MXRCC1
NO, ENABLE THIS LINE
48950000
OI
IOB2,LVIDLEM
FLAG LINE IDLE FOR OPFNS REFERENCE 48960000
B
MPXEXIT
YES, SYSTEM IS GOING DOWN
48970000
B
MXRCC2
DO NOT OPTIMIZE, THIS IS EXECUTED
49140000
DROP BA
49150000
DELAY READ BECAUSE NO BUFFER AVAILABLE
49260000
MVI PTFBUF+1,EMPTYM
KILL POINTER TO NON-BUFFER
49270000
MVI STATE,LISTEN
49280000
BAL 5,SDSUB
WAIT TWO SECONDS FOR BUFFER
49290000
LA
BA,PREPCCW
LOAD PREPARE WHILE WE WAIT FOR BUFFR 49300000
B
MXRCC2
49310000
49320000
L
1,SVOFLIM
KILL SIGN OFF HOLD KILL
49330000
OR
1,PTR
49340000
B
PRGIE
IESOHK MAY BE ENQ D FOR TERMINAL
49350000
49370000
SIGN OFF WITH HOLD
49380000
USING SVOFFH,10
49390000
TM
IOB2,LOEXP
EXPRESS LINE )OFF HOLD IGNORED
49400000
BO
SVOFF0
TRNSMUTE TO )OFF
49410000
CLI SHUTDOWN,0
AFTER SHUTDOWN, TRANSMUTE ANY
49420000
BNE SVOFF0
)OFF HOLD TO )OFF
49430000
DROP 10
WHICH WAS USED TO REACH SVOFF0
49440000
TRANSMUTED )OFF ENTERS )OFF HOLD HERE
49450000
BAL LINK,OFFSUB
LOSE WORKSPACE ETC.
49460000
CLI PTTYPE,Q103A
49470000
BH
SVTYI1
NO TIMEOUT FOR NON-DIALUP
49480000
TM
IOB2,Q4WMDM
49490000
BO
SVTYI1
NO TIMEOUT FOR MODEMS.
49500000
49510000
SVOFFH IS TIMING DEPENDENT.
49520000
WE ASSUME THAT TERMINAL IS STILL IN WRITES TYPING THE
49530000
SIGN OFF STATISTICS. SETIDLE WITH INWAIT WILL UNLOCK KEYBD
49540000
49550000
LM
2,3,SVOFLIM
49560000
OR
2,PTR
49570000
BAL 5,ENQIE
49580000
B
SVTYI1
INITMOP SUBROUTINE
49590000
MAKES TIMING NON-CRITICAL.
49600000
=A(256*INPOLL)
BYTE 1 = PTCCW1 OP CODE
BYTE 0 = INPOLL DISPLACEMENT

*
*
*
OFFSUB

*
*
*
*
*
*
*
*
*
*

SUBROUTINE TO PURGE TERMINAL FROM SYSTEM AND CONDITION MPXINT

TO LOOK FOR SIGN ON MESSAGE
MVI ACTIVE,INWAITM+NONINM+MISCM
PTSET ACTIVE
MVI IOB1,NSIGNM
NOT SIGNED ON
PTSET IOB1
NI
IOB2,Q4WMDM+LOEXP
PTSET IOB2
LR
4,PTR
CL
PTR,OPTERM
BNE WSLOSEC
THIS IS THE OPERATOR SIGNING OFF
MVI OPNUM,X'FF'
TO REJECT MESSAGES TO OPERATOR
MVC OPTERM+1(3),=AL3(DUMINACT)
QZA0 IS ONLY USER OF THIS VALUE OF OPTERM. ALL OTHERS
ARE STOPPED BY OPNUM=X'FF'.
CLI SHUTDOWN,0
SEE IF SHUTDOWN IS IN PROGRESS.
BE
WSLOSEC
BRANCH IF NOT.
OPERATOR HAS SIGNED OFF WITH SHUTDOWN IN PROGRESS.
- ENQUEUE A TIMER EVENT TO RETURN TO THE HOST, ALLOWING
TIME TO PRINT THE SIGN OFF ACCOUNTING.
CODE COULD BE PLACED HERE TO ATTEMPT TO BOUNCE ANY REMAINING
USERS.
LM
CLI
BNE
LA
ST
BAL
L
LR
B

*
*
*
*
*
TERMDEL

2,3,DOWNLIM
PTTYPE,Q1050
*+8
3,6*300(0,3)
LINK,MXTEM12
5,ENQIE
LINK,MXTEM12
4,PTR
WSLOSEC

INTERVAL EVENT.
1050 REQUIRES EXTRA TIME
WAIT AN ADDITIONAL 6 SECONDS
ENQUEUED.
DISPOSE OF WORKSPACE

SUSPEND AND SET DELAY SUBROUTINE

R5 = RETURN
R3 = TIME INTERVAL
L
2,KIETCLOK
CLOKWAIT CODE FOR EXTIM4
OR
2,PTR
TM
ACTIVE,ATTENM
ATTENTION ALREADY SET
BCR 1,5
BREAKS US OUT IMMEDIATELY
LA
3,0(3)
AVOID TIME WARP. (15.5 HR MAX DEL
OI
MISCB,CLOKWAIT
OI
ACTIVE,MISCM
B
ENQIE

*
*
SUBROUTINE TO TERMINATE COPY OPERATION
*
PTR IS ASSUMED TO BE SINK TERMINAL
COPKILL C
PTR,COPSINK
TEST FOR SINK
BCR 7,LINK
NO, IGNORE
L
PTR,COPSOUR
SOURCE PERTERM ADDRESS
LA
BA,PTFBUF
DISCARD ANY REMAINING BUFFERS
LR
1,LINK
BAL LINK,FREEBQ
LR
LINK,1
LM
0,1,PTABTM
ADD IN SOURCE TIME
MVC PTABTM(8),ZERO
SOURCE

49610000
49620000
49630000
49640000
49650000
49660000
49670000
49680000
49690000
49700000
49710000
49720000
49730000
49740000
49750000
49760000
49770000
49780000
49790000
49800000
49810000
49820000
49830000
49840000
49850000
49860000
49870000
49880000
49890000
49900000
49910000
49920000
49930000
49940000
49950000
49960000
49970000
49980000
49990000
50000000
50010000
50020000
50030000
50040000
50050000
50060000
50070000
50080000
50090000
50100000
50110000
50120000
50130000
50140000
50150000
50160000
50170000
50180000
50190000
50200000

LR
4,PTR
FOR WSLOSE
L
PTR,COPSINK
RESTORE PTR
MVI COPSINK+1,EMPTYM
MARK AS NO COPY
AR
0,1
COMPUTE TIME USED BY SOURCE
A
0,PTABTM
ST
0,PTABTM
INCLUDE SOURCE COMPUTE TIME
NI
IOB1,255-COPYRM
*
DESUSPEND PERTERMS IN SDWAIT TO MAKE FURTHER COPIES FEASIBLE.
LM
0,2,PTBXLE
COPDS1 NI
MISCB-PERTERM(2),255-SDWAIT DESUSPEND.
BNZ COPDS2
ACTIVE.(MISCM). IS OR / MISCB
NI ACTIVE-PERTERM(2),255-MISCM MISCB IS ZERO.
COPDS2 BXLE 2,0,COPDS1
DROP PTR
USING PERTERM,4
WSLOSEC SSM ALLOFF
LOSE WS IF IT EXISTS
TM
MISCB,NOWSM
DRP6 OR CCCZ MAY HAVE DESTROYED
MVI MISCB,NOWSM
KILL WANTON BIT
PTSET MISCB
BCR 7,LINK
SOURCE WORKSPACE ALREADY
MVI CDTERM,0
CHECK TO SEE IF SOURCE WS
C
4,CDTERM
IS INVOLVED IN A DISK OPERATION
BNE WSLOSE
NO, KILL IT NOW
CLI SELBUSY,0
CDTERM IS MEANINGLESS IF CHANNEL IS
BE
WSLOSE
IDLE
MVI CDOP,16+0*(SELWSK-*) BRANCH TO SELWSK FROM SELNOR
BR
LINK
WS WILL BE LOST THEN
*
*
A COPY SOURCE MAY NOT HAVE A WS ASSIGNED IF A LEMP
*
WAS ENQUED.
*
*
*
ELIMINATE WORKSPACE DESIGNATED BY R4
WSLOSE SSM ALLOFF
SELRDZ COULD CAUSE TROUBLE
CLI PTCORE+1,EMPTYM
BE
COPK2
NOT IN CORE
L
1,PTCORE
MVI PCTERM+1-PERCORE(1),EMPTYM
MVI PTCORE+1,EMPTYM
THUS FREEING CORE SLOT
BR
LINK
USING PERDISK,3
SEARCH DISK FOR SOURCE WORKSPACE
COPK2
ST
4,MXTEM12
LM
0,3,PDBXLE
COPK3
CLC PDTERM+1(3),MXTEM12+1
BE
COPK4
FOUND IT
BXLE 3,0,COPK3
UGH ,
WORKSPACE MUST BE ON DISK
COPK4
MVI PDTERM+1,EMPTYM
LOSE WORKSPACE
BR
LINK
DROP 3,4
USING PERTERM,PTR
*
*
*
CONVERT PTR TO TERMINAL NUMBER
CVTERM SR
0,0
LR
1,PTR
S
1,PTBXLE+8
D
0,PTBXLE
R1=TERMINAL NUMBER
BR
2
*

50210000
50220000
50230000
50240000
50250000
50260000
50270000
50280000
50290000
50300000
50310000
50320000
50330000
50340000
50350000
50360000
50370000
50380000
50390000
50400000
50410000
50420000
50430000
50440000
50450000
50460000
50470000
50480000
50490000
50500000
50510000
50520000
50530000
50540000
50550000
50560000
50570000
50580000
50590000
50600000
50610000
50620000
50630000
50640000
50650000
50660000
50670000
50680000
50690000
50700000
50710000
50730000
50740000
50750000
50770000
50780000
50790000
50800000
50810000
50820000

*
RECMSUB CHECKS TO SEE IF MESSAGE CAN BE PLACED IN BUFFER.
*
RETURNS TO CALLER IF MESSAGE IS NOT PLACED IN BUFFER.
RECMSUB L
10,=A(REMRECM)
LOAD BASE REG FOR WILD BLUE YONDER
TM
IOB1,BROADM+RINGM CHECK FOR SPURIOUS CALL
BCR 7,10 BNZR
REMRECM
BR
LINK
*
VALTERM L
1,REGSV+4
COMPUTE PERTERM BASE REGISTER
CL
1,TERMMAX
BCR 11,LINK BNLR
TOO BIG
STC 1,MSGTEM
DESBYTE SETTING
MH
1,PTBXLE+2
A
1,PTBXLE+8
POINTER TO ADDRESSEE
CLI 0(1),0
DUMMY PERTERM
P035
BCR 8,LINK BER
YES
P035
B
4(LINK)
*
*
*
*
RNEWBUF ATTACHS ANOTHER BUFFER TO READ CCW CHAIN.
*
NEW BUFFER ADDRESS IS ALREADY IN BA
USING PERBUF,1
POINT TO FORMER LAST BUFFER
RNEWBUF L
1,PTLBUF
RNEWB1 MVI PBFLAG,0
O
BA,TICCON
MAKE SURE BUFFER AD IS TIC
ST
BA,PBTIC
CHAIN TO PREVIOUS OLD BUFFER
ST
BA,PTLBUF
MARK AS NEW LAST BUFFER
DROP 1
*
RNEWB2 INITIALIZES A NEW BUFFER
USING PERBUF,BA
RNEWB2 LA
0,1
UPDATE BUFFER COUNT
AH
0,PTBFA
STH 0,PTBFA
RNEWB3 LA
0,PBSTAR
SETUP CCW ADDR AND COUNT
ST
0,PBCCW
MVC PBCCW+4(8),RNBCON
DROP BA
BR
LINK
*
*
OUTPUT BUFFER RATIONING
*
FSHARE HAS BEEN SET BY POSOM AT LAST SIGN ON-OFF
*
FSHARE = TOTBC * OVERBOOK DIV PLUS / SIGNEDON
*
TOTBC = COUNT OF BUFFERS CREATED BY SUPINI
*
MAXRAT IS (FREEBC-+/SIGNEDON) MIN (20*PTBFA=0)+FSHARE-PTBFA
*
LINK = RETURN
TYORAT L
0,FSHARE
SH
0,PTBFA
BNP SETBUFWQ
RATION ALREADY EXCEEDED
C
0,FSHARE
FIRST OUTPUT LINE GETS EXTRA RATION
BNE *+8
TO ALLOW BOOTLEG BACKSPACE ETC.
AH
0,POSO2
ADD MAXIMUM VALUE OF FSHARE
L
2,FREEBC
S
2,POSO
THIS IS TO PROTECT READ STATE PORTS
BNP SETBUFWQ
OUTPUT CAN WAIT, PCI CANNOT
CR
0,2
BH
*+6
LR
2,0
ST
2,MAXRAT
MIN
2222
BR
LINK
*

50830000
50840000
50850000
50860000
50870000
50880000
50900000
50910000
50920000
50930000
50940000
50950000
50960000
50970000
50980000
50990000
51000000
51010000
51020000
51030000
51040000
51050000
51060000
51070000
51080000
51090000
51100000
51110000
51120000
51130000
51140000
51150000
51160000
51170000
51180000
51190000
51200000
51210000
51220000
51230000
51240000
51250000
51260000
51270000
51280000
51290000
51300000
51310000
51320000
51330000
51340000
51350000
51360000
51370000
51380000
51390000
51400000
51410000
51420000
51430000

*
*
*
NUINS

NOTE FROM UNDERGROUND EDIT AND INSERTION

R3 POINTS TO HALFWORD COUNT AND ZSYMBOL TEXT
NOTE THAT PTR IS DESTROYED
ST
LINK,MXTEM12+8
RETURN
CLI OPNUM,X'FF'
IGNORE NOTE WHEN OPERATOR
BCR 8,LINK BER
IS NOT SIGNED ON
MVI MAXRAT,INFIN
NOTES FROM UNDERG IS GREEDY
L
PTR,OPTERM
USE OPERATOR'S TERMINAL TYPE
BAL LINK,TYOSUB
B
NUINSZ
NO BUFFERS, LOSE THIS NOTE
OI
IOB1,BROADM
SIGNAL OPERATOR
LA
PTR,NUTERM
FAKE PERTERM, NOTES FROM UNDERGROUND
BAL LINK,TYOINS
CHAIN MULTIPLE NOTES TOGETHER
L
LINK,MXTEM12+8
BR
LINK

51450000
51460000
51470000
51480000
51490000
51500000
51510000
51520000
51530000
51540000
51550000
51560000
51570000
NUINSZ
51580000
51590000
*
51610000
*
TYOINS APPENDS A CHAIN OF BUFFERS TO OUTPUT BUFFER CHAIN OF A 51620000
*
PARTICULAR TERMINAL. FOR A TERMINAL, CHAIN STARTS WITH PTFBUF 51630000
*
PTLBUF POINTS TO LAST BUFFER IN CHAIN.
51640000
*
FBUF IS HEAD OF CHAIN TO APPEND
51650000
*
BA POINTS TO TAIL
51660000
*
LINK = RETURN
51670000
USING PERBUF,BA
51680000
TYOINS MVI FBUF,TIC
51690000
MVI PBFLAG,LINEZ+LISTZ
51700000
LH
0,BUFTS
UPDATE BUFFER COUNT
51710000
AH
0,PTBFA
51720000
STH 0,PTBFA
51730000
LR
0,BA
INTERCHANGE BA AND PTLBUF
51740000
L
BA,PTLBUF
POINT TO END OF EXISTING CHAIN
51750000
ST
0,PTLBUF
51760000
CLI PTFBUF+1,EMPTYM
51770000
BE
TYOINSE
EXISTING CHAIN IS EMPTY
51780000
MVI PBFLAG,LINEZ
OLD LAST IS END OF LINE, NOT LIST
51790000
MVC PBTIC,FBUF
51800000
BR
LINK
51810000
TYOINSE MVC PTFBUF,FBUF
OLD CHAIN WAS EMPTY
51820000
BR
LINK
51830000
*
51840000
*
GETBUF OBTAINS ONE TYPEWRITER BUFFER
51850000
*
EXIT IS 0(LINK) IF NO BUFFER
51860000
*
EXIT IS 4(LINK) WITH BUFFER ADDRESS IN R7
51870000
GETBUF CLI FREEBA+1,EMPTYM
51880000
BCR 8,LINK
NO BUFFERS LEFT
51890000
L
BA,FREEBC
51900000
BCTR BA,0
DECREMENT FREE BUFFER COUNT
51910000
ST
BA,FREEBC
51920000
L
BA,FREEBA
51930000
TM
PBFLAG,FREEBIT
51940000
UGH Z
NASTY, NOT A FREE BUFFER
51950000
MVI PBFLAG,0
51960000
MVC FREEBA+1(3),PBTIC+1 UPDATE FREE BUFF LIST
51970000
B
4(LINK)
51980000
DROP BA
51990000
*
52000000
*
FREEBQ IS CONDITIONAL BUFFER RELEASE.
52010000
*
BA POINTS TO HEAD-OF-CHAIN WORD IN SOTRAGE
52020000
FREEBQ CLI 1(BA),EMPTYM
52030000
BCR 8,LINK
NOTHING TO RELEASE
52040000
L
0,0(BA)
POINT TO FIRST BUFFER
52050000

MVI 1(BA),EMPTYM
MARK EMPTY
LR
BA,0
POINT TO FIRST BUFFER
*
FREEBUF RETURNS A BUFFER CHAIN TO THE AVAILABLE (FREE) CHAIN
*
BA IS HEAD OF CHAIN TO BE RELEASED
*
LINK = RETURN
USING PERBUF,BA
FREEBUF SR
0,0
TO COUNT RELEASED BUFFERS
MVC FBTEM,FREEBA
SAVE OLD FREE HEAD
ST
BA,FREEBA
NEW HEAD OF FREE LIST
B
*+8
FREEB1 L
BA,PBTIC
SEARCH FOR END OF LIST
TM
PBFLAG,FREEBIT
VALIDITY CHECK OF FREE SPACE LIST
UGH O
DOUBLE FREEING OF BUFF A NO NO
OI
PBFLAG,FREEBIT
MARK AS FREE
AH
0,KHONE
UPDATE COUNT
TM
PBFLAG,LISTZ
BZ
FREEB1
MVC PBTIC,FBTEM
APPEND OLD FREELIST
DROP BA
*
R0 IS COUNT OF BUFFERS RELEASED
LH
BA,PTBFA
UPDATE COUNT FOR TERMINAL
SR
BA,0
STH BA,PTBFA
A
0,FREEBC
UPDATE GLOBAL COUNT
ST
0,FREEBC
UPDATE FREE BUFFER COUNT
*
REMOVE ONE TERMINAL FROM BUFFWAIT QUEUE
CLI BUFWLTOP,EMPTYM
BCR 8,LINK
QUEUE IS EMPTY
L
BA,BUFWLTOP-1
POINT TO A PERTERM
MVC BUFWLTOP(BFWLMX+4-BUFWLTOP),BUFWLTOP+3 SHRINK QUEUE
L
0,BUFWLEND
DECREASE END ADDRESS
SH
0,=H'3'
ST
0,BUFWLEND
NI
MISCB-PERTERM(BA),255-BUFFWAIT
BCR 7,LINK
NI
ACTIVE-PERTERM(BA),255-MISCM
OI
RESCH,1
DISPATCH APL.
3064
BR
LINK
*
*
*
*
*
*
GLITCH TO SUSPEND TERM ZERO FOR ATTENTION OR MESSAGE
*
*
TURN OFF ATTENTION BIT (STORE PROTECT INHIBITS INTRP)
SVATOFF NI
ACTIVE,255-ATTENM
MVC PTCPULIM(2),PTCPULM2 RESET POSSIBLE SHORT TIME LIMIT
*
PRECEDING A FORCED ATTENTION
*
THIS IS REQUIRED IN CASE SOME USER GETS BOUNCY ON ATTN KEY.
B
SVEXIT
*
SVRAPEIT
*
SVEXIT
*
SVRPCON DC
AL2(SVRAPE2-APLLOW)
SVRPTAB DC
FL1'2,4,4,6'
INDEXED BY OPCODE BITS 0,1
*
*
PARAMTER BLOCKS FOR HISTCOMP USE AS PERHIST DSECT

52060000
52070000
52080000
52090000
52100000
52110000
52120000
52130000
52140000
52150000
52160000
52170000
52180000
52190000
52200000
52210000
52220000
52230000
52240000
52250000
52260000
52270000
52280000
52290000
52300000
52310000
52320000
52330000
52340000
52350000
52360000
52370000
52380000
52390000
52400000
52410000
52420000
52430000
52440000
52450000
52460000
53620000
53630000
53640000
53650000
53660000
53670000
53680000
53690000
53700000
53710000
53720000
53730000
53740000
53750000
53760000
53780000
53800000
53810000
53820000

*
KEY
*
SD
FBC
BFA

INPUT KEYING SPEED

PHGEN 36300,122,3
SPECIAL DISK OPERATIONS POPULARITY
PHGEN 26,14,0
SCALE IS 2 (SEE XX SYMBOLS)
PHGEN 100,51,11
SEE STYONO
PHGEN 20,21,12
SEE STYONO
PRINT GEN

53830000
53840000
53850000
53860000
53870000
53880000
53890000
*
53900000
*
CCW CHAIN TO DETECT END OF TALK-DATA SEQUENCE ON 2741
53910000
*
AND WAIT FOR KEYBOARD TO LOCK AFTER POWERON RESET IN 2741
53920000
LIRS2741 CCW REINHIB,SKALIRS,CC+SLI+SKIP,L'SKALIRS
53930000
CCW WR,KCRD,SLI,1
SEND A CRD TO GET 2741 TO RCV TEXT 53940000
PREPCCW CCW X'06',SKAPREP,SLI+SKIP,1
53950000
KHONE
EQU PREPCCW+6
CONSTANT H'1'
53960000
MSENCCW CCW SENSE,0,SLI,1
53970000
WR
EQU 1
270X WRITE
54020000
RETIME EQU 2
270X READ TIMEOUT
54030000
REINHIB EQU X'0A'
270X READ INHIBIT
54040000
*
CONSTANTS FOR USE BY MXRCC1 270X INPUT CHANNEL
54050000
*
PROGRAM ASSEMBLER. FOUR BYTES ARE..
54060000
*
0
ADDR(PTCCW1)-A(INPOLL)
54070000
*
1
COMMAND BYTE OF PTCCW1
54080000
*
2
COUNT OF PTCCW1
54090000
*
3
COMMAND BYTE OF PTCCW2
54100000
DC
0F'0'
54110000
KRC2741A DC
AL1(INPCRC-INPOLL,WR,1,REINHIB) TO RESTORE KRC2741
54120000
KRC2741 DC
AL1(INPCRC-INPOLL,WR,1,REINHIB)
54130000
KRC1050 DC
AL1(0,WR,5,REINHIB)
54140000
KRCAMW DC
AL1(INPCRC+1-INPOLL,WR,2,RETIME)
54150000
KRCAME DC
AL1(0,ENABLE,1,RETIME)
54160000
DS
0F
54170000
RNBCON DC
AL1(DC+PCI,LISTZ,0,TBL-1-(PBSTAR-PERBUF),TIC)
54180000
DC
AL3(DISCARD)
ALSO USED AS CONSTANT TIC DISCARD 54190000
TICCON DC
AL1(TIC,0,0,0)
54200000
CREP
EQU 250*F*F
MPXPC ON SKIP FAIL
54210000
* END MULTI-FUNCTION STORAGE * * * * * * * *
54220000
*
1050, 2741 LINE CONTROL CHARACTERS
54230000
CRB
EQU X'3D'
END OF BLOCK, EOB, CIRCLE B
54240000
CRN
EQU X'40'
1050 NEGATIVE RESPONSE
54250000
CRD
EQU X'16'
ALSO KNOWN AS..
54260000
*
CIRCLE UPPER CASE D
54270000
*
CIRCLE LOWER CASE D
54280000
*
POSITIVE ANSWER
54290000
*
POSITIVE POLL RESPONSE
54300000
*
READER READY
54310000
*
INQUIRY
54320000
*
EOA
54330000
*
END OF ADDRESS
54340000
*
POUND SIGN CHARACTER
54350000
*
8 21
54360000
*
BID CHARACTER
6/4/68 - 2740 MANUAL.
54370000
CRC
EQU X'1F'
END OF TRANSMISSION,EOT,CIRCLE C
54380000
CRY
EQU X'76'
POSITIVE ANSWER, POSITIVE RESPONSE 54390000
UCRET
EQU X'DB'
UPPERCASE CARRIAGE RETURN
54400000
LF
EQU X'BB'
BCD LINE FEED
54410000
EMPTYM EQU X'80'
USED IN HIGH ORDER BYTE OF VARIOUS ADDRESS
54420000
*
FIELDS TO INDICATE UNDEFINED ALSO MARKS END OF TYPEWRITER BUFF 54430000
EMPT3
EQU X'800000'
EMPTY MARK FOR AL3 SETTING
54440000
INFIN
EQU X'7F'
POSITIVE INFINITY
54450000
DOWNLIM IEBRN APLCNCL,12*300
TWELVE SECONDS
54470000

MSPCI1
MSPCI2
BROADPT
SOMPT
CCBTR
*
*
*
NUBFA
NUFBUF
NULBUF
NUTERM
MSGTEM
MPXPCT
MPXCTA
HEXTAB
SVOFLIM
KIETCLOK
ADIAG1
INPCON
MAXRAT
BUFTS
FBUF
FBTEM
*
*
*
*
BUFWLEND
BFLEMAX
STBFW1
BUFWLTOP
BFWLMX
*
ERINC
LIRSINC
*
*
*
ICR
BCR
DEST
SR
BA
REMTYO

DC
F'0'
UNRZ19 MISSED PCI COUNT
DC
F'0'
NO BUFFER AVAILABLE AT MREADPCI
DC
A(BROADBF)
POINTS TO BROADCAST MESSAGE BUFFER
DC
A(SOMBF)
POINTS TO SIGN-ON MESSAGE BUFFER
DC
AL1(13,14,15,4,5,0,1) TO RECONSTRUCT SAVCSW FROM CCB
FOLLOWING WORDS ARE USED BY TYOINS CALLS IN SELRTRY TO ENQ
NOTES FROM THE UNDERGROUND IN PSUEDO PERTERM FOR RECEPTION
BY OPTERM AT SVRECM3.
CNOP 2,4
ALIGN NUBFA
DC
H'0'
NOTES FROM UNDERGROUND BUFFER COUNT
DC
A(EMPT3)
POINTS TO FIRST NOTE FROM UNDERGROUN
DC
A(EMPT3)
POINTS TO LAST BUFFER OF NFU
EQU NUBFA-(PTBFA-PERTERM) DUMMY PERTERM BASE ADDRESS
DS
3F
SV OLD PSW, ADDRESSEE TERM NUMBER
DC
H'9'
DC
AL1(ZM,ZP,ZX,ZP,ZC,ZBLANK)
DC
2X'00'
UNIT ADDRESS IN HEX
DC
AL1(ZCR,ZEOB)
EQU *-X'F0'
DC
AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,ZA,ZB,ZC,ZD,ZE,ZF)
DC
A(IETSOHK*F*F*F,OFFHLIM)
DC
A(IETCLOK*F*F*F)
DC
A(TIC*F*F*F+DIAG1)
DC
AL3(INPOLL)
FOR MXRCCC
DC
F'10'
TEMP GLICH
2222
DC
H'0'
BUFFER INCREMENT THIS SVC
DC
A(EMPT3)
TYOSUB, TYOINS COMMUNICATION
DC
A(EMPT3)
FREEBUF TEMP
BUFWLTOP IS A FIFO QUEUE OF TERMINALS IN BUFFWAIT. EACH
ENTRY IS THREE BYTES LONG. END OF LIST IS AN ENTRY WITH FIRST
BYTE=EMPTYM. FULL WORD ATBUFWLTOP-1 IS OLDEST ENTRY.
BUFWLEND POINTS TO A BYTE CONTAINING EMPTYM.
DC
A(BUFWLTOP)
POINTER TO END OF QUEUE
DC
A(BFWLMX)
MAX VALUE OF BUFLEND
DC
A(0)
FOR INSERTION OF PERTERM ADDRESS
DC
AL1(EMPTYM)
FOR INSERTION OF END MARK
DC
259AL1(EMPTYM)
BUFF WAIT QUEUE
EQU *-7

54480000
54490000
54500000
54510000
54520000
54530000
54540000
54550000
54560000
54570000
54580000
54590000
54600000
54610000
54620000
54630000
54640000
54650000
54660000
54670000
54760000
54770000
54780000
54790000
54800000
54810000
54820000
54830000
54840000
54850000
54860000
54870000
54880000
54890000
54900000
54910000
54930000
54980000
54990000
DC
AL1(1,2,0)
MPX ERROR COUNTER
55000000
DC
AL1(1,2,3,4,5,6,7,8,9,0) LIRS RETRY COUNTER
55010000
55020000
55030000
55040000
USING REMTYO,8
55050000
EQU 0 TRUE COUNT OF CHARACTERS REMAINING IN INTERNAL BUFF 55060000
EQU 4 SS COUNT OF CHARACTERS REMAINING IN EXTERNAL BUFFER 55070000
EQU 3
DESTINATION ADDRESS IN EXTERNAL BUFF 55080000
EQU 5
SOURCE ADDRESS IN INTERNAL BUFFER
55090000
EQU 7
55100000
LH
6,0(3)
SS COUNT OF INTERNAL CHARACTERS
55110000
LTR 5,6
55120000
BNH STYOBAD
NEGATIVE OR ZERO LENGTH, EVIL
55130000
ST
LINK,MXTEM12+4
RETURN ADDR
55140000
AH
6,KHONE
TRUE COUNT OF INTERNAL CHARACTERS
55160000
SR
4,4
55180000
SH
5,KMXWIS
FUDGE FACTOR
55190000
BP
*+6
AVOID NEGATIVE IDLE COUNT
55200000
SR
5,5
MAKE IT ZERO
55210000
D
4,KRZID
2741 IDLE COMPUTATION
55220000

ST
5,MXTEM12
SR
4,4
ESTIMATE BUFFER REQUIREMENTS, THIS
AR
5,6
TYOSUB CALL
A
5,=A(L'PBSTAR)
TAKE CEIL
D
4,=A(L'PBSTAR)
C
5,MAXRAT
IF TOO HIGH, SKIP TRT MVC TR AND2222
BH
TYS10
AND OTHER FUTILE INSTRUCTIONS
LA
SR,2(3)
TM
IOB1,COPYWM
COPY NOT INCLUDED IN HISTOGRAM
BO
TYS11
LR
HISTVAL,6
OUTPUT LINE LENGTH IN ZSYMBOLS
LA
PHR,PERHOUTL
BAL LINK,HISTCOMP
HISTOGRAM * * * * * * * * *
TYS11
LR
ICR,6
BAL 1,DEVXCC
COMPUTE PERDEVX ADDRESS
USING PERDEVX,6
TO GET TYOTAD
L
6,TYOTAD
USING TYOTAA,6
DEVICE DEPENDENT TRANSLATE TABLE
SR
1,1
MARK AS TRT NEEDED
TM
IOB1,COPYWM
BZ
TYS14
ORDINARY TYO
MVI TYOTR,X'D5'
CHANGE TRANSLATE TO CLC
LA
1,2000(SR)
MARK AS NO OVERSTRIKES
*
COPY TYO WILL ACT LIKE ORDINARY TYO WITH EXCEPTION OF SKIPPING
*
ALL TRANSLATE OPERATIONS
*
GET FIRST BUFFER
USING PERBUF,BA
TYS14
BAL LINK,GETBUF
B
TYS10
NO BUFFERS (SHOULDN'T HAPPEN)
MVC BUFTS,KHONE
ONE BUFFER OBTAINED
ST
BA,FBUF
FIRST BUFFER ADDRESS
MVI BINC,PBSTAR-PERBUF ASSUME NO TERM CONTROL CHARS AT FRON
CLI PTTYPE,Q1050
BL
TYS16
2741 NEEDS IDLES.
3587
BH
TYS0
IDLE AND CRD NOT NEEDED
MVI RESID,CRD
END OF ADDRESS FOR 1050
MVI BINC,PBSTAR+1-PERBUF PROTECT INSERTED CRD
TYS0
MVI MXTEM12+3,0
NO IDLE CHARACTERS
B
TYS1
DON'T NEED IDLES.
3587
* IDLES ARE ADDED TO FRONT OF TEXT TO PREVENT SUPEREDIT OVERPRINT. 3587
TYS16
L
4,CURRENTM
ADDRESS OF WORKSPACE.
3587
LA
4,0(4)
3587
CL
4,=A(SCHSAVE)
REALLY A WORKSPACE?
3587
BE
TYS1
NO.
3587
LH
3,CARRPOS-M(4)
LOCATION OF CARRIER
3587
SR
2,2
3587
STH 2,CARRPOS-M(4)
CLEAR CARRIER POINTER.
3587
LTR 3,3
IF CARRIER IS AT LEFT MARGIN, 3587
BZ
TYS1
NO IDLES ARE NEEDED.
3587
LA
3,20(3)
ADD A MIN OF 2 IDLES.
3587
D
2,KRZID
COMPUTE IDLE COUNT.
3587
LA
2,15
MAX IDLE COUNT.
3587
CR
2,3
IF IDLE COUNT
3587
BNL TYS17
EXCEEDS MAX OF 15,
3587
LR
3,2
SET TO 15.
3587
TYS17
STC 3,IDLMVC+1
SETUP MVC FOR IDLE COUNT.$$$$$ 3587
LR
4,3
3587
AH
3,BINC-1
UPDATE BINC TO INCLUDE
3587
STC 3,BINC
ADDITION OF IDLES.
3587
LA
DEST,PBSTAR
DATA AREA FOR WRITE.
3587

55230000
55240000
55250000
55260000
55270000
55280000
55290000
55300000
55320000
55330000
55340000
55350000
55360000
55380000
55390000
55400000
55410000
55420000
55430000
55440000
55450000
55460000
55470000
55480000
55490000
55500000
55510000
55520000
55530000
55540000
55550000
55560000
55570000
55590000
55600000
55640000
55650000
55670000
55710000
55720000
55730000
55740000
55750000
55760000
55770000
55780000
55790000
55800000
55810000
55820000
55830000
55840000
55850000
55860000
55870000
55880000
55890000
55900000
55910000
55920000

* $$$ IDLMVC MODIFIED BY TYS17

$$$$$ 3587
IDLMVC MVC 0(1,DEST),DCZEOB
MOVE IDLES TO BUFFER.
3587
EX
4,TYOTR
TRANSLATE IDLES
3587
MVC RESID(2),0(DEST)
MAKE SURE RESID IS XLATED
3587
*
INITIALIZE A NEW BUFFER
TYS1
LA
DEST,PBSTAR
DATA ADDRESS FOR WRITE
ST
DEST,PBCCW
OR DC CCW
LA
BCR,TBLM1
SH
BCR,BINC-1
LA
DEST,PBSTAR-PERBUF(BA,0) MODIFIED AT TYS5&TYS6 $$$$$$$$
BINC
EQU *-1
VALUES ARE PBSTAR+IOTA 3
MVI BINC,PBSTAR-PERBUF
SET TO NORMAL VALUE
MVC PBSTAR(2),RESID
RESIDUE FROM LAST OVERSTRIKE
*
DEST & BCR ARE SETUP, ANY RESIDUAL CHARACTERS FROM
*
BUFFER OVERFLOW DURING BACKSPACE INSERTION ARE NOW AT START
*
OF THIS NEW BUFFER
LTR 1,1
TRT LEAVES R1 NON-ZERO
BNZ TYS2
SKIP THE TRT
*
TYS3 ASSUMES LAST BYTE OF BUFFER IS NOT LAST BYTE OF STORE
TYS3
LR
1,ICR
LOOK FOR NEXT OVERSTRIKE
EX
1,TYOTRT
BC
10,*+12
STC 2,RESID+1
SAVE SECOND GRAPHIC
B
TYS2
LA
1,20(1,SR)
INDICATE NO MORE OVERSTRIKES
TYS2
EX
BCR,TYOMVC
MOVE TO BUFFER
EX
BCR,TYOTR
LA
SR,1(SR,BCR)
CR
1,SR
R1 WAS SET BY TRT
BL
TYS13
DO BACKSPACE INSERTION
TYS15
BCTR ICR,0
ICR IS TRUE COUNT, BCR IS SS COUNT
SR
ICR,BCR
BP
TYS8
*
INTERNAL BUFFER IS NOW DEPLETED, TRY IDLE CHAR INSERTION
BALR 2,0
PRESERVE CONDITION CODE
AR
BCR,ICR
BCR IS (-1)+ ICR OF TYS2
LA
DEST,1(DEST,BCR)
UPDATE DESTINATION IN EXT BUFFER
CLI MXTEM12+3,0
SEE IF IDLE CHARACTERS REQUIRED
BE
TYS4
NO, MOP UP FINAL BUFFER
LCR BCR,ICR
BCTR BCR,0
BCR IS NOW CORRECT
L
ICR,MXTEM12
COUNT OF IDLE CHARACTERS
MVI MXTEM12+3,0
PREVENT LOOPING
LA
SR,DCZEOB
SOURCE OF 2741 PROTO-IDLES
LA
1,797(SR)
INDICATE NO OVERSTRIKES
SPM 2
RESTORE CONDITION CODE
BZ
TYS8
GET ANOTHER BUFFER
B
TYS2
PUT IDLES IN CURRENT BUFFER
*
FINISHUP LAST BUFFER
TYS4
LA
BCR,PBSTAR
SR
DEST,BCR
STH DEST,PBCCW+6
COUNT FOR FINAL CCW
MVI PBTIC+1,EMPTYM
END OF CHAIN
MVI PBCCW+4,SLI
MVI PBFLAG,LINEZ+LISTZ
*
EXIT WITH BA POINTING TO LAST BUFFER OF LINE
*
... FBUF POINTING TO FIRST BUFFER OF LINE
MVI TYOTR,X'DC'
RESTORE TO TRANSLATE
L
LINK,MXTEM12+4
B
4(LINK)
TAKE SUCCESS EXIT

55930000
55940000
55950000
55960000
55970000
55980000
55990000
56000000
56010000
56020000
56030000
56040000
56050000
56060000
56070000
56080000
56090000
56100000
56110000
56130000
56140000
56150000
56260000
56270000
56280000
56290000
56300000
56310000
56320000
56330000
56340000
56350000
56360000
56370000
56380000
56390000
56400000
56410000
56420000
56430000
56440000
56450000
56460000
56560000
56580000
56590000
56600000
56610000
56620000
56630000
56640000
56650000
56660000
56670000
56680000
56690000
56700000
56710000
56720000
56730000

*
TYS13

TYS6
TYS5
TYS7
*
TYS8
*
*

*
*
TYS9
*
TYS10
TYOTRT
TYOTR
TYOMVC
RESID
TYSK1
DCZEOB
*

BACKSPACE INSERTION MECHANISM

LA
2,2(BCR,1)
REVISE COUNT OF CHARACTERS MOVED
SR
2,SR
K IS R1+BCR+2-SR
LA
SR,1(1)
NEW SOURCE REGISTER
SR
ICR,2
INTERNAL CHARACTERS REMAINING
BNP STYOBAD
MESSAGE ENDS WITH OVERSTRIKE
AR
DEST,2
UPDATE DESTINATION IN BUFFER
SR
BCR,2
BUFFER CHAR REMAINING, UPDATE
BM
TYS5
NO ROOM FOR BACKSPACE
MVC 0(1,DEST),ZBSUC+TYOTAA
BZ
TYS6
NO ROOM FOR SECOND GRAPHIC
MVC 1(1,DEST),RESID+1
INSERT SECOND GRAPHIC
AH
BCR,=H'-2'
TEST FOR END OF BUFFER
C022
BM
TYS7
NO MORE ROOM
LA
DEST,2(DEST)
UPDATE DESTINATION
B
TYS3
INSERT AT LEAST ONE MORE
MVI BINC,PBSTAR+1-PERBUF
MVC RESID(1),RESID+1
NEXT BUFFER STARTS WITH 2ND GRAPHIC
B
TYS7
MVI BINC,PBSTAR+2-PERBUF NEXT BUFFER STARTS WITH
MVC RESID(1),ZBSUC+TYOTAA BACKSPACE AND SEC3ND GRAPHIC
SR
1,1
DO NEXT TRT
COMMON END OF BUFFER LOGIC
EQU *
REGISTER USAGE HERE.. ICR, R1 AND SR STILL NEEDED
R2, DEST & BCR ARE FREE NOW
LR
BCR,BA
SAVE PREVIOUS BUFFER ADDRESS
LH
DEST,BUFTS
BUFFERS OBTAINED IN THIS CALL
C
DEST,MAXRAT
RATION FOR THIS CALL OF TYOSUB 2222
BNL TYS9
BAL LINK,GETBUF
GET ANOTHER BUFFER
B
TYS9
NO BUFFER (SHOULD NOT HAPPPEN)
LA
DEST,1(DEST)
INCREMENT COUNT OF BUFFERS OBTAINED
STH DEST,BUFTS
ST
BA,PBTIC-PERBUF(BCR) LINK NEW BUFFER INTO CHAIN
MVC PBCCW+4-PERBUF(5,BCR),TYSK1 DATACHAIN,0,L'PBSTAR,TIC
B
TYS1
NOT ENOUGH BUFFERS FOR THIS TYO
BCR POINTS TO LAST BUFFER OBTAINED
MVI PBFLAG-PERBUF(BCR),LISTZ
AH
DEST,PTBFA
DEST = BUFTS
STH DEST,PTBFA
FREEBUF WILL DECREMENT PTBFA SO COMPENSATE NOW.
L
BA,FBUF
RELEASE BUFFER CHAIN
BAL LINK,FREEBUF
MVI TYOTR,X'DC'
RESTORE TRANSLATE
L
LINK,MXTEM12+4
BR
LINK
TAKE FAILURE EXIT
TRT 0(1,SR),TYOTAT
TR
0(1,DEST),TYOTAA
MVC 0(1,DEST),0(SR)
DC
XL2'0'
FOR OVERSTRIKES ON BUFFER BOUNDARY
DC
AL1(DC,0,0,L'PBSTAR,TIC) FOR USE AT TYS8
DROP 6,8,BA
DC
26AL1(ZEOB)
BECOMES BCD IDLE CHAR

SPACE 3
*
USE OF PERTERM POINTERS DURING INPUT
*
*PTFBUF POINTS TO LAST UNTRANSLATED BUFFER. RTRBUF (CALLED ON PCI)

56740000
56750000
56760000
56770000
56780000
56800000
56840000
56850000
56860000
56870000
56880000
56890000
56900000
56910000
56920000
56930000
56940000
56950000
56960000
56970000
56980000
56990000
57000000
57010000
57020000
57030000
57040000
57050000
57060000
57070000
57080000
57090000
57100000
57110000
57120000
57130000
57140000
57150000
57160000
57170000
57180000
57190000
57200000
57210000
57220000
57230000
57240000
57250000
57270000
57320000
57330000
57340000
57350000
57360000
57380000
57400000
57410000
57420000
57430000
57440000

*
*
*
*PTLBUF
*
*PTIBUF
*
*PTRBUF
*PTBFA
*
*
*
UNRZ

*
*
*
*
*
*
*
*
*
*
*
UNRZ19

UNRZ6

*
*
*
*

TRANSLATES ONE BUFFER AND EXITS WITH PTFBUF AND BA POINTING TO

THE BUFFER JUST TRANSLATED. MXRCCC SET THE INITIAL VALUE OF
PTFBUF TO A(PTCCW2) AND PTCCW3 TO TIC TO FIRST BUFFER.
POINTS TO LAST BUFFER IN INPUT CHAIN. RNEWBUF MAINTAINS
PTLBUF DURING INPUT.
POINTS TO FIRST BUFFER IN INPUT CHAIN. IT IS USED BY TYPEIN
AND THE APLSUP ROUTINES WHICH RELEASE INPUT BUFFERS.
NOT USED DURING INPUT.
IS NUMBER OF BUFFERS POINTED TO BY PTIBUF.

57450000
57460000
57470000
57480000
57490000
57500000
57510000
57520000
57530000
57540000
57550000
NORMAL END OF READ FOR MULTIPLEX DEVICE
57560000
USING UNRZ,10
57570000
CLI PTTYPE,Q103A
SEE IF THIS IS A 270X DEVICE
57580000
BH
UNRZ6
BRANCH IF NOT.
57590000
CLI PTRESP,CRD
VALIDITY CHECK ON READ OPERATION
57600000
BE
UNRZ6
BRANCH ON POSITIVE RESPONSE.
57610000
CLI PTTYPE,QAMBIG
SEE IF TYPE IS UNRESOLVED.
57620000
BNE UNRRT
NO, RETRY 1050 MYSTERY
57630000
57640000
END OF READ, AMBIGUOUS DEVICE.
57650000
CRD FROM 2741 MAY HAVE BEEN LOST DUE TO VARIOUS RACE
57660000
CONDITIONS RESULTING FROM CONTROL MODE TIMEOUTS ON 270X
57670000
CONTROL UNITS. PTRESP MAY CONTAIN THE RIGHT PARENTHESIS.
57680000
57690000
IC
2,PTRESP
RES2741 EXITS TO UNRRTA IF RITEPAREN 57700000
BAL LINK,RES2741
IS NOT FOUND
57710000
TERMINAL TYPE IS RESOLVED, BUT SIGN-ON MESSAGE IS DISPLACED
57720000
IN BUFFERS.
57730000
RATHER THAN TRYING TO SHIFT IT RIGHT ONE BYTE, PRINT 'RESEND' 57740000
AND LET USER RETYPE IT.
57750000
B
UNRRT
57760000
PCI WAS MISSED, INCREMENT COUNT
57770000
L
1,MSPCI1
57790000
LA
1,1(1)
57800000
ST
1,MSPCI1
57810000
B
UNRRT
PRINT RESEND MAYBE AND UNLOCK KEYB 57860000
USING PERBUF,4
57870000
EQU *
57880000
MVI SAVCSW,TIC
MAKE STORED CAW A TIC
57890000
L
0,SAVCSW
TO FINAL CCW FOR COMPARISON
57900000
SH
0,=H'8'
PURPOSES
57910000
ST
0,LASTBUF
FOR FUTURE COMPARISONS
57920000
C
0,RNBCON+4
COMPARE WITH TIC DISCARD
57930000
BE
UNRZ19
WE MISSED A PCI
57940000
CLI PTTYPE,QAMBIG
57950000
BNL UNRZ24
THIS IS END OF INPUT
57960000
CHECK FOR 2741 LINE FEED
57970000
L
4,PTFBUF
POINT TO LAST TRANSLATED BUFFER
57980000
BALR LINK,0
TRANSLATE ALL INPUT BUFFERS UNTIL
57990000
C
0,PBTIC
WE HAVE ONE UNTRANSLATED BUFFER
58000000
BNE RTRBUF
WITH EXTRA ROOM
58010000
L
4,PBTIC
POINT TO UNTRANSLATED BUFFER
58020000
SOME CHARACTER OF THIS BUFFER OTHER THAN THE LAST IS A
58030000
CRC (UNLESS BUFFER IS EMPTY). CHECK TO SEE IF CRC IS PRECEDED 58040000
BY A CARRIAGE RETURN. EMPTY BUFFER CASE HANDLED BY UNRZ27
58050000
LH
1,PBCCW+6
COMPUTE NUMBER OF CHARACTERS
58060000
SH
1,SAVCSW+6
TRANSFERRED. NOTE THAT IS NOT
58070000
EQUAL TO NUMBER OF DATA CHARS IN BUFFER
58080000
BZ
UNRZ27
EMPTY BUFFER CASE
58090000

LA
0,PBSTAR
MVI PBCCW,0
DO 24 BIT ARITHMETIC
S
0,PBCCW
SR
1,0
GIVING NUMBER OF CHARS IN BUFFER
BCT 1,UNRZ26A
CRET AND CRC IN THE SAME BUFFER MAYB
*
CRC IS FIRST CHARACTER IN BUFFER
*
POTENTIAL CRET IS IN THE PRECEDING BUFFER
L
2,PTFBUF
LOOK IN LAST TRANSLATED BUFFER
TM
PBFLAG-PERBUF(2),FORCELF THIS BIT IS SET IN PTCCW2 BY
*
MXRCCC AND IS RESET BY SVTYIX WHEN
*
A BUFFER ENDING WITH ZCR IS RELEASED
BO
*+8
SKIP CLI, CONDITION CODE IS 3
CLI PBLAST-1-PERBUF(2),ZCR
L
2,PBCCW
R2 POINTS TO CRC
B
UNRZ26C
TEST CONDITION CODE
UNRZ26B CLI =AL1(UCRET),X'80' FORCE UPPER CASE COMPARE
UNRZ26A IC
2,PBSTAR-1(1)
POTENTIAL CARR RETURN
EX
2,UNRZ26B
COMPARE WITH UPPER&LOWER CASE CRET
LA
2,PBSTAR(1)
POINT TO CRC
UNRZ26C BE
UNRZ25
THIS IS NOT 2741 LINE FEED
MVI 0(2),LF
INSERT LINE FEED (BCD CODE)
LA
2,1(2)
ST
2,PBCCW
RECOMPUTE CCW ADDR
MVC PBCCW+6(2),SAVCSW+6 RESIDUAL COUNT TO NEW CCW
C
4,PTLBUF
BNE UNRZ30
WE HAVE AN EMPTY BUFFER
BAL LINK,GETBUF
TRY TO GET ANOTHER
B
UNRZ31
PRAY FOR PCI ON PARTIAL BUFFER
BAL LINK,RNEWBUF
LINK NEW BUFFER INTO CHAIN
UNRZ30 MVI PBCCW+4,DC
TURN OFF PCI IN PARTIAL BUFFER
UNRZ31 ST
4,PTCCW3
*
SETUP PTCCW1 TO TRANSMIT PSEUDO POLLING SEQUENCE FOR LINE FEED
LA
1,Q2741LF
CLI PTTYPE,Q2741
BE
UNRZ32
BRANCH IF REAL 2741
LA
1,QTS41LF
TSS IMITATION 2741
UNRZ32 ST
1,PTCCW1
FORM WRITE CCW
MVI PTCCW1,WR
MVI PTCCW1+7,L'Q2741LF
MVI PTCNT,0
B
MXSION
*
UNRZ27 IS CASE OF.. CHANNEL END ON 2741 WITH NO UNTRANSLATED
*
CHARACTERS FOR THIS TERMINAL. IF THIS IS REALLY LINEFEED,
*
RTRBUF HAS DONE AN EARLY 2741LF DETECTION FOR INLINE AND
*
UNRZ27 (WHICH ARE ASSUMED TO BE RACING EACH OTHER).
UNRZ27 L
4,PTFBUF
CLI PBLAST-1,ZLF
BNE UNRZ25
BUFFER CONTAINS A ZCR
L
4,PBTIC
POINT TO AN EMPTY BUFFER
B
UNRZ31
SET PTCC3 TO TIC R4
*
UNRZ24 AND UNRZ25 ARE NON 2741 AND NON LINE FEED CASES OF
*
CHANNEL END RESPECTIVELY. ALL UNTRANSLATED BUFFERS ARE
*
PROCESSED, EMPTY INPUT BUFFERS ARE RELEASED.
UNRZ24 BAL LINK,RESTYPE
IN CASE TERM TYPE IS AMBIG
UNRZ25 L
4,LASTBUF
LH
1,PBCCW+6
COMPUTE NUMBER OF
SH
1,SAVCSW+6
CHARS IN LAST TRANSFER
ST
1,MXTEM12
FOR INPUT LENGTH HISTOGRAM
BNZ UNRZ25A
*
LAST BUFFER IS EMPTY

58100000
58110000
58120000
58130000
58140000
58150000
58160000
58170000
58180000
58190000
58200000
58210000
58220000
58230000
58240000
58250000
58260000
58270000
58280000
58290000
58300000
58310000
58320000
58330000
58340000
58350000
58360000
58370000
58380000
58390000
58400000
58410000
58420000
58430000
58440000
58450000
58460000
58470000
58480000
58490000
58500000
58510000
58520000
58530000
58540000
58550000
58560000
58570000
58580000
58590000
58600000
58610000
58620000
58630000
58640000
58650000
58660000
58670000
58680000
58690000

CL
4,PTIBUF
TEST FOR ALL BUFFERS EMPTY
BE
UNRZ25C
YES, MANUFACTURE ZEOB IN 1ST BUFF
MVI MXTEM12+3,L'PBSTAR-1
CORRECT FOR BCTR HISTVAL,0 UNRZ
L
4,PTFBUF
TRANSLATE ALL UNTR BUFFERS
BALR LINK,0
RETURN POINT FOR RTRBUF
CLC PBTIC,LASTBUF
BNE RTRBUF
LOOP UNTIL ALL ARE TRANSLATED
MVI PBLAST,ZEOB
MARK AS LAST BUFFER
B
UNRZ25B
UNRZ25A BAL LINK,RTRBUF
CL
4,LASTBUF
BNE UNRZ25A
TRANSLATE ANOTHER BUFFER
UNRZ25C A
1,PBCCW
MVI 0(1),ZEOB
EXTRA EOB TO BE SURE
UNRZ25B MVI PBFLAG,FILLBIT+LISTZ+LINEZ
MVI PTFBUF+1,EMPTYM
NOT NEEDED NOW
CLC PBTIC,RNBCON+4
BE
UNRZ3
NO EMPTY BUFFERS IN CHAIN
L
BA,PBTIC
BAL LINK,FREEBUF
RELEASE EMPTY BUFFERS
UNRZ3
BAL LINK,CORTIME
TM
MISCB,NOWSM
SEE IF WORKSPACE IS ASSIGNED
BO
UNRZ5
NO WORKSPACE
LR
2,0
LR
HISTVAL,0
S
HISTVAL,PTMTIME
KEYING TIME THIS INPUT.
ST
0,PTMTIME
TO MEASURE RESPONSE TIME.
LR
0,HISTVAL
A
0,PTMTIM3
CUMULATIVE KEYING TIME
ST
0,PTMTIM3
SAVE FOR IBEAM RETRIEVAL.
LA
PHR,PERHKEY
*
HISTOGRAM *** * * * * * *** * * ** * ** *
BAL LINK,HISTCOMP
*
HISTOGRAM ON INPUT ARRIVAL TIMES **************************
LA
PHR,PERHARIV
INPUT ARRIVAL TIMES HISTOGRAM
LR
HISTVAL,2
S
HISTVAL,PTMTIM2
ST
2,PTMTIM2
BAL LINK,HISTCOMP
XI
ACTIVE,INWAITM+NONINM
*
CHANGE USER STATE FROM AWAITING INPUT TO INPUT READY
CLI PTCORE+1,EMPTYM
BE
UNRZ2
NOT IN CORE
L
1,PTCORE
MVC PCQUONT-PERCORE(2,1),ZERO URGE RETENTION IN CORE
B
UNRZ4
*
END OF READ WITH NO WORKSPACE ASSIGNED TO TERMINAL
UNRZ5
ST
0,PTMTIME
FOR HISTOGRAMS
ST
0,PTMTIM2
SAVE TIME OF FIRST EOB FOR HIST
MVI ACTIVE,MISCM
TURN OFF INWAIT TO PREVENT NEW SIO
PTSET ACTIVE
BAL LINK,LEMP
GET WORKSPACE LOADED
B
UNRZ4
CONTINUE READ MOP UP
UNRZ2
MVI FSWAP,1
TELL SCHED (AND/NONINM) IS NOW ZERO
*
NOTE THAT ALTHOUGH RSELSUB, SELRDZ COULD MAKE (AND/NONINM) ONE
*
(BY SELECTING THE USER NOW BEING PROCESSED), THE EXTRA SWAP
*
SHOULD TAKE PLACE ANYWAY. THIS IS THE CASE WHERE THE HCSCNT
*
WINDOW IS ELONGATED.
CLI SELBUSY,0
BNE UNRZ4

58700000
58710000
58720000
58730000
58740000
58750000
58760000
58770000
58860000
58870000
58880000
58890000
58900000
58910000
58970000
58980000
58990000
59000000
59010000
59020000
59030000
59050000
59060000
59070000
59080000
59090000
59100000
59110000
59120000
59130000
59140000
59150000
59160000
59170000
59180000
59190000
59200000
59210000
59220000
59230000
59240000
59250000
59260000
59270000
59280000
59290000
59300000
59310000
59320000
59330000
59340000
59350000
59360000
59370000
59380000
59390000
59400000
59410000
59420000
59430000

*
UNRZ4

UNRZ41

*
*

UNRZ11

*
*
UNRZ12

*
RESTYPE

RES2741

* TYPE
*

BAL LINK,RINGSUB BECAUSE WORKSPACE IS ON DISK AND

DEVICE DEPENDENT MOPUP
LH
HISTVAL,PTBFA
COMPUTE TOTAL NUMBER OF INPUT
BCTR HISTVAL,0
CORRECT FOR PARTIAL BUFFER
MH
HISTVAL,RNBCON+2
CHARACTERS IN THIS LINE
A
HISTVAL,MXTEM12
LR
5,HISTVAL
SAVE FOR IDLE COMPUTATION
TM
MISCB,NOWSM
SIGN-ON NOT INCLUDED IN HISTOGRAM
BO
UNRZ41
LA
PHR,PERHRKEY
BAL LINK,HISTCOMP
EQU *
MVI RESCH,1
FOR ENTRY TO GENERAL EXIT
MVI STATE,WRITES
MARK DEVICE END PRESENT.
CLI PTTYPE,Q1050+Q103A-Q103A TEST FOR 1050
BH
SETIDLE
OTHER DEVICES DO NOT NEED ANSWER
BE
UNRZ12
1050 DOES NOT NEED IDLE CHARACTERS
LA
0,WCRDI
ADDR OF CCW
ST
0,PUCCB
FOR ERROR RETRY
WRITE TO TERMINAL.. CRD AND ZERO OR MORE IDLES
NUMBER OF IDLES IS BASED UPON ESTIMATED CARRIAGE RETURN TIME
SR
4,4
SH
5,KRZIS
SUBTRACT FUDGE FACTOR
BNP UNRZ11
NEGATIVE OR ZERO
D
4,KRZID
STC 5,WCRDI+7
IDLE CHAR COUNT
CLI WCRDI+7,0
ZERO COUNT IS EVIL
BNE *+8
MVI WCRDI+7,1
FORCE MINIMUM
CLI WCRDI+7,IDLMAX
BL
MXSIO
WITHIN RANGE
MVI WCRDI+7,IDLMAX
FORCE MAXIMUM
B
MXSIO
SEND CRD (=OK ANSWER) AND THEN BLACKSHIFT SEQUENCE FOR
1050 RIBBON COLOUR CONTROL
MVC PTCCW1(9),BLKCCW1
MVI PTCCW2+4,CC+SLI
READ RESPONSE
MVC PTCCW3,TBLKCCW3
TIC TO BLKCCW3
B
MXSION

59440000
59450000
59460000
59470000
59480000
59490000
59500000
59510000
59520000
59530000
59540000
59550000
59570000
59660000
59670000
59680000
59690000
59700000
59710000
59720000
59730000
59740000
59750000
59760000
59770000
59780000
59790000
59800000
59810000
59820000
59830000
59840000
59850000
59860000
59870000
59880000
59890000
59900000
59910000
59920000
CLI PTTYPE,QAMBIG
CHECK FOR AMBIGUITY IN DEVICE TYPE. 59930000
BCR 7,LINK
OK
59940000
L
4,PTIBUF
POINT TO FIRST BUFFER
59950000
IC
2,PBSTAR
FIRST DATA CHAR FOR RES2741 USE
59960000
RESOLVE 1050 VS 2741 ON BASIS OF POLLING SEQUENCE WHICH WORKED 59970000
DC
0AL4(MXR2741)
INVESTIGATE BEFORE CHANGING * * * * * * 59980000
CLI PTRESP,CRD
SEE IF A SEQ REALLY WORKED.
59990000
BNE RES2741
NO - MAY BE LOST 2741 RACE.
60000000
CLI PTCCW1+7,1
2741 POLLING SEQ IS ONE CHARACTER
60010000
BE
RES2741
2741 TSS OR STANDARD
60020000
MVI PTTYPE,Q1050
60030000
LA
PXR,Q1050-QAMBIG(PXR)
60040000
BR
LINK
60050000
LA
3,Q2741
60060000
BAL 6,TRYRPAR
60070000
LA
3,QTS41
MAYBE IT IS TSS 2741
60080000
BAL 6,TRYRPAR
60090000
IS NOT RESOLVABLE, UNLOCK KEYBOARD
60100000
B
UNRRTA
RETRY READ AS 2741
60110000
60120000

TRYRPAR L
PXR,PERDEVB
CHECK 2741 CHARACTER SET
AR
PXR,3
L
1,TYOTAD-PERDEVX(PXR)
EX
2,TRYCLI
LOOK FOR RIGHT PAREN
BCR 7,6
NO MATCH
STC 3,PTTYPE
BR
LINK
TRYCLI CLI ZRPAR(1),0
EXECUTED BY TRYRPAR
DROP 10
DROP 4
PERBUF
*
*
SETUP CCW AND FLAGS TO DISCONNECT HARD WIRE OR DIALUP LINE
USING MXDCCC,10
MXDCCC MVI STATE,WRITES
MVI PTCCW1,ENABLE
DISABLE MUST BE AVOIDED FOR
TM
IOB2,Q4WMDM
HARD WIRED LINES
BO
MXDCC1
SKIP DISABLE
MVI PTTYPE,QAMBIG
MARK TERMINAL TYPE UNKNOWN
MVI PTCCW1,DISABLE
DISCONNECT DIALUP LINE
MXDCC1 LA
BA,PTIBUF
RELEASE ANY INPUT BUFFERS
BAL LINK,FREEBQ
BAL LINK,SAT8
RELEASE OUTPUT BUFFERS
BAL LINK,KSOHK
KILL SIGN OFF HOLD KILL EVENT
MVI PTCNT,0
MVI ACTIVE,INWAITM+NONINM+MISCM
PTSET ACTIVE
* DISABLE MUST BE AVOIDED FOR HARD WIRE LINES. RESULTS IN TIMEOUT. P056
TM
IOB2,Q4WMDM
HDWIRE?
P056
BZ
MXDCC2
NO - ISSUE THE DISABLE.
P056
CLI SHUTDOWN,0
SHUTDOWN?
P056
BE
MXDCC2
NO - ISSUE AN ENABLE TO HARDWIR P056
MVI PTTYPE,QAMBIG
USED BY UNWZ
P056
B
UNWZ
NO I/O NEEDED
P056
MXDCC2 EQU *
P056
LA
0,PTCCW1
FOR SIO ROUTINES
ST
0,PUCCB
MVC PTCCW2(1),PTSAD
REFRESH SAD FIELD
MVI PTCCW2+4,SLI
END OF CHAIN
B
MXSION
DROP 10
*
*
RELEASE INPUT BUFFERS OF PRECEDING TYI
SVBREL LA
BA,PTIBUF
BAL LINK,FREEBQ
B
SVEXIT
SPACE 3
*
USE OF PERTERM POINTERS DURING OUTPUT.
*
*PTFBUF POINTS TO A CHAIN OF BUFFERS AWAITING OUTPUT.
*PTLBUF POINTS TO LAST BUFFER IN PTFUBF CHAIN. IT IS MAINTAINED BY
*
TYOINS AND IS NOT VALID WHEN PTFBUF IS EMPTY.
*PTIBUF POINTS TO INPUT BUFFERS FROM LAST INPUT OPERATION OR ELSE WHEN
*
TRAWAITM IS SET PTIBUF POINTS TO A CHAIN OF MESSAGE BUFFERS
*
DESTINED FOR THE PORT WHOSE NUMBER IS STORED IN DESBYTE.
*PTRBUF POINTS TO THE CHAIN BEING PRINTED NOW WHICH WILL BE RELEASED
*
BY MXWCCC BEFORE STARTING PRINTING OF THE NEXT LINE.
*PTBFA IS THE NUMBER OF BUFFERS POINTED TO BY PTFBUF PTIBUF PTRBUF
*
*
USING MXWCCC,8

60130000
60140000
60150000
60160000
60170000
60180000
60190000
60200000
60210000
60220000
60230000
60240000
60250000
60260000
60270000
60280000
60290000
60300000
60310000
60320000
60330000
60340000
60350000
60360000
60380000
60390000
60410000
60420000
60430000
60440000
60450000
60460000
60470000
60480000
60490000
60500000
60510000
60520000
60530000
60540000
60550000
60560000
60570000
60580000
60590000
60600000
60610000
60620000
60630000
60640000
60650000
60660000
60670000
60680000
60690000
60700000
60710000
60720000
60730000
60740000

MXWCCC

LA
BA,PTRBUF
RELEASE BUFFERS MAYBE
BAL LINK,FREEBQ
L
BA,PTFBUF
BUFFERS TO WRITE TO TERMINAL
ST
BA,PTRBUF
RELEASE NEXT TIME
CLI PTFBUF+1,EMPTYM
BE
MXWEMP
NOTHING MORE TO PRINT
LR
1,BA
BA STILL POINTS TO FIRST BUFF
USING PERBUF,1
WILL BE LAST BUFFER OF LINE
MVI PBCCW,WR
WRITE COMMAND IN FIRST BUFFER
B
*+8
MXWC2
L
1,PBTIC
SEARCH FOR LAST BUFFER
TM
PBFLAG,LINEZ
OF FIRST LINE IN CHAIN
BZ
MXWC2
OI
PBFLAG,LISTZ
FOR FREEBUF
MVC PTFBUF,PBTIC
BAL LINK,MXWOUTWK
RESET OUTWAIT MAYBE
MVI PTCNT,0
CLEAR ERROR COUNT
MVI STATE,WRITES
TM
PBFLAG,KILLFLAG
TEST FOR SVOFF
BO
UNKILL1
QUEUED DISCONNECT SIGNAL
CLI PTTYPE,Q1050
BE
MXW1050
*
SAME CHAIN FOR 2741 AND 1052
MXW1052 LA
0,0(BA)
MXWZ
ST
0,PUCCB
B
MXSION
MXW1050 MVC PTCCW1(9),WR1050AD
MVI PBCCW+4,CC+SLI
CHAIN LAST WRITE CCW
MVC PBTIC,ADIAG1
ALL 1050 ANSWER CHARACTERS ARE
*
READ TO SAME BYTE IN STORAGE.
ST
BA,PTCCW3
MAKE PTCCW3 TIC TO FIRST BUFFER
MVI PTCCW2+4,CC+SLI
*
ASSUME RESPONSE WILL BE CRY, CRN OR ABSENT
LA
0,PTCCW1
B
MXWZ
DROP 1
MXWEMP LA
LINK,SETIDL2
MXWOUTWK RETURN ADDRESS
MXWOUTWK CLI PTFBUF+1,EMPTYM
TEST BUFFER ALMOST EMPTY
BCR 7,LINK
TM
ACTIVE,OUTWAITM
WAS THIS PORT OUTPUT BOUND
3064
BCR 8,LINK
NO.
3064
MVI RESCH,1
POST QZA7
3064
NI
ACTIVE,255-OUTWAITM
BR
LINK
DROP 8
SPACE 3
*
COMMAND CHAINS FOR INPUT
*
2741 OR TS41 NORMAL INOUT
*PTCCW1 CCW WR,INPCRC,CC+SLI,1
*PTCCW2 CCW REINHIB,PTRESP,DC,1
*PTCCW3 TIC PBCCW
OF FIRST BUFFER
*PBCCW(1) CCW 0,PBSTAR,DC+PCI,L'PBSTAR-1
*PBTIC(1) TIC DISCARD
*
*
2741 (TS41) AFTER ATTN KEY IN READ STATE (PSEUDO LINEFEED)
*PTCCW1 CCW WR,Q2741LF(QTS41LF),CC+SLI,L'Q2741LF
*PTCCW2 CCW REINHIB,PTRESP,DC,1
*PTCCW3 TIC PBCCW
OF BUFFER IN WHICH CRC LIES OR NEXT BUFFER
*
TWO POSSIBLITIES FOR REMAINDER OF 2741(TS41) PSEUDO LINEFEED
*
CHAIN DEPENDING ON BUFFER AVAILABILITY AT UNRZ30..

60750000
60760000
60770000
60780000
60790000
60800000
60810000
60820000
60830000
60840000
60850000
60860000
60870000
60880000
60890000
60900000
60910000
60920000
60970000
60980000
60990000
61000000
61010000
61020000
61030000
61040000
61050000
61060000
61070000
61080000
61090000
61100000
61110000
61120000
61130000
61140000
61190000
61200000
61210000
61230000
61240000
61250000
61270000
61280000
61290000
61300000
61310000
61320000
61330000
61340000
61350000
61360000
61370000
61380000
61390000
61400000
61410000
61420000
61430000
61440000

*
WHEN BUFFER WAS AVAILABLE
*PBCCW CCW 0,1+ADDRESS OF CRC IN BUFFER,DC,RESIDUAL COUNT FROM CSW
*PBTIC TIC PBCCW
OF EMPTY BUFFER OBTAINED AT UNRZ30
*PBCCW CCW 0,PBSTAR,DC+PCI,L'BPSTAR-1
*PBTIC TIC DISCARD
*
IF NO BUFFER WAS AVAILABLE
*PBCCW CCW 0,1+ADDRESS OF CRC IN BUFFER,DC+PCI,RESIDUAL COUNT
*PBTIC TIC DISCARD
*
*
2741(TS41) AFTER TRANSMISSION ERROR OR MISSED PCI
*PTCCW1 CCW WR,RST2741(RSTTS41),CC+SLI,L'RST2741
*PTCCW2 CCW REINHIB,PTRESP,DC,1
*PTCCW3 TIC PBCCW
OF FIRST BUFFER
*PBCCW(1) CCW 0,PBSTAR,DC+PCI,L'PBSTAR-1
*PBTIC(1) TIC DISCARD
*
*
1050 ALL CASES OF INPUT
*PTCCW1 CCW WR,INPOLL,CC+SLI,5
*PTCCW2 CCW REINHIB,PTRESP,DC,1
*PTCCW3 TIC PBCCW
OF FIRST BUFFER
*PBCCW(1) CCW 0,PBSTAR,DC+PCI,L'PBSTAR-1
*PBTIC(1) TIC DISCARD
*
*
1052 MODEL 7
*
PTCCW1, PTCCW2 AND PTCCW3 ARE NOT USED BY CHANNEL PROGRAM
*PBCCW CCW X'0A',PBSTAR,DC+PCI,L'PBSTAR-1
*PBTIC TIC DISCARD
*
*
NOTE THAT A PCI FROM PBCCW FOR ANY OF THE ABOVE DEVICES
*
WILL RESULT IN ASSIGNMENT AND INITIALIZATION OF ANOTHER BUFFER
*
AND REPLACEMENT OF PBTIC IN THE PARTIALLY FILLED BUFFER WITH A
*
TIC TO THE NEW BUFFER.
*
*
FOR A 270X DEVICE OF AMBIGUOUS TYPE THE CHAIN IS AS FOR A 1050
*
OR 2741 EXCEPT FOR THE COMMAND CODE OF PTCCW2 WHICH BECOMES
*
RETIME AND PTCCW1 WHICH TAKES ON ONE OF THE FOLLOWING VALUES..
*PTCCW1 CCW ENABLE,INPOLL,CC+SLI,1 AFTER A DISABLE
*PTCCW1 CCW WR,INPCRC+1,CC+SLI,2
ASSUMED 1050
*PTCCW1 CCW WR,INPCRC,CC+SLI,1
ASSUMED 2741 (TS41)
SPACE 3
*
WRITE ANSWER CCW CHAIN FOR USE AFTER SUCCESSFUL COMPLETION
*
OF AN INPUT CCW CHAIN.
*
2741 AND TS41
*WCRDI CCW WR,CRD AND IDLES,SLI,1 MAX IDLMAX MIN 2*PTBFA
*
1050
*PTCCW1 CCW WR,BLKADR,CC+SLI,5
FROM BLKCCW1
*PTCCW2 CCW RETIME,PTRESP,CC+SLI,1
*PTCCW3 TIC BLKCCW3
*
*
1052 DOES NOT NEED AN ANSWER CHAIN
SPACE 3
*
OUTPUT CCW CHAINS
*
A SIO WILL BE ISSUED TO PRINT A SINGLE LINE USING BUFFERS
*
OBTAINED AND FILLED BY TYOSUB. EVERY BUFFER EXCEPT THE LAST
*
HAS A FLAGS FIELD OF DC, AN ADDRESS OF PBSTAR AND A COUNT OF
*
L'PBSTAR. THE LAST BUFFER MAY HAVE A SHORT COUNT AND A
*
DEVICE DEPENDENT FLAGS FIELD. IN THE MODEL CHAINS BELOW, (F)
*
INDICATES FIRST BUFFER, (L) INDICATES LAST BUFFER
*
*
2741, TS41 OR 1052 WRITE CHAIN

61450000
61460000
61470000
61480000
61490000
61500000
61510000
61520000
61530000
61540000
61550000
61560000
61570000
61580000
61590000
61600000
61610000
61620000
61630000
61640000
61650000
61660000
61670000
61680000
61690000
61700000
61710000
61720000
61730000
61740000
61750000
61760000
61770000
61780000
61790000
61800000
61810000
61820000
61830000
61840000
61850000
61860000
61870000
61880000
61890000
61900000
61910000
61920000
61930000
61940000
61950000
61960000
61970000
61980000
61990000
62000000
62010000
62020000
62030000
62040000

*PBCCW(F) CCW WR,PBSTAR,DC,L'PBSTAR

*PBTIC(F) TIC TO NEXT BUFFER
*PBCCW(L) CCW 0,PBSTAR,SLI,POSSIBLE SHORT COUNT
*PBTIC(L) UNDEFINED
*PBSTAR(L) IS FILLED OUT WITH ENOUGH IDLE CHARACTERS FOR CARRIAGE RET
*
*
1050 WRITE CHAIN
*PTCCW1 CCW WR,OUTADR,CC+SLI,3
*PTCCW2 CCW RETIME,PTRESP,CC+SLI,1
*PTCCW3 TIC PBCCW(F)
*PBCCW(F) CCW WR,PBSTAR,DC,L'PBSTAR
*PBTIC(F) TIC TO NEXT BUFFER
*PBSTAR(F) BEGINS WITH AL1(CRD)
*PBCCW(L) CCW 0,PBSTAR,CC+SLI,POSSIBLE SHORT COUNT
*PBTIC(L) TIC DIAG1
TO READ ANSWER
*PBSTAR(L) ENDS WITH A AL1(CRB)
SPACE 3
*
DISCONNECT SEQUENCES
*
DIALUP 270X DEVICES
*PTCCW1 CCW DISABLE, ,CC+SLI,EITHER 1 3 OR 5
*PTCCW2 CCW PTSAD,PTRESP,SLI,1
*
NONDIALUP 270X DEVICES
*PTCCW1 CCW ENABLE, ,CC+SLI,EITHER 1 3 OR 5
*PTCCW2 CCW PTSAD,PTRESP,SLI,1
SPACE 3
*
*
BLACK CCWS ARE USED AT UNRZ12 TO FORM A CCW CHAIN TO GET 1050
*
INTO BLACK SHIFT. CAHIN IS STORED IN PTCCW1 THRU PTCCW4 AND
*
ISSUED WITH TERMINAL IN WRITES STATE.
WCRDI
CCW WR,KCRD,SLI,0
SEE UNRZ4 FOR COUNT LOGIC $ $ $ $ $
DISCARD CCW 0,SKADISC,DC+SLI+SKIP+PCI,L'SKADISC
DC
A(TIC*F*F*F+DISCARD)
TBLKCCW3 DC
A(TIC*F*F*F+BLKCCW3)
KMXWIS DC
H'10'
TYOSUB SUBTRACT FROM CHAR COUNT
KRZIS
DC
H'40'
UNRZ4 SUBTRACT FROM INPUT COUNT
KRZID
DC
F'10'
UNRZ4 DIVISOR IN IDLE COMPUTATION
BLKCCW1 CCW WR,BLKADR,CC+SLI,5 PTCCW1
DC
AL1(RETIME)
PTCCW2 COMMAND BYTE
*
INPOLL ASSUMES 1050 IS ALREADY IN RED SHIFT OR THAT PREVIOUS
*
OPERATION WAS WRITE TO PRINTER1.
INPOLL DC
X'3E62'
PREFIX,A FOR REDSHIFT
INPCRC DC
AL1(CRC)
DC
X'6215'
A,ZERO COMMON POLL
BLKDATA DC
AL1(CRD,X'3E',X'64',CRB) BLACK SHIFT SEQUENCE
*
RESEND TEXT FOR BOTH KINDS OF 2741
RST2741 DC
AL1(CRD)
SET RECEIVE TEXT MODE IN 2741
DC
15X'7F'
IDLES PREVENT OVERPRINT
3587
DC
X'4A295229252A5B' GENUINE 2741
DC
AL1(CRC)
SET TRANSMIT TEXT MODE IN 2741
LRSTXT EQU *-RST2741
LASTBUF DC
A(0)
UNRZ TEMP CELL
BLKCCW3 CCW X'01',BLKDATA,CC+SLI,4 PTCCW3
DIAG1
CCW RETIME,SKADIAG,SKIP+SLI,1
WR1050AD CCW X'01',OUTADR,CC+SLI,3 NORMAL 1050 WRITE PTCCW1
DC
AL1(RETIME)
PTCCW2 COMMAND BYTE
RSTTS41 DC
AL1(CRD)
DC
15X'7F'
IDLES PREVENT OVERPRINT
3587
DC
X'526B256B4A685B' TSS 2741
DC
AL1(CRC)
BLKADR DC
AL1(CRD,X'DF',CRC) CRD= READ ANSWER

62050000
62060000
62070000
62080000
62090000
62100000
62110000
62120000
62130000
62140000
62150000
62160000
62170000
62180000
62190000
62200000
62210000
62220000
62230000
62240000
62250000
62260000
62270000
62280000
62290000
62300000
62310000
62320000
62330000
62340000
62350000
62360000
62370000
62380000
62390000
62400000
62410000
62420000
62430000
62440000
62450000
62460000
62470000
62480000
62490000
62500000
62510000
62520000
62530000
62540000
62550000
62560000
62570000
62580000
62590000
62600000
62610000
62620000
62630000
62640000

*
*
*

X'DF' IS ALL MARKS CHARACTER FOR

UNATTENDED 1050S
CRC=POLLING CHARACTER ONE
DC
X'6213'
BCD A,9 TRANSMIT TO ALL RCV COMPONE
NOTE... THE FIRST 96 IS A CRD, THE SECOND AN INVERTED CARET.
EQU BLKADR+2
NORMAL WRITE ADDRESSING SEQUENCE

*
OUTADR
*
Q2741LF DC
X'96BB96DDBB1F'
QTS41LF DC
X'96BB93DDBB1F'
KCRD
DC
AL1(CRD)
FOLLOWED BY IDLE CHARACTERS
DC
(IDLMAX-1)X'7F'
ENOUGH IDLES FOR 2741
DC
5X'7F'
MORE IDLES FOR TYOSUB
*
FOLLOWING DATA AREAS ARE FOR THE USE OF THE MULTIPLEXOR SUB*
CHANNEL
SKALIRS DC
XL4'00'
LIRS2741
SKAPREP DC
X'00'
PREPCCW
SKADISC DC
XL9'00'
DISCARD
SKADIAG DC
X'00'
DIAG1
*
DIFFERENT AREA FOR EACH COMMAND SO NON-ZERO CONTENTS CAN BE
*
TRACED DOWN TO CULPRIT.
*
RKEY
PHGEN 150,150,8
RAW INPUT CHARACTER COUNT
*
ARIV
PHGEN 36300,122,9
INPUT ARRIVAL TIME
*
OUTL
PHGEN 150,150,10
INTERNAL OUTPUT CHARACTER COUNT
*
*
*
SIGN OFF AND DROP LIN E
SVOFF0 BALR 10,0
TRANSMUTED )OFF HOLD
USING SVOFF,10
SVOFF
CLI PTTYPE,Q103A
BH
SVOFFH1
TRANSMUTE TO )OFF HOLD
* TREAT MODEM LIKE DIALUP IF SHUTDOWN HAS BEEN EXECUTED.
P056
CLI SHUTDOWN,0
SHUTDOWN?
P056
BNE SVOFF1
YES.
P056
* OTHERWISE TREAT MODEM LIKE )OFF HOLD
P056
TM
IOB2,Q4WMDM
BO
SVOFFH1
TRANSMUTE TO )OFF HOLD
SVOFF1 EQU *
P056
OI
IOB1,NSIGNM
FOR SATSUB USE
BAL LINK,TYORAT
COMPUTE BUFFER RATION
LA
3,SVOFFM
EXCUSE TO ENTER TYOSUB
BAL LINK,TYOSUB
GET ONE BUFFER NEATLY
B
SETBUFWQ
SVOFF MACRO GENERATES SIX BYTES
BAL LINK,TYOINS
APPEND TO CHAIN
LR
BA,0
POINT TO BUFFER AGAIN
OI
PBFLAG-PERBUF(BA),KILLFLAG
BAL LINK,INITMWR
IN CASE CHANNEL IS IDLE
BAL LINK,OFFSUB
LOSE WORKSPACE ETC.
B
QUEND
SVOFFM DC
H'1'
SOMETHING FOR TYOSUB
DC
AL1(ZY,ZEOB)
(NEVER PRINTED)
*
*
SVC REQUESTING ANY OF
*
LOAD, DROP, SAVE, COPY, SIGNOFF, LIBRARY
USING SVSDREQ,10
SVSDREQ CLI SDT+1,EMPTYM
BE
SVSDR1
NO SPECIAL DISK OP GOING NOW
SVSDR6 MVI MISCB,SDWAIT
SD OP IN PROGRESS, WAIT FOR SDKILL

62650000
62660000
62670000
62680000
62690000
62700000
62710000
62720000
62730000
62740000
62750000
62760000
62770000
62780000
62790000
62800000
62810000
62820000
62830000
62840000
62850000
62860000
62870000
62880000
62890000
62900000
62910000
62920000
62940000
62950000
62960000
62970000
62980000
62990000
63000000
63010000
63020000
63030000
63040000
63050000
63060000
63070000
63080000
63090000
63100000
63110000
63120000
63130000
63140000
63150000
63160000
63170000
63180000
63190000
63200000
63210000
63220000
63230000
63240000
63250000

PTSET
OI
B
TM
UGH
L
CLI
BNE
CLI
BNE
ST
LA
B
LA
CLI
BNE
CLC
BNL

MISCB
ACTIVE,MISCM
BACK6
-6 TO PSW
SVSDR1
IOB1,COPYRM+COPYWM DETECT ANY COPY WE FORGOT TO END
NZ
MEANS MAJOR CRISIS
1,REGSV
PDSOPA-PDSLIB(1),XXCOPY LOOK FOR COMMANDS WHICH NEED
SVSDR4
NOT COPY
COPSINK+1,EMPTYM
PERMIT ONE COPY AT A TIME
SVSDR6
SET SDWAIT
PTR,COPSINK
MARK AS COPY SINK
4,PDSLEN+L'PDSID
MOVE COPY PARAMETER
SVSDR2
SVSDR4
4,PDSLEN
DO NOT MOVE COPY PARAMETER
PDSOPA-PDSLIB(1),XXLIB EXTRA SWAPPING DISK
SVSDR2
SVSDR3
LIBNOW+1(1),LIBLIM+1 WE CAN ONLY HANDLE SO MANY
BACK6
TWO-WORKSPACE OPERATIONS AT ONCE.
*
IF LIMIT IS EXCEEDED, DON'T RUN THIS
*
GUY BUT LET HIM KEEP HAMMERING AT US
LH
2,LIBNOW
BUMP )LIB COUNT
LA
2,1(2)
STH 2,LIBNOW
*
START SPECIAL DISK OPERATION
SVSDR2 ST
PTR,SDT
MVC SDQZSW(8),GETDIR GET DIRECTORY INTO CORE
OI
ACTIVE,LOCKM
FORCE CONTINUED CORE RESIDENCE
NI
IOB1,255-TRREJ
MARK AS ACCEPTED
MVC SVOLDPSW+4(4),=A(SDRET)
L
2,RRCORE
MVI PCQUONT-PERCORE(2),X'F0'
L
8,ASDPAR
SPECIAL DISK PARAM AREA IN DSEARCH
USING PDSDDDD,8
EX
4,SVSDRMVC
MVC SDOP(1),PDSOPA
PDSOPA IS IN TYPEWRITER BUFFER
MVC PDSOP,SDOP
PDSOP IS BELOW TYPEWRITER BUFFER
LH
HISTVAL,SDOP-1
CLI SDOP,XXMAX
BH
SVILG
ILLEGAL SVC, SPECIAL DISK
LA
PHR,PERHSD
BAL LINK,HISTCOMP
CLI SDOP,XXSAVE
BNE QUEND
L
4,LIBBASE
2221
COPY TRCOMP
STH 1,PDSTCNT-1
FOR SAVE DIRECTORY SEARCH
B
QUEND
DROP 4
SVSDRMVC MVC PDSDDDD,0(1)
DROP 8
USING REMCDC,7
DASD
REMCDC REMCDC ,
DASD
*
*
*
TRANSMIT MESSAGE TO LOG
USING SVLOG,10
SVLOG
LA
10,SVTRAN
CHANGE BASE REG
USING SVTRAN,10
CLI OPNUM,X'FF'
CHECK FOR OPERATOR NOT SIGNED ON
BE
SVLOG1

63260000
63270000
63280000
63290000
63300000
63310000
63320000
63330000
63340000
63350000
63360000
63370000
63380000
63390000
63400000
63410000
63420000
63430000
63440000
63450000
63460000
63470000
63480000
63490000
63500000
63510000
63520000
63530000
63540000
63550000
63560000
63570000
63580000
63590000
63600000
63610000
63620000
63630000
63640000
63650000
63660000
63670000
63680000
63690000
63700000
63710000
63720000
63730000
63740000
63750000
63760000
63770000
63790000
63800000
63820000
63830000
63840000
63850000
63860000
63870000

MVI MSGTEM,0
DESTINATION
L
1,OPTERM
OPR IS LOG FOR NOW
B
SVTRAN1
*
TRANSMIT MESSAGE TO SOME TERMINAL
SVTRAN CLI REGSV+7,0
MESSAGE TO TERMINAL ZERO IS CHANGED
BNE *+10
INTO MESSAGE TO OPERATOR'S PORT NUMB
MVC REGSV+7(1),OPNUM
NUMBER OF OPERATOR'S PORT
CLC REGSV(4),ZERO
BE
SVOPGL
SPECIAL GLITCH
*
ASSUME CALLING SEQUENCE IS SIMILAR TO TYO
*
L
1,TERMNUMBER
0 LEQ R1 LEQ TERMCOUN
*
LA
0,INTERNAL BUFFER
*
SVCC YYTRAN
*
NOW SET FLAGS FOR ADDRESSEE
BAL LINK,VALTERM
GET BASE REGISTER
B
SVTYOT
OUT OF RANGE, REJECT
SVTRAN1 EQU *
AT THIS POINT MSGTEM WILL BE ZERO
*
IFF ORIGINAL SVC WAS YYLOG. DESBYTE = 0 IS USED IN SATSUB TO
*
AVOID SETTING ATTENTION WHEN A TERMINAL IS SUSPENDED TRYING TO
*
TRANSMIT TO THE LOG.
*
CURRENT VERSION OF RECMSUB ALLOWS OPERATOR TO RECEIVE MESSAGES
*
TO THE LOG.
CR
1,PTR
BE
SVTYOT
MESSAGE TO SELF, REJECT
LA
BA,PTIBUF
FREE INPUT BUFFER
BAL LINK,FREEBQ
DROP PTR
CHANGE TO DESTINATION
USING PERTERM,1
TM
MISCB,NOWSM
SEE IF THIS TERMINAL HAS WORKSPACE
BO
SVTYOT
NOWORKSPACE, REJECT
DROP 1
USING PERTERM,PTR
BAL LINK,TYORAT
USE SENDER'S PTBFA IN RATION COMP
LR
PTR,1
USE DESTINATION PTTYPE
L
3,REGSV
POINT TO INTERNAL BUFFER
BAL LINK,TYOSUB
B
SVMSG3
INSUFFICENT BUFFERS
TM
MISCB,TRAWAITM+REPWAITM
BNZ SVMSG7
IN MESSAGE SUSPENSION, SEND IT NOW
SVMSG2A LR
1,PTR
L
PTR,PTBASE
SVMSG2 OI
IOB1-PERTERM(1),RINGM MARK AS MESSAGE PENDING
OI
MISCB,TRAWAITM
OI
ACTIVE,MISCM
MVC DESBYTE,MSGTEM
FOR SEARCH AT SVRECM4
LH
0,BUFTS
AH
0,PTBFA
UPDATE COUNT OF BUFFERS OWNED BY
STH 0,PTBFA
SENDING TERMINAL
MVC PTIBUF,FBUF
POINT TO MESSAGE
BAL LINK,RECMSUB
SENDER TRYS TO RECEIVE
B
QUEND
AWAIT TRANSMISSION
SVMSG3 L
PTR,PTBASE
RESTORE PTR BEFORE SETTING OUTWAITM
B
STYONO
*
DESTINATION IS IN EITHER TRAWAIT OR REPWAIT
SVMSG7 BAL LINK,TYOINS
DEST GETS MESSAGE
BAL LINK,INITMWR
START OUTPUT IF NEEDED
TM
IOB2,RECMM
DON'T DESUSPEND TERM IN PERMANENTBO
SVMSG4
RECEIVE STATE
NI
MISCB,255-REPWAITM
BNZ SVMSG4
IN TRANSMIT WAIT

63880000
63890000
63900000
63910000
63920000
63930000
63940000
63950000
63960000
63970000
63980000
63990000
64000000
64010000
64020000
64030000
64040000
64050000
64060000
64070000
64080000
64090000
64100000
64110000
64120000
64130000
64140000
64150000
64160000
64170000
64180000
64190000
64200000
64210000
64220000
64230000
64240000
64250000
64260000
64270000
64280000
64290000
64300000
64310000
64320000
64330000
64340000
64350000
64360000
64370000
64380000
64390000
64400000
64410000
64420000
64430000
64440000
64450000
64460000
64470000

SVMSG4
*
*
*
SVRECM

NI
L
FALL
DROP

ACTIVE,255-MISCM
PTR,PTBASE
INTO SVRECM
10

BREAK REPWAIT
RESTORE SENDER'S PTR.

INTERPRETER WISHES TO RECEIVE MESSAGES NOW

BAL LINK,RECMSUB
TM
IOB1,BROADM IF PA STILL PENDING DUE TO BUFFER RATION3039
BO
SETBUFWQ SET OUTWAIT (BUFFWAIT) AND RETRY LATER 3039
*
NOTE MUST HAVE INTERRUPTS DISABLED TO PREVENT ENQUE OF
3039
* NOTE FROM UNDERGROUND HERE ELSE SCHEDULER WILL BE SUSPENDED
3039
B
SVEXIT
*
*
GLITCH TO LOCK OPERATOR'S KEYBOARD
SVOPGL BAL LINK,RECMSUB
RECEIVE MESSAGES
MVI MISCB,REPWAITM
SUSPEND ALLOWING MESSAGE RECEIPT
PTSET MISCB
OI
ACTIVE,MISCM
B
QUEND
*
*
SVC YYLOG WITH OPERATOR NOT SIGNED ON
SVLOG1 LA
3,5*300
WAIT FIVE SECONDS
BAL 5,TERMDEL
SET CLOCKWAIT
B
BACK6
AND THEN RETRY THE SVC
*
*
*
BODY OF RECMSUB (MESSAGE RECPTION SUBROUTINE)
USING REMRECM,10
REMRECM ST
LINK,MXTEM12+8
CL
PTR,OPTERM
SPECIAL MESSAGE
BE
SVRECM3
RECEPTION TECHNIQUES FOR OPERATOR
TM
IOB1,BROADM
BZ
SVRECM1
MUST BE ADDRESSED MESSAGE
BAL LINK,TYORAT
RATION FOR PA MSG
3039
L
3,BROADPT
BROADCAST MESSAGE POINTER
BAL LINK,TYOSUB
B
SVRECM12
IGNORE PA TEMPORARILY,RECEIVE MSGS 3039
BAL LINK,TYOINS
ATTACH BROADCAST MESSAGE
NI
IOB1,255-BROADM
BROADCAST IS ACCEPTED
SVRECM12 TM
IOB1,RINGM
TEST FOR ADDRESSED MSGS
3039
BZ
SVRECM2
EXIT
SVRECM1 BAL 2,CVTERM
SET R1= TERMINAL NUMBER
SVRECM11 STC 1,SVRECM4+1
PROG MODIFICATION $ $ $ $ $ $
LM
0,2,PTBXLE
SVRECM4 CLI DESBYTE-PERTERM(2),C'*' MODIFIED ABOVE $$$$$$$$$$
BE
SVRECM5 WE HAVE FOUND A TERMINAL TO RECEIVE FROM
SVRECM7 BXLE 2,0,SVRECM4
CLI SVRECM4+1,0
BE
SVRECM1
SECOND PASS FOR OPTERM
NI
IOB1,255-RINGM
SVRECM2 L
LINK,MXTEM12+8
CLI PTFBUF+1,EMPTYM
SEE IF SIO IS NEEDED
BCR 8,LINK
NO INSERTIONS WERE MADE
B
INITMWR
INITIATE WRITE BEFORE RETURN
SVRECM5 STM 0,2,MSGTEM
USING PERTERM,2
DROP PTR
*
MAKE CERTAIN THAT THIS TERMINAL REALLY HAS A MESSAGE FOR US
TM
MISCB,TRAWAITM
BZ
SVRECM8
SYSTEM ERROR, IGNORE

64480000
64490000
64500000
64510000
64520000
64530000
64540000
64550000
64560000
64570000
64580000
64590000
64600000
64610000
64620000
64630000
64640000
64650000
64660000
64670000
64680000
64690000
64700000
64710000
64720000
64730000
64740000
64750000
64760000
64770000
64780000
64790000
64800000
64810000
64820000
64830000
64840000
64850000
64860000
64870000
64880000
64890000
64900000
64910000
64920000
64930000
64940000
64950000
64960000
64970000
64980000
64990000
65000000
65010000
65020000
65030000
65040000
65050000
65060000
65070000

L
BA,PTIBUF
SETUP FOR TYOINS
ST
BA,FBUF
HEAD OF BUFFER CHAIN PARAMETER
MVI PTIBUF+1,EMPTYM
MARK EMPTY TO INHIBIT RELEASE
USING PERBUF,BA
SR
0,0
B
*+8
L
BA,PBTIC
LOCATE END OF LIST
AH
0,KHONE
COUNT BUFFERS IN THIS MESSAGE
TM
PBFLAG,LISTZ
BZ
*-12
LOOP BACK
STH 0,BUFTS
FAKE PRIOR TYOSUB FOR TYOINS
LH
1,PTBFA
DECREMENT SENDER'S COUNT
SR
1,0
STH 1,PTBFA
BAL LINK,TYOINS
ATTACH TO BUFFER
DROP BA
*
MESSAGE IS IN PTR BUFFER, CLEAR SENDER FLAGS
LM
0,2,MSGTEM
NI
MISCB,255-TRAWAITM RELEASE SUSPENSION
NI
ACTIVE,255-MISCM
SVRECM8 MVI DESBYTE,X'FF'
MARK AS NO MESSAGES
B
SVRECM7
DROP 2
PRESTORE NORMAL BASE REGISTERS
USING PERTERM,PTR
SVRECM3 TM
IOB1,BROADM
OPERATOR DOES NOT GET PA'S
BZ
SVRECM6
NO N FROM U WAITING
MVC FBUF,NUFBUF
RECEIVE A NOTE FROM THE UNDERGROUND
L
BA,NULBUF
FAKE A PRIOR TYOSUB
MVI NUFBUF+1,EMPTYM
MARK NOTES FROM UNDERGROUND EMPTY
MVC BUFTS,NUBFA
NOTE FROM UND BUFFER COUNT
MVC NUBFA,ZERO
BAL LINK,TYOINS
ATTACH NOTES TO OPERATOR TERMINAL
NI
IOB1,255-BROADM
*
OPTERM MAKES TWO COMPLETE PASSES THROUGH THE SVRECM4, SVRECM7
*
LOOP. THE FIRST PASS IS WITH SVRECM4+1 SET TO ZERO TO RECEIVE
*
LOG MESSAGES. THE SECOND PASS USES THE TRUE TERMINAL NUMBER
*
OF THE OPERATOR TO RECEIVE ORDINARY MESSAGES TO THE OPERATOR.
SVRECM6 SR
1,1
TERM ZERO
B
SVRECM11
DROP 10
*
LOAD EMPTY WORKSPACE REQUEST FROM INTERPRETER
SVLEMP LR
4,PTR
BAL LINK,WSLOSE
DISCARD OLD WORKSPACE
BAL LINK,LEMP
START OR ENQUE READ EMPTY OP
MVC PTCORE+2(2),REGSV+2 POSSIBLE DIRECTORY NUMBER
B
QUEND
*
*
SVC TO TERMINATE A )LIB OPERATION
*
PTR POINTS TO TERMINAL
*
PXR (CURRENTM) POINTS TO DIRECTORY IN CORE
*
CONCEAL POINTS TO A PERDISK FOR THE REAL WORKSPACE
SVLIBZ L
1,CONCEAL
REAL WS WAS SWAPPED OUT AND HIDDEN
MVC PDTERM+1-PERDISK(3,1),PTBASE+1 RESTORE PDTERM
L
1,RRCORE
DESTROY CORE COPY OF DIRECTORY
MVI PCTERM+1-PERCORE(1),EMPTYM
MVI PTCORE+1,EMPTYM
LH
0,LIBNOW
DECREMENT THE COUNT OF )LIB OPS
BCTR 0,0
CURRENTLY IN PROGRESS
STH 0,LIBNOW
B
QUEND

65080000
65090000
65100000
65110000
65120000
65130000
65140000
65150000
65160000
65170000
65180000
65190000
65200000
65210000
65220000
65230000
65240000
65250000
65260000
65270000
65280000
65290000
65300000
65310000
65320000
65330000
65340000
65350000
65360000
65370000
65380000
65390000
65400000
65410000
65420000
65430000
65440000
65450000
65460000
65470000
65500000
65510000
65520000
65530000
65540000
65550000
65560000
65570000
65580000
65590000
65600000
65610000
65620000
65630000
65640000
65650000
65660000
65670000
65680000
65690000

SPACE

65700000
65710000
APL SHUTDOWN.
65720000
SET FLAG TO INHIBIT ENABLE COMMANDS.
65730000
DROP LINES WITH NO WORKSPACE ASSIGNED.
65740000
65750000
USING SVEOD,10
65760000
SVEOD
MVI SHUTDOWN,1
SHUTDOWN NOW IN PROGRESS.
65770000
LA
PTR,APLCNCL
65780000
CLI REGSV+3,0
LOW BYTE OF INTERPRETER R0 = 0
65790000
BCR 7,PTR BNER
MEANS INITIATE SHUTDOWN, ELSE MAKE 65800000
*
A MAD DASH TO PUT SYSTEM BACK INTO 65810000
*
A PRESENTABLE SHAPE.
65820000
LM
4,6,PTBXLE
65830000
B
SVEOD2
SKIP COPY SOURCE PERTERM.
65840000
SVEOD1 LR
PTR,6
65850000
USING PERTERM,PTR
65860000
CLI PTTYPE,Q103A
ASSUME OPERATOR WILL SHUT DOWN
65870000
BH
SVEOD2
NON-270X TERMINALS.
65880000
CLI MISCB,NOWSM
CHECK FOR WORKSPACE ASSIGNED.
65890000
BNE SVEOD2
SKIP HIO IF WS IS THERE OR ON THE WA 65900000
TM
STATE,DVBUSY
SEE IF THE SUBCHANNEL IS RUNNING.
65910000
MVI STATE,TODROP
DISABLE AT NEXT INTERRUPT.
65920000
BZ
SVEOD2
SKIP HIO IF NOT.
65930000
OI
STATE,DVBUSY
PRESERVE RUNNING FLAG.
65940000
MVI PTFBUF+1,EMPTYM
MIGHT NEVER HAVE BEEN TO MXRCCC.
65950000
BAL LINK,HIOSUB
HALT CURRENT IO.
65960000
SVEOD2 BXLE 6,4,SVEOD1
65970000
B
SVEXIT
65980000
*
65990000
*
SET SIGN ON MESSAGE
66000000
*
66010000
SVSOM
L
1,REGSV
MOVE SIGN-ON MESSAGE INTO BUFFER
66020000
L
2,SOMPT
66030000
MVC 0(130,2),0(1)
66040000
B
SVEXIT
66050000
*
66060000
USING SVDEL,10
66070000
*
SUSPEND THIS TERMINAL UNTIL INTERVAL EXPIRES
66080000
SVDEL
L
3,REGSV
R0 IS TIME IN SEC DIV 300
66090000
SVDEL1 BAL 5,TERMDEL
SUSPEND AND SET DELAY
66100000
B
QUEND
66110000
DROP 10
66120000
EXITPC
66140000
*
66150000
*
ATTEMPT TO COMPENSATE FOR MISSING INTERRUPT OR HIO
66160000
*
TERMINAL NUMBER IN INTRP R0
66170000
USING SVRESET,10
66180000
SVRESET BAL LINK,VALTERM
GET PTR SETTING
66190000
B
SVEXIT
INVALID TERM NUMBER
66200000
LR
PTR,1
RESET THIS TERM
66210000
TM
STATE,DVBUSY
66220000
BZ
SVRST1
SIO WITH PUCCB AS CAW
66230000
BAL LINK,HIOSUB
66240000
B
SVEXIT
66250000
SVRST1 LA
8,MXSIOQ
66260000
BAL LINK,INITM1
CALL MPX CODE
66270000
B
SVEXIT
66280000
DROP 10
66290000
*
66300000
*
*
*
*
*

USING SVBOUNC,10
*
BOUNCE A USER OFF THE MACHINE
*
TERMINAL NUMBER IN INTRP R0
SVBOUNC BAL LINK,VALTERM
B
SVEXIT
INVALID NUMBER
LR
PTR,1
PTR POINTS TO BOUNCEE
LA
8,SVEXIT
B
BOUNSUB
DROP 10
*
*
USING SVBROAD,10
*
BROADCAST MESSAGE TO ALL TERMINALS
SVBROAD L
1,REGSV
L
2,BROADPT
MVC 0(130,2),0(1)
STORE MESSAGE TEXT (INTERNAL CODE)
LM
0,2,PTBXLE
B
SVBR1
SVBR2
LR
PTR,2
TM
IOB1,NSIGNM
AVOID BROADCAST
BAM8
BNZ SVBR1
IF NOT SIGNED ON
BAM8
CL
2,OPTERM
DON'T BROADCAST TO THE OPERATOR.
BE
SVBR1
OI
IOB1,BROADM
NI
MISCB,255-REPWAITM WAIT FOR REPLY
BNZ SVBR1
NI
ACTIVE,255-MISCM
SVBR1
BXLE 2,0,SVBR2
B
SVEXIT
DROP 10
*
USING SVDSZ,10
*
END OF DIRECTORY SEARCH
SVDSZ
L
1,REGSV+4*13
POINTER TO DIRSEAR WORKING STORE
MVC DIRSMAN(15),16(1)
DASD
EX
0,SDSWRSET
RESET SPECIAL DISK SWITCH
*
*
RESET STORAGE KEYS TO PREVENT PROTECTION CHECK ON DISK.
*
IC
3,INACTKEY
KEY OF PARTITION.
LR
6,PXR
M.
BAL LINK,SSKSUB
RESET STORAGE KEYS
L
4,HDCORE
MVI PCQUONT-PERCORE(4),0 DECREASE CORE RES PRIORITY
OI
ACTIVE,LOCKM
SUSPEND DURING DIRECTORY WRITE
LH
2,SDOP-1
LH
10,SDTAB(2)
DEREL ,
DERELATIVIZE
DROP 10
BALR LINK,10
USE DIRECTORY SEARCH RESULT
B
QUEND
PRINT NOGEN
SDTAB
DCY DSZDROP
DROP
DCY DSZSAVE
SAVE
DCY DSZLOAD
LOAD
DCY DSZCOPY
COPY
DCY DSZDROP
ADD
DCY SVILG
DCY SVILG
DCY DSZOFF
SIGN OFF SAVE AND ACCOUNTING

66310000
66320000
66330000
66340000
66350000
66360000
66370000
66380000
66390000
66400000
66410000
66430000
66440000
66450000
66460000
66470000
66480000
66490000
66500000
66510000
66520000
66530000
66540000
66550000
66560000
66570000
66580000
66590000
66600000
66610000
66620000
66630000
66640000
66650000
66660000
66670000
66680000
66690000
66700000
66710000
66720000
66730000
66740000
66750000
66760000
66770000
66780000
66790000
66800000
66810000
66820000
66830000
66840000
66850000
66860000
66870000
66880000
66890000
66900000
66910000

XXMAX

DCY
DCY
DCY
DCY
EQU
PRINT

DSZDROP
DSZDROP
DSZDROP
DSZDROP
*-2-SDTAB
GEN

DELETE USER
USER LOCKOUT
USER REDEMPTION
PASSWORD CHANGE

*
USING SVSOOK,10
SIGN ON MESSAGE HAS BEEN EXAMINED
MOPUP AFTER VALID SIGN ON MESSAGE
MVC PTABTM(8),ZERO
MESSAGE VALIDATION IS FREE
MVC PTMTIM3(4),ZERO
INITIALIZE CUMULATIVE KEYING TIME.
MVC PTSOTM,PTMTIME
LINE CHARGE TIME
MVI MISCB,0
PTSET MISCB
NI
IOB1,255-NSIGNM
MVI PTDAYSON,0
NUMBER OF DAYS SIGNED ON.
L
1,REGSV+8
TYPEIN R2
USING PERLIB,1
MVC PTMAN,LIBNUM
MVC PTWSQ(4),MANWSQ
*
MOVE FIRST THREE CHARACTERS OF HISNAME INTO PERTERM.
LA
2,3
SVSOOK2 IC
0,HISNAME(2)
EX
2,SVSOOKCL
INSERT TRAILING BLANKS IF SHORT NAME
BNL *+8
LA
0,ZBLANK
STC 0,PTMANI-1(2)
BCT 2,SVSOOK2
MVC PTCPULIM(2),SRALIM CPU TIME LIMIT.
MVC PTCPULM2(2),PTCPULIM BOTH PLACES.
DROP 1
CLI REGSV+7,1
TYPEIN R1
BNE SVSOOK1
ST
PTR,OPTERM
THIS IS SIGN ON OF OPERATOR
BAL 2,CVTERM
STC 1,OPNUM
FOR MESSAGES TO TERM ZERO
OI
IOB1,PRIVBIT
OPERATOR IS PRIVLEGED
OI
IOB2,RECMM
MESSAGE-RECEIVING STATE
SVSOOK1 BAL LINK,KSOHK
DEFUSE TIME BOMB
TM
IOB2,LOEXP
CHECK FOR EXPRESS TERMINAL
BZ
SVSOOK3
THIS IS ORDINARY PORT
*
2224
* IF THIS IS OPTERM, WE WANT TO IGNORE EXPRESS STATUS
2224
*
2224
CL
PTR,OPTERM
IS THIS OPERATOR SIGNING ON?
2224
BE
SVSOOK3
IF SO, DON'T SET FUSE
2224
OI
IOB2,SHEXP
TURN ON AUTO BOUNCE BIT FOR IESZUG
LM
2,3,KEXPLIM
ENQ IESZUG SO THAT USER WILL BE
OR
2,PTR
BOUNCED AFTER FIXED TIME PERIOD
BAL 5,ENQIE
UNLESS OPERATOR RESETS SHEXP BIT
SVSOOK3 LA
0,1
BAL LINK,POSOM
INCREMENT SIGNED ON COUNT
MVI MAXRAT,INFIN
SVSOOK IS NOT RETRYABLE
L
3,SOMPT
PRINT SIGN-ON MESSAGE
CLI 1(3),16
CHECK FOR EMPTY MESSAGE
BL
SVEXIT
SHORT MESSAGE IS IGNORED
BAL LINK,TYOSUB
B
SVEXIT
TYOSUB HAS TWO RETURNS
BAL LINK,TYOINS
*
*
SVSOOK

66920000
66930000
66940000
66950000
66960000
66970000
66980000
66990000
67000000
67010000
67020000
67030000
67040000
67050000
67060000
67070000
67080000
67090000
67100000
67110000
67120000
67130000
67140000
67150000
67160000
67170000
67180000
67190000
67200000
67210000
67220000
67230000
67240000
67250000
67260000
67270000
67280000
67290000
67300000
67310000
67320000
67330000
67340000
67350000
67360000
67370000
67380000
67390000
67400000
67410000
67420000
67430000
67440000
67470000
67480000
67490000
67500000
67510000
67520000
67530000

B
STYO8
FIRE UP SUBCHANNEL SNEAKILY
SVSOOKCL CLI HISNAME-PERLIB(1),0
DROP 10
*
SVTYOT BALR 10,0
IN CASE WE GO TO STYONO
USING SVTYO,10
SVTYO
TM
ACTIVE,ATTENM
CHECK FOR UNRECOGNIZED ATTENTION
BO
SVEXIT
IGNORE THIS TYO
LA
BA,PTIBUF
RELEASE INPUT BUFFERS MAYBE
BAL LINK,FREEBQ
IN CASE TYPEIN NEGLECTED TO DO SO.
BAL LINK,COPKILL
TERMINATE POSSIBLE COPY
TM
IOB2,LVIDLEM
IGNORE TYO IF DS READY HAS DROPPED
BO
SVEXIT
TM
IOB1,COPYWM
SPECIAL TREATMENT OF COPY SOURCE
BO
COPTYO
BAL LINK,TYORAT
COMPUTE BUFFER RATION
L
3,REGSV
INTRP R0 IS BUFFER ADDRESS
BAL LINK,TYOSUB
EXPAND OVERSTRIKES, STORE IN BUFFERS
B
STYONO
BUFFER RATION EXCEEDED
BAL LINK,TYOINS
LINK TO PREVIOUS LINES
STYO8
BAL LINK,INITMWR
TRY TO START WRITE OPERATION
B
SVEXIT
*
*
SET EITHER OUTWAIT OR BUFFWAIT AND BACKUP OLDPSW SO TYO CAN
*
BE RETRYED. STYONO ASSUMES SVC YYTYO IS PRECEDED BY A FOUR
*
BYTE INSTRUCTION.
*
STYONO EQU *
*
DEBUGGING STATISTICS TO SEE IF WE HAVE ENOUGH BUFFERS
L
HISTVAL,FREEBC
CURRENT FREE BUFFER COUNT
LA
PHR,PERHFBC
BAL LINK,HISTCOMP
LH
HISTVAL,PTBFA
BUFFERS CURRENTLY ALLOCATED, THIS TE
LA
PHR,PERHBFA
BAL LINK,HISTCOMP
B
SETBUFWQ
*
COPTYO L
2,COPSINK
TYO FROM COPY SOURCE
NI
ACTIVE-PERTERM(2),255-LOCKM DESUSPEND SINK
L
2,FREEBC
COMPUTE BUFFER RATION THIS TYO
S
2,POSO
SUBTRACT 2 TIMES PLUS/SIGNEDON
S
2,POSO
BNP COPTYONO
NOT ENOUGH, QUIT
ST
2,MAXRAT
2222
L
3,REGSV
BAL LINK,TYOSUB
MOVE TO BUFFERS
B
COPTYONO
NOT ENOUGH BUFFERS
BAL LINK,TYOINS
INSERT IN CHAIN
B
SVEXIT
*
SOURCE BUFFER RATION REACHED
COPTYONO OI
ACTIVE,LOCKM
SUSPEND AND SIGNAL MORE OUTPUT
L
2,COPSINK
NI
ACTIVE-PERTERM(2),255-LOCKM
B
BACK6
Q END FOR SOURCE
DROP 10
*
USING SVTYI,10
SVTYI
TM
IOB1,COPYRM+COPYWM
BNZ COPTYI
TYI FROM SOURCE OR SINK OF COPY
TM
ACTIVE,ATTENM
SOME SPECIAL CASE

67540000
67570000
67580000
67600000
67610000
67620000
67630000
67640000
67650000
67660000
67680000
67690000
67700000
67710000
67720000
67770000
67780000
67790000
67800000
67810000
67890000
67900000
67910000
67920000
67930000
67940000
67950000
67970000
67980000
67990000
68000000
68010000
68020000
68030000
68040000
68050000
68100000
68120000
68130000
68140000
68150000
68160000
68170000
68180000
68190000
68200000
68210000
68220000
68230000
68240000
68250000
68260000
68270000
68280000
68300000
68310000
68320000
68340000
68350000
68360000

BNZ
TM
BO
OI
MVC
*
SVTYI3

*
*
*
*
*
COPTYI1

*
COPTYI

*
*
COPTYI3
*
COPTYI5
COPTYI4

SVTYI3
MAY BE ORDINARY ATTENTION OR PRESIGN
IOB2,BOUNCM
IGNORE TYI DURING BOUNCE OP
QUEND
ACTIVE,INWAITM
PTCPULIM(2),PTCPULM2 RESET CPU TIME LIMIT SINCE
INTRP HAS NOW RESPONDED.
NI
SWITCHES,NOT-QZSW1 SET QZSW1 TO ZERO
C022
B
SVTYI1
TRY TO START READ OP
TM
IOB1,NSIGNM
CHECK FOR SELDRZ1 CASE
BZ
QUEND
IGNORE TYI UNLESS INIT SIGNON COMM
MVI ACTIVE,ATTENM+NONINM-ATTENM-NONINM SET TO ZERO
PTSET ACTIVE
NI
SWITCHES,NOT-QZSW1 SET QZSW1 TO ZERO
C022
B
QUEND

68370000
68430000
68440000
68450000
68460000
68470000
68480000
68490000
68510000
68520000
68530000
68540000
68550000
68560000
68580000
COPY SOURCE WS HAS ISSUED A TYI TO SIGNAL END OF COPY.
68600000
NOTE THAT THE SINK HAS NOT YET CONSUMED ALL COPY BUFFERS.
68610000
KILL SOURCE WS NOW. COPY OPERATION WILL END WHEN SINK GETS
68620000
TO COPTYI3.
68630000
LR
4,PTR
WSLOSEC PARAM
68640000
BAL LINK,WSLOSEC
DESTROY SOURCE WORKSPACE
68650000
MVI ACTIVE,INWAITM+MISCM SUSPEND SOURCE WITHOUT LOCKM
68660000
PTSET ACTIVE
68670000
L
2,COPSINK
SOURCE IS EXHAUSTED
68680000
NI
ACTIVE-PERTERM(2),255-LOCKM ACTIVATE SINK
68690000
B
QUEND
END OF SOURCE QUANTUM
68700000
68710000
TM
IOB1,COPYRM
TYI FROM SOURCE OR SINK
68720000
BZ
COPTYI1
SOURCE
68730000
LA
BA,PTIBUF
RELEASE PREVIOUS INPUT LINE
68740000
BAL LINK,FREEBQ
IF IT EXISTS
68750000
L
2,COPSOUR
POINT TO SOURCE
68760000
L
BA,PTFBUF-PERTERM(2) NEXT LINE FROM SOURCE
68770000
ST
BA,PTIBUF
68780000
MVI PTFBUF+1-PERTERM(2),EMPTYM ASSUME THIS IS LAST LINE
68790000
IF IT IS NOT, THE STORE BEFORE COPTYI6 WILL SET PTFUBF(SOURCE) 68800000
SR
0,0
TO COUNT BUFFERS
68810000
CLI PTIBUF+1,EMPTYM
SOURCE HAS A LINE FOR SINK
68820000
BNE COPTYI4
68830000
NO LINES AWAITING SINK
68840000
NI
ACTIVE-PERTERM(2),255-LOCKM DESUSPEND SOURCE
68850000
BNZ COPTYI3
END OF COPY, SOURCE HAS DONE TYI
68860000
OI
ACTIVE,LOCKM
SUSPEND SINK
68870000
LH
0,=H'-2'
NOTE THAT PSW IS BACKED FOR TYI
68880000
B
SVWAIT2
IN COPY MODE BUT NOT FOR NORMAL TYI 68890000
68900000
END OF COPY, SINK HAS ACCEPTED ALL INPUT
68910000
BAL LINK,COPKILL
TERMINATE COPY
68920000
MVI ACTIVE,ATTENM+NONINM SET ATTENTION SO TYPEIN WILL RETRY 68930000
PTSET ACTIVE
68940000
TYI, INCLUDING 6-SPACE INDENTATION.
68950000
B
QUEND
68960000
USING PERBUF,BA
68970000
L
BA,PBTIC
UPDATE PTFBUF IN SOURCE
68980000
OI
PBFLAG,FILLBIT
BY REMOVING ONE LINE
68990000
BCTR 0,0
INCREMENT BUFFER COUNT
69000000
TM
PBFLAG,LINEZ+LISTZ
69010000
BZ
COPTYI5
CONTINUE TILL END OF LINE
69020000
BO
COPTYI6
THIS IS LAST LINE IN LIST
69030000
OI
PBFLAG,LISTZ
FOR FREEBUF
69040000

L
BA,PBTIC
BA POINTS TO NEXT LINE
ST
BA,PTFBUF-PERTERM(2) UPDATE FORNEXT COPTYI
COPTYI6 LH
1,PTBFA
SR
1,0
INCREASE SINK BUFF COUNT
STH 1,PTBFA
AH
0,PTBFA-PERTERM(2) DECREASE SINK BUFFER COUNT
STH 0,PTBFA-PERTERM(2)
B
SVEXIT
DROP BA
DROP 10
*
DROP PTR,PXR
END OF SVC ROUTINES
DROP MR
TITLE 'S P E C I A L D I S K R O U T I N E S'
*
LOSE SOURCE WORKSPACE (OF COPY) AT END OF A DISK OPERATION
*
COPKILL ACTIVATES SELWSK
USING SELWSK,10
SELWSK LM
1,3,CDDISK
USING PERDISK,1
USING PERCORE,3
MVI PCTERM+1,EMPTYM
C
2,SDT
R2 = CDTERM
BE
SDKILLA
DIRECTORY READ TERMINATION
MVI PDTERM+1,EMPTYM
BR
LINK
DROP 1,3,10
*
*
SEE IF SECOND DIRECTORY MUST BE REWRITTEN
USING DIR3RD,10
DIR3RD CLI DIRCHANG,3
)SAVE OR )DROP IN PUB LIB MAY
BNE SETDROPZ
AFFECT TWO DIFFERENT DIRECTORIES
DROP 10
*
READ OTHER DIRECTORY
MVI CDOP,12
GO TO DIR4TH AT SELECTOR INTERRUPT
L
3,SDT
L
5,DIRSMAN
MAN NUMBER GIVES DIRECTORY NUMBER
B
RSDIR1
*
*
AFTER READ OF SECOND DIRECTORY (DIR3RD)
USING DIR4TH,10
DIR4TH BAL 6,RELOCT
WAS NOT DONE THROUGH NORMAL CHANNELS
L
1,CCPAR1
USING M,1
L
2,MANSTAR
LA
3,MANENTL
L
4,DIRSMAN
LIB OF ORIGINAL SAVER
3591
DIR4A
L
5,M(2)
CR
4,5
BE
DIR4B
LTR 5,5
BM
SETDROPZ
UNUSUAL -- WSS EXIST BUT MAN DOESN'T
BXH 2,3,DIR4A
DIR4B
AR
1,2
SR
2,2
BXLE INDEX
3591
LA
3,2
BXLE INCREMENT AND STOPPER
3591
DIR4C
LH
4,MANWSQ-PERLIB(2,1)
3591
AH
4,DIRSWSQ(2)
BUMP QUOTA OR ACTUAL
3591
BNM *+6
DON'T ALLOW NEGATIVE QUOTA
3591
SR
4,4
3591
STH 4,MANWSQ-PERLIB(2,1)
STORE NEW QUOTA OR ACTUAL 3591

69050000
69060000
69070000
69080000
69090000
69100000
69110000
69120000
69130000
69150000
69160000
69170000
69180000
69200000
69210000
69220000
69230000
69240000
69250000
69260000
69270000
69280000
69290000
69300000
69310000
69320000
69330000
69340000
69350000
69360000
69370000
69380000
69390000
69400000
69410000
69420000
69430000
69440000
69450000
69460000
69470000
69480000
69490000
69500000
69510000
69520000
69530000
69540000
69550000
69560000
69570000
69580000
69590000
69600000
69610000
69620000
69630000
69640000
69650000
69660000

BXLE
MVI
B
DROP

2,3,DIR4C
DIRCHANG,1
WWZO1
10,1

BRANCH TO GET ACTUAL

3591 69670000
PREVENT REENTRY TO DIR4 TH FROM 3RD 69680000
WRITE THIS DIRECTORY
69690000
3591 69700000
*
69710000
USING PERTERM,4
SAVE AND DROP BASE
69720000
USING PERCORE,5
69730000
*
69740000
*
SIGN OFF DIR SEARCH AUTO SAVE, ACCOUNTING UPDATE
69750000
USING DSZOFF,10
69760000
DSZOFF LM
4,5,SDT &HDCORE
69770000
MVC CCPAR1+1(3),PCADDR
69780000
L
3,CCPAR1
69790000
L
2,REGSV-M(3)
R0 FROM SAVED WORKSPACE
69800000
USING M,PXR
69810000
MVC 0(16,2),REGSV+2*4 DELIVER ACCOUNTING INFORMATION
69820000
LR
5,LINK
PRESERVE LINK FOR LATER USE
69830000
L
HISTVAL,REGSV+4*4 CONNECT TIME FOR THIS SESSION
69840000
LA
PHR,PERHCONN
HISTAGRAPH
69850000
BAL LINK,HISTCOMP
69860000
L
HISTVAL,REGSV+5*4 CPU TIME FOR THIS SESSION
69870000
LA
PHR,PERHCPU
HISTAGRAPH
69880000
BAL LINK,HISTCOMP
69890000
L
1,KEXPLIM
PURGE EXPRESS TERM IE
69900000
OR
1,4
69910000
BAL LINK,PRGIE
WHICH MAY NOT BE ENQUED
69920000
LH
0,KX24M+2
R0 = -1
69930000
BAL LINK,POSOM
DECREMENT SIGNED ON COUNT
69940000
LR
LINK,5
RESTORE LINK
69950000
DROP PXR
69960000
B
WWZO1
REWRITE DIRECTORY
69970000
DROP 10
69980000
*
69990000
*
END OF DIRECTORY SEARCH SAVE OPERATION
70000000
*
ASSUME REACHED BY BALR LINK,10 = = = = = = = = = = = =
70010000
USING DSZSAVE,10
70020000
DSZSAVE CLI DIRCHANG,2
70030000
BE
DSZBAD
INVALID SAVE OPERATION
70040000
L
0,LIBBASE
70050000
AH
0,DSFILE
70060000
ST
0,CDCBASE
70070000
MVI CDOP,6
END OF WRITE TO LIBRARY IS HANDLED 70080000
*
LIKE DROP END OF DIRECTORY SEARCH
70090000
LM
4,5,SDT & HDCORE
70100000
MVC CCPAR1+1(3),PCADDR PRESERVE OLD LABEL
70110000
L
3,CCPAR1
70120000
USING M,3
70130000
MVC WFLLIB(LWFLAB),OBUF-M(PXR) NEW WS LABEL FROM DIRSEAR
70140000
MVC PHYCYL,DIRSRES
ADDRESS FROM DIRECTORY
DASD 70150000
STM 4,5,CDTERM
BASE REGISTER TROUBLE PREVENT
70160000
B
CDCOMPS
BRANCH TO DSZS1
70170000
DROP 10
70180000
*
END OF WORKSPACE WRITE DURING SAVE
70190000
DROP 3
70200000
USING WWZSAVE,10
70210000
WWZSAVE TM
DIRCHANG,1
70220000
BZ
SETDROPZ
DIRECTORY IS UNCHANGED
70230000
DROP 10
70240000
*
70250000
*
END OF DIRECTORY SEARCH DROP
70260000

DSZDROP TM
DIRCHANG,1
MUST BE ONE OR THREE
BZ
DSZBAD
INVALID DROP
WWZO1
MVC PHYCYL,DIRCYL
ADDRESS FROM DIRECTORY
DASD
MVC CDCBASE,LIBBASE
ALL DIRECTORIES ON FIRST FILE
MVI CDOP,14
WRITE SECOND COPY NEXT
L
4,SDT
L
5,PTCORE
DIRECTORY CORE SLOT
STM 4,5,CDTERM
B
CDCOMPS
DROP 4,5
SAVE & DROP BASE REGISTERS
SETDROPZ MVC SDQZSW,=A(DROPZ)
ERASE DIRECTORY NEXT TIME THROUGH
*
SCHEDULER
B
RINGSUB
ENCOURAGE TRIP THROUGH SCHEDULER
*
*
WRITE SECOND COPY OF DIRECTORY
DIR2ND MVC PHYCYL,ALTCYL
ALTERNATE DIRECTORY
DASD
MVI CDOP,8
GO TO DIR3RD AT SELECTOR INTERRUPT
B
CDCOMP2
*
USING PERTERM,3
LOAD AND COPY BASE REGISTERS
USING PERCORE,4
*
END OF DIRECTORY SEARCH LOAD
*
ASSUME REACHED BY BALR LINK,10 = = = = = = = = = = = =
DSZLOAD CLI DIRCHANG,0
BNE DSZBAD
INVALID LOAD
LM
3,4,SDT &HDCORE
MVI PCTERM+1,EMPTYM
OLD WORKSPACE
B
DSZCOP2-DSZLOAD(10)
*
END OF DIRECTORY SEARCH COPY OPERATION
USING DSZCOPY,10
DSZCOPY CLI DIRCHANG,0
BNE DSZBAD
INVALID COPY
LM
3,4,SDT & HDCORE
MVC PCTERM+1(3),SDT+1
ST
4,PTCORE
WORKSPACE IS RECONNECTED
MVI ACTIVE,LOCKM
SINK (HIGH PRIORITY)
PTSET ACTIVE
OI
IOB1,COPYRM
MARK THIS AS SINK OF COPY OPERATION
L
3,COPSOUR
MVC ACTIVE(4),KDSZCOPY
SETUP ACTIVE,MISCB,IOB1,IOB2(SINK)
PTSET ACTIVE
PTSET MISCB
PTSET IOB1
PTSET IOB2
DROP 10
DSZLOAD BASE REG IS DIFFERENT
DSZCOP2 MVC PHYCYL,DIRSRES
LIBRARY CYLINDER FOR DISK READ DASD
L
0,LIBBASE
AH
0,DSFILE
GET PROPER DISK ADDRESS
ST
0,CDCBASE
MVI PTCORE+1,EMPTYM
L
4,CDCORE
DIRECTORY SLOT
MVI PCTERM+1,EMPTYM
MVC CDCAD+1(3),PCADDR
LA
2,CDTERM+PERDISK-PDTERM ADDR OF DUMMY PERDISK
ST
LINK,DSZEXIT
MVI CDOP,10
RESET OURDISK UPON COMPLETION OF SEL
BAL LINK,RSELSTAR
SET MORE FLAGS AND SIO
L
LINK,DSZEXIT
B
SDKILL
TERMINATE SPECIAL DISK OPERATION
DROP 3,4
END OF LOAD COPY

70270000
70280000
70290000
70300000
70310000
70320000
70330000
70340000
70350000
70360000
70370000
70380000
70390000
70400000
70410000
70420000
70430000
70440000
70450000
70460000
70470000
70480000
70490000
70500000
70510000
70520000
70530000
70540000
70550000
70560000
70570000
70580000
70590000
70600000
70610000
70620000
70630000
70640000
70650000
70660000
70670000
70680000
70690000
70700000
70710000
70720000
70730000
70740000
70750000
70760000
70770000
70780000
70790000
70800000
70810000
70820000
70830000
70840000
70850000
70860000

KDSZCOPY DC
AL1(0,0,COPYWM,0)
70870000
*
70890000
TITLE 'I N T E R V A L E V E N T S'
70900000
USING PERTERM,PTR
70910000
USING MPXSAVE,MR
70920000
*
MR AND PTR ARE VALID FOR MOST INTERVAL EVENTS
70930000
*
70940000
*
70950000
USING IEMPX,10
70960000
IEMPX
CLI PTTYPE,0
IGNORE INTERVAL EVENT TO DUMMY
70970000
BE
EXTIM2
PERTERM OR TO PUBENT
70980000
MVI DELZFLG,1
FOR MPXEXIT
70990000
NI
STATE,255-QIEBIT
AVOID PURGE AT MSIOERR
71000000
MVC DELPSW+3(1),PTUNAD
71010000
MVC MXOLDPSW(16),DELPSW DUMMY CSW AND EXIT ADDREESS
71020000
LH
1,MPXCHANL
CHANNEL ADDRESS
5991 71030000
IC
1,PTUNAD
71040000
BAL 3,IODADV
RECORD SGDELZ
71050000
USING IODBUG,2
71060000
MVI IODIE,X'FD'
INDICATE MPX IE
71070000
MVC IODTYPE,PTTYPE
RECORD PTTYPE & STATE
71080000
MVC IODCCB,PUCCB
RECORD PUCCB
71090000
DROP 2
71100000
BAL 1,DEVXCC
PREPARE TO SKIP MSIOERR CODE
71110000
LR
PXR,6
71120000
MVI MSERR,0
PSEUDO INTERRUPT
71130000
LA
SIGR,SGDELZ
71140000
B
ANALSIG
71150000
*
71160000
USING IECLOK,10
71170000
IECLOK NI
MISCB,255-CLOKWAIT DESUSPEND AFTER TIME INTERVAL
71180000
BNZ EXTIM2
MISCM IS OR/MISCB
71190000
MVI RESCH,1
POST SCHEDULER
C023 71200000
NI
ACTIVE,255-MISCM
71210000
B
EXTIM2
71220000
*
71230000
*
SIGN OFF HOLD KILL
71250000
USING IESOHK,10
71260000
IESOHK CLI STATE,DVBUSY+READS
71270000
BNE IESOH2
PROCRASTINATE HIO
71280000
MVI PTFBUF+1,EMPTYM
AVOID RELEASE OF NONBUFFER
71290000
MVI STATE,DVBUSY+TODROP DISABLE AT NEXT INTERRUPT
71300000
LA
PTR,0(PTR)
71310000
BAL LINK,OFFSUB
KILL POSSIBLE WORKSPACE
71320000
BAL LINK,HIOSUB
HALT READ
71330000
B
EXTIM2
71340000
*
EXTRA TWO SECONDS GRACE
71350000
IESOH2 LR
2,PTR
71360000
O
2,SVOFLIM
RE-ENQUEUE SIGNOFF HOLD KILL
71370000
LA
3,TWOSEC
71380000
L
0,REALTIME
71390000
BAL 5,ENQIET
71400000
B
EXTIM2
71410000
DROP 10
3064 71420000
*
71630000
*
PANICINT HAS ELAPSED, SETPAN HAS NOT BEEN PURGED
71640000
USING SETPAN,PTR
71650000
SETPAN
71660000
DROP PTR
71670000
*
71680000

*
SET PANICINT TO PROTECT AGAINST A RUN-AWAY INTERPRETER
SETBELL0 BALR PTR,0
ESTABLISH ADDRESSIBILITY FOR SETBELL 3064
USING SETBELL,PTR
3064
SETBELL LM
2,3,QUANLIM
QUANTUM LIMIT EVENT DATA
3064
*
QZACT SETPAN
GET CPU TIME USED
3064
QZACT SETPAN
GET CPU TIME USED
3064
SR
3,0
SUBTRACT FROM TIME REQUESTED
3064
LA
3,MAXQUAN/6(,3) ADD AN EXTRA 15 PERCENT FOR SECON 3064
*
AND SUBSEQUENT ATTEMPTS TO GET A
3064
BP
SETBELL2
FULL QUANTUM
3064
DROP PTR
3064
SETBELL1 LM
2,3,PANLIM
PANIC LIMIT EVENT
3064
SETBELL2 ST
2,QZPRG
SAVE EVENT TYPE FOR PRGIE AT QEND
3064
L
0,REALTIME
BAL 5,ENQIET
SETUP PANICINT
BAL LINK,RINGSUB
TERMINATE QUANTUM
B
EXTIM2
*
*
*
EXPLIM MINUTES AFTER SIGNON AT AN EXPRESS PORT.
*
BOUNCE HIM IF HE HAS NOT PAID THE SCHNELLZUG AUSLAG
USING IESZUG,10
USING PERTERM,PTR
IESZUG LA
8,EXTIM2
RETURN ADDRESS FOR BOUNSUB
TM
IOB2,SHEXP
BCR 8,8
HE HAS PAID THE AUSLAG
*
FALL INTO BOUNCE SUBROUTINE
*
*
BOUNCE SUBROUTINE
*
PTR IS TERMINAL TO BOUNCE
*
R8 IS RETURN
*
R10 IS LOCAL BASE
BOUNSUB BALR 10,0
USING *,10
TM
IOB1,NSIGNM
IGNORE IF NOT SIGNED ON
BZ
BOUN1
TM
MISCB,NOWSM
ALLOW BOUNCE IF NSIGNM BUT NOT
BCR 1,8
IF TERM IS WITHOUT WS
BOUN1
EQU *
*
WE ASSUME A POSSIBLE COPY WILL
*
TERMINATE EVENTUALLY. A CALL TO
*
COPKILL IS NOT DESIRABLE HERE.
OI
IOB2,BOUNCM
FORCE HIM OFF
C
PTR,SDT
DO NOTHING NOW IF THIS IS
BCR 8,8
THE SPECIAL DISK TERMINAL
BAL 5,SHCPUSUB
SET CPU LIMIT TO ONE SECOND
LR
1,PTR
ASSUME MPX EVENT ENQ'D
TM
MISCB,CLOKWAIT
PURGE CLOKWAIT EVENT
BZ
*+8
IF ENQ'D, ELSE PURGE MPX
O
1,KIETCLOK
BAL LINK,PRGIE
CLI DESBYTE,0
MESSAGE TO LOG MAYBE
BE
BOUN2
LEAVE IN TRAWAIT
BOUN4
MVC ACTIVE(2),ZERO
CLEAR ATTENTION AND SUSPENSION BITS
PTSET ACTIVE
PTSET MISCB
BOUN2
EQU *
CLI STATE,WRITES+DVBUSY
BCR 8,8 BER
ALLOW OUTPUT TO FINISH
TM
STATE,SENREQ
TRUE IF STATE IS TRANSIENT

71690000
71710000
71720000
71730000
71740000
71750000
71760000
71770000
71780000
71790000
71800000
71810000
71820000
71880000
71890000
71900000
71910000
71920000
71930000
71940000
71950000
71960000
71970000
71980000
72000000
72010000
72060000
72070000
72080000
72090000
72100000
72110000
72120000
72130000
72150000
72160000
72170000
72180000
72190000
72200000
72210000
72220000
72240000
72260000
72270000
72320000
72330000
72340000
72350000
72360000
72370000
72380000
72390000
72410000
72460000
72470000
72480000
72490000
72500000
72510000

BOUN5
*
*
*
*
*
*
KEXPLIM
HILIM
LOWTIME
LOWLIM
HIGHTIME
*
*
CONN
*
CPU
*
*
*
*
APLCNCL
*
*
*
CNCHIO

CNCHIO1

CNCHIO2
*
*

BO
EX
XI
TM
BNZ
MVI
TM
MVI
BCR
MVI
LR
B
DROP

*+8
0,HIDESTAT
SAVSTAT,READS
SAVSTAT,X'0F'
*+8
PTFBUF+1,EMPTYM
STATE,DVBUSY
STATE,IDLE
8,8 BER
STATE,IDLE+DVBUSY
LINK,8
HIOSUB
10

SVSTAT IS ALREADY PERM STATE

SAVSTAT IS STATE

72520000
72530000
72540000
ALL ZERO IN READ STATE
72550000
PTFBUF POINTS TO A BUFFER
72560000
AVOID RELEASE OF NON-BUFFER
72570000
SEE IF COMMAND IS PENDING
72580000
ASSUME NO
72590000
NO COMMAND ERGO, NO HIO
72600000
72610000
HIOSUB EXIT IS BOUNSUB EXIT
72620000
72630000
72640000
72650000
SETHILO
72670000
ENTRY HILIM
72680000
72690000
HILIM ENTRY IN TRANSFER VECTOR ALLOWS OPFNS ACCESS TO
72700000
PPERQ EXPLIM HILIM LOLIM
72710000
*** NOTE *** OPFNS MAKE ASSUMPTIONS ABOUT ORDERING ***
72720000
TIME LIMIT FOR EXPRESS (SCHNELLZUG) TERMINALS
72730000
DC
A(IETSZUG*F*F*F,EXPLIM)
72740000
IEBRN APLSETHI,MAXQUAN
LIMIT ON HIGH PRIORITY.
72750000
EQU HILIM+4
72760000
IEBRN APLSETLO,MINQUAN
LIMIT ON LOW PRIORITY.
72770000
EQU LOWLIM+4
72780000
72800000
72810000
PHGEN 2178000,122,6
CONNECT TIME FOR THIS SESSION
72820000
72830000
PHGEN 14460,242,7
CPU TIME FOR THIS SESSION
72840000
72850000
DROP MR
72860000
TITLE 'MULTIPROGRAMMING APL TERMINATION.'
72880000
73050000
THE OPERATOR HAS SIGNED OFF AFTER USING 'SHUTDOWN'
73060000
73070000
BALR 9,0
73080000
USING *,9
73090000
73110000
HALT ALL 270X LINES
73120000
73130000
LM
0,2,PTBXLE
73140000
USING PERTERM,2
73150000
CLI PTTYPE,0
IF DUMMY PERTERM, IGNORE
73160000
BE
CNCHIO2
73170000
CLI PTTYPE,Q1052
IF NOT 270X DEVICE, IGNORE LASO
73180000
BNL CNCHIO2
73190000
LH
1,MPXCHANL
AVOID HIO ON BURST MODE
5991 73200000
TCH 0(3)
BECAUSE IT IS PROBABLY FOR ANOTHER 73210000
BC
2,*-4
DEVICE
73220000
IC
3,PTUNAD
73230000
MVI CSW+4,0
73240000
HIO 0(3)
73250000
TM
CSW+4,CUB2702
270X REJECTED HIO
73260000
BO
CNCHIO1
HIT IT AGAIN
73270000
BXLE 2,0,CNCHIO
73280000
DROP 2
73290000
73300000
SET STORAGE KEYS BACK THE WAY THE HOST SYSTEM HAD THEM
73310000

*
L
SR
IC
BAL
*
*
*
*
*

ACTIVE WORKSPACE, MAYBE.

HOST ASSIGNED PROTECT KEY.
RESET STORAGE KEYS.

K03
K03
K03
K03
K03
LA
1,OSEXIT
NEXT TIME THE DAUGHTER TASK IS 5996
L
3,RBFILLE
DISPATCHED BY OS, GO TO
5996
ST
1,RBOPSW+4(3)
THE TERMINATION CODE.
5996
OI
RESCH,4
MAKE SURE SUBTASK GETS POSTED
K03
B
EXRET
DROP 9
K03
HAS TERMINATED, TELL MOTHER ALL ABOUT IT.
K03
K03
SR
15,15
RC=0 FOR NORMAL TERMINATION
K03
SVC EXIT
K03
SPACE 3
K03
EQU 3
K03
SPACE 1
ROUTINE TO POST DAUGHTER TASK
SPACE 1
USING MVTPOST,2
TM
ECBFILLE,X'40' ALREADY POSTED ?
C042
BCR 7,1
YES, SO DON'T DO IT AGAIN
C042
SPACE 1
STM 0,15,RPOSTSV
SR
10,10
RETURN CODE.
LA
11,ECBFILLE
DAUGHTER'S ECB.
L
12,TCBFILLE
ADDRESS OF DAUGHTER'S TCB.
L
15,CVT
ADDRESS OF THE CVT.
L
15,CVT0PT01(15)
BRANCH ENTRY TO POST.
BALR 14,15
USING *,14
LM
0,15,RPOSTSV
USING APLLOW,14
BR
1
RETURN.
SPACE 1
DS
16F
SPACE 1
TITLE 'SELECTOR CHANNEL START IO AND ERROR RECOVERY ROUTINES'
SELECTOR CHANNEL START IO AND ERROR RECOVERY ROUTINES
USING SELSTAR,10
SELSTAR

IT IS TIME TO TERMINATE THE APL SUBTASK.

ARRANGE FOR DAUGHTER TO BE POSTED,
AT WHICH TIME THE SVC EXIT WILL BE EXECUTED.

*
* APL
*
OSEXIT
EXIT
*
MVTPOST

RPOSTSV
*

6,CURRENTM
3,3
3,INACTKEY
LINK,SSKSUB

*
*
* SELECTOR CHANNEL DISK ERROR RETRY SUBROUTINE
SELRTRY LA
0,8
LOCATE SEEK COMMAND
MVI SELFERR,0
CLEAR CDCOMP FORCED ERROR MARK
MVI RD1A,0
CLEAR TIC/NOP BEFORE RETRY
2540
MVC SELSTAT,CSW+4
SAVE STATUS FOR SELERLOG
DASD
L
1,CSW
LA
1,0(0,1)
REMOVE HIGH-ORDER GARBAGE
SELRTR1 SR
1,0
BM
DRA2
ADDRESS WAS ZERO, NO CCW CHAIN
CLI 0(1),SEEK

73320000
73330000
73340000
73350000
73360000
74430000
74440000
74450000
74460000
74470000
74480000
74490000
74500000
74510000
74520000
74530000
74540000
74550000
74560000
74570000
74580000
74590000
74600000
74630000
74640000
74650000
74660000
74670000
74800000
74890000
74900000
74910000
74920000
74930000
74940000
74950000
74960000
74970000
74980000
74990000
75000000
75010000
75020000
75030000
75050000
75060000
75070000
75080000
75090000
75100000
75110000
75120000
75140000
75150000
75160000
75170000
75180000
75190000
75200000
75210000

BNE SELRTR1
EQU *
SA ONLY, ENTRY FROM SELSTAR
L
2,0(1)
SEEK DATA ADDRESS
MVC SELSENS+4(2),2(2) CYLINDER
DASD
MVC SELSENS+7(1),5(2) HEAD
DASD
MVI SEEKAD,0
POSSIBLE GARBAGE HERE, ALSO
LA
0,1
AH
0,SELCNT
INCREMENT ERROR COUNT
STH 0,SELCNT
C
1,SEEKAD
SAME AS PREVIOUS ERROR MAYBE
BNE DRA1
NEW ERROR
CLI SELCNT+1,SELERMX
COMPARE WITH MAX NUMBER RETRIES
BL
DRA2
SELRTR2 EQU *
ENTRY FROM SCHEDULER DETECTED FOR
DASD
*
UNRECOVERABLE I/O ERROR
DASD
TM
SWITCHES,SELAPENT IF WE ENTERED THE APPENDAGE
DASD
BO
SELOGIT
WE FILLED IN THE SELERLOG DATA DASD
LA
9,DSKIOB
LETS USE THE DSECT
DASD
USING IOBD,9
TELL THE ASSEMBLER
DASD
MVC SELSTAT,IOBCSW+3
OTHERWISE WE SHOULD FILL IT IN DASD
MVC SELSENS(2),IOBSENS0 FROM THE IOB
DASD
MVI SELSENS+2,X'FF'
THIS MEANS THAT THERE ARE ONLY DASD
*
TWO VALID SENSE BYTES AND THAT FOLLOWING
DASD
MVC SELSENS+3(1),IOBECBCC THIS IS THE COMPLETION CODE DASD
MVC SELSENS+4(2),IOBSEEK+3 MOVE IN THE CYLINDER
DASD
MVC SELSENS+6(1),IOBSEEK+5 AND THE LAST H FOR CCH
DASD
L
9,IOBDCB
GET THE ADDRESS OF THE DCB
DASD
L
9,DCBDEB(9)
GET THE DEB ADDRESS
DASD
L
9,DEBUCB(9)
GET UCB ADDRESS
DASD
MVC SELUNIT,UCBCHA(9) MOVE IN CUU
DASD
MVO SELUNIT(1),CDOP
AND THE CURRENT OPERATION
DASD
SELOGIT BAL 9,SELERLOG
LOG THE ERROR
DASD
CLI DOP+1,X'06'
UGH NE
PERMANENT WRITE ERROR
*
*
PERMANENT READ ERROR
CLC CDCBASE(4),LIBBASE ARE DIRECTORIES IN THIS EXTENT?
BNE DRP30
NO. NONDISASTER
CLC PHYCYL,ALTCYL
IF THIS IS THE ALTERNATE
DASD
UGH E
THE DIRECTORY IS LOST
DASD
CLC PHYCYL,DIRCYL
DISASTER ONLY IF READING
DASD
BNE DRP30
A DIRECTORY
*
*
DIRECTORY READ ERROR RECOVERY.
*
DASD
*
TRY TO READ SECOND COPY OF DIRECTORY
DASD
*
DASD
MVC PHYCYL,ALTCYL
OTHERWISE TRY THE ALTERNATE
DASD
B
DRP4
GO START READING
DASD
*
PERMANENT READ ERROR OF A WORKSPACE
DRP30
MVI SELBUSY,0
GIVE UP GRACEFULLY
MVI CDCBASE+1,EMPTYM
FORCE PROG CK IF NOT SET BEFORE USE
LH
1,COPLIM
MUST DECREASE ALLOWABLE NUMBER OF
BCT 1,DRP6
COPIES AND LIBS IF THIS IS SWAP AREA
UGH ,
UNRECOVERABLE DIRECTORY READ ERROR
*
DRP6
L
PTR,CDTERM
HAPLESS TERMINAL
CLI CDOP,2
CHECK FOR SWAP AREA
BNE LEMP
NOT A SWAPPING READ
STH 1,COPLIM
SWAPPING READ. DROP COPLIM.
DRSIO2

75220000
75230000
75240000
75250000
75260000
75270000
75280000
75290000
75300000
75310000
75320000
75330000
75340000
75420000
75430000
75440000
75450000
75460000
75470000
75480000
75490000
75500000
75510000
75520000
75530000
75540000
75550000
75560000
75570000
75580000
75590000
75610000
75620000
75630000
75640000
75650000
75660000
75670000
75680000
75690000
75700000
75710000
75720000
75730000
76010000
76020000
76030000
76040000
76050000
76070000
76080000
76090000
76100000
76110000
76120000
76130000
76140000
76150000
76160000
76170000

L
MVC
B
*
DRA1
DRA2
*

DRSIO3

NON-

*
*
*
*
*
*
SELERLOG

SELSTAT
SELERSAV
SELSENS
SELCNT

1,CDDISK
MAKE SLOT UNUSABLE AND LOSE
PDTERM+1-PERDISK(3,1),=AL3(DUMINACT) UNREADABLE WS
LEMP
ESTABLISH LOAD EMPTY

ST
1,SEEKAD
EQU *
DASD
MVT APPENDAGE - GET SENSE BYTES FROM UCB.
L
2,APLSAVE+4*7
UCB ADDRESS.
LH
1,UCBCHA(2)
PHYSICAL CHANNEL AND UNIT ADR DASD
N
1,=F'16383'
X'3FFF' OS USES THE TOP TWO BITS DASD
MVC SELSENS(4),UCBSNS(2)
USING MPXSAVE,MR
DASD
TM
UCBFL5(2),X'08'
ARE THESE THE SENSE BYTES
DASD
BZ
DRSIO3
YES
DASD
L
3,UCBSNS+2(2)
IF NOT, USE INDIRECT ADDRESSING DASD
MVC SELSENS(4),0(3)
FOR THE SENSE BYTES
DASD
BAL 3,IODADV
USING IODBUG,2
MVC IODSENSE,SELSENS
ERROR RECORD
MVO IODCDOP(1),CDOP
SAVE CURRENT OP
MVC SELUNIT(2),IODCDOP SAVE CDOP & CUU FOR LATER PRINTING
DROP 2
TM
CSW+4,UC
UNIT CHECK ERROR
DASD
BCR 1,LINK
MAKE IOS DO ERROR RECOVERY
DASD
UC ERROR
DASD
L
0,SEEKAD
ADDRESS OF LAST SEEK
DASD
B
SELSTAR
RESTART IO OPERATION
DASD
DASD
LOG PERMANENT I/O ERRORS
DASD
DASD
ERROR REPORT FORMAT:
DASD
OCCU=____,STATUS=____,SENSE=________,CCH=______
DASD
DASD
EQU *
DASD
STM MR,9,SELERSAV
SAVE THE REGS
L
MR,SVBASE
AND ADDRESS MPX CODE
UNPK ERLGA2,SELSENS(5)
SENSE=________,
TR
ERLGA2,HEXTAB
MVI ERLGA2+L'ERLGA2-1,ZCOMMA
UNPK ERLGA6,SELSTAT(3)
STATUS=____,
DASD
TR
ERLGA6,HEXTAB
DASD
MVI ERLGA6+L'ERLGA6-1,ZCOMMA
DASD
UNPK ERLGA3(5),SELSENS+4(3) CCH=______
DASD
UNPK ERLGA3+4(3),SELSENS+7(2)
DASD
TR
ERLGA3,HEXTAB
MVI ERLGA3+L'ERLGA3-1,ZBLANK
DASD
UNPK ERLGA4,SELUNIT(3)
OCUU=____,
TR
ERLGA4,HEXTAB
MVI ERLGA4+L'ERLGA4-1,ZCOMMA
LA
3,ERLGA1
BAL LINK,NUINS
INSERT NOTE FROM UNDERGROUND
LM
MR,9,SELERSAV
RESTORE THE REGS
MVI SELCNT+1,0
ZERO SEL CHAN ERROR COUNTER
BR
9
RETURN
DC
H'0'
LAST ABNORMAL STATUS FOR SELERLOG DASD
DS
15F
REGISTER SAVE AREA
DROP MR
DC
F'0'
FOUR BYTES FOR SEL CHAN SENSE BYTES
DC
X'0000FE00'
FOR IODTAB STORAGE
DC
H'0'
SEL CHAN ERROR COUNT

76180000
76190000
76200000
76260000
76310000
76320000
76490000
76500000
76510000
76520000
76530000
76540000
76550000
76560000
76570000
76580000
76690000
76700000
76710000
76720000
76730000
76740000
77010000
77020000
77030000
77040000
77050000
77060000
77070000
77080000
77090000
77100000
77110000
77120000
77140000
77150000
77160000
77170000
77180000
77190000
77200000
77210000
77220000
77230000
77240000
77250000
77260000
77270000
77280000
77370000
77380000
77390000
77400000
77410000
77420000
77430000
77440000
77640000
77650000
77700000

SELUNIT DC
H'0'
OCUU OF LAST SEL CHAN ERROR
SEEKAD DC
F'0'
ADDRESS OF LAST GOOD SEEK
DASD
DROP 10
DASD
ERLGX
DC
D'0',F'0'
TEMP SAVE AREA
ERLGA1 DC
Y(ERLGAZ-*-3)
DC
AL1(ZO,ZC,ZU,ZU,ZEQ)
ERLGA4 DC
CL5' '
DC
AL1(ZS,ZT,ZA,ZT,ZU,ZS,ZEQ)
DASD
ERLGA6 DC
CL5' '
DASD
DC
AL1(ZS,ZE,ZN,ZS,ZE,ZEQ)
ERLGA2 DC
CL9' '
DC
AL1(ZC,ZC,ZH,ZEQ)
DASD
ERLGA3 DC
CL7' '
DASD
DC
AL1(ZCR,ZEOB)
DASD
ERLGAZ EQU *
TITLE 'UGH CATASTROPHIC (BUT RECOGNIZED) SYSTEM FAILURE.' K01
*
K01
*
A CATASTROPHIC FAILURE CONDITION HAS BEEN RECOGNIZED
K01
*
THE CURRENT ENVIRONMENT ( REGISTERS AND LOW CORE ) K01
*
WILL BE SAVED , AND APL ABNORMALLY TERMINATED.
K01
*
K01
DROP 14
K01
USING UGHS,MR
ADDRESSIBILITY ESTABLISHED AT UGH
K01
*
K01
* AT CALL TO UGH, A BAL 14,UGH WAS EXECUTED. AT UGH, REG MR
K01
*
WAS SAVED AT 0(14), AND ADDRESSIBILITY TO UGHS ESTABLISHEDK01
*
K01
UGHS
NOP REUGH
K01
MVI UGHS+1,X'F0'
K01
NI
UGHQA+3,X'E0' ALIGN ADDRESS FOR EASY DUMP READING K01
L
MR,UGHQA
K01
DROP MR
K01
XC
0(256,MR),0(MR)
AN ALL ZERO AREA TO MAKE IT
K01
USING UGHAREA,MR
STAND OUT IN A DUMP
K01
UGHAREA DSECT
K01
UGHAREAG DS
8D
BLANK LINES
K01
REGS
DS
16F
K01
DS
4D
2217
FR0
DS
D
K01
FR2
DS
D
K01
FR4
DS
D
K01
FR6
DS
D
K01
DS
8D
K01
*
K01
LCOR
DS
XL256
K01
UGHAREAZ DS
0D
K01
UGHAREAL EQU UGHAREAZ-UGHAREAG
K01
APLSUP CSECT
K01
*
K01
STM 0,15,REGS
K01
STD 0,FR0
K01
STD 2,FR2
K01
STD 4,FR4
K01
STD 6,FR6
K01
MVC LCOR(256),0
K01
MVC REGS+4*MR(4),0(14)
K01
DROP MR
K01
REUGH
BALR 2,0
SUG
USING *,2
SUG
L
14,ADAPLLOW
ADDRESSABILITY FOR APLLOW.
2217

77710000
77840000
77850000
77880000
77890000
77900000
77910000
77920000
77930000
77940000
77950000
77960000
77970000
78010000
78020000
78050000
78060000
78070000
78080000
78090000
78100000
78110000
78120000
78130000
78140000
78150000
78160000
78170000
78180000
78190000
78200000
78210000
78220000
78230000
78240000
78250000
78260000
78270000
78280000
78290000
78300000
78310000
78320000
78330000
78340000
78350000
78360000
78370000
78380000
78390000
78400000
78410000
78420000
78430000
78440000
78450000
78460000
78470000
78480000
78500000

USING APLLOW,14
2217
L
1,ABCODE
ABEND CODE 1200,DUMP
2217
TM
UGHSW,SVC+EXTERNAL SVC OR EXTERNAL?
2217
BZ
UGHMPX
NO.
2217
*
NO RETURN HAS TO BE MADE SO ABEND HERE.
2217
UGHABEND ABEND (1)
ABEND 1200,DUMP
2217
UGHMPX TM
UGHSW,MPXIO+APPENDG IF IT'S NOT MPX OR APPENDG WE 2217
BZ
UGHABEND
ARE LOST SO ABEND.
2217
L
0,TCBFILLE
ABTERM FILLE.
2217
L
4,CVT
2217
LR
7,14
SAVE REG 14 ACROSS ABTERM.
2217
L
14,CVTBTERM(4)
ABTERM ADDRESS.
2217
BALR 14,14
ABTERM RETURNS ON REG 14.
2217
LR
14,7
RESTORE REG 14.
2217
TM
UGHSW,MPXIO
MPX?
2217
BZ
UGHAPPN
NO. IT IS APPENDG.
2217
L
5,CVTTCBP(4)
TCBNEW/OLD POINTER.
2217
MVC 0(8,5),MXCVTTCB
RESTORE ORIGINAL NEW/OLD.
2217
XC
CSW(8),CSW
CLEAR CSW.
2217
CLC TCBMERE,MXCVTTCB+4 MERE CURRENT?
2217
BE
IOREJ
YES-GOTO TO DISPATCHER VIA IOS 2217
CLC TCBFILLE,MXCVTTCB+4 FILLE CURRENT?
2217
BNE IOREJ
NO. RETURN TO INTERRUPTEE.
2217
* SINCE FILLE IS CURRENT, MOVE RBOPSW TO IOOLDPSW AND
2217
* GO TO THE OS DISPATCHER VIA IOS.
2217
L
6,RBFILLE
2217
MVC IOOLDPSW,RBOPSW(6) MOVE RBOPSW TO IOOLDPSW.
2217
B
IOREJ
OFF TO IOS AND THE OS DISPATCHER2217
* REG 10 IS THE DISPLACEMENT USED FOR RETURN TO IOS. IT IS SET
2217
* TO +12 SO THAT WE ARE NOT POSTED AND THE RQE IS NOT RELEASED.
2217
*
2217
UGHAPPN MVI 4*10+APLSAVE+3,12 BRANCH RETURN TO IOS.
2217
LR
9,14
ADDRESSABILITY
2217
B
SELUGH
BACK TO IOS+12.
2217
ABCODE DS
0F
ABEND 1200,DUMP
2217
DC
X'80'
DUMP
2217
DC
AL3(1200)
ABEND 1200
2217
ADAPLLOW DC
A(APLLOW)
2217
DROP 2,14
2217
UGHQA
DC
A(TYPEIN+31)
+31 IS ALIGNMENT FOR DUMP.
2217
TITLE 'LITERALS, DSECTS, AND MISC TABLES
05/11/70'
*
ORG LTAR
PUT LITERALS UNDER BASE REG ZERO
LTORG
LTARY
EQU *
MUST BE LESS THAN OR EQ LTARZ
LTARX
DS
0XL(1+LTARZ-LTARY) CONDITIONAL ERROR FLAG AND LENGTH
* IF PREVIOUS CARD HAS ERROR MESSAGE, INCREASE LTAR STORAGE
*
ORG
SOMBF
DS
H,130C
HI MESSAGE BUFFER
BROADBF DS
H,130C
PA MESSAGE BUFFER
ORG SOMBF
DC
H'0'
SOMBF & BROADBF MUST BE ON HALF WORD
*
SVINIT
*
ORG
*
*
*
ONE COPY PER CORE SLOT

78510000
78520000
78530000
78540000
78550000
78560000
78570000
78580000
78590000
78600000
78610000
78620000
78630000
78640000
78650000
78660000
78670000
78680000
78690000
78700000
78710000
78720000
78730000
78740000
78750000
78760000
78770000
78780000
78790000
78800000
78810000
78820000
78830000
78840000
78850000
78860000
78870000
79010000
79020000
79030000
79050000
79060000
79070000
79080000
79090000
79100000
79110000
79120000
79130000
79140000
79150000
79160000
79170000
79180000
79190000
79200000
79210000
79220000
79230000
79240000

PERCORE
PCQUONT
PCADDR
PCTERM

DSECT
DS
1H
QUONT COUNTER
DS
AL3
STARTING ADDRESS OF THIS SLOT
EQU *-1
PERTERM BASE REGISTER
DS
AL3
HIGH ORDER BIT ON MEANS UNASSIGNED
DS
0D
PERCOREL EQU *-PERCORE
PERDISK DSECT
ONE PER DISK AREA
PDDA
DS
F
CCHH - DASD CYLINDER, HEAD ADDRESS DASD
PDXTENT EQU *
SWAP EXTENT INDEX (PSFILE FORMAT)
DASD
PDTERM DS
X
DS
AL3 (PERTERM)
HIGH ORDER BIT MEANS UNASSIGNED
PERDISKL EQU *-PERDISK
IEBLOCK DSECT
INTERVAL TIMER EVENT QUE BLOCK
IEBASE DS
A
DESCRIBES EVENT
IELINK DS
A
LINK TO NEXT IEBLOCK
IETIME DS
F
CLOCK TIME AT WHICH EVENT IS DESIRED
PERDEVXG CSECT
*
TABLE OF DEVICE CHARACTERISTICS, ENTRIES FOLLOW PERDEVX LAYOUT
*
NOTE.. CODE AT END OF UNRZ DEPENDS ON VALUES OF Q2741,Q1050
MPDVX TS41
TSS 2741
MPDVX 2741
MPDVX AMBIG
MPDVX 1050
MPDVX 1052
DC
20X'00' DUMMY PERDEVXG ENTRY FOR AUX TERMINAL BAM15
*
LOW ORDER BITS OF STATE BYTE
WRITES EQU 0
WIRS
EQU 1
WRITE INT REQ STATE
LISTEN EQU 2
PREPARE COMMAND LOADED
IDLE
EQU 3
NO COMMAND LOADED
READS
EQU 4
PROCR
EQU 5
PROCRASTINATED SIO
LIRS
EQU 7
LISTEN INT REQ STATE
TODROP EQU 8
DROP LINE AT NEXT INTERRUPT
DIAGN
EQU 9
DIAGNOSTIC STATE
*
HIGH ORDER BITS OF STATE BYTE
DVBUSY EQU X'80'
COMMAND LOADED
DEMISS EQU X'40'
SPECIAL BIT
SENREQ EQU X'20'
WITH PROCR, SENSE IO REQUIRED
QIEBIT EQU X'10'
IE QUEUED FOR THIS PUB
SENSING EQU X'40'+PROCR+SENREQ LAST SUCCESSFUL SIO ON THIS DEVICE
*
WAS SENSIO. NOTE THAT THIS IS DIFFERENT FROM PROCR+SENR
*PROCR+SENREQ INDICATES FAILURE AT SIO TIME OF SENSEIO ON THIS DEVICE.
*
THE SENSEIO WILL BE RETRYED ON DEVICEEND.
*
SIGNAL DEFINITIONS (PASSED TO ANALSIG VIA SIGR)
SGNE
EQU 0
NORMAL END
MAXSTAT EQU 10
SGINTR EQU MAXSTAT
SGMIN
EQU 2*MAXSTAT
MINOR ERROR
SGDELZ EQU 3*MAXSTAT
END OF DELAY PERIOD
SGTIME EQU 4*MAXSTAT
HIO OR 2702 READ TIMEOUT
*
SENSE BYTE DEFINITIONS
COMREJ EQU X'80'
INTREQ EQU X'40'
BUSOUT EQU X'20'
EQUIPC EQU X'10'
DATAC
EQU X'08'
OVERRUN EQU X'04'
LOSTDATA EQU X'02'

79250000
79270000
79320000
79330000
79340000
79350000
79360000
79370000
79380000
79390000
79400000
79410000
79420000
79430000
79440000
79450000
79460000
79470000
79480000
79490000
79500000
79510000
79520000
79530000
79540000
79550000
79560000
79570000
79580000
79590000
79600000
79610000
79620000
79630000
79640000
79650000
79660000
79670000
79680000
79690000
79700000
79710000
79720000
79730000
79740000
79750000
79760000
79770000
79780000
79790000
79800000
79810000
79820000
79830000
79840000
79850000
79860000
79870000
79880000
79890000

TIMEOUT EQU X'01'

*
*
CHANNEL STATUS WORD -- STATUS BYTES
*
CSW + 4 -- DEVICE STATUS
ATT
EQU X'80'
ATTENTION
SM
EQU X'40'
STATUS MODIFIER
CUE
EQU X'20'
CONTROL UNIT END
BSY
EQU X'10'
BUSY
CE
EQU X'08'
CHANNEL END
DE
EQU X'04'
DEVICE END
UC
EQU X'02'
UNIT CHECK
UE
EQU X'01'
UNIT EXCEPTION
*
CSW + 5 -- CHANNEL STATUS
PCICSW EQU X'80'
PROGRAM-CONTROL INTERRUPTION
IL
EQU X'40'
INCORRECT LENGTH
PC
EQU X'20'
PROGRAM CHECK
PRC
EQU X'10'
PROTECTION CHECK
CDC
EQU X'08'
CHANNEL DATA CHECK
CCC
EQU X'04'
CHANNEL CONTROL CHECK
ICC
EQU X'02'
INTERFACE CONTROL CHECK
CHC
EQU X'01'
CHAINING CHECK
*
CUB2702 EQU SM+CUE+BSY
CONTROL UNIT BUSY FOR 270X
*
Q103A
EQU Q1050+1
DISABLE LOGIC
SCHIDEQ EQU X'31'
SEARCH ID EQUAL
5993
APLSUP CSECT
*
TUSGEN
TUSTAB TUSGEN
SE2741 EQU SE1050
SE2741X EQU SE1050X
SETS41X EQU SE2741X
AVOID MPDVX BUG
*
*
MXSSAG DS
(SGTIME+8)AL1
PRINT NOGEN
*
SSA MACRO PRESETS MXSSAG TABLE
*
BODY OF SSA CAN BE CONSIDERED..
*
MXSSAG(/ ARG(/1/) ., ARG(/2/) /) ..= ARG(/3/)
*
ONLY USE OF MXSSAG IS AT ANALSIG WHICH DOES..
*
ANALSIG.. GOTO MXSSAG(/ STATE ., SIGR /)
SSA PROCR,SGNE,UNPRO
SSA PROCR,SGMIN,UNPRO
SSA PROCR,SGINTR,UNPINT
SSA PROCR,SGDELZ,UNPRO
SSA PROCR,SGTIME,UNDIS
*
FOLLOWING PORTION IS FOR 270X WITH 1050,2741 OR LOCAL 1052
*
1050 SIGNAL, STATE, ACTION MAP
SSA WRITES,SGNE,UNWZ
SSA WRITES,SGINTR,SETWIRS
SSA WRITES,SGMIN,UNWCNT
SSA WRITES,SGDELZ,UNRWC
SSA WRITES,SGTIME,SETWIRS
SSA READS,SGNE,UNRZA
SSA READS,SGMIN,UNRRT
* 1050 ASSUMPTION: EOT OF THE POLLING SEQUENCE WILL BE TREATED AS
*
NEGATIVE ANSWER TO EOB IF 1050 IS AWAITING ANSWER.
SSA READS,SGINTR,UNRINT
SSA READS,SGDELZ,UNRRT

79900000
79910000
79920000
79930000
79940000
79950000
79960000
79970000
79980000
79990000
80000000
80010000
80020000
80030000
80040000
80050000
80060000
80070000
80080000
80090000
80100000
80110000
80120000
80130000
80140000
80150000
80160000
80170000
80180000
80190000
80200000
80210000
80220000
80230000
80240000
80250000
80260000
80270000
80280000
80290000
80300000
80310000
80320000
80330000
80340000
80350000
80360000
80370000
80380000
80390000
80400000
80410000
80420000
80430000
80440000
80450000
80460000
80470000
80480000
80490000

SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
SSA
PRINT

READS,SGTIME,UNRTIME
WIRS,SGNE,SETIDLE
WIRS,SGTIME,SETIDLE
WIRS,SGINTR,SETLIRS
WIRS,SGDELZ,UNHIO
WIRS,SGMIN,SETIDLE
LIRS,SGNE,SETIDLE
LIRS,SGMIN,SETIDLE
LIRS,SGINTR,UNLIRINT
LIRS,SGDELZ,UNLIRDZ
LIRS,SGTIME,SETIDLE
LISTEN,SGNE,UN2741BF
LISTEN,SGINTR,SETLIRSA
LISTEN,SGTIME,SETIDLE
LISTEN,SGDELZ,UNHIO
LISTEN,SGMIN,SETIDLE
IDLE,SGNE,SETIDLE
IDLE,SGINTR,UNSAT GLITCH FOR 1052 WHICH IS TERM ZERO
IDLE,SGMIN,SETIDLE
IDLE,SGDELZ,SETIDLE
IDLE,SGTIME,SETIDLE
TODROP,SGNE,UNKILL1
TODROP,SGTIME,UNKILL1
TODROP,SGMIN,UNKILL1
TODROP,SGINTR,UNKILL1
TODROP,SGDELZ,UNKILL1
GEN

*
*
TABLE GIVING DEVICE CHARACTERISTICS
PERDEVX DSECT
PXSENC DS
HL1
LENGTH OF SENSE TO STATE MAP
DS
AL3
ORIGIN OF SENSE TO STATE MAP
PXUEAD DS
A
ADDRESS OF UNIT EXCEPTION ROUTINE
PXMXR
DS
A(MXRCCC) ROUTINE TO SETUP READ CCW CHAIN
PXRSTA EQU 0+PXMXR
RESEND TEXT POINTER
TYOTAD DS
A(TYOTAB)
OUTPUT CONVERSION TABLES
TYITAD DS
A(TYITAB)
INPUT CONVERSION TABLE
TYITAB DSECT
TYOTAB DSECT
DEVICE DEPENDENT TRANSLATE TABLES
TYOTAA DS
CL(ZLENGTH)
MAIN TRANSLATE TABLE
TYOTAT DS
CL(ZLENGTH)
TRT FOR BACKSPACE INSERTION
*
TRANSFER VECTOR ALLOWS APL FUNCTIONS TO LOCATE ABS
*
ADDRESSIS IN APLSUP FOR DISPLAY AND PATCH PURPOSES
*
ALL CALLS OF THE PHGEN MACRO MUST PRECEED THIS POINT
HDIR
CSECT ,
HISTOGRAM DIRECTORY
ORG HBASE+8*5
TRANXFER VECTOR IS IBEAM 5
DC
A(TVEC)
ADDRESS OF TRANSFER VECTOR
DC
A(TVECZ-TVEC)
LENGTH OF TRANSFER VECTOR
ORG ,
TRANSFER VECTOR IS IN HDIR
*
AFTER THE DIRECTORY
HDIRZ
EQU *
END OF HISTOGRAM DIRECTORY
TVEC
EQU *
TVEC ENTRIES FOLLOW IN ORDER
* ***
WARNING OPFNS MAKES ASSUMPTIONS ABOUT THE ORDERING AND
* ***
PRESENCE OF ENTRIES IN THIS TABLE
DC
A(MPXCUTAB)
DC
A(PUBENTL)
DC
A(PUBENTG)
DC
A(HILIM)
DC
A(PERDEVXG)
DC
A(PTBXLE)

80500000
80510000
80520000
80530000
80540000
80550000
80560000
80570000
80580000
80590000
80600000
80610000
80620000
80630000
80640000
80650000
80660000
80670000
80680000
80690000
80700000
80710000
80720000
80730000
80740000
80750000
80760000
80770000
80780000
80790000
80800000
80810000
80820000
80830000
80840000
80850000
80860000
80870000
80880000
80890000
80910000
80930000
80940000
80960000
80970000
80980000
80990000
81000000
81010000
81020000
81030000
81040000
81050000
81060000
81070000
81080000
81090000
81100000
81110000
81120000

TVECZ

DC
DC
DC
DC
DC
DC
DC
DC
EXTRN
DC
EQU
EXTRN
EXTRN
COPY
COPY

A(TYO1052)
A(CDCBXLE)
A(SOMBF)
A(MONADTAB)
A(DYADTAB)
A(QUANLIM)
A(IODSIFT)
A(PCSWITCH)
APLXREF
A(APLXREF)
*
TVEC ENTRIES PRECEED IN ORDER
PUBENTG,CDCBXLE,MONADTAB,DYADTAB
PCSWITCH
CDCPARS
TQE

*
END
./ ADD
NAME=APLSATCH
ATCH
TITLE 'A T T A C H O P E R A T O R S
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXCATEN CSECT
COPY APLDEFN
COPY OPSECT
PRINT ON,NOGEN
TITLE 'A T T A C H O P E R A T O R S
05/11/70'
EXTRN OPSPACE
EXTRN ERROR
EXTRN FETCH
EXCATEN CSECT
USING *,9
USING OPSECT-16,13
ST
12,CALLBASE
SAVE THE CALLING ROUTINES BASE REG
DROP 9
BALR 12,0
USING *,12
ST
LKR,RETURN
SAVE RETURN ADDRESS
LA
14,(LEND-LORG+7)/8*8(14)
LA
6,1
L
1,LHXRHO
GET NO OF ELE IN LEFT
LTR 1,1
BP
EM1
ITS NOT EMPTY
ST
6,LHTYPE
FORCE EMPTY TO BOOLEAN
MVC RCTYPE+3(1),RHTYPE+3
IN CASE WE FETCH
EM1
L
1,RHXRHO
LTR 1,1
DO SAME FOR RIGHT SIDE
BP
EM2
ST
6,RHTYPE
FORCE EMPTY TO BOOLEAN
MVC LCTYPE+3(1),LHTYPE+3 IN CASE WE FETCH
EM2
L
1,RHTYPE
IF TYPES ARE THE SAME
ST
1,RSTYPE
MAKE RESULT TYPE MAX
C
1,LHTYPE
OF ARG TYPES
BH
EX2
MVC RSTYPE(4),LHTYPE RESULT SAME TYPE AS LEFT
*
R15 = 4 TILL CALL OPSPACE
*
R10 = ABSOLUTE ADDRESS OF RHOB IN STACK
*
R8 = ABSOLUTE ADDRESS OF RHOA IN STACK
*
R7 = ABSOLUTE ADDRESS OF RHOR IN STACK

81130000
81140000
81150000
81160000
81170000
81180000
81190000
81200000
81210000
81220000
81230000
81240000
81250000
81270000
81290000
81310000
82240000
00180000
00360000
00540000
00720000
01080000
01260000
01440000
01620000
01800000
01980000
02160000
02340000
02520000
02700000
02880000
03060000
03240000
03420000
03600000
03780000
03960000
04140000
04320000
04500000
04680000
04860000
05040000
05220000
05400000
05580000
05760000
05940000
06120000
06300000
06480000
06660000
06840000
07020000
07200000
07380000
07560000
07740000

*
*
*
EX2

LA
L
L
ST

*
LR
CR
BNL
LR
*
LA
LA
*
LA
LA
CR
LA
BNL
LTR
BZ
L
LA
*
MRHOA

GINDEX

GIN1

FLTIND

EX
LTR
BZ
L
LA
EX
EX
TM
BNZ
LR
SR
B
SPACE
BO
L
B
SPACE
MVC
LD
AD

*
LTER
BL
CE
BNL
AW
STD
L
AR
*
*
SPACE
JINRANK SLA
JINRANK1 LA

R6 = RANK OF A
R5 = RANK B (TILL CATLAM)
R3 = INDEX
15,4
6,LHRANK
4*RANK A
5,RHRANK
4*RANK B
6,RRANK
RESULT RANK = RANK A
GET MAXIMUM OF RANKS
4,5
ASSUME RANK B BIGGER
5,6
IS IT ?
*+6
YES
4,6
NO. A IS BIGGER
R4=MAXIMUM OF RANKS
10,DIM+4
ABSOLUTE ADDRESS OF RHOB
8,8(10,4)
ROOM FOR LARGEST RANK+2 WORD SLOP
ABSOLUTE ADDRESS OF RHOA
7,8(8,4)
LIKEWISE
3,8(7,4)
END OF DIMENSION VECTORS
3067
3,TLR
CHECK OVERFLOW OF DIM TABLE
3067
1,ENONCE
3067
ER
NONCE ERROR IF OVERFLOW
3067
5,5
RANK B = ZERO THEN NOTHING TO MOVE
MRHOA
3,RHBASE
M-ENTRY BASE OF B
3,MRHO(3)
ABSOLUTE RHOB
BECAUSE OF SLACK ITS OK TO MOVE AN EXTRA BYTE
5,MOVRHOB
MOVE RHOB INTO STACK
6,6
0=RANK A THEN NOTHING TO MOVE
GINDEX
3,LHBASE
3,MRHO(3)
ABSOLUTE RHOA
6,MOVRHOA
MOVE RHOA INTO STACK
6,MOVATOR
MOVE RHOR INTO STACK (COPY RHOA)
INDBASE,X'C0'
IS AN INDEX SUPPLIED ?
GIN1
YES
3,4
DEFAULT TO LARGEST RANK
3,15
ADJUST FOR ORIGIN
JINRANK1
3
FLTIND
BRANCH ON FRACTIONAL INDEX
3,INDEX
GET INTEGER INDEX
JINRANK
CHECK RANGE OF INDEX
3
DBL,FINDEX
WE KNOW INDEX IS NOT WITHIN FUZZ
0,DBL
OF AN INTEGER SO WE CAN JUST ADD
0,DONE
ONE AND TAKE THE FLOOR
AND PRETEND ITS AN INTEGER
0,0
NO USE WASTING TIME ON
OUT
A NEGATIVE INDEX
0,TWO31
ALSO QUIT IF WAY TO BIG
OUT
0,RDUNZ
SHIFT OVER INTEGER PART
0,DBL
3,DBL+4
NOW WE HAVE IT AS AN INTEGER
4,15
PRETEND MAX RANK IS ONE LARGER
SO AN INDEX REQUESTING LAMINATE ON
THE RIGHT IS STILL IN RANGE
3
3,2
USE 4* INDEX
0,1
CONSTANT TO INSERT IN DIMENSIONS

07920000
08100000
08280000
08460000
08640000
08820000
09000000
09180000
09360000
09540000
09720000
09900000
10080000
10260000
10440000
10620000
10800000
10980000
11160000
11340000
11520000
11700000
11880000
12060000
12240000
12420000
12600000
12780000
12960000
13140000
13320000
13500000
13680000
13860000
14040000
14220000
14400000
14580000
14760000
14940000
15120000
15300000
15480000
15660000
15840000
16020000
16200000
16380000
16560000
16740000
16920000
17100000
17280000
17460000
17640000
17820000
18000000
18180000
18360000
18540000

ST
ST
LTR
BNZ
TM
BZ
*
*
*
*
JDS
*

DIFFER

CR
BNL
LTR
BL
TM
BO
CR
BE
SPACE

*
*
*
*

BSC

*
NOSC

LTR
BNZ
EX
LR
ST
B
SPACE
LTR
BNZ
EX
LR
ST
B
SPACE
LR
SR
CR
BE
CH
BNE

*
D2
D3
*
D4
*

LR
BAL
SR
SR
LA
EX
ST
B
LR
BAL
SR
AR
SPACE

0,AID
0,BID
4,4
JDS
INDBASE,X'C0'
CAT8

A INDEXED DIMENSION FOR LAMINATE

B INDEXED DIMENSION FOR LAMINATE
BOTH SCALARS ?
NO SO CHECK INDEX
YES THEN ITS LAMINATE 2F NO INDEX
DO LAMINATE
IF FALL THROUGH THEN E[ROR
WILL BE CAUGHT BELOW BECAUSE
NO INDEX IS POSITIVE AN: LESS
THAN THE RANK OF A SCALAR
EQUALITY MEANS OUT OF RANGE
BECAUSE OF 0-ORIGIN INDEX
INDEX IS TOO BIG
NEGATIVE MEANS TOO SMALL

18720000
18900000
19080000
19260000
19440000
19620000
19800000
19980000
20160000
20340000
3,4
20520000
20700000
OUT
20880000
3,3
21060000
OUT
21240000
INDBASE,X'C0'
IF FRACTIONAL INDEX
21420000
LAM
ITS LAMINATE
21600000
5,6
ELSE, IF EQUAL RANKS
21780000
CATLAM
ITS CATENATE
21960000
6
22140000
CAN ONLY BE ADJOIN
22320000
IF EITHER A OR B IS SCALAR THEN WE EXTEND THE SCALAR TO 22500000
HAVE THE SAME DIMENSIONS AS THE OTHER ARG EXCEPT A
22680000
1 IN THE INDEXED POSITION
22860000
6,6
IS A SCALAR ?
23040000
BSC
NO ITS NOT
23220000
5,MOVBTOA
MOVE RHOB TO RHOA
23400000
6,5
SET RANK A TO RANK B
23580000
0,0(3,8)
SET 1 IN INDEXED POSITION
23760000
D3
23940000
24120000
5,5
IS B SCALAR?
24300000
NOSC
NO SCALAR EXTENSION
24480000
6,MOVATOB
MOVE RHOA TO RHOB
24660000
5,6
SET RANK B TO RANK A
24840000
0,0(3,10)
SET A 1 IN INDEXED POSITION
25020000
CATLAM
25200000
5
25380000
WE HAVE ADJOIN OR NOTHING
25560000
2,6
RANK A
25740000
2,5
RANKA - RANK B
25920000
2,15
DOES A HAVE BIGGER RANK?
26100000
D4
YES
26280000
2,=H'-4'
DOES B HAVE BIGGER RANK
26460000
RANER
RANKS MUST DIFFER BY EXACTLY ONE
26640000
WE INSERT A 1
26820000
9,8
INTO RHOA
27000000
1,INSERT
27180000
8,15
NOW A STARTS ONE LOWER
27360000
7,15
PUT A INTO RESULT
27540000
6,4(6)
NEW RANK OF A
27720000
6,MOVATOR
OK TO MOVE ONE BYTE TO MUCH
27900000
6,RRANK
IS ALSO RANK OF B
28080000
CATLAM
28260000
A HAS BIGGER RANK
28440000
9,10
WE INSERT A 1 INTO RHOB
28620000
1,INSERT
28800000
10,15
NEW START OF RHOB
28980000
5,15
UP RANK B BY ONE (NEVER NEEDED)
29160000
8
29340000

CATLAM
CAT1

*
LAM

BSCL
CAT6

*
*
CAT8

*
*
CALC
*
CAL1
CAL2

CAL3

LTR
BZ
BCTR
LA
L
L
ST
ST
EX
BNE
ST
ST
AR
ST
B
SPACE

4,4
CAT8
6,0
1,ELENGTH
5,0(10,3)
2,0(8,3)
1,0(10,3)
1,0(8,3)
6,CDIM
ER
5,BID
2,AID
5,2
5,0(7,3)
CALC
8

IF SCALARS CAN ONLY BE LAMINATE

ITS LAMINATE OF SCALARS
READY TO COMPARE DIMENSIONS

29520000
29700000
29880000
30060000
R5 = RHOB(J)
30240000
R2 = RHOA(J)
30420000
MAKE RHOB(J) = RHOA(J)
30600000
TO MAKE COMPARISON EASY
30780000
EQUAL WHERE REQUIRED ?
30960000
NO
31140000
SAVE B INDEXED POSITION
31320000
SAVE A INDEXED POSITION
31500000
ADD INDEXED DIMENSIONS
31680000
SET RHOR(J)=RHOA(J)+RHOB(J)
31860000
32040000
32220000
THIS IS A LAMINATE
32400000
LTR 6,6
IS A SCALAR
32580000
BNZ BSCL
NO ITS NOT
32760000
EX
5,MOVBTOA
MOVE RHOB TO RHOA
32940000
EX
5,MOVATOR
MOVE IT INTO RESULT DIMENSION
33120000
ST
5,RRANK
SET RESULT RANK
33300000
LR
6,5
SET RANK A = RANK B
33480000
BCTR 6,0
COMPARE LENGTH CODE
33660000
LTR 5,5
IS B SCALAR
33840000
BZ
CAT8
YES SO SKIP COMPARE
34020000
SR
5,6
RANKS MUST BE EQUAL
34200000
BCT 5,RANER
RECALL RANK A IS REDUCED FOR COMPARE 34380000
EX
6,CDIM
ALL DIMENSIONS MUST BE EQUAL
34560000
LA
1,ELENGTH
34740000
BNE ER
LENGTH ERROR IF NOT
34920000
ENTER HERE ON LAMINATE OF SCALARS BECAUSE
35100000
DIMENSIONS ARE AUTOMATICALLY EQUAL
35280000
LR
9,8
INSERT A 1 TO LEFT OF INDEXED DIM
35460000
BAL 1,INSERT
DONT REALLY CARE WHAT IS INSERTED
35640000
SR
8,15
NEW START RHOA
35820000
AR
6,15
PRETEND ARG IS ONE HIGHR RANK
36000000
LR
9,7
WORK ON RESULT
36180000
LA
0,2
PUT A 2 TO LEFT OF
36360000
BAL 1,INSERT
INDEXED DIMENSION
36540000
SR
7,15
NEW START OF RHOR
36720000
L
1,RRANK
UP RESULT RANK
36900000
AR
1,15
37080000
ST
1,RRANK
37260000
I KNOW DIMENSIONS ARE THE SAME EXCEPT POSSIBLY AT
37440000
THE INDEXED POSITION
37620000
SR
4,4
INDEX TO DIMENSION
37800000
SR
8,15
POINTS 1(4BYTES) BELOW RHOA
37980000
LR
2,15
INCREMENT OF 4
38160000
R3 ALREADY HAS THE INDEX
38340000
LA
1,1
PRIME THE PRODUCT
38520000
B
CAL2
38700000
M
0,0(4,8)
MULTIPLY IN NEXT DIMENSION
38880000
BXLE 4,2,CAL1
AND AGAIN
39060000
ST
1,N
= NUMBER OF TIMES TO LOOP
39240000
LR
5,3
SAVE INDEX
39420000
LA
3,1(6)
RANK OF A
39600000
LA
1,1
PRIME THE PRODUCT
39780000
B
CAL4
39960000
M
0,0(4,8)
MULTIPLY IN NEXT DIMENSION
40140000

CAL4

TYPEOK

*
*

AB1

AB3

AB15

BXLE 4,2,CAL3
L
3,AID
A INDEXED POSITION
MR
2,1
GET MA = AMOUNT OF A TO MOVE AT ONC
ST
3,MA
AND SAVE IT
M
0,BID
GET MB=AMOUNT OF B TO MOVE AT ONCE
ST
1,MB
AND SAVE IT
A
1,MA
MA+MB
M
0,N
RXRHO=N*(MA+MB)
MVC DIM(256),0(7)
MOVE RESULT DIM DOWN SO OPSPACE
ST
1,RXRHO
SAVE IT (MAYBE NO NEED TO )
LTR 1,1
IF RESULT IS EMPTY
BNZ TYPEOK
MAKE TYPE SAME AS RT ARG
L
3,RHBASE
PICK UP TYPE FROM M-ENTRY BECAUSE
LA
3,M(3)
RHTYPE FOR AN EMPTY ARRAY IS
MVC RSTYPE+3(1),MTYPE-M(3)
L
3,RSTYPE
L
2,RRANK
DON'T FORGET THIS
L
10,=A(OPSPACE)
BALR LKR,10
L
2,RSTYPE
STC 2,MTYPE(1)
INSERT TYPE
L
2,RRANK
STH 2,MRANK(1)
AND RANK
LA
1,MRHO(1)
AT DIMENSION ABSOLUTE
BCTR 2,0
EX
2,MTORES
MOVE RESULT DIM INTO M-ENTRY
LA
1,1(2,1)
AT RESULT DATA ABSOLUTE
ST 1,RESORG
SAVE IT ABSOLUTE (NOT USED OVER QUEN
ADJUST CONSTANTS AND PREPARE FOR LOOP
LOOK AT LEFT ARG
L
3,MA
L
8,LHBASE
L
9,LCTYPE
FETCH CODE IN CASE OF CONVERSION
BAL 4,ADJUST
C
6,BEXTEND
IF EXTEND IS USED
BNE AB1
USE LEFT ENTRY POINT
L
6,BEXTENDL
MVC CONVERTA(12),CONVERTS
ST
6,MOVEA
BRANCH ADDRESS
ST
8,AAD
STARTING DATA ADDRESS
MR
6,3
ADJUST MA FOR
ST
7,MA
LENGTH OF AN ITEM
REPEAT FOR RIGHT ARG
L
3,MB
L
8,RHBASE
L
9,RCTYPE
FETCH CODE IN CASE OF CONVERSION
BAL 4,ADJUST
ST
6,MOVEB
STORE BRANCH ADDRESS
ST
8,BAD
AND STARTING ADDRESS
M
6,MB
ADJUST MB FOR LENGTH OF AN ITEM
ST
7,MB
L
5,RSTYPE
L
6,RESORG
AN ABSOLUTE ADDRESS
SR
6,MR
MAKE IT RELATIVE
CH
5,=H'1'
IS RESULT BOOLEAN
BNE AB15
SLL 6,3
MAKE ROOM FOR BIT DISPLACE,ENT
L
9,N
NUMBER OF TIMES TO LOOP
LTR 9,9
MIGHT NOT NEED TO LOOP AT ALL
BNP LP2
COULD CHECK EARLIER BUT WHO CARES

40320000
40500000
40680000
40860000
41040000
41220000
41400000
41580000
41760000
41940000
42120000
42300000
42480000
42660000
42840000
43020000
43200000
43380000
43560000
43740000
43920000
44100000
44280000
44460000
44640000
44820000
45000000
45180000
45360000
45540000
45720000
45900000
46080000
46260000
46440000
46620000
46800000
46980000
47160000
47340000
47520000
47700000
47880000
48060000
48240000
48420000
48600000
48780000
48960000
49140000
49320000
49500000
49680000
49860000
50040000
50220000
50400000
50580000
50760000
50940000

LOOP

LP1
LP2

*
*
*
*
INSERT

INS1
*
*
*
*
*
*
*
*
*
ADJUST

AN0
AD1

IC
ST
ST
ST
L
SPACE
L
L
EX
ST
LR
L
EX
LR
QUEND
BCT
L
L
BR
EJECT

5,LEN-1(5)
5,CONVERTL+8
5,CONVERTS+8
5,CONVERTA+8
10,BAD
8
2,AAD
8,MA
0,MOVEA
2,AAD
2,10
8,MB
0,MOVEB
10,2

GET LENGHT OF RESULT

SAVE IT

51120000
51300000
51480000
51660000
MIGHT AS WELL USE REG 10
51840000
52020000
M-REL ADDRESS OR ELE INDEX OF A
52200000
# BYTES OR ELE TO MOVE
52380000
52560000
SAVE A POINTER
52740000
M-REL ADDRESS OR ELE INDEX OF NEXT B 52920000
53100000
53280000
SAVE B POINTER
53460000
53640000
9,LOOP
STILL MORE ?
53820000
15,RETURN
ALL DONE
54000000
12,CALLBASE
54180000
15
54360000
54540000
INSERT A CONSTANT INTO A DIMENSION VECTOR
54720000
R3 = NUMBER OF BYTES TILL INSERT
54900000
R0 = CONSTANT TO BE STORED
55080000
R9 = START ADDRESS
55260000
SH
9,=H'4'
NEW START ADDRESS
55440000
LTR 3,3
0 MEANS NOTHING TO MOVE
55620000
BNP INS1
55800000
BCTR 3,0
GET MOVE CODE FROM BYTE COUNT
55980000
EX
3,INSMVC
56160000
LA
3,1(3)
MAINTAIN INDEX
56340000
AR
9,3
POINTER TO INSERT LOCATION
56520000
ST
0,0(9)
56700000
BR
1
56880000
EJECT
57060000
ADJUST CONSTANTS AND PREPARE FOR LOOP
57240000
ON ENTRY
57420000
R8 = M-REL START OF ARGUMENT
57600000
R3 = #ELEMENTS OF ARG MOVED AT ONCE
57780000
ON EXIT
57960000
R8 = ADDRESS FOR START OF LOOP ON ARG
58140000
R7 = LENGTH OF ONE ELEMENT OF ARG
58320000
R6 = BRANCH TO PROPER MOVE ROUTINE
58500000
LINKAGE : BAL 4,ADJUST
58680000
L
6,NOP
IF NOTHING TO MOVE
58860000
LTR 3,3
NOP USED FOR EXECUTED ROUTINE
59040000
BNP 0(4)
59220000
SR
5,5
59400000
IC
5,MTYPE(8)
59580000
LA
8,MRANK-M(8)
AT RANK M-REL
59760000
LH
7,M(8)
59940000
LA
8,2(7,8)
AT DATA M-REL
60120000
LTR 7,7
IS ARG SCALAR ?
60300000
BZ
ACVTS
YES EXTEND IT
60480000
IC
7,LEN1-1(5)
LENGTH OF AN ITEM
60660000
C
5,RSTYPE
SAME AS RESULT TYPE
60840000
BNE ACVT
NO, MUST CONVERT
61020000
BCT 5,AN1
BRANCH IF NOT BOOLEAN
61200000
L
6,BBITMOV
USE BIT MOVE ROUTINE
61380000
SLL 8,3
MAKE ROOM FOR BIT DISPLACEMENT
61560000
BR
4
61740000

AN1
ACVT

ACVTS

L
BR
L
ST
SR
LA
ST
BR
L
ST
SR
LA
ST
BR
EJECT

*
*
*
*
BITMOVE ST
ST
SRDL
SLL
L
SRL
S
LCR
SRL
SRDL
SLL
L
SRL
*
BITM2
SLL
SLDL
ST
L
L
LA
SR
CR
BNL
LR
AR
AR
SR
BP
BITDONE AR
AR
BR
*
*
EJECT
*
*
*
*
BYTEMOVE LA
BCTR
AR

6,BBYTMOV
4
6,BCONVERT
8,CONVERTL+4
8,8
7,1
9,CONVERTL
4
6,BEXTEND
8,CONVERTS+4
8,8
7,1
9,CONVERTS
4

WHATEVER IT IS WE MOVE BYTES

USE CONVERT ROUTINE
DATA BASE FOR CONVERSION
USE ELEMENT INDEX
LENGTH OF ELEMENT = 1
SAVE CONVERT CODE
USE SCALAR EXTENSION
M-REL DATA BASE
USE ELEMENT INDEX
LENGHT OF ELEMENT
SAVE CONVERT CODE
RETURN

MOVE BITS UP TO 32 AT A TIME

R6 = RELATIVE BIT ADDRESS OF SINK
R2 = M-REL BIT ADDRESS OF SOURCE
R8 = # OF BITS TO MOVE
6,SINKAD
SAVE STARTING ADDRESSES
2,SOURCEAD
6,5
CHOP OFF BIT DISPLACEMENT
6,2
FULLWORD ADDRESS
0,M(6)
GET SINK WORD
7,27
DETERMINE AMOUNT OF SHIFT
7,=F'32'
TO PUT FIRST UNUSED SINK
7,7
BIT IN BIT 0 OF REG 1
0,0(7)
R7 = # BITS ACCEPTABLE TO SINK
2,5
GET BIT DISPLACEMENT IN SOURCE
2,2
GET FULLWORD ADDRESS OF SOURCE
1,M(2)
GET A SOURCE WORD
3,27
DETERMINE SHIFT TO PUT FIRST
BIT TO BE MOVED IN BIT 0 OF REG 1
1,0(3)
LEFT JUSTIFY SOURCE BITS IN R1
0,0(7)
MOVE SOURCE INTO SINK
0,M(6)
STUFF RESULT BACK
6,SINKAD
2,SOURCEAD
1,32
DETERMINE # BITS PROVIDED BY THE
1,3
SOURCE
1,7
THE # BITS MOVED = MINIMUM OF
*+6
NUMBER PROVIDED AND
7,1
NUMBER ACCEPTABLE
6,7
UPDATE SINK ADDRESS
2,7
UPDATE SOURCE ADDRESS
8,7
REDUCE COUNT
BITMOVE
BACK FOR MORE
6,8
UPDATE ADDRESSES ONLY BY
2,8
COUNT REQUESTED.WE MAY
LKR
MOVE TOO MUCH BUT SINCE
WE FILL RESULT FROM LOW ADDRESS
TO HIGH ADDRESS IT DOESN'T MATTER
MOVE BYTES UP TO 256 AT A TIME
R6 = RELATIVE BYTE ADDRESS OF SINK
R2 = M-REL ADDRESS OF SOURCE
R8 = # OF BYTES TO MOVE
0,256
8,0
CHANGE BYTE COUNT TO MOVE COUNT
2,MR
MAKE SOURCE ADDRESS ABSOLUTE

61920000
62100000
62280000
62460000
62640000
62820000
63000000
63180000
63360000
63540000
63720000
63900000
64080000
64260000
64440000
64620000
64800000
64980000
65160000
65340000
65520000
65700000
65880000
66060000
66240000
66420000
66600000
66780000
66960000
67140000
67320000
67500000
67680000
67860000
68040000
68220000
68400000
68580000
68760000
68940000
69120000
69300000
69480000
69660000
69840000
70020000
70200000
70380000
70560000
70740000
70920000
71100000
71280000
71460000
71640000
71820000
72000000
72180000
72360000
72540000

AR
CR
BH
LA
SR
*
BYTELOOP MVC
AR
BXLE
N
LASTBYTE EX
LA
LA
SR
SR
BR
EJECT
*
*
*
*
CONVERT LM
*
LR
AR
C2
ICALL
STM
EX
LA
LA
BCT
SR
BR
EJECT
*
*
*
*
EXTENDL LM
B
EXTEND LM
EXTEND1 LR
SR
EXTE0
ICALL
CLI
BE
STM
LA
EX
LR
LA
BCT
BR
SPACE
EXTM
MR
AR
LR
B
SPACE
SPACE

6,MR
0,8
LASTBYTE
1,0(6,8)
1,0

MAKE SINK ADDRESS ABSOLUTE

NO LOOP IF 256 OR FEWER TO MOVE
REMEMBER COUNT IS ALREADY REDUCED

0(256,6),0(2)
2,0
6,0,BYTELOOP
8,=F'255'
8,MOVEBYT
6,1(8,6)
2,1(8,2)
2,MR
6,MR
AND
LKR

CAUSE END OF LOOP WHENEVER 256 OF

FEWER LEFT TO MOVE

GET 256 RESIDUE OF COUNT

MOVE REMAINDER
UPDATE POINTER TO RESULT
UPDATE POINTER TO SOURCE
RELATIVIZE SOURCE
SINK

CONVERT ELEMENTS ONE AT A TIME

R2 = ELEMENT INDEX OF SOURCE
R6 = RELATIVE BYTE ADDRESS OF SINK
R8 = NUMBER OF ELEMENTS TO MOVE
3,5,CONVERTL
TYPE DATA BASE,LENGTH
LENGTH MUST BE MOVE COUNT (0,3,7)
7,LKR
SAVE RETURN ADDRESS
6,MR
MAKE SINK ABSOLUTE
FETCH
0,1,DBL
STORE LEFT JUSTIFIED IN DBL
5,MVC
MOVE PROPER # OF BYTES
6,1(5,6)
POINT TO NEXT RESULT SLOT
2,1(2)
INCREMENT ELEMENT INDEX
8,C2
6,MR
MAKE SINK RELATIVE
7
EXTEND A SCALAR BY FETCHING FIRST VALUE AND MOVING
THE REST BY MOVE ROUTINES
R6 = RELATIVE ADDRESS OF SINK
R8 = NUMBER OF ELEMENTS TO MOVE
3,5,CONVERTA
EXTEND1
3,5,CONVERTS
TYPE,DATA BASE, LENGTH
7,LKR
SAVE RETURN ADDRESS
2,2
LOOP THINKS ITS AN ARRAY
FETCH
GET THE ELEMENT TO BE REPLICATED
RSTYPE+3,1
IF BOOLEAN
EXTB
MOVE BITS FOR EXTENSION
0,1,DBL
2,M(6)
NEED IT ABSOLUTE
5,MVC2
PUT IN FIRST ELEMENT
2,6
SOURCE IS REST OF SINK
6,1(5,6)
UPDATE SINK ADDRESS
8,EXTM
7
QUIT EARLY IF ONLY ONE ELEMENT
2
4,8
DETERMINE NUMBER OF BYTES
8,5
REMAINING TO MOVE
LKR,7
RESTORE RETURN ADDRESS
BYTEMOVE
PERFORM OVERLAPPING MVC

72720000
72900000
73080000
73260000
73440000
73620000
73800000
73980000
74160000
74340000
74520000
74700000
74880000
75060000
75240000
75420000
75600000
75780000
75960000
76140000
76320000
76500000
76680000
76860000
77040000
77220000
77400000
77580000
77760000
77940000
78120000
78300000
78480000
78660000
78840000
79020000
79200000
79380000
79560000
79740000
79920000
80100000
80280000
80460000
80640000
80820000
81000000
81180000
81360000
81540000
81720000
81900000
82080000
82260000
82440000
82620000
82800000
82980000
83160000
83340000

EXTB

BITL

MOVRHOB
MOVRHOA
MOVBTOA
MOVATOB
INSMVC
MOVATOR
MTORES
MOVEBYT
MVC
MVC2
BBITMOV
BBYTMOV
BCONVERT
BEXTEND
BEXTENDL
NOP
CDIM
RANER
OUT
ER
LEN
LEN1
DONE
RDUNZ
TWO31
PATCH
OPSECT
FINDEX
LORG
DBL
CONVERTL
CONVERTS
CONVERTA

LR
SR
LTR
BZ
BCTR
ST
SRDL
SLL
SRL
S
LCR
L
SRL
LR
SLDL
ST
L
AR
SR
BP
AR
BR
EJECT
MVC
MVC
MVC
MVC
MVC
MVC
MVC
MVC
MVC
MVC
DS
BAL
BAL
BAL
BAL
BAL
BCR
CLC
LA
B
LA
ICALL
DC
DC
DC
DC
DC
DC
LTORG
EJECT
DSECT
EQU
EQU
DS
DS
DS
DS

LKR,7
4,4
0,0
BITL
4,0
6,SINKAD
6,5
6,2
7,27
7,=F'32'
7,7
0,M(6)
0,0(7)
1,4
0,0(7)
0,M(6)
6,SINKAD
6,7
8,7
BITL
6,8
LKR

MOVE BITS UP TO 32 AT A TIME

R4 IS ALL ZEROS OR ALL ONES
DEPENDING UPON THE SCALAR BEING
A ZERO OR A ONE
ITS A ONE
SAVE STARTING ADDRESS
GET FULLWORD ADDRESS

83520000
83700000
83880000
84060000
84240000
84420000
84600000
84780000
AND BIT DISPLACEMENT
84960000
85140000
R7 IS NUMBER OF BITS PROVIDED
85320000
GET SINK WORD
85500000
LINE UP SINK ON REG 1
85680000
85860000
86040000
86220000
PICK UP START ADDRESS
86400000
ADD NUM BITS MOVED
86580000
REDUCE COUNT
86760000
GO BACK FOR MORE
86940000
ADJUST FOR LAST MOVE
87120000
87300000
87480000
0(0,10),0(3)
TO MOVE RHOB INTO STACK
87660000
0(0,8),0(3)
TO MOVE RHOA INTO STACK
87840000
0(0,8),0(10)
MOVE RHOB TO RHOA
88020000
0(0,10),0(8)
MOVE RHOA TO RHOB
88200000
0(0,9),4(9)
TO INSERT CONST IN DIMENSION
88380000
0(0,7),0(8)
COPY RHOA INTO RHOR
88560000
0(0,1),DIM
COPY RHOR INTO M-ENTRY
88740000
0(0,6),0(2)
88920000
0(0,6),DBL
89100000
0(0,2),DBL
89280000
0F
MAKE SURE BRANCH IS ON FULLWORD BOUN 89460000
LKR,BITMOVE
89640000
LKR,BYTEMOVE
89820000
LKR,CONVERT
90000000
LKR,EXTEND
90180000
LKR,EXTENDL
90360000
0,0
TO MOVE ZERO BYTES
90540000
0(0,10),0(8)
90720000
1,ERANK
RANK ERROR
90900000
ER
91080000
1,EINDEX
AN INDEX ERROR
91260000
ERROR
OH WHAT'S THE USE
91440000
AL1(0,3,7,0)
LENGTH CODE PER TYPE
91620000
AL1(1,4,8,1)
LENGTH PER TYPE
91800000
D'1'
91980000
X'4E00000000000000' UNNORMALIZED ZERO
92160000
X'48800000'
92340000
10H'1'
92520000
92700000
92880000
93060000
INDRANK
93240000
*
93420000
D
FOR CONVERSIONS
93600000
3F
TYPE,DATA BASE,LENGTH CODE
93780000
3F
SAME FOR SCALARS
93960000
3F
94140000

*
MOVEA
MOVEB
MA
MB
N
AAD
AID
BID
*
*
*
BAD
RETURN
CALLBASE
SINKAD
SOURCEAD
DIM
LEND

DS
DS
DS
DS
DS
DS
DS
DS

F
F
F
F
F
F
F
F

ADDRESS OF PROPER MOVE BRANCH

SAME FOR B
AMOUNT OF A MOVED AT ONE TIME
AMOUNT OF B MOVED AT ONE TIME
NUMBER OF TIMES TO LOOP
IF MOVEBITS = 2**5 * M-REL ADDRESS +
A INDEXED DIMENSION
B INDEXED POSITION
BIT DISPLACEMENT
IF MOVEBYTES = M-RELATIVE ADDRESS
IF CONVERT = ELEMENT INDEX
SAME FOR B
RETURN ADDRESS IN OPCTL
BASE REGISTER OF OPCTL
TEMP LOC FOR BITMOVE
LIKEWISE
ALLOW UP TO RANK 24
3067
END OF DSECT

DS
F
DS
F
DS
F
DS
F
DS
F
DS
80F
EQU *
END
./ ADD
NAME=APLSBLOW
BLOW
TITLE 'FIXED POINT OVERFLOW RECOVERY ROUTINE
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
BLOWUP CSECT
PRINT OFF
APLDEFN, OPSECT
COPY APLDEFN
COPY OPSECT
TITLE 'FIXED POINT OVERFLOW RECOVERY ROUTINE
05/11/70'
PRINT ON,NOGEN
BLOWUP CSECT
EXTRN MBLOWRTN
EXTRN BLOWRTN
EXTRN OPSPACE
EXTRN CLEANUP
EXTRN FETCH
EXTRN STORE
EXTRN ARTHTP
SPACE
*
*
1.
MONADIC OPERATOR BLOWUP.
*
RESULT IS NEVER STORED ON OPERAND IN A SITUATION
*
WHERE A BLOWUP MIGHT OCCUR.
*
- MARK CURRENT RESULT GARBAGE, SET UP ARTHTP OPERANDS
*
TO FORCE A FLOATING RESULT, AND RETURN TO MBLOWRTN
*
IN OPERATOR CONTROL.
*
*
2.
DYADIC OPERATOR BLOWUP.
*
A.
RESULT NOT STORED ON AN OPERAND.
*
- TREAT AS IS THE MONADIC CASE AND RETURN TO
*
BLOWRTN IN OPERATOR CONTROL.
*
*
B.
RESULT STORED ON AN OPERAND.
*
GET SPACE FOR RESULT, CONVERT CALCULATED RESULTS
*
TO FLOATING, COMPLETE CALCULATION.
*
SPACE
BALR 9,0
ESTABLISH ADDRESSING.
USING *,9

94320000
94500000
94680000
94860000
95040000
95220000
95400000
95580000
95760000
95940000
96120000
96300000
96480000
96660000
96840000
97020000
97200000
97380000
97560000
97740000
00430000
00860000
01290000
01720000
02150000
03010000
03440000
03870000
04300000
04730000
05160000
05590000
06020000
06450000
06880000
07310000
07740000
08170000
08600000
09030000
09460000
09890000
10320000
10750000
11180000
11610000
12040000
12470000
12900000
13330000
13760000
14190000
14620000
15050000
15480000
15910000
16340000
16770000
17200000

USING OPSECT-16,LR
SPACE
DETERMINE IF OPERATION WAS MONADIC OR DYADIC.
SPACE
MVI BLOWN,1
TURN ON BLOWUP RECOVERY SWITCH.
CLI LHTYPE+3,0
ZERO LEFT TYPE INDICATES MONADIC.
BE
MONABLOW
BRANCH IF MONADIC.
L
1,RBASE
FIND SYNONYM OF RESULT BASE.
C
1,LHBASE
BE
BLEFT
LEFT ARG IS RESULT
C
1,RHBASE
BE
BRIGHT
RIGHT ARG IS RESULT

17630000
18060000
*
18490000
18920000
19350000
19780000
20210000
20640000
21070000
21500000
21930000
22360000
*
22790000
*
CASE 2A - DYADIC, RESULT NOT ON OPERAND.
23220000
SPACE
23650000
DYABLOW L
10,=A(BLOWRTN)
DYADIC RETURN TO OP CONTROL.
24080000
BLOWCOMM MKG 1
MARK OLD RESULT GARBAGE.
24510000
L
1,SVI
MOVE SVI BACK ONE ENTRY.
24940000
LA
1,4(1)
25370000
ST
1,SVI
25800000
RSTSVI LA
0,3
CAUSE ARTHTP TO FORCE FLOATING RES. 26230000
BR
10
RE-ENTER OPERATOR CONTROL.
26660000
SPACE
27090000
*
CASE 1 - MONADIC.
27520000
SPACE
27950000
MONABLOW L
10,=A(MBLOWRTN)
MONADIC RETRUN TO OP CONTROL.
28380000
L
1,RBASE
PICK UP OLD RESULT ADDRESS.
28810000
B
BLOWCOMM
ENTER COMMON CODE.
29240000
EJECT
29670000
*
30100000
*
CASE 2B - RESULT STORED ON A DYADIC OPERAND.
30530000
*
30960000
*
R8 CONTAINS REMAINING LOOP COUNT.
31390000
*
31820000
BRIGHT MVI TEMPRGT,1
RE-MARK RIGHT AS TEMP
32250000
MVI LTORRT,2
INDICATE THAT RIGHT HAS RESULT.
32680000
B
BSPACE
33110000
BLEFT
MVI TEMPLFT,1
MARK LEFT AS AGAIN TEMP.
33540000
MVI LTORRT,1
INDICATE THAT LEFT HAS RESULT.
33970000
BSPACE ST
8,LHFROUT
HIDE REMAINING COUNT.
34400000
SPACE
34830000
*
REALIGN EXECUTION STACK.
35260000
SPACE
35690000
L
3,SVI
PICK UP SVI
36120000
LA
3,4(3)
INCREMENT IT.
36550000
ST
3,SVI
AND PUT IT BACK.
36980000
LA
3,4(3)
POINT AT LEFT OPERAND
37410000
TM
LTORRT,1
CHECK LEFT OR RIGHT.
37840000
BNZ *+8
BRANCH IF LEFT
38270000
LA
3,12(3)
POINT AT RIGHT OPERAND ON STACK
38700000
ST
3,MHEAD(1)
RESTORE APPROPRIATE M-ENTRY.
39130000
L
10,=A(BLOWRTN)
39560000
C
8,RXRHO
SEE IF BLOWUP WAS ON FIRST EL.
39990000
BE
RSTSVI
DON'T NEED THE FOLLOWING CODE IF SO. 40420000
SPACE
40850000
*
CAN NOW GET SPACE FOR RESULT.
41280000
SPACE
41710000
BALR PR,0
SWITCH PROG BASE TO PR.
42140000
USING *,PR
42570000
L
1,RXRHO
GET X / RHO RESULT.
43000000

L
2,RRANK
AND RESULT RANK.
LA
3,3
RESULT THPE IS FLOATING.
ST
3,RESTYPE
L
10,=A(OPSPACE)
CALL COMMON GET SPACE ROUTINE.
BALR LKR,10
RETURN WITH RESULT M-POINTER IN R1.
ST
1,RBASE
STORE RESULT BASE.
SPACE
*
SET UP RESULT RANK, ETC.
SPACE
LA
3,3
RESULT TYPE.
L
2,LHBASE
PICK UP LEFT BASE.
TM
LTORRT,1
CHECK LEFT OR RIGHT.
BO
*+8
BRANCH IF LEFT.
L
2,RHBASE
PICK UP RIGHT BASE.
ST
2,BINSAVE
SAVE FOR USE AT CONVERSION.
L
4,RRANK
RESULT RANK.
ST
4,MTYPE(1)
STORE RANK.
STC 3,MTYPE(1)
INSERT TYPE CODE.
LTR 4,4
SEE IF ALL THIS IS FOR A SCALAR.
BZ
CARTHTP
BRANCH IF SO. (SHOULDN'T HAPPEN)
BCTR 4,0
OTHERWISE, CONVERT RANK TO SS COUNT.
LA
1,MRHO(1)
GET ABSOLUTE POINTER.
LA
2,MRHO(2)
TO RANK VECTORS.
EX
4,MOVRANK
AND MOVE IN RESULT RANK.
SPACE
*
NOW, CALL ARTHTP.
SPACE
CARTHTP LA
0,3
FORCE A FLOATING RESULT.
L
1,OPERATOR
GET OPERATOR,
L
2,LHTYPE
LEFT TYPE,
L
3,RHTYPE
RIGHT TYPE,
ICALL ARTHTP
AND CALL ARTHTP.
STM 1,5,TYPINFO
STORE RESULTS.
SPACE
*
CONVERT PREVIOUSLY CALCULATED RESULTS TO FLOATING.
SPACE
L
8,RXRHO
CALCULATE LOOP COUNT.
S
8,LHFROUT
SUBTRACT HIDDEN REMAINDER.
SR
1,1
ZERO FETCH INDICES.
ST
1,LINDX
USE LEFT FETCH OPERANDS.
ST
1,RESINDX
AND RESULT.
L
1,LCTYPE
PICK UP LEFT CONVERSION CODE.
TM
LTORRT,1
CHECK LEFT OR RIGHT.
BO
*+8
BRANCH IF LEFT.
L
1,RCTYPE
OTHERWISE, RIGHT CONVERSION CODE.
ST
1,LCFTYPE
CONVERSION CODE FOR FIRST PART.
L
1,RBASE
NOW, BASES.
A
1,RRANK
LA
1,MRHO-M(1)
ST
1,RESORG
RESULT BASE.
L
1,BINSAVE
OPERAND WHICH WAS OVERWRITTEN.
A
1,RRANK
HAS SAME RANK AS RESULT.
LA
1,MRHO-M(1)
ST
1,LHORG
SPACE
*
CONVERT PREVIOUSLY COMPUTED RESULTS.
SPACE
CONVERT LM
2,4,LHFETCH
FETCH OPERANDS.
ICALL FETCH
FETCH FIXED RESULT.
LM
2,4,RESTORE
STORE OPERANDS.

43430000
43860000
44290000
44720000
45150000
45580000
46010000
46440000
46870000
47300000
47730000
48160000
48590000
49020000
49450000
49880000
50740000
51170000
51600000
52030000
52460000
52890000
53320000
53750000
54180000
54610000
55040000
55470000
55900000
56330000
56760000
57190000
57620000
58050000
58480000
58910000
59340000
59770000
60200000
60630000
61060000
61490000
61920000
62350000
62780000
63210000
63640000
64070000
64500000
64930000
65360000
65790000
66220000
66650000
67080000
67510000
67940000
68370000
68800000
69230000

ICALL STORE
69660000
LA
2,1(2)
UPDATE FETCH INDICES.
70090000
ST
2,LINDX
70520000
ST
2,RESINDX
70950000
QUEND
71380000
BCT 8,CONVERT
LOOP.
71810000
SPACE
72240000
*
NOW, COMPLETE EXECUTION.
72670000
SPACE
73100000
L
8,LHFROUT
PICK UP REMAINING LOOP COUNT.
73530000
L
1,LHBASE
SET UP FETCH OPERANDS.
73960000
A
1,LHRANK
74390000
LA
1,MRHO-M(1)
74820000
ST
1,LHORG
LEFT.
75250000
L
1,RHBASE
75680000
A
1,RHRANK
76110000
LA
1,MRHO-M(1)
76540000
ST
1,RHORG
RIGHT.
76970000
MVC LCFTYPE(4),LCTYPE LEFT CONVERSION CODE.
77400000
MVC RCFTYPE(4),RCTYPE RIGHT CONVERSION CODE.
77830000
MVC LINDX(4),RESINDX
ELEMENT INDICES.
78260000
MVC RINDX(4),RESINDX
78690000
LA
1,1
INDEX INCREMENTS.
79120000
ST
1,LHFROUT
79550000
ST
1,RHFROUT
79980000
*
ASSUMPTION - BOTH OPERANDS ARE NOT SCALAR.
80410000
SR
1,1
80840000
TM
LHSCALAR,1
TEST FOR LEFT SCALAR.
81270000
BZ
ISRH
BRANCH IF NOT.
81700000
ST
1,LINDX
SET FETCH INDEX TO ZERO.
82130000
ST
1,LHFROUT
AND INCREMENT.
82560000
B
COMPUTE
AND ENTER COMPUTE LOOP.
82990000
ISRH
TM
RHSCALAR,1
TEST FOR SCALAR RIGHT.
83420000
BZ
COMPUTE
BRANCH IF NOT.
83850000
ST
1,RINDX
OTHERWISE, ZERO FETCH INDEX.
84280000
ST
1,RHFROUT
AND INCREMENT.
84710000
SPACE
85140000
*
LOOP TO COMPLETE COMPUTATION.
85570000
SPACE
86000000
COMPUTE L
9,OPRN
GET EXECUTION ROUTINE ADDRESS.
86430000
COMPUTE2 LM
2,4,RHFETCH
FETCH RIGHT OPERAND FIRST.
86860000
ICALL FETCH
87290000
STD 0,DTEMP
SAVE OVER NEXT CALL.
87720000
A
2,RHFROUT
ADD IN INCREMENT.
88150000
ST
2,RINDX
AND SAVE INDEX.
88580000
LM
2,4,LHFETCH
NOW FETCH LEFT.
89010000
ICALL FETCH
89440000
A
2,LHFROUT
ADD FETCH INCREMENT.
89870000
ST
2,LINDX
AND SAVE IT.
90300000
LD
2,DTEMP
PICK UP RIGHT OPERAND.
90730000
BALR LKR,9
EXECUTE OPERAND.
91160000
STD 0,DTEMP
THESE TWO INSTRUCTION MIGHT NOT BE N 91590000
LM
0,1,DTEMP
NECESSARY.
92020000
LM
2,4,RESTORE
PICK IP STORE OPERANDS.
92450000
ICALL STORE
AND STORE RESULT.
92880000
LA
2,1(2)
INCREMENT STORE INDEX.
93310000
ST
2,RESINDX
93740000
QUEND
LET SOMEONE ELSE IN.
94170000
BCT 8,COMPUTE2
AND LOOP.
94600000
SPACE
95030000

RECOVERY IS COMPLETE.
SPACE
L
PR,=A(CLEANUP)
RE-ENTER OPERATOR CONTROL.
BR
PR
SPACE 5
MOVRANK MVC 0(0,1),0(2)
LTORG
END
./ ADD
NAME=APLSDIOT
DIOT
TITLE 'DYADIC IOTA - INVERSE INDEXING
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXIOTA CSECT
COPY APLDEFN
COPY OPSECT
TITLE 'DYADIC IOTA - INVERSE INDEXING
05/11/70'
PRINT ON,NOGEN
*
*
INVERSE INDEXING.
*
*
R = A IOTA B
*
A MUST BE VECTOR.
*
B IS ARBITRARY.
*
*
(RHO R) = RHO B.
*
*
R(I) = J SUCH THAT B(I) = A(J) WHERE J IS MINIMUM, OR IF
*
0 = OR/B(I) = A, THEN R(I) = 1+RHO A.
*
SPACE
EXIOTA CSECT
USING *,9
USING OPSECT-16,LR
ST
LKR,TEMPRES
SAVE THE LINK.
SPACE
L
1,LHRANK
FIRST, MAKE SURE LH IS VECTOR.
C
1,IOTA4
BE
SETUP
BRANCH IF SO.
LA
1,ERANK
OTHERWISE,
ICALL ERROR
GIVE A RANK ERROR.
SPACE
*
*
CALCULATE, AND GET SPACE.
*
SPACE
SETUP
L
1,RHXRHO
NEED SAME NO. OF ELS AS RHS.
L
2,RHRANK
PICK UP THE RANK.
LA
3,2
INTEGER TYPE.
L
10,=A(OPSPACE)
GET ENTRY INTO COMMON GETSPACE.
BALR LKR,10
AND ENTER IT.
EJECT
*
*
NOW, SET UP HEADER.
*
SPACE
LR
8,1
MOVE RESULT BASE TO R8.
L
1,RHRANK
PICK UP RESULT RANK.
ST
1,MTYPE(8)
PUT INTO RESULT.

95460000
95890000
96320000
96750000
97180000
97610000
98040000
98470000
00330000
00660000
00990000
01320000
01980000
02310000
02640000
02970000
03300000
03630000
03960000
04290000
04620000
04950000
05280000
05610000
05940000
06270000
06600000
06930000
07260000
07590000
07920000
08250000
08580000
08910000
09240000
09570000
09900000
10230000
10560000
10890000
11220000
11550000
11880000
12210000
12540000
12870000
13200000
13530000
13860000
14190000
14520000
14850000
15180000
15510000
15840000
16170000
16500000
16830000
17490000

LA
STC
L
LA
LA
L
LTR
BZ
BCTR
EX
SPACE
*
*
*
RANKIN

*
*
*
DECIDE

*
*
*
*

1,2
1,MTYPE(8)
7,RHBASE
7,MRHO(7)
6,MRHO(8)
5,RHRANK
5,5
RANKIN
5,0
5,MOVRANK

INTEGER TYPE.
PICK UP RIGHT BASE.
ABSOLUTE POINTER TO RANK VECTOR
ABS POINTER TO RESULT RANK VECTOR.
NUMBER OF BYTES TO MOVE.
SEE IF WE HAVE A SCALAR
BRANCH IF SO.
FOR THE OFFSET.
RANK MOVED IN.

NOW, SET UP FOR FETCHES.

SPACE
EQU
L
LTR
BZ
L
A
LA
ST
L
ST
L
A
LA
ST
L
ST
A
LA
L
L
SR
ST
ST
LTR
BNZ
L
BR
EJECT

*
4,LHXRHO
4,4
LHEMPTY
4,LHBASE
4,LHRANK
4,MRHO-M(4)
4,LHORG
4,LCTYPE
4,LCFTYPE
4,RHBASE
4,RHRANK
4,MRHO-M(4)
4,RHORG
4,RCTYPE
4,RCFTYPE
8,RHRANK
8,MRHO-M(8)
7,RHXRHO
6,COMTYP
2,2
2,RINDX
2,LINDX
7,7
DECIDE
LKR,TEMPRES
LKR

SEE IF LEFT IS EMPTY.

BRANCH IF SO.

LEFT BASE.
LEFT FETCH TYPE.

RIGHT BASE.
FETCH CODE FOR RIGHT.
NOW, SET UP RESULT BASE.
WE'RE POINTED.
NUMBER OF TIMES THROUGH.
COMPUTE TYPE.

TEST FOR NONE.

BRANCH IF NOT.
WE'RE FINISHED.

EXECUTE TYPE DEPENDENT ROUTINES.

SPACE
L
O
BCT
BCT
SPACE

4,LHTYPE
4,RHTYPE
6,*+4
4,MBEFIX

SEE IF BOTH OPERANDS ARE BOOLEAN.

BRANCH IF NOT BOOLEAN.

BOOLEAN IS FAST - FIRST 0, OR FIRST 1.

OTHER THAN 1 OR 0 IN EITHER OPERAND IS IMPOSSIBLE.

SPACE
BOOLIOTA EQU *
L
6,LHXRHO
LKFRZERO BAL 5,FETCHLFT

LOOK FOR FIRST ZERO.

FETCH A LEFT.

17820000
18150000
18480000
18810000
19140000
19470000
19800000
20130000
20460000
20790000
21120000
21450000
21780000
22110000
22440000
22770000
23100000
23430000
23760000
24090000
24420000
24750000
25080000
25410000
25740000
26070000
26400000
26730000
27060000
27390000
27720000
28050000
28380000
28710000
29040000
29370000
29700000
30030000
30360000
30690000
31020000
31350000
31680000
32010000
32340000
32670000
33000000
33330000
33660000
33990000
34320000
34650000
34980000
35310000
35640000
35970000
36300000
36630000
36960000
37290000

LTR
BZ
QUEND
BCT
LA
GOTZERO S
ST
L
SR
ST
LKFRONE BAL
LTR
BNZ
QUEND
BCT
LA
GOTONE S
L
A
A
STM
SPACE
*
GO TO
*
SPACE
BOOLOOP BAL
LM
LTR
BNZ
ST
B
ITSAONE ST
BOOLBUMP LA
QUEND
BCT
SPACE
L
BR
EJECT
*
*
CTYPE
*
(ALSO
*
SPACE
MBEFIX BCT
SPACE
*
*
OUTER
*
SPACE
FIXOUTER SR
ST
L
BAL
ST
*
*
INNER
*
FIXINNER BAL
C

0,0
GOTZERO

SEE IF WE HAVE A ZERO.

BRANCH IF SO.

6,LKFRZERO
2,1(2)
2,IOTA1
2,A
6,LHXRHO
2,2
2,LINDX
5,FETCHLFT
0,0
GOTONE

OTHERWISE, LOOP.
BUMP INDEX BY 1.
SUBTRACT 1 FROM INDEX.
SAVE THIS.
LOOK FOR FIRST 1.

6,LKFRONE
2,1(2)
2,IOTA1
3,A
2,IORIGIN
3,IORIGIN
2,3,A

OTHERWISE, LOOP.
BUMP INDEX.
SUBTRACT 1 FROM INDEX.
PICK UP INDEX OF FIRST ZERO.
ADD IN INDEX ORIGIN.

FETCH A LEFT.
SEE IF IT'S A 1.
BRANCH IF SO.

IT, STORING APPROPRIATE INDEX DEPENDING ON ORIGIN.

5,FETCHRIT
2,3,A
0,0
ITSAONE
3,M(8)
BOOLBUMP
2,M(8)
8,4(8)

FETCH A RIGHT.

7,BOOLOOP

AND LOOP.

LKR,TEMPRES
LKR

PICK UP LINK.
AND DEPART.

TEST IT.
BRANCH IF ONE.
STORE INDEX OF FIRST ZERO.
AND BRANCH.
STORE INDEX OF 1ST ONE.
BUMP RESULT POINTER.

INTEGER - SIMPLE LOOPS.

HANDLES CHAR,CHAR)
6,MBEFLT

BRANCH IF NOT INTEGER.

LOOP ON X/RHO B.
2,2
2,LINDX
6,LHXRHO
5,FETCHRIT
0,RHSAVE

REINITIALIZE LEFT FETCH INDEX.

AND INNER LOOP COUNT.
FETCH A RIGHT.
AND SAVE IT.

LOOP ON X/RHO A.
5,FETCHLFT
0,RHSAVE

FETCH A LEFT.
COMPARE TO CURRENT RIGHT.

37620000
37950000
38280000
38610000
38940000
39270000
39600000
39930000
40260000
40590000
40920000
41250000
41580000
41910000
42240000
42570000
42900000
43230000
43560000
43890000
44220000
44550000
44880000
45210000
45540000
45870000
46200000
46530000
46860000
47190000
47520000
47850000
48180000
48510000
48840000
49170000
49500000
49830000
50160000
50490000
50820000
51150000
51480000
51810000
52140000
52470000
52800000
53130000
53460000
53790000
54120000
54450000
54780000
55110000
55440000
55770000
56100000
56430000
56760000
57090000

FIXHIT

BE
QUEND
BCT
LA
SPACE
A
S
ST
LA
QUEND
BCT
SPACE
L
BR
EJECT

FIXHIT

BRANCH ON A HIT.

6,FIXINNER
2,1(2)

END OF INNER LOOP.

BUMP UP INDEX ON FALL-THRU.

2,IORIGIN
2,IOTA1
2,M(8)
8,4(8)

ADD IN INDEX ORIGIN.

SUBTRACT 1 FOR FETCH OVERSHOOT.
STORE RESULT ELEMENT.
KICK UP RESULT POINTER.

7,FIXOUTER

END OF OUTER LOOP.

LKR,TEMPRES
LKR

*
*
*

CTYPE FLOAT - FUZZ IS INVOLVED.

MBEFLT

SPACE
BCT 6,CHARACTR
SPACE

*
*
*

OUTER LOOP - SAME AS CTYPE FIXED.

BRANCH IF CHARACTER.

SPACE
FLTOUTER SR
2,2
REINITIALIZE LEFT FETCH INDEX.
ST
2,LINDX
L
6,LHXRHO
INNER LOOP COUNT.
BAL 5,FETCHRIT
FETCH A RIGHT.
STD 0,DBLSAVE
SAVE IT.
SPACE
*
*
INNER LOOP.
*
SPACE
FLTINNER BAL 5,FETCHLFT
FETCH A LEFT.
SW
0,DBLSAVE
STD 0,DTEMP
CLC DTEMP+1(7),RFUZZ+1
BNH FLTHIT
BRANCH LOW OR EQUAL - A HIT.
QUEND
BCT 6,FLTINNER
END OF INNER LOOP.
LA
2,1(2)
BUMP ON FALL THROUGH.
SPACE
FLTHIT A
2,IORIGIN
ADD IN INDEX ORIGIN.
S
2,IOTA1
SUBTRACT 1 FOR FETCH OVERSHOOT.
ST
2,M(8)
STORE RESULT ELEMENT.
LA
8,4(8)
BUMP RESULT POINTER.
QUEND
BCT 7,FLTOUTER
END OF OUTER LOOP.
SPACE
L
LKR,TEMPRES
PICK UP LINK.
BR
LKR
EJECT
*
*
CTYPE CHARACTER.
*
TWO POSSIBILITIES...
*
1)
BOTH TYPES CHAR - USE INTEGER LOOPS.
*
2)
ONE TYPE NOT CHARACTER - NO HITS.
*

57420000
57750000
58080000
58410000
58740000
59070000
59400000
59730000
60060000
60390000
60720000
61050000
61380000
61710000
62040000
62370000
62700000
63030000
63360000
63690000
64020000
64350000
64680000
65010000
65340000
65670000
66000000
66330000
66660000
66990000
67320000
67650000
67980000
68310000
68640000
68970000
69300000
69630000
69960000
70290000
70620000
70950000
71280000
71610000
71940000
72270000
72600000
72930000
73260000
73590000
73920000
74250000
74580000
74910000
75240000
75570000
75900000
76230000
76560000
76890000

SPACE
CHARACTR L
2,LHTYPE
C
2,RHTYPE
BE
FIXOUTER
SPACE
L
2,LHXRHO
A
2,IORIGIN
SPACE
MIXCHAR ST
2,M(8)
LA
8,4(8)
BCT 7,MIXCHAR
SPACE
L
LKR,TEMPRES
BR
LKR
SPACE
*
*
LH OPERAND EMPTY VECTOR.
*
SPACE
LHEMPTY L
6,RHXRHO
LTR 6,6
BNZ ALLONES
L
LKR,TEMPRES
BR
LKR
SPACE
ALLONES A
8,RHRANK
LA
8,MRHO-M(8)
L
1,IORIGIN
STONES ST
1,M(8)
LA
8,4(8)
BCT 6,STONES
L
LKR,TEMPRES
BR
LKR
EJECT
*
*
FETCH SUBROUTINES.
*
SPACE
FETCHLFT LM
2,4,LHFETCH
ICALL FETCH
LA
2,1(2)
ST
2,LINDX
BR
5
SPACE
FETCHRIT LM
2,4,RHFETCH
ICALL FETCH
LA
2,1(2)
ST
2,RINDX
BR
5
SPACE 5
*
*
CONSTANTS.
*
SPACE
EXTRN ERROR
EXTRN OPSPACE
EXTRN FETCH
SPACE 2
MOVRANK MVC 0(0,6),0(7)
IOTA1
DC
F'1'

PICK UP LEFT TYPE

USE FIXED IF EQUAL.
OTHERWISE, ALL RESULT ELEMENTS
ADD IN INDEX ORIGIN.
STORE IN RESULT.
BUMP RESULT POINTER.
END OF LOOP.

SEE IF RIGHT IS ALSO EMPTY.

BRANCH IF NOT.
OTHERWISE, RETURN.
RESULT IS ALL ONES.
RESULT IS ALL IORIGIN.

PICK UP FETC ARGUMENTS.

FETCH.
BUMP INDEX.
SAVE IT.
JUMP BACK.
PICK UP FETCH ARGUMENTS.

THAT'S ALL.

77220000
77550000
77880000
78210000
78540000
78870000
79200000
79530000
79860000
80190000
80520000
80850000
81180000
81510000
81840000
82170000
82500000
82830000
83160000
83490000
83820000
84150000
84480000
84810000
85140000
85470000
85800000
86130000
86460000
86790000
87120000
87450000
87780000
88110000
88440000
88770000
89100000
89430000
89760000
90090000
90420000
90750000
91080000
91410000
91740000
92070000
92400000
92730000
93060000
93390000
93720000
94050000
94380000
94710000
95040000
95370000
95700000
96030000
96360000
96690000

IOTA4

DC
F'4'
LTORG
END
./ ADD
NAME=APLSDPY
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, ZSYMBOLS, PERTERM
DPY
TITLE 'S T A T E M E N T D I S P L A Y
05/11/70'
PRINT NOGEN
DISPLAY CSECT
COPY APLDEFN
COPY ZSYMBOLS
COPY PERTERM
TITLE 'S T A T E M E N T D I S P L A Y
05/11/70'
PRINT ON
*
DISPLAYS A STATEMENT RECREATED FROM A CODESTRING.
*
ON ENTRY,
*
R2 = CODESTRING M-POINTER
*
R3 = CODESTRING INDEX OF ERROR BYTE, MINUS 1
*
= X'FFXXXXXX' FOR DISPLAY WITH NO ERROR-INDICATION
EXTRN FETCH
EXTRN LOUT
EXTRN LOUTN
EXTRN SQUIRT
EXTRN SQUIRTM
EXTRN TOBCD
EXTRN TOPRINT
CBCONST EQU ZBCONST*2+1
CCCONST EQU ZCCONST*2+1
CREM
EQU ZREM*2+1
DISPLAY CSECT
PROLOG DILOC,DILEND
STM 2,7,DISRS
N
2,QF24BITS
BZ
DISQ
QUIT INSTANTLY IF 'CODESTRING' IS 0
LTR 3,3
IF R3 REALLY IS A CODESTRING INDEX,
BM
DIS0
AR
3,2
ADD IN CODESTRING BASE ADDR
DIS0
STM 2,3,DISCS
LH
1,OBUFPTR
SAVE CURRENT OUTPUT BUFFER POINTER
ST
1,BLFLG
AND CLEAR BLANK-INSERTION FLAG.
LA
4,M(2)
GET ABS ADDRESS OF START OF CODESTRN
AH
2,MCSCNT(2)
GET REL ADDRESS OF END OF CODESTRING
ST
2,LASTSYL
FOR END CHECK ON LEFT-TO-RIGHT SCAN
LA
5,0(2,MR)
AND ABS ADDRESS (LESS MCSORG-M-1)
*
FOR RIGHT-TO-LEFT SCAN.
MVC TSIGDIG(1),OSIGDIG+3 SAVE CURRENT OUTPUT SIGNIFICANCE
MVI OSIGDIG+3,16
DISPLAY OUTPUT IS FULL SIGNIFICANCE.
*
BEFORE WE CAN DISPLAY THE CODESTRING, WE MUST PERMUTE
*
LONG SYLLABLES AND CONSTANT ENTRIES SO THAT THE LOW*
ORDER BIT OF THE SYLLABLE (WHICH DISTINGUISHES SHORT
*
FROM LONG) CAN BE RECOGNIZED WHEN WE SCAN LEFT-TO-RIGHT.
*
THE LEFT-TO-RIGHT SCAN WHICH DOES THE DISPLAY HAS THE
*
RESPONSIBILITY FOR REPERMUTING THE CODESTRING TO ITS
*
ORIGINAL STATE.
FLIP1
SR
1,1
PREPARE TO LOOK AT NEXT SYL
ST
1,ERPOS
CLEAR OUTPUT BUFFER POSITION OF ERR
IC
1,MCSORG-M-1(5)
TM
MCSORG-M-1(5),1
IS SYL SHORT OR LONG --

97020000
97350000
97680000
00400000
00600000
00800000
01000000
01200000
01400000
01600000
01800000
02000000
02200000
02400000
02600000
02800000
03000000
03200000
03400000
03600000
03800000
04000000
04200000
04400000
04600000
04800000
05000000
05200000
05400000
05600000
05800000
06000000
06200000
06400000
06600000
06800000
07000000
07200000
07400000
07600000
07800000
08000000
08200000
08400000
08600000
08800000
09000000
09200000
09400000
09600000
09800000
10000000
10200000
10400000
10600000
10800000
11000000
11200000
11400000

BO
MVC
STC
BCT
*
FLIP3

*
*

FLIP4
*
*
*
*
*
*
*
*
*
*

DIS1

*
DIS1E

DIS1D
DIS1A

FLIP3
SHORT.
MCSORG-M-1(1,5),MCSORG-M-2(5) LONG. INTERCHANGE BYTES.
1,MCSORG-M-2(5)
5,FLIP4
DROP POINTER 1 EXTRA FOR LONG SYL
PERMUTE FIRST AND LAST THREE BYTES OF A CONSTANT.
S
1,QACB
IS SHORT SYL A CONSTANT BEGINNER -CL
1,QF6
BH
FLIP4
NO. NO ACTION ON OTHER SHORT SYLS.
MVC FLTEMP(3),MCSORG-M-3(5) PUT COUNT ON HALFWD BNDRY.
LH
2,FLTEMP
FROM COUNT
IC
1,FLIN(1)
AND TYPE
SLL 2,0(1)
COMPUTE NUMBER OF DATA BITS.
LA
2,7+16(2)
ROUND UP (FOR BOOLEAN) AND ADD 2
SRL 2,3
(FOR COUNT) AND MAKE IT A BYTE COUNT
NOW R2 = NO. OF BYTES IN CONST DATA AND COUNT
R5 = ADDR OF TYPE SYL + 1 (LESS MCSORG-M)
LNR 2,2
AR
2,5
POSITION R2 TO LEFT END OF CONST
MVC MCSORG-M-3(3,5),Q210
MOVE FIRST 3 BYTES TO LAST,
TR
MCSORG-M-3(3,5),MCSORG-M-1(2) REVERSED.
MVC MCSORG-M-1(3,2),Q201 MOVE TYPE AND COUNT BYTES TO FIRST
TR
MCSORG-M-1(3,2),FLTEMP 3 BYTES, WITH TYPE PRECEDING CNT
LR
5,2
BCTR 5,0
MOVE R5 TO NEXT PRECEDING BYTE
CR
5,4
IF IT EQUALS THE CODESTRING ADDRESS,
BH
FLIP1
WE'RE DONE.

11600000
11800000
12000000
12200000
12400000
12600000
12800000
13000000
13200000
13400000
13600000
13800000
14000000
14200000
14400000
14600000
14800000
15000000
15200000
15400000
15600000
15800000
16000000
16200000
16400000
16600000
16800000
NOW WE'RE READY FOR THE REVERSE (PRINTING) SCAN.
17000000
LONG SYLLABLES
B1 B2,0
17200000
LOOK LIKE ...
B2,0 B1
17400000
17600000
CONSTANT SYL STRINGS
C1 C2 C3 C4 C5 ... CN CNT CS,1 17800000
LOOK LIKE ...
CS,1 CNT C4 C5 ... CN C3 C2 C1 18000000
18200000
R4 IS POINTER (ALTERNATELY RELATIVE AND ABSOLUTE)
18400000
TO SYLLABLE OF INTEREST, LESS MCSORG-M .
18600000
MVI REMTOG,CCCONST
ASSUME NORMAL APL STATEMENT
18800000
CLI MCSORG-M(4),CREM
UNLESS IT'S A COMMENT LINE,
19000000
BNE *+8
19200000
MVI REMTOG,0
FOR WHICH USE UNUSUAL OUTPUT FMT
19400000
LA
1,512
REENTRY AFTER DISPLAYING A SYLLABLE 19600000
IC
1,MCSORG-M(4)
19800000
TM
MCSORG-M(4),1
LOOK AT LENGTH OF NEXT SYLLABLE
20000000
BZ
DIS2
IF LONG SYLLABLE, 1-BIT IS 0.
20200000
SR
4,MR
R4 IS NOW RELOCATABLE
20400000
SRL 1,1
ZSYMBOL CODE IS (SYL-1)/2.
20600000
STH 1,TEC
STORE IT WITH CHAR CNT FOR SQUIRT
20800000
LA
3,TOSSE-1
SEARCH TABLE OF EXCEPTIONAL SHORT
21000000
SYLLABLES.
21200000
CLC TEC+1(1),0(3)
TABLE IS ORDERED, SO WE CAN EXIT
21400000
BH
DIS1B
ON HIGH.
21600000
BE
*+8
EXCEPTIONAL MATCH
21800000
BCT 3,DIS1E
ALWAYS BRANCHES
22000000
SR
1,1
22200000
IC
1,TOSR-TOSS(3)
REPLACEMENT GRAPHIC OR MAGIC CODE
22400000
SR
2,2
22600000
IC
2,TOSA-TOSS(3)
BRANCH ADDR OF EXCEPTION ROUTINE
22800000
B
DIS1D(2)
23000000
MVC TEC(3),QZTORS
T DELTA OR S DELTA
23200000
STC 1,TEC+1
STRAIGHTFORWARD REPLACEMENT
23400000

DIS1B
DIS1C
*

DIS1N
*
*
DIS1L
DIS1K
*
*
*
DIS3

*
*
*
*

DIS3D
DIS3P

LA
BAL

1,2
5,BLINS

UNEXCEPTIONAL CHARACTERS
PARENS AND BRACKETS. R1 IS BLANKINSERTION CODE
RECALL NUMBER OF CHARS
(1 EXCEPT FOR TRACE AND STOP)
CHECK CARRIER SPACING
FINALLY PRINT THE CHAR

23600000
23800000
24000000
SR
0,0
24200000
IC
0,TEC
24400000
BAL LKR,DISUB
24600000
LA
1,TEC
24800000
ICALL SQUIRT
25000000
BCT 4,DIS9
DROP R4 BY 1 BEFORE ADDING 2.
25200000
THE BCT ALWAYS BRANCHES.
25400000
25600000
LH
1,OBUFPTR
LABELLED END-OF-STATEMENT CHAR
25800000
BCTR 1,0
EXDENT ONE
26000000
STH 1,OBUFPTR
26200000
BCT 4,DIS9
COMMENT AT DIS1N APPLIES
26400000
26600000
LEFT-TO-RIGHT SCAN -- CONSTANT SYLLABLE.
26800000
27000000
AR
4,MR
ABSOLUTIZE R4
27200000
MVC FLTEMP+1(3),MCSORG-M(4) MOVE TYPE AND COUNT TO FLTEMP
27400000
SR
3,3
27600000
ST
3,DCJ
CLEAR VECTOR INDEX BEFORE PRINT LOOP 27800000
IC
3,FLIN-1(1)
SAVE ELEMENT LENGTH FOR LATER USE
28000000
ST
3,DCN
28200000
IC
3,FLIN-2(1)
NOW FIND BYTE LENGTH OF CONSTANT
28400000
SRL 1,1
CODESTRING ENTRY.
28600000
ST
1,DCT
28800000
LH
2,FLTEMP+2
PICK UP CONST COUNT
29000000
SLL 2,0(3)
29200000
LA
2,7+8(2)
ROUND UP TO A BYTE AND ADD 1 FOR
29400000
SRL 2,3
THE OVERHEAD SYLLABLES.
29600000
AR
2,4
29800000
NOW R4 = ABS ADDRESS OF LEFTMOST BYTE (TYPE SYLLABLE), 30000000
LESS MCSORG-M
30200000
R2 = ABS ADDRESS OF NEXT-TO-RIGHTMOST BYTE,
30400000
LESS MCSORG-M
30600000
MVC MCSORG-M(3,4),Q210 PUT THE CODESTRING BACK TOGETHER.
30800000
TR
MCSORG-M(3,4),MCSORG-M-1(2)
31000000
MVC MCSORG-M-1(3,2),Q201+2 THIS SHOULD BE THE INVERSE OF
31200000
TR
MCSORG-M-1(3,2),FLTEMP+1 THE MVC'S AND TR'S IN R-L SCAN 31400000
SR
2,MR
RELATIVIZE POINTER
31600000
ST
2,FCSP
TO BE PICKED UP TO RESUME DISPLAY. 31800000
SR
4,MR
RELATIVIZE POINTER TO LEFT END OF
32000000
ST
4,DCO
32200000
CLI REMTOG,CCCONST
IF THIS IS A COMMENT,
32400000
BNE DIS3C
AVOID ALL THE BLANK-INSERTION LOGIC 32600000
LA
1,X'18'
PREPARE TO INSERT SPACES
32800000
CLI FLTEMP+1,CCCONST
33000000
BE
DIS3D
ALWAYS ON CHARACTER CONSTANTS
33200000
CLC FLTEMP+2(2),QH1
33400000
BNH *+8
33600000
LA
1,X'1F'
EVEN MORESO ON NUMERIC VECTORS
33800000
BAL 5,BLINS
34000000
B
DIS3A
34200000
BAL 5,BLINS
34400000
LA
1,ZQUOTE
IF THIS IS CHARACTER-TYPE VECTOR,
34600000
B
DIS3M
START OFF WITH A QUOTE MARK.
34800000
CLI FLTEMP+1,CCCONST
35000000
BE
DIS3C
IF THIS ISN'T CHARACTER VECTOR,
35200000
LA
1,ZBLANK
PUT A SPACE BETWEEN ELEMENTS.
35400000

DIS3M
DIS3A
DIS3C

DIS3X
DIS3XX

DIS3G

DIS3B

DIS3F

*
DIS3V

*
DIS3S
DIS3N

DIS3R
*

BAL
ICALL
CLI
BE
L
LA
MVC
A
ST
CLC
BNE
OC
BE
CLI
BE
CLI
BNE
L
TM
BO
L
BAL
B
LA
BAL
ICALL
B
LM
LA
ICALL
ST
L
SR
SR
IC
SR
BAL
LM
ICALL

LKR,DISUBON4
CHECK FOR FIT INTO OBUF
3571
TOPRINT
SP, OR INITL QUOTE OF CHARCONST 3571
FLTEMP+1,CBCONST
WHAT KIND OF CONSTANT IS THIS -DIS3B
BOOLEAN.
4,DCO
CURRENT POINTER INTO CONSTANT 3571
1,M(4)
ABS ADDR FOR NON-BOOLEAN.
3571
DTEMP(8),MCSORG-M(1)
MOVE IN ENOUGH BYTES TO DTEMP
4,DCN
BUMP DATA ADDRESS
4,DCO
FLTEMP+1(1),REMTOG IF CHARACTER TYPE (NOT COMMENT)
DIS3R
A02
FLTEMP+2(2),FLTEMP+2 AND EMPTY VECTOR -- E.G. '', A02
DIS3S
QUIT RIGHT NOW.
DTEMP,ZQUOTE
OR, IF ELEMENT IS A QUOTE,
DIS3G
PRINT AN EXTRA QUOTE.
DTEMP,ZCR
OR IF ELEMENT IS A RETURN,
DIS3F
4,MPTBASE
IOB1-PERTERM(4),COPYWM AND WE'RE NOT A COPY SOURCE,
DIS3F
0,OBUFLIM
FORCE END-OF-LINE
LKR,DISUB
IN LIEU OF PRINTING CR.
DIS3V
1,ZQUOTE
LKR,DISUBON4
SEE IF ONE MORE WILL FIT
3571
TOPRINT
DIS3F
2,4,DCJ
BOOLEAN FETCH.
4,MCSORG-M(4)
FETCH
USE THE FETCH SUBROUTINE -- IT'S
0,DTEMP
EASIER.
2,DCT
3,3
0,0
FOR LINE-LENGTH ESTIMATION, ASSUME
0,LPERT-1(2)
MAXIMUM LENGTH FOR EACH TYPE.
4,4
DON'T LET DISUB MARK ERROR POSITION
LKR,DISUB
CHECK VISIBILITY AND CARETIZING
0,1,DTEMP
TOBCD
PRINT VALUE WITH WIDTH = 0
REENTRY FOR QUOTED CR
L
1,DCJ
LA
1,1(1)
BUMP ELEMENT INDEX
ST
1,DCJ
CH
1,FLTEMP+2
BACK TO PRINT THE NEXT ELEMENT
BL
DIS3P
UNLESS INDEX GTR CONSTANT COUNT
EX
0,DIS3X
CHECK FOR CHAR TYPE AND NOT COMMENT
BNE DIS3N
REENTRY FOR EMPTY CHARACTER VECTOR
LA
1,ZQUOTE
TO PRINT A CLOSING QUOTE.
BAL LKR,DISUBON4
ROOM FOR ONE MORE CHAR Q
3571
ICALL TOPRINT
L
4,FCSP
PICK UP SYLLABLE INDEX
SR
0,0
CHECK ERROR ON PRECEDING CONSTANT
BAL LKR,DISUB
B
DIS9
EQU *
A02
EX
0,DIS3XX
CHECK FOR COMMENT LINE WITH
A02
ZERO-LENGTH CHARACTER STRING. A02
BNE DIS3F
BRANCH IF NON-ZERO
A02
B
DIS3N
ZERO
A02

35600000
35800000
36000000
36200000
36400000
36600000
36800000
37000000
37200000
37400000
37600000
37800000
38000000
38200000
38400000
38600000
38800000
39000000
39200000
39400000
39600000
39800000
40000000
40200000
40400000
40600000
40800000
41000000
41200000
41400000
41600000
41800000
42000000
42200000
42400000
42600000
42800000
43000000
43200000
43400000
43600000
43800000
44000000
44200000
44400000
44600000
44800000
45000000
45200000
45400000
45600000
45800000
46000000
46200000
46400000
46600000
46800000
47000000
47200000
47400000

2
MCSORG-M(1,4),MCSORG-M+1(4) LONG SYLLABLE.
1,MCSORG-M+1(4)
REARRANGE PERMUTED BYTES.
FLTEMP(2),MCSORG-M(4)
4,MR
RELATIVEIZE R4 AGAIN
1,FLTEMP
PICK UP LONG SYLLABLE
1,2
MAKE IT DOUBLE-WORD INDEX
DIS9
IF SYL REPRESENTS NONEXISTENT
*
PARAMETER, IGNORE IT COMPLETELY.
A
1,QR13STK
MAKE IT M-RELATIVE
LA
1,M+4(1)
THEN ABSOLUTE
CLI 0(1),4
IS PRINT NAME LONG OR SHORT -BL
DIS2B
SHORT
L
1,0(1)
LONG
LA
1,MPNAME(1)
POINT R1 AT LONG PRINT NAME IN M
DIS2B
LR
7,1
SAVE PRINTNAME POINTER
3571
LA
1,X'18'
BAL 5,BLINS
CHECK FOR BLANK-INSERTION
SR
0,0
IC
0,0(,7)
GET THE ITEM LENGTH
3571
BAL LKR,DISUB
CLI ERSYL,2
IS THIS ERR DISPLAY
3571
BNH DIS2C
YES, DON'T GO NEAR SQUIRT
3571
LR
1,7
NO, SEND PRINTNAME OUT
3571
ICALL SQUIRT
3571
B
DIS9
ON TO NEXT SYL
3571
DIS2C
CLI ERSYL,1
PRINTING MAY BE A DEAD ISSUE
3571
BE
DIS9
IT IS, BAG IT.
3571
SR
5,5
NO. R5 GETS LENGTH
3571
IC
5,0(,7)
OF PRINTNAME
3571
LH
1,OBUFPTR
R1 GETS WHERE WE ARE
3571
LH
0,OBUFLIM
R0 GETS HOW FAR WE CAN GO
3571
SR
0,1
R0 GETS HOW MUCH WE CAN MOVE
3571
CR
5,0
WILL WHOLE NAME FIT
3571
BNH DIS2D
YES, BR
3571
LR
5,0
NO, MOVE WHAT WILL
3571
DIS2D
LA
1,OBUF(1)
ABSOLUTE BUFFER POINTER
3571
EX
5,DIS2MVC
MOVE PRINTNAME
3571
* ---BUT DON'T CALL LOUT, AS SQUIRT MIGHT HAVE DONE--3571
AH
5,OBUFPTR
UPDATE
3571
STH 5,OBUFPTR
POINTER
3571
DIS9
LA
4,2(4)
REENTRY FOR CONSTS AND SHORT SYLS
C
4,LASTSYL
BUMP CS POINTER AND TEST FOR END OF
LA
4,M(4)
(RE-ABSOLUTIZE R4 W/O SETTING CC)
BL
DIS1
CODESTRING
SR
4,MR
CLI ERSYL,2
ALL DONE WITH DISPLAY.
BNH DIS9A
FUNCTION DISPLAY AND ERROR DISPLAY
ICALL LOUT
FORCE OUT A PRINT LINE DIFFERENTLY.
B
DIS9B
DIS9A
LH
0,OBUFLIM
BAL LKR,DISUB
FORCE OUT LAST LINE OF STATEMENT
DIS9B
XC
OBUFPTR(2),OBUFPTR AND RESET OUTPUT POINTER TO LEFT MAR
MVC OSIGDIG+3(1),TSIGDIG
DISQ
LM
2,7,DISRS
IRETURN
GIN AND QUIT.
SPACE 2
3571
DIS2MVC MVC 0(1,1),1(7)
MOVE PRINTNAME TO BUFFER
3571
SPACE 5
*
DISPLAY SUBROUTINE
DIS2

SPACE
MVC
STC
MVC
SR
LH
SLA
BZ

47600000
47800000
48000000
48200000
48400000
48600000
48800000
49000000
49200000
49400000
49600000
49800000
50000000
50200000
50400000
50800000
51000000
51200000
51400000
51600000
51800000
52000000
52200000
52400000
52600000
52800000
53000000
53200000
53400000
53600000
53800000
54000000
54200000
54400000
54600000
54800000
55000000
55200000
55400000
55600000
55800000
56000000
56200000
56400000
56600000
56800000
57000000
57200000
57400000
57600000
57800000
58000000
58200000
58400000
58600000
58800000
59000000
59200000
59400000
59600000

*
*
*
*
*
*
*
*
*
*
*
*
*
DISUBON4
DISUB
DISUB1

IF THIS IS ERROR DISPLAY (FIRST BYTE OF ERSYL NOT FF),

WE PRINT ONLY THE LINE CONTAINING THE ERROR, AND A CARET.
IF THIS IS FUNCTION DISPLAY, WE PRINT THE ENTIRE STATEMENT.
ON ENTRY, R0 = CHARACTER COUNT OF LATEST SYM.
POSSIBLE VALUES OF FIRST BYTE OF ERSYL ARE ...
00
ERROR PRINT, ERROR SYLLABLE NOT FOUND YET
01
ERROR PRINT, LINE CONTAINING ERROR ALREADY PRINTED
DO NOT PRINT ANY FURTHER LINES.
02
ERROR PRINT, ERROR SYLLABLE FOUND IN CURRENT LINE
FF
FUNCTION DISPLAY. PRINT ALL LINES.
SR
LA
ST
ST
AH
CH
BNL
CLI
BCR
CL
BCR

4,4
0,1
1,DISUBT
LKR,DISUBR
0,OBUFPTR
0,OBUFLIM
DISUB2
ERSYL,0
7,LKR
4,ERSYL
4,LKR

DO NOT SET ERSYL (DESTROY R4) 3571

LENGTH OF ONE CHAR FOR TOPRINT 3571
WE KILL ONLY REGISTER 0.
ADD IN CARRIAGE POSITION
ARE WE OFF THE END -YES. ANALYZE FURTHER.
IF THIS IS ERR DPY WITH UNPRINTED ER
(WHICH IT'S NOT),
AND WE JUST PASSED THE ERROR SYL,

SAVE THE CURRENT CARRIAGE POSITION

LH
0,OBUFPTR
FOR PRINTING THE CARET.
SH
0,ERLIN2
COMPENSATE FOR ZLF ON LINE 2
3571
STH 0,ERPOS
CARET POINTER
3571
MVI ERSYL,2
INDICATE ERROR SYL IN THIS LINE
BR
LKR
DISUB2 CLI ERSYL,2
IF WE DONT PRINT THIS LINE
3571
BL
DISUB4
THEN BRANCH TO DON'T PRINT IT 3571
* THIS IS ERROR DSPLY & ERROR LINE, OR FUNCTION DSPLY, OR ) COPY 3571
L
1,MPTBASE
FIRST CHECK FOR )COPY DISPLAY 3571
TM
IOB1-PERTERM(1),COPYWM IS IT
3571
BZ
DISUB2A
NO, BR, AND PRINT ON TERMINAL 3571
* THIS IS COPY DISPLAY, PRINT WITH NO CARRIER RETURN, AND EXIT
3571
ICALL LOUTN
SHOOT IT OVER
3571
B
DISUBX
RETURN TO CALLER
3571
* THIS IS EITHER FUNCTION DISPLAY OR ERROR DISPLAY
3571
DISUB2A CLI ERSYL,2
IS IT WHICH ONE
3571
BNE DISUB7
FN DISPLAY, PRINT NORMALLY
3571
* DEFINITELY ERROR DISPLAY. NOW DO WE SPACE FORE OR AFT TO CARET. 3571
LH
1,OBUFPTR
POINT TO VIRTUAL TYPEBALL
3571
SH
1,ERPOS
AND KNOW WHICH LINE-HALF
3571
CH
1,ERPOS
IF RESULT IS HIGH WE SPACE
3571
BH
DISUB7
-SO DO IT
3571
SH
1,ERLIN2
BACKSPACE ONE LESS ON LINE 2
3571
STH 1,ERPOS
REMEMBER BKSP COUNT TO CARET
3571
LH
1,OBUFPTR
NOW, IT MAY SEEM ODD THAT
3571
LA
0,ZLF
WE DONT USE TOPRINT FOR THIS
3571
STC 0,OBUF(1)
BUT TOPRINT MIGHT CALL LOUT,
3571
LA
1,1(,1)
WHICH WE CAN'T TOLERATE HERE
3571
STH 1,OBUFPTR
YEA, VERILY.
3571
ICALL LOUTN
SHOVE IT OUT, AND THEN PREPARE 3571
MVI OBUF,ZBS
(OBUFPTR - ERPOS) BACKSPACES.
B
DISUB5
DISUB7 ICALL LOUT
MVI OBUF,ZBLANK
CLI ERSYL,2
FOR FUNCTION DISPLAY,

59800000
60000000
60200000
60400000
60600000
60800000
61000000
61200000
61400000
61600000
61800000
62000000
62200000
62400000
62600000
62800000
63000000
63200000
63400000
63600000
63800000
64000000
64200000
64400000
64600000
64800000
65000000
65200000
65400000
65600000
65800000
66000000
66200000
66400000
66600000
66800000
67000000
67200000
67400000
67600000
67800000
68000000
68200000
68400000
68600000
68800000
69000000
69200000
69400000
69600000
69800000
70000000
70200000
70400000
70600000
70800000
71000000
71200000
71400000
71600000

LA
BH
LH
STH
EX
CLI
BH
LA
ICALL
ICALL
MVI
B
LH
LA
STH
LA
STC

1,6
DISUB6
1,ERPOS
1,OBUFPTR
1,DISMVC
ERSYL,2
DISUBX
1,ZAND
TOPRINT
LOUT
ERSYL,1
DISUBX
1,OOPTR
1,1(1)
1,OBUFPTR
0,ZLF
0,OBUF-1(1)

71800000
PRINT 6 BLANKS FOR INDENTATION
72000000
DISUB5
SP/BKSP COUNT TO ERR CARET
3571 72200000
DISUB6
PRINT BLANKS UP TO THE ERROR SYL POS 72400000
72600000
FUNCTION DISPLAY QUITS NOW
72800000
73000000
ERROR LINE PRINTS A CARET
73200000
73400000
73600000
INDICATE ERROR LINE HAS BEEN PRINTED 73800000
74000000
DISUB4
THIS IS A LINE WE DON'T WANT TO
74200000
PRINT. RESET OBUFPTR TO THE
74400000
BEGINNING OF THE LINE (ALLOWING FOR 74600000
A LONG FUNCTION NAME.)
74800000
PUT IN A LINEFEED
75000000
*
TO DISTINGUISH PRINTED LINE FROM
75200000
*
FIRST LINE OF STATEMENT.
75400000
CLI ERSYL,0
IF WE HAVEN'T YET SEEN THE ERROR3571 75600000
BNE DISUBX
(BUT WE HAVE)
3571 75800000
CL
4,ERSYL
IT MAY BE THAT THE CARET
3571 76000000
BL
DISUB4X
IS RIGHT ON THE WIDTH
3571 76200000
BCTR 1,0
IT IS, COMPENSATE FOR ZLF
3571 76400000
STH 1,ERPOS
BEFORE NEXT PASS WE WANT
3571 76600000
MVI ERSYL,2
TO NOTE WE SAW THE ERROR
3571 76800000
DISUB4X MVI ERLIN2+1,1
REMEMBER WE DROPPED A LINE
3571 77000000
DISUBX L
LKR,DISUBR
77200000
L
1,DISUBT
77400000
BR
LKR
77600000
*
77800000
*
THE BLANK-INSERTION SUBROUTINE.
78000000
*
78200000
*
A BLANK IS INSERTED BETWEEN THE FOLLOWING PAIRS OF SYMBOLS... 78400000
*
IDENTIFIER
CONSTANT
78600000
*
IDENTIFIER
IDENTIFIER
78800000
*
CONSTANT
IDENTIFIER
79000000
*
CONSTANT
CONSTANT
79200000
*
VECTOR CONSTANT
ANY SPECIAL EXCEPT PARENS & BRACKETS 79400000
*
A.S.E.P&B
VECTOR CONSTANT
79600000
*
), RBR
CONSTANT OR IDENTIFIER
79800000
*
80000000
*
ALL THIS IS DONE VIA THE BLANK FLAG, WHOSE VALUE DEPENDS ON
80200000
*
THE TYPE OF CURRENT SYMBOL AS FOLLOWS ...
80400000
*
IDENTIFIER
X'18'
80600000
*
NUMERIC VECTOR
80800000
*
CONSTANT X'1F'
81000000
*
OTHER CONST X'18'
81200000
*
SPECIALS
X'02'
81400000
*
) RBR
X'20'
81600000
*
( LBR
X'00'
81800000
*
THE INSERTION CRITERION IS
82000000
*
OR / NEW-BLANK-FLAG AND 1 RIGHT-ROTATE OLD-BLANK-FLAG
82200000
*
TO AVOID INSERTION BETWEEN CONSECUTIVE SPECIALS.
82400000
*
82600000
BLINS
EX
1,BLITM
IS BLANK-INSERTION REQUIRED -82800000
SRL 1,1
CLEVERLY MODIFY FLAG
83000000
STC 1,BLFLG
BEFORE STORING IT FOR NEXT SYMBOL
83200000
BCR 8,5
NO BLANKS NEEDED.
83400000
*
MAKE SURE THAT WE HAVE SPACE IN OBUF FOR THIS BLANK
3571 83600000

BLINS2
BLITM
*
DISMVC
QH1
Q201
Q210
FLIN
LPERT
*
TOSS
TOSSE
*
TOSR
QZTORS
*

LH
LA
CH
BNL
STH
AR
MVI
BR
ST
B
TM

1,OBUFPTR
1,1(,1)
1,OBUFLIM
BLINS2
1,OBUFPTR
1,MR
OBUF-1-M(1),ZBLANK
5
5,DISUBR
DISUB2
BLFLG,0

MVC
DC
DC
DC
DC
DC

OBUF+1(0),OBUF
H'1'
FL1'2,0,1,2,0'
FL1'2,1,0'
FL1'0,0,5,4,6,8,3,1' BYTE-COUNT AND SHIFT-COUNT VALUES
FL1'1,10,23,1'
MAX LENGTH OF CONST, BY TYPE
3571
TABLE OF EXCEPTIONAL SYMBOLS
AL1(ZILG,ZEOS,ZLEOS,ZDUM,ZFCOLON,ZFPER,ZECONST,ZBCONST)
AL1(ZICONST,ZFCONST,ZCCONST,ZLBR,ZRBR,ZLPAR,ZRPAR)
AL1(ZFE,ZFOVB,ZTDELTA,ZSDELTA)
*
REPLACEMENTS FOR EXCEPTIONAL SYMBOLS
AL1(0)
UNUSED
AL1(2,2,ZDELTA)
JUST SAVING A 3-BYTE CONSTANT -POSITIONS 1 AND 3 ABOVE UNUSED
AL1(ZCOLON,ZPER,ZREM,2,4,6,8,0,X'20',0,X'20')
AL1(ZE,ZOVB,ZT,ZS)
ADDRESSES OF EXCEPTION ROUTINES
AL1(DIS1N-DIS1D,DIS1N-DIS1D,DIS1L-DIS1D,DIS1N-DIS1D)
3AL1(DIS1A-DIS1D)
4AL1(DIS3-DIS1D),4AL1(DIS1C-DIS1D),2AL1(DIS1A-DIS1D)
2AL1(DIS1D-DIS1D)
A(ZBCONST*2+1)
A(X'FFFFFF')
F'6'

DC
DC
DC
EQU
DC
DC
DC
DC

*
TOSA

DC
DC
DC
DC
QACB
DC
QF24BITS DC
QF6
DC
LTORG
DILOC
DSECT
DTEMP
DS
DISRS
DS
DISUBT DS
DIS2T
DS
DISUBR DS
FLTEMP DS
ERPOS
DS
ERLIN2 EQU
LASTSYL DS
FCSP
DS
DCN
DS
DCJ
DS
DCT
EQU
DCO
EQU
DISCS
DS
ERSYL
EQU
DS
BLFLG
DS
OOPTR
EQU
TSIGDIG DS
DS

D
6F
F
F
A
F
F
ERPOS+2
F
F
F
3F
DCJ+4
DCJ+8
2F
DISCS+4
0F
F
BLFLG+2
FL1
0H

TEST BUFFER FULL AS DISUB DO

TO ALLOW FOR ZLF
BR TO FORGET BLANK, NEW LINE
UPDATE PTR AS TOPRINT DOES
STICK IN THE BLANK
RETURN
SET RETURN ADDR FOR DISUB
GO TO DISUB END-OF-LINE CODE
EXECUTED TM

3571
3571
3571
3571
3571
3571
3571
3571
3571
3571

TEMP FOR R1 WHILE IN DISUB

TEMP FOR LINK TO DISUB
POSITION OF ERROR SYLLABLE OR 0
LINE FEED COMPENSATION FIELD
3571
REL ADDRESS OF LAST CODESTRING SYL
FUTURE CODESTRING POINTER (DIS3)
INDEX TO CONSTANT VECTOR ELEMENT
TRUE TYPE OF CONST
OFFSET TO ADDRESS CONST IN CODESTR
CODESTRING M-POINTER
POSITION OF ERROR SYLLABLE OR 0
BLANK-INSERTION FLAG
ORIGINAL VALUE OF OBUFPTR
PRESERVED OUTPUT-SIGNIFICANCE VALUE

83800000
84000000
84200000
84400000
84600000
84800000
85000000
85200000
85400000
85600000
85800000
86000000
86200000
86400000
86600000
86800000
87000000
87200000
87400000
87600000
87800000
88000000
88200000
88400000
88600000
88800000
89000000
89200000
89400000
89600000
89800000
90000000
90200000
90400000
90600000
90800000
91000000
91200000
91400000
91600000
91800000
92000000
92200000
92400000
92600000
92800000
93000000
93200000
93400000
93600000
93800000
94000000
94200000
94400000
94600000
94800000
95000000
95200000
95400000
95600000

TEC
REMTOG
DILEND

DS
3FL1
TEMPS FOR EXCEPTIONAL CHARACTERS
DS
FL1
= CCCONST IF NOT DISPLAYING COMMENT
EQU *
END
./ ADD
NAME=APLSDQRY
DQRY
TITLE 'D Y A D I C Q U E R Y
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXRANDOM CSECT
COPY APLDEFN
COPY OPSECT
TITLE 'D Y A D I C Q U E R Y
05/11/70'
PRINT ON,NOGEN
EXRANDOM CSECT
SPACE
EXTRN ERROR
EXTRN OPSPACE
EXTRN FETCH
EXTRN RANDOM
ENTRY EXRANDOM
USING OPSECT-16,LR
*
*
DYADIC QUERY
A QUERY B
*
A AND B MUST BE ONE COMPONENT.
*
A= RHO RESULT.
*
RESULT = 'A' ELEMENTS CHOSEN RANDOMLY WITHOUT REPLACEMENT FROM
*
IOTA B.
BALR 9,0
USING *,9
ST
LKR,CURRES
SAVE THE LINK REGISTER.
LA
1,ERANK
READY TO TEST FOR RANK ERRORS
SPACE
L
2,LHXRHO
TEST NO. OF ELEMENTS IN LEFT
BCT 2,RKERR
RANK ERROR IF NOT 1-ELEMENT.
SPACE
L
2,RHXRHO
TEST NO. OF ELEMENTS IN RIGHT
BCT 2,RKERR
RANK ERROR IF NOT 1-ELEMENT.
SPACE
L
4,LHBASE
READY TO FETCH LEFT OPERAND
A
4,LHRANK
L
3,LCTYPE
FETCH CONVERSION CODE.
BAL 7,TSTFETCH
FETCH OPERAND AND TEST FOR NEGATIVE
BL
RGERR
DOMAIN ERROR IF 'A' NEGATIVE
ST
0,LHSAVE
SAVE IT.
SPACE
L
4,RHBASE
READY TO FETCH RIGHT OPERAND
A
4,RHRANK
L
3,RCTYPE
CONVERSION CODE.
BAL 7,TSTFETCH
FETCH OPERAND
********* THIS 'BAL' ALSO INITIALIZES REGISTER 7 .GT. ZERO TO INDICATE
********* THE FAST DYADIC QUERY.
ST
0,RHSAVE
SAVE IT.
SPACE
L
1,LHSAVE
READY FOR RESERVE SPACE = RHO A
B
QUES
RSVP
LR
6,1
SAVE RESERVATION LENGTH
LA
2,4
MAKE RANK VECTOR.
LA
3,2
TYPE IS INTEGER

95800000
96000000
96200000
96400000
00570000
01140000
01710000
02280000
03420000
03990000
04560000
05130000
05700000
06270000
06840000
07410000
07980000
08550000
09120000
09690000
10260000
10830000
11400000
11970000
12540000
13110000
13680000
14250000
14820000
15390000
15960000
16530000
17100000
17670000
18240000
18810000
19380000
19950000
20520000
21090000
21660000
22230000
22800000
23370000
23940000
24510000
25080000
25650000
26220000
26790000
27360000
27930000
28500000
29070000
29640000
30210000
30780000
31350000
31920000

SCRAM
QUES

L
10,=A(OPSPACE)
BALR LKR,10
ST
1,RESORG
LR
8,1
NOW BUILD RESULT HEADER
L
1,QATR
ST
1,MTYPE(8)
L
1,LHSAVE
ST
1,MRHO(8)
LTR 1,1
BZ
SCRAM
LA
8,MRHO-M+4(8)
B
DQUERY
L
LKR,CURRES
BR
LKR
EJECT
CR
1,0
BH
RGERR
SRL 0,4
CR
1,0
BNL RSVPA
SRA 1,6

RSVPA

DQUERY

SLOW
*

SLOWLP

LR
L
BZ
L
L
S
A
SRL
SR
SRA
BH
SR
L
B
EQU
L
LR
LA
SR
L
LTR
BNZ
L
ST
EQU
BALR
OUTER
MR
SLDL
A
LR
QUEND
C
BE
BXLE
AR
ST

PICK UP ENTRY TO COMMON GETSPACE.

AND ENTER IT.
SAVE RESULT.
SAVE RESULT BASE
SET INTEGER TYPE, VECTOR RANK
LOAD FINAL LENGH
AND STORE IT IN HEADER
TEST IF NULL RESULT
IF NULL, SCRAM
POINT AT DATA.
PICK UP LINK.
AND UNLINK.
TEST A AGAINST B
DOMAIN ERROR IF A .GT. B
R0 = FLOOR (B/16)
TEST IF A .LT. R0
IF NOT, RESERVE SPACE FOR B ELEMENTS
OTHERWISE, TEST IF A SMALL ENOUGH
FOR SLOW METHOD.
R7=0 FOR SLOW, POSITIVE FOR FAST.
PREPARE FOR SLOW METHOD
BRANCH IF CODE INDICATES SLOW METHOD
SET TO RESERVE SPACE FOR IOTA B
CALC IF ROOM ENOUGH FOR IOTA B
NOW HAVE STACK END TO DATA
GARBAGE AVAILABLE
NOW IS WORD COUNT
SUBTRACT WORDS NEEDED
AND ALLOW FOR 16 MORE WORDS
BRANCH IF (IOTA B) WILL FIT
SET R7 FOR SLOW METHOD
SET FOR SLOW METHOD
GO RESERVE STORAGE

7,1
1,LHSAVE
RSVP
1,RHSAVE
0,SVI
0,MX
0,MINGL
0,2
0,1
0,4
RSVP
7,7
1,LHSAVE
RSVP
*
2,RHSAVE
SET MODULUS FOR FRANDOM
5,8
GET START OF DATA POINTER
4,4
SET UP COUNT FOR LOOP
5,4
INITIALIZE END TEST
10,=A(RANDOM)
SET REGISTER FOR RANDOM
7,7
SET CONDITION FOR FAST OR SLOW
FAST
1,ONES
STORE INITIAL BAD DATA
1,M(8)
*
LKR,10
GET THE FIRST RANDOM NUMBER
LOOP RETURNS TO HERE
0,2
BEGIN TO FORM MODULUS
0,1
FIX UP ARITHMETIC
0,IORIGIN
MODIFY BY ORIGIN
3,8
INITIALIZE SCAN INDEX TO TOP OF DATA
PROTECT AGAINST GHASTLY LOOPS
0,M(3)
TEST IF NEW NO. = TO GENERATED DATA
SLOW
BRANCH TO REGENERATE IF =
3,4,SLOWLP
TEST IF SCAN THRU
5,4
UP STORAGE POINTER
0,M(5)
STORE GOOD DATA

32490000
33060000
33630000
34200000
34770000
35340000
36480000
37050000
37620000
38190000
38760000
39330000
39900000
40470000
41040000
41610000
42180000
42750000
43320000
43890000
44460000
45030000
45600000
46170000
46740000
47310000
47880000
48450000
49020000
49590000
50160000
50730000
51300000
51870000
52440000
53010000
53580000
54150000
54720000
55290000
55860000
56430000
57000000
57570000
58140000
58710000
59280000
59850000
60420000
60990000
61560000
62130000
62700000
63270000
63840000
64410000
64980000
65550000
66120000
66690000

BCTR 6,10
FORM ANOTHER NO. IF NOT THRU.
B
SCRAM
OTHERWISE, EXIT
FAST
EQU *
LR
1,6
GET COUNT FOR IOTA B
A
1,IORIGIN
READY FOR BCTR
LR
3,2
COUNT IN BYTES
SLL 3,2
M*4
AR
5,3
NOW R5 IS PROPER FOR END TEST
LR
3,8
GET STORAGE ORIGIN
FSTLP
BCTR 1,0
DECREMENT COUNTER
ST
1,M(3)
STORE (REVERSE IOTA B)
BXLE 3,4,FSTLP
CONTINUE IF IOTA B NOT YET GENERATED
L
7,LHSAVE
GET A FOR LOOP END TEST
SR
6,7
R6=NO. OF EXCESS WORDS TAKEN
CALC
BALR LKR,10
GET A RANDOM NUMBER IN R0 AND R1
QUEND
GIVE UP OCCASIONALLY IF 'A' LARGE
MR
0,2
Q(M-J)
SLDL 0,1
FIX ARITHMETIC
SLL 0,2
4*(Q(M-J)
LR
1,0
FOR LATER INDEXING
AR
1,8
I=4*(J + Q(M-J))
L
0,M(1)
BEGIN SWAP
L
3,M(8)
ST
0,M(8)
R(J)=R(I)
ST
3,M(1)
R(I)=R(J)
AR
8,4
J = J + 4
BCTR 2,0
M=M-1
BCT 7,CALC
CONTINUE UNTIL 'A' EXHAUSTED
SLL 6,2
CONVERT TO BYTES
L
2,MX
SR
2,6
RESET MX TO PROPER PLACE
ST
2,MX
POINTS TO NEXT AVAILABLE STORAGE
L
8,RESORG
GET HEADER POINTER
L
2,MCOUNT(8)
GET VECTOR BYTE COUNT
SR
2,6
RESET TO ACTUAL VECTOR LENGTH
ST
2,MCOUNT(8)
B
SCRAM
SPACE
*
FETCH AND SET CONDITION CODE FOR FETCHED DATA
TSTFETCH LA
4,MRHO-M(4)
POINTER TO FIRST ELEMENT
SR
2,2
SET FOR FIRST ELEMENT
ICALL FETCH
GET ELEMENT
LTR 0,0
READY TO TEST
BR
7
RETURN TO CALLER WITH SIGNED DATA
SPACE
*
ERROR EXITS
RGERR
LA
1,ERANGE
DOMAIN ERROR
RKERR
ICALL ERROR
TAKE ERROR EXIT
SPACE
*
CONSTANTS.
*
ONES
DC
F'-1'
QF4
DC
F'4'
QATR
DC
AL1(2,0,0,4)
MTYPE, MRANK
LTORG
END
./ ADD
NAME=APLSDRHO
DRHO
TITLE 'D Y A D I C R H O
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970

67260000
67830000
68400000
68970000
69540000
70110000
70680000
71250000
71820000
72390000
72960000
73530000
74100000
74670000
75240000
75810000
76380000
76950000
77520000
78090000
78660000
79230000
79800000
80370000
80940000
81510000
82080000
82650000
83220000
83790000
84360000
84930000
85500000
86070000
86640000
87210000
87780000
88350000
88920000
89490000
90060000
90630000
91200000
91770000
92340000
92910000
93480000
94050000
94620000
95190000
95760000
96330000
96900000
97470000
98040000
98610000
00310000
00620000
00930000

REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083

PRINT OFF
APLDEFN, OPSECT
EXRHO
CSECT
COPY APLDEFN
COPY OPSECT
TITLE 'D Y A D I C R H O
05/11/70'
PRINT ON,NOGEN
EXRHO
CSECT
USING *,9
USING OPSECT-16,LR
SPACE
ST
15,CURRES
SAVE THE LINK REGISTER.
SPACE
L
6,LHRANK
CALCULATE ORIGIN OF LH DATA.
A
6,LHBASE
LA
6,MRHO-M(6)
ST
6,LHORG
L
1,LHRANK
LEFT OPERAND MUST BE C
1,RHO4
SCALAR OR VECTOR.
BNH RANKOK
BRANCH IF SO.
LA
1,ERANK
OTHERWISE,
ICALL ERROR
RANK ERROR.
EJECT
*
*
FIRST, GET SPACE.
*
RANKOK L
3,LHTYPE
FIRST, GET X/LEFT OPERAND.
SLA 3,2
A LA ARTHTP.
LA
3,2(3)
IC
3,FTCHTYP-5(3)
GOT IT.
ST
3,LCTYPE
SAVE IT.
SR
2,2
CLEAR R2.
L
4,LHORG
GET THE ORIGIN OF THE DATA.
SR
6,6
LA
7,1
L
8,LHXRHO
PICK UP NUMBER OF ELEMENTS.
C
8,SIXTHREE
SEE IF RANK VECTOR IS TOO LONG.
BNH LLTHOK
BRANCH IF NOT
LA
1,ELENGTH
OTHERWISE, LENGTH ERROR.
ICALL ERROR
LLTHOK LTR 8,8
SEE IF THERE ANY.
BZ
RESSCLR
IF NOT, RESULT IS SCALAR.
XREDUCE ICALL FETCH
FETCH,
LA
2,1(2)
BUMP INDEX,
LTR 0,0
TEST ELEMENT.
BM
RNGEROR
BRANCH IF NEGATIVE.
MR
6,0
MULTIPLY,
LTR 6,6
REJECT MUCH TOO BIG XRHO
BNZ WSFULL
BCT 8,XREDUCE
AND LOOP.
LR
1,7
X REDUCTION NOW IN R1.
ST
1,RXRHO
OTHERWISE, STORE RESULT.
L
2,LHXRHO
PICK UP LEFT LENGTH
SLA 2,2
X 4 TO GET A RANK.
L
3,RHTYPE PICK UP THE TYPE.
L
10,=A(OPSPACE)
CALL COMMON GETSPACE ROUTINE.
BALR LKR,10
ST
1,RESORG
STORE RESULTING M-POINTER.
L
1,RESORG
AND PICK UP M-POINTER AGAIN.
EJECT

01240000
01860000
02170000
02480000
02790000
03100000
03410000
03720000
04030000
04340000
04650000
04960000
05270000
05580000
05890000
06200000
06510000
06820000
07130000
07440000
07750000
08060000
08370000
08680000
08990000
09300000
09610000
09920000
10230000
10540000
10850000
11160000
11470000
11780000
12090000
12400000
12710000
13020000
13330000
13640000
13950000
14260000
14570000
14880000
15190000
15500000
15810000
16120000
16430000
16740000
17050000
17360000
17670000
17980000
18290000
18600000
18910000
19220000
19530000
19840000

*
*
*

SET UP RESULT HEADING AND RANK VECTOR.

L
3,RHTYPE
STC 3,MTYPE(1)
L
8,LHXRHO
LR
3,8
GOLDBRIK SLL 3,2
STH 3,MRANK(1)
L
4,LHTYPE
C
4,RHO2
BE
MOVINT
LR
7,1
LA
7,MRHO-M(7)
L
4,LHBASE
A
4,LHRANK
LA
4,MRHO-M(4)
L
3,LCTYPE
SR
2,2
L
5,LHRANK
LTR 5,5
BZ
MOVSCAL
SPACE
RANKLOOP ICALL FETCH
LA
2,1(2)
ST
0,M(7)
LA
7,4(7)
BCT 8,RANKLOOP
B
MOVINELS
SPACE
MOVSCAL ICALL FETCH
ST
0,M(7)
LA
7,4(7)
B
MOVINELS
SPACE
MOVINT LA
7,MRHO(1)
L
6,LHBASE
A
6,LHRANK
LA
6,MRHO(6)
BCTR 3,0
EX
3,MOVRANK
L
7,RESORG
LA
7,MRHO-M(7)
LA
7,1(7,3)
B
MOVINELS
*
MOVRANK MVC 0(0,7),0(6)
EJECT
*
*
NOW MOVE IN ELEMENTS.
*
MOVINELS L
8,RHBASE
A
8,RHRANK
LA
8,MRHO-M(8)
ST
8,RHORG
L
6,RHXRHO
L
5,RXRHO
LTR 5,5
BZ
RESEMPTY
LTR 6,6

PICK UP RESULT TYPE.

AND STORE IT.
PICK UP LEFT LENGTH.
MOVE IT.
NOW HAVE RANK OF RESULT.
SO STORE IT.
NOW LOOK AT LEFT TYPE.
SEE IF IT'S INTEGER.
BRANCH IF SO.
MOVE RESULT POINTER TO R7.
AND KICK IT.
R4 NOW POINTS TO LH OPERAND.
GET CONVERSION TYPE.
START INDEX AT ZERO.
TEST LH RANK AGAIN.
BRANCH IF ZERO.
FETCH A DIMENSION.
BUMP INDEX,
STORE A DIMENSION,
BUMP POINTER,
AND LOOP.
AND GO REPLICATE.
FETCH SCALAR LEFT.
STORE IT.
AND BUMP.
ABSOLUTE POINTER TO RESULT.
ABSOLUTE POINTER TO LEFT OPERAND.
KNOCK COUNT DOWN.
BLAST IT IN.
GET 7 POINTED RIGHT.
ADD IN NUMBER OF RANK BYTES.

PICK UP RIGHT.
POINTER TO FIRST ELEMENT.
RIGHT HAND LENGTH.
RESULT LENGTH.
SEE IF THERE IS ANY.
BRANCH IF NOT.

20150000
20460000
20770000
21080000
21700000
22010000
22320000
22630000
23250000
23560000
23870000
24180000
24490000
24800000
25110000
25420000
25730000
26040000
26350000
26660000
26970000
27280000
27590000
27900000
28210000
28520000
28830000
29140000
29450000
29760000
30070000
30380000
30690000
31000000
31310000
31620000
31930000
32240000
32550000
32860000
33170000
33480000
33790000
34100000
34410000
34720000
35030000
35340000
35650000
35960000
36270000
36580000
36890000
37200000
37510000
37820000
38130000
38440000
38750000
39060000

BZ
L
BCT
*
*
*

RNGEROR
2,RHTYPE
2,FIXTELS

PICK UP TYPE
BRANCH IF NOT BOOLEAN.

REPLICATE BOOLEAN ELEMENTS.

C
6,RHO1
SEE HOW MANY ON LEFT.
BE
MUNCH
IF ONE, BRANCH.
CR
5,6
OTHERWISE, COMPARE LENGTHS.
BNH MOOCH
EASY IF RESULT SHORTER OR 5Q41C#
LR
4,8
FETCH SET UP.
LA
3,1
BOOL TO BOOL CONVERSION.
SR
2,2
INDEX OF FIRST ELEMENT.
STM 2,4,RHFETCH
SAVE IT.
LR
4,7
STORE SET UP.
LA
3,1
BOOLEAN STORE TYPE CODE.
STM 2,4,LHFETCH
SAVE IT.
SPACE
GOLOOP LM
2,4,RHFETCH
FETCH A RIGHT.
ICALL FETCH
LA
2,1(2)
BUMP INDEX.
BCT 6,HOWDOON
BRANCH ON RH COUNT.
L
6,RHXRHO
EXHAUSTED, START OVER.
SR
2,2
HOWDOON ST
2,RINDX
STORE INDEX.
LM
2,4,LHFETCH
NOW, STORE RESULT.
ICALL STORE
DONE.
LA
2,1(2)
INCREMENT STORE INDEX.
ST
2,LINDX
AND SAVE IT.
QUEND
BCT 5,GOLOOP
AND LOOP ON RESULT XRHO.
RESEMPTY L
LKR,CURRES
OTHERWISE,
BR
15
WE'RE DONE.
*
*
BOOLEAN - SINGLE RIGHT ELEMENT.
*
MUNCH
L
1,M(8)
PICK IT UP.
SRA 1,31
SPREAD IT ALONG A WORD.
LA
4,31(5)
GET COUNT,
SRL 4,5
RESULT WORD COUNT.
MUNCHEM ST
1,M(7)
STORE IN RESULT.
LA
7,4(7)
KICK POINTER.
BCT 4,MUNCHEM
AND LOOP.
L
15,CURRES
OR,
BR
15
WE'RE DONE.
*
*
BOOLEAN - RIGHT OPERAND LONGER OR EQUAL.
*
MOOCH
LA
3,M(7)
NEED ABSOLUTE POINTERS.
LA
4,M(8)
LA
1,255
LA
5,31(5)
SRL 5,5
SLL 5,2
B
RSLTSHRT
EJECT
*
*
FIXED, FLOAT, CHARACTER RIGHT OPERAND.
*
FIXTELS BCT 2,FLTELS
BRANCH IF NOT FIXED.

39370000
39680000
39990000
40300000
40610000
40920000
41230000
41540000
41850000
42160000
42470000
42780000
43090000
43400000
43710000
44020000
44330000
44640000
44950000
45260000
45570000
45880000
46190000
46500000
46810000
47120000
47430000
47740000
48050000
48360000
48670000
48980000
49290000
49600000
49910000
50220000
50530000
50840000
51150000
51460000
51770000
52080000
52390000
52700000
53010000
53320000
53630000
53940000
54250000
54560000
54870000
55180000
55490000
55800000
56110000
56420000
56730000
57040000
57350000
57660000

FLTELS
*
*
*
MVCLOOP

*
*
*
MVCCRAP

BLOOP

*
MAXMOV

STRTOVER

*
*
*
RSLTSHRT

SLL
SLL
B
SPACE
BCT
SLL
SLL

5,2
6,2
MVCLOOP

MULTIPLY LENGTHS BY 4.
TO GET BYTES.

57970000
58280000
58590000
58900000
2,MVCLOOP
FLOAT - BRANCH IF CHARACTER.
59210000
5,3
OTHERWISE, MULTIPLY LENGTHS BY 8.
59520000
6,3
TO GET BYTES.
59830000
60140000
NOW PERFORM GREAT GRONKING MOVE CHARACTERS.
60450000
60760000
LA
1,255
MAXIMUM MOVE COUNT.
61070000
LA
3,M(7)
ABS PTR TO RESULT.
61380000
LA
4,M(8)
ABS PTR TO RIGHT.
61690000
CR
5,6
COMPARE LENGTHS.
62000000
BNH RSLTSHRT
BRANCH IF RESULT NOT SHORTER.
62310000
62620000
RESULT LONGER THAN RH OPERAND.
62930000
63240000
SPACE
63550000
LR
2,6
TURN RH LENGTH
63860000
BCTR 2,0
INTO MVC COUNT.
64170000
LR
0,2
AND SAVE IT.
64480000
CR
2,1
COMPARE TO MAXIMUM MOVE.
64790000
BH
MAXMOV
BRANCH IF GREATER.
65100000
SPACE
65410000
EX
2,MOVER
OTHERWISE, MOVE.
65720000
SR
5,0
SUBTRACT RH COUNT.
66030000
BCTR 5,0
AND SUBTRACT ONE MORE.
66340000
LR
4,3
LOAD 'FROM' PTR WITH RESORG.
66650000
LA
3,1(2,3)
BUMP RESULT POINTER.
66960000
LR
2,5
SET RH COUNT TO RES COUNT.
67270000
B
RSLTSHRT
AND GO DO AN OVERLAPPED MOVE.
67580000
67890000
EX
1,MOVER
MOVE 256 BYTES.
68200000
LA
4,1(1,4)
KICK RH POINTER.
68510000
LA
3,1(1,3)
AND RESULT POINTER.
68820000
SR
5,1
KNOCK DOWN RESULT COUNT.
69130000
BCTR 5,0
69440000
SR
2,1
AND RH COUNT.
69750000
LTR 2,2
SEE IF WE HAD A MULTIPLE OF 256.
70060000
BZ
STRTOVER
BRANCH IF SO.
70370000
BCTR 2,0
BOTH BY 256.
70680000
CR
2,1
COMPARE REMAINING COUNT TO 255.
70990000
BH
MAXMOV
STILL GREATER - GO BACK AGAIN.
71300000
SPACE
71610000
EX
2,MOVER
OTHERWISE, MOVE REST OF RIGHT.
71920000
LA
4,M(8)
START RH OVER.
72230000
LA
3,1(2,3)
KICK RESULT POINTER.
72540000
SR
5,2
DECREMENT RESULT COUNT BY LAST MOVE. 72850000
LR
2,6
RELOAD RIGHT COUNT.
73160000
BCTR 2,0
KNOCK IT DOWN.
73470000
CR
5,6
COMPARE LENGTHS AGAIN.
73780000
BNH RSLTSHRT
BRANCH IF RESULT NOW NOT LONGER.
74090000
B
MAXMOV
OTHERWISE, LOOP.
74400000
SPACE
74710000
75020000
RIGHT SHORTER OR EQUAL RESULT.
75330000
75640000
SPACE
75950000
CR
5,1
SEE IF RESULT IS LESS THAN 255.
76260000

FINI
*
MOV256

*
MOVER

BH
EX
L
BR

MOV256
5,MOVER
LKR,CURRES
LKR

BRANCH IF NOT.
OTHERWISE, SLAP THEM IN.

EX
LA
LA
SR
LTR
BZ
BCTR
B

1,MOVER
3,1(1,3)
4,1(1,4)
5,1
5,5
FINI
5,0
RSLTSHRT

MOVE IN 256 BYTES.

KICK POINTER.
KNOCK DOWN COUNT.

AND TRY AGAIN.

MVC 0(0,3),0(4)
EJECT

*
*
SCALAR RESULT.
*
RESSCLR L
1,RHXRHO
LTR 1,1
BNZ MAKESCLR
LA
1,ELENGTH
ICALL ERROR
MAKESCLR LA
1,1
L
3,RHTYPE
SR
2,2
L
10,=A(OPSPACE)
BALR LKR,10
L
6,RHBASE
A
6,RHRANK
LA
6,MRHO(6)
LM
4,5,0(6)
ST
4,MRHO(1)
L
7,RHTYPE
C
7,RHO3
BNE BUNNY
ST
5,MRHO+4(1)
BUNNY
SR
2,2
STH 2,MRANK(1)
STC 7,MTYPE(1)
L
15,CURRES
BR
15
EJECT
*
ERRORS AND CONSTANTS.
*
LNGEROR LA
1,ELENGTH
ICALL ERROR
SPACE
RNGEROR LA
1,ERANGE
ICALL ERROR
WSFULL LA
1,EMFULL
ICALL ERROR
*
EXTRN ERROR
EXTRN FETCH
EXTRN STORE
EXTRN OPSPACE
*
RHO1
DC
F'1'

NEED 1 ELEMENT.
PICK UP THE TYPE.
RANK IS ZERO
USE COMMON GETSPACE ROUTINE.
PICK UP RIGHT BASE.
ADD IN THE RH RANK.
AND HEAD LENGTH.
PICK UP FIRST DOUBLE WORD.
STORE FIRST ONE.
PICK UP THE TYPE.
SEE IF IT'S FLOATING.
BRANCH IF NOT FLOATING.
OTHERWISE, STORE SECOND WORD.
CLEAR R2.
STORE IN RANK.
AND THE TYPE.

76570000
76880000
77190000
77500000
77810000
78120000
78430000
78740000
79050000
79360000
79670000
79980000
80290000
80600000
80910000
81220000
81530000
81840000
82150000
82460000
82770000
83080000
83390000
83700000
84010000
84320000
84630000
84940000
85250000
85560000
85870000
86180000
86490000
86800000
87110000
87420000
87730000
88040000
88350000
88970000
89280000
89590000
89900000
90210000
90520000
90830000
91140000
91450000
91760000
92070000
92380000
92690000
93000000
93310000
93620000
93930000
94240000
94550000
94860000
95170000

RHO2
RHO3
RHOM4
RHO4
RHO32
SIXTHREE
RHO24
TWO24
FTCHTYP

DC
F'2'
DC
F'3'
DC
F'-4'
DC
F'4'
DC
F'32'
DC
F'63'
DC
X'02000004'
DC
X'01000000'
DC
FL1'1,5,6,13,7,2,8,13,9,10,3,13,13,13,13,4'
LTORG
END
./ ADD
NAME=APLSDSER
DSER
TITLE 'DIRECTORY SEARCH FOR DISK OPERATIONS
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&L
ZTEXT &A
LCLA &I,&N
LCLC &C
&N
SETA (K'&A)-2
&I
SETA 1
SKIP LEFT QUOTE
&L
EQU &N
AIF (&I EQ &I).A4
APL DEVELOPMENT GLITCH
.A4
AIF (&I EQ &N+1).A1
&I
SETA &I+1
&C
SETC '&A'(&I,1)
AIF ('&C' NE ' ').A3
&C
SETC 'BLANK'
AGO .A2
.A3
AIF ('&C' NE ',').A2
&C
SETC 'COMMA'
.A2
DC
AL1(Z&C)
AGO .A4
.A1
MEXIT
MEND
MACRO
ZEND
DC
AL1(ZCR,ZEOB)
MEND
MACRO
&OP
SDPAR &F,&ADR
ORG SDTAB+2*XX&OP
DC
AL1(&F)
DC
AL3(&ADR)
MEND
DIRSEAR CSECT
PRINT OFF
APLDEFN, ZSYMBOLS,PERTERM, APLSUPC
2230
COPY APLDEFN
COPY ZSYMBOLS
COPY PERTERM
APLSUPC ,
MAPS SUPPARS AREA IN APLSUP
2230
VALCON EQU 0
AVOIDS ASM ERROR
2230
PRINT ON,NOGEN
TITLE 'DIRECTORY SEARCH FOR DISK OPERATIONS'
ENTRY DSIRMSG
EXTRN GETIME
EXTRN KMANHASH
EXTRN LIBPARS
EXTRN LIBPZ

95480000
95790000
96100000
96410000
96720000
97030000
97340000
97650000
97960000
98270000
98580000
00160000
00320000
00480000
00640000
00800000
00960000
01120000
01280000
01440000
01600000
01760000
01920000
02080000
02240000
02400000
02560000
02720000
02880000
03040000
03200000
03360000
03520000
03680000
03840000
04000000
04160000
04320000
04480000
04640000
04800000
04960000
05120000
05280000
05440000
05760000
05920000
06080000
06240000
06400000
06560000
06720000
06880000
07040000
07200000
07360000
07520000
07680000
07840000

WORKS
DIRSMAN
OUT1
OUT2
DIRSWSQ
ASDIRCHG
DIRCHG
TEMA
GETTEM
OLDLAB
WORKZ
DIRSEAR

LIBS1

*
*

EXTRN LOUT
EXTRN PRWSNAME
EXTRN SUPPARS
MAPPED BY SUPPARD DSECT
2230
EXTRN SQUIRT
EXTRN SQUIRTM
DSECT
DS
4F
DS
F
LIBRARY NO FOR ASUP, 2ND DIR UPDATE
DS
F
CCHH
DASD
DS
H
PSFILE
DS
2H
WSQ, WSA FOR ASUP 2ND DIR UPDATE
DS
X'00'
DIRCHG FLAG FOR ASUP
DASD
DS
X'01'
DS
F
DS
6F
FOR GETRKS
DS
CL16
HOLDS OLD WFLIB & WFLNAME
DS
0D
COPY DIRSECT
USING WORKS,13
CSECT
USING PERTERM,10
USING CDCPARS,8
PARAMETER FROM APLSUP
BALR 12,0
USING *,12
LA
14,WORKZ
PSEUDO PROLOG
USING PDSDDDD,9
L
9,=A(SDPAR)
START OF SPECIAL DISK PROBLEM STATE ROUTINES
L
10,=A(SUPPARS)
A(PERTERM) FROM PROTECTED CORE 2230
L
10,PTBASE-SUPPARD(10)
2230
USING PERCORE,7
APLSUP SETS R7 TO REQUESTOR'S WS
MVC TEMA+1(3),PCADDR
L
7,TEMA
DROP 7
MVC OLDLAB,WFLLIB-M(7)
ICALL GETIME
DO ONE GETIME AND BE DONE WITH IT
ST
1,WFLTIME
ASSUME TIME IS CONSTANT OVER DIRSEAR
MVI DIRCHG,1
FOR GETRKS
L
2,LIBENDMK
L
0,PDSLIB
LIBRARY NUMBER FROM COMMAND
L
1,MANSTAR
AR
1,MR
USING PERLIB,1
SR
3,3
FIND CODE WORD FOR OPERATION
IC
3,SDOP
AR
3,3
LA
3,SDTAB(3)
B
LIBS1+4
SKIP INCREMENT
LA
1,MANENTL(1)
INCREMENT TO NEXT ENTRY
CL
0,LIBNUM
BE
LIBFND
LIBRARY NUMBER FOUND
CL
2,LIBNUM
TEST FOR END OF LIBRARY
BNE LIBS1
SEARCH NEXT LIBENT
DROP 1
LIBRARY NUMBER NOT FOUND
CLI PDSWSN,11
CHAR COUNT OVER 11 MEANS DIRECTORY
BH
DSF2
LABEL -- I.E. NAMELESS )SAVE OF
CLEAR WS. REJECT IT.
TM
0(3),NOLBM+ADDNL
BM
WSNFN
'WSNFND' IF LOAD, DROP, COPY

08000000
08160000
08320000
08480000
08640000
08800000
08960000
09120000
09280000
09440000
09600000
09760000
09920000
10080000
10240000
10400000
10560000
10720000
10880000
11040000
11200000
11360000
11520000
11680000
11840000
12000000
12160000
12320000
12480000
12640000
12800000
12960000
13120000
13280000
13440000
13600000
13760000
13920000
14080000
14240000
14400000
14560000
14720000
14880000
15040000
15200000
15360000
15520000
15680000
15840000
16000000
16160000
16320000
16480000
16640000
16800000
16960000
17120000
17280000
17440000

LIBFND

SWS1

*
*
*
DSLOAD
*

DSLNP
DSLNM1
DSLNM2
*
*
*
DSSAVE

DSF3
*

DSF6

*
DSF5

*
*
DSF4
DSF2

BO
ADDNF
ADD NEW LIB OR MAN IF )ADD
B
ILSAVE
OTHERWISE IMPROPER LIB REFERENCE
SPACE 2
USING PERSAVW,4
LR
4,1
TM
0(3),NOWS
L
LKR,0(3)
BCR 1,LKR
SKIP WS SEARCH
CLC PSLINK,ZERO
SEE IF ANOTHER ENTRY EXISTS.
BE
SWS2
L
1,PSLINK
LR
5,4
FOR USE BY DROP
LA
4,0(1,MR)
SCAN NEXT ENTRY
CLC PSNAME,PDSWSN
BNE SWS1
TRY AGAIN
FOUND WORKSPACE NAME
BR
LKR
SPACE 2
LOAD OR COPY OPERATION
CLC PSPASS,PDSPASS
MATCH PASSWORDS, DIR & COMMAND
BNE DSLNP
NO MATCH
LOAD, COPY, SAVE COMMAND OKAY, DIRECTORY UNCHANGED
L
0,PSCYL
PARAMETER TO APLSUP
DASD
MVI ASDIRCHG,0
DASD
MVC OUT2,PSFILE
B
DSEXIT
TYO DSLNM1
B
SDREJ
DC
Y(DSLNM2+1)
ZTEXT 'WS LOCKED'
ZEND
)SAVE, WSNAME FOUND
L
0,PSMAN
PREVIOUS SAVER
BAL LKR,PROTCH2
CHECK RESAVE OKAY IN THIS LIB
CLC OLDLAB,PDSLIB
)LOOK FOR )LOAD A )SAVE B
BNE DSF4
COMPLAIN UNLESS )SAVE CONTINUE
CLC PSLEN,PDSTCNT
SAVE, COMPARE TRACK COUNTS
BL
DSF5
WON'T FIT IN OLD SLOT
CHECK TO SEE IF PASSWORD HAS CHANGED
CLC PDSPASS,PSPASS
BNE DSF6
DIRECTORY IS CHANGED
MVI DIRCHG,0
TELL APLSUP DIR UNCHANGED
LR
3,4
FOR MKFLAB
MVC PSPASS,PDSPASS
BAL 15,MKFLAB
B
DSEXIT
NEW BLOCK OF TRACKS REQUIRED FOR THIS SAVE
BAL 15,GETRKS
LR
1,3
RELATIVE ADDR OF NEW BLOCK
AR
3,MR
MVC PSLINK-PERSAVW(4,3),PSLINK
B
DSDROP1
COMPLETE LINKAGE INTO LIST FOR
THIS LIBRARY AND SALVAGE OLD
SAVE AREA
CLC ZCONT,PDSWSN
BE
DSF3
)LOAD A )SAVE CONTINUE OKAY
LA
1,SAINB1

17600000
17760000
17920000
18080000
18240000
18400000
18560000
18720000
18880000
19040000
19200000
19360000
19520000
19680000
19840000
20000000
20160000
20320000
20480000
20640000
20800000
20960000
21120000
21280000
21440000
21600000
21760000
21920000
22080000
22240000
22400000
22560000
22720000
22880000
23040000
23200000
23360000
23520000
23680000
23840000
24000000
24160000
24320000
24480000
24640000
24800000
24960000
25120000
25280000
25440000
25600000
25760000
25920000
26080000
26240000
26400000
26560000
26720000
26880000
27040000

SAINB1
SAINB2
*
*
*
*
DSDROP

DSDROP2
*
DSDROP1
*
DSDRSUB

*
DSOFF

SETPASS

*
*
*
SWS2

ICALL
LA
ICALL
B
DC
ZTEXT

SQUIRT
1,OLDLAB
PRWSNAME
SDREJ
AL1(SAINB2)
'NOT SAVED, THIS WS IS '

27200000
27360000
27520000
27680000
27840000
28000000
28160000
28320000
)DROP, WSNAME FOUND. R0 = PDSLIB
28480000
28640000
L
0,PSMAN
CHECK DROP BY VALID MAN NO
28800000
BAL LKR,PROTCH2
28960000
CLC ZCONT,PDSWSN
29120000
BE
DSDROP2
CONTINUE IS NOT PART OF QUOTA
29280000
SR
7,7
29440000
BCTR 7,0
29600000
BAL LKR,ADJQOT
DECREASE COUNT OF SAVED WORKSPACES 29760000
DC
AL2(0)
29920000
L
1,PSLINK
30080000
R5 WAS SET BY CODE AT SWS1
30240000
MVC ASDIRCHG,DIRCHG
1 OR 2 DIRECTORY WRITES REQ'D DASD 30400000
ST
1,PSLINK-PERSAVW(5)
30560000
LA
LKR,DSEXIT
RETURN FROM DELINKING SUBROUTINE
30720000
UNLINK THIS PERSAVW FROM LIBRARY LIST AND PUT IT ON SALVHED
30880000
SR
2,2
31040000
IC
2,PSLEN
TRACK COUNT
31200000
SLL 2,2
31360000
L
1,SALVHED-4(2)
31520000
ST
1,PSLINK
LINK TO OTHER BLOCKS THIS SIZE
31680000
SR
4,MR
31840000
ST
4,SALVHED-4(2)
32000000
BR
LKR
32160000
32320000
USING PERLIB,1
32480000
LM
4,5,PTABTM
32640000
AR
5,4
COMPUTE TIME, TODAY
32800000
L
4,WFLTIME
32960000
S
4,PTSOTM
CONNECTION TIME TODAY
33120000
LM
2,3,CUMCON
CUMULATIVE TIMES
33280000
AR
2,4
CONNECTION
33440000
AR
3,5
COMPUTE
33600000
STM 2,3,CUMCON
33760000
NI
PLMISC,255-LIBAUTOL
33920000
TM
PDSWSQI,LIBAUTOL
AUTO-LOAD FUN AND GAMES
34080000
BZ
*+8
34240000
OI
PLMISC,LIBAUTOL
34400000
MVI ASDIRCHG,1
DIRECTORY REWRITE REQUIRED
DASD 34560000
SR
0,0
DASD 34720000
CLI PDSPASS,0
CHECK FOR SIGNOFF PASSWORD CHANGES 34880000
BE
DSEXIT
NO CHANGE TO PASSWORD
35040000
MVC SOPASS,PDSPASS
NEW PASSWORD
35200000
CLI PDSPASS,X'FF'
35360000
BNE DSEXIT
35520000
XC
SOPASS,SOPASS
EMPTY PASSWORD
35680000
B
DSEXIT
35840000
DROP 1
36000000
36160000
)SAVE, WSNAME NOT FOUND (OR 'IMPROPER REFERENCE')
36320000
36480000
CLI SDOP,XXSAVE
36640000

WSNF3
WSNF2

ZCONT
ZCONT1
*
ILSAVR
ILSVR1
ILSVR2
*
*
*
*
*
*
*
*
*
*
*
ADJQOT

PTLOC1

PTLOC2

ADJQ4

BNE WSNFN
WSNAME NOT FOUND, NON SAVE OP
BAL 15,PROTCHK
CHECK FOR PROPER MAN/LIB NUMBERS
BNL *+8
CREDITEE IS LIB NO. IF PRIVATE LIB
L
0,PTMAN
AND SAVER IF PUBLIC LIB
NAME NOT FOUND IN SAVE OPERATION, CREATE NEW ENTRY
CLI PDSWSN,11
CHAR COUNT OVER 11 MEANS DIRECTORY
BH
DSF2
(IE NAMELESS SAVE OF CLEAR WS)
CLC ZCONT,PDSWSN
BE
WSNF2
CONTINUE IS NOT PART OF QUOTA
LA
7,1
BAL LKR,ADJQOT
INCREASE COUNT OF SAVED WORKSPACES
DC
AL2(0)
BAL 15,GETRKS
ST
3,PSLINK
INSERT IN LIST FOR THIS LIBRARY.
B
DSEXIT
CLC PUBPRI,PDSLIB
NO )SAVE OF CONTINUE IN PUBLIC LIB
BL
WSNF3
B
ILSAVE
REJECT SAVE OF WS NAMED CONTINUE
DROP 4
DC
0XL9'00'
ESTABLISH LENGTH ATTRIBUTE
DC
X'08'
COUNT
ZTEXT 'CONTINUE'
TYO
MVI
B
DC
ZTEXT
ZEND

ILSVR1
A LIBRARY IS FULL
ASDIRCHG,2
SEARCH FAILURE
DSEXIT
Y(ILSVR2+1)
'NOT SAVED, WS QUOTA USED UP'

DASD

ADJUST SAVED WORKSPACE QUOTA FOR )SAVE, )DROP

R0 = LIB NUMBER OF CREDITEE
R7 IS INCREMENT OR DECREMENT FOR WSA
0(LKR) IS HALFWORD GLITCH TO LET )ADD CHANGE QUOTA, NOT ACTUAL
)SAVE EXITS TO ILSAVR ON WS QUOTA USED UP
IF MAN CREDITED WITH SAVE, DROP IS SIGNED ON, ADJUST PTWSA.
IF MAN CREDITED WITH SAVE, DROP IS IN THIS DIRECTORY,
ADJUST MANWSA. ONE OR BOTH OF THE ABOVE WILL OCCUR.
IF NOT IN THIS DIRECTORY, TELL ASUP TO READ OTHER DIRECTORY.
ST
0,DIRSMAN
SAVE CREDITEE FOR ASUP DIR READ
XC
DIRSWSQ(4),DIRSWSQ CLEAR INCREMENT FIELDS
3591
L
2,=A(SUPPARS)
SEE IF THIS GUY IS SIGNED ON
2230
LA
2,PTBXLE-SUPPARD(2) R2 POINTS TO PTBXLE
2230
L
3,8(2)
NOT ENOUGH REGISTERS AROUND FOR BXLE
TM
IOB1-PERTERM(3),NSIGNM
BO
PTLOC2
C
0,PTMAN-PERTERM(3)
BE
ADJQ4
FOUND HIM
A
3,0(2)
C
3,4(2)
BNH PTLOC1
B
ADJQ2
NOT FOUND
LR
6,7
SIGNED ON. ADJUST PERTERM WS INFO
LH
1,0(LKR)
WE MAY HIT QUOTA OR ACTUAL
AH
6,PTWSA-PERTERM(3,1)
BNM *+6
DON'T ALLOW NEGATIVE QUOTA
3591
SR
6,6
3591
CH
6,PTWSQ-PERTERM(3) FOR )SAVE, CHECK RATION EXCEEDED
BNH ADJQ1
OK

36800000
36960000
37120000
37280000
37440000
37600000
37760000
37920000
38080000
38240000
38400000
38560000
38720000
38880000
39040000
39200000
39360000
39520000
39680000
39840000
40000000
40160000
40320000
40480000
40640000
40800000
40960000
41120000
41280000
41440000
41600000
41760000
41920000
42080000
42240000
42400000
42560000
42720000
42880000
43040000
43200000
43360000
43520000
43680000
43840000
44000000
44160000
44320000
44480000
44640000
44800000
44960000
45120000
45280000
45440000
45600000
45760000
45920000
46080000
46240000

ADJQ1
ADJQ2

LOC8A

LOC8B

ADJQ3
*
*
ADJQ5
*
*
*
GETRKS

*
*
*

EWS3

EWS6

CLI SDOP,XXSAVE
DON'T PARALYZE HIM ON )DROP
BE
ILSAVR
SVRAPE
STH 6,PTWSA-PERTERM(3,1)
L
1,DIRSMAN
SR
0,0
NOW SEE IF CREDITEE IS IN THIS DIR.
L
2,=A(KMANHASH)
D
0,0(2)
MVI DIRCHG,3
ASSUME NOT
C
0,WFLMAN
L
0,DIRSMAN
BNE ADJQ5
NOT IN THIS DIRECTORY
3591
MVI DIRCHG,1
ONLY ONE DIRECTORY REWRITE
L
2,LIBENDMK
L
1,MANSTAR
AR
1,MR
C
0,0(1)
BE
LOC8B
C
2,0(1)
LA
1,MANENTL(1)
BNE LOC8A
B
2(LKR)
NOT FOUND. HE'S BEEN DELETED.
LH
2,0(LKR)
THIS USUALLY DUPLICATES PERTERM
AH
7,MANWSA-PERLIB(1,2)
BNM *+6
DON'T ALLOW NEGATIVE QUOTA
3591
SR
7,7
3591
CH
7,MANWSQ-PERLIB(1) CALCULATION ABOVE
BNH ADJQ3
CLI SDOP,XXSAVE
BE
ILSAVR
STH 7,MANWSA-PERLIB(1,2)
B
2(LKR)
PUT INCREMENT TO QUOTA OR ACTUAL INTO APPROPRIATE
3591
HALFWORD IN DIRSWSQ. APLSUP WILL LOOK AT DIRSWSQ.
3591
LH
1,0(LKR)
=0 FOR ACTUAL, =-2 FOR QUOTA
3591
STH 7,DIRSWSQ+2(1)
3591
B
2(LKR)
RETURN TO CALLER
3591
SUBROUTINE TO LOCATE BLOCK OF TRACKS ON DISK
STM 0,5,GETTEM
PRESERVE R0,R1,R4,R5
LH
1,PDSTCNT-1
BCTR 1,0
SLL 1,2
SALVAGED BLOCKS ARE RECORDED IN LINKED LISTS. A DIFFERENT
LIST IS USED FOR EACH SIZE BLOCK.
LIST HEADS ARE IN VECTOR STARTING ATSALVHED.
LA
2,SALVHED(1)
CLC 0(4,2),ZERO
BE
EWS2
LIST IS EMPTY
L
3,SALVHED(1)
AR
3,MR
USING PERSAVW,3
L
2,PSLINK
REMOVE TOP BLOCK
ST
2,SALVHED(1)
MVC PSMAN,GETTEM
REMEMBER SAVER
MVC PSNAME,PDSWSN
MVC PSPASS,PDSPASS
PASSWORD
MVC PSLINK,ZERO
LM
0,1,GETTEM

46400000
46560000
46720000
46880000
47040000
47200000
47360000
47520000
47680000
47840000
48000000
48160000
48320000
48480000
48640000
48800000
48960000
49120000
49280000
49440000
49600000
49760000
49920000
50080000
50240000
50400000
50560000
50720000
50880000
51040000
51200000
51360000
51520000
51680000
51840000
52000000
52160000
52320000
52480000
52640000
52800000
52960000
53120000
53280000
53440000
53600000
53760000
53920000
54080000
54240000
54400000
54560000
54720000
54880000
55040000
55200000
55360000
55520000
55680000
55840000

LO
*
MKFLAB

*
*
EWS2

*
*
*
*
*
MAXS1

MAXS3
MAXS4

MAXS2
*
EWS1

EWS9

LM
4,5,GETTEM+16
EQU OBUF-WFLLIB
LABEL OFFSET
NOW SETUP NEW WS LABEL FOR APLSUP
MVC WFLLIB+LO(16),PDSLIB & WSNAME
MVC WFLMAN+LO(12),PSMAN & PSPASS
MVC WFLDATE+LO,ZSYMDATE
MVC WFLTIME+LO,WFLTIME TIMESTAMP WS
L
0,PSCYL
PARAMETER TO APLSUP
DASD
MVC ASDIRCHG,DIRCHG
DIRECTORY REWRITE CODE
DASD
MVC OUT2,PSFILE
DROP 3
SR
3,MR
BR
15
NO SALVAGED BLOCK OF EXACT SIZE EXISTS
TRY FREE AREA ON DISK PACK
L
3,DSNXTF
LA
2,PSWL(3)
FIRST MAKE SURE THERE'S ROOM IN
C
2,MANSTAR
DIRECTORY FOR NEW PERSAVW
BNL EWS7
SELECT A FILE TO SAVE THIS WORKSPACE ON
LIB EXTENT IS FULL IF CFREDSK IS LARGER THAN EXTUP.
5981
R3
IS MAX NUMBER OF FREE TRACKS SO FAR.
5981
R5
IS NUMBER OF FREE TRACKS IN EXTENT R2.
5981
R8 IS ((EXTUP-CFREDSK) IOTA MAX/EXTUP-CFREDSK) (/1/)
LM
0,2,CDCBXLE
SR
3,3
SR
5,5
IF END-CYL MINUS FR-CYL IS MINUS5981
LH
4,EXTUP-CDCPARS(2) END-CYL MINUS FREE-CYL
5981
SH
4,CFREDSK-CDCPARS(2)
5981
BM
MAXS4
ONLY IF EXTENT IS FULL
5981
LH
5,2+EXTUP-CDCPARS(2) END-HEAD MINUS FREE-HEAD
5981
SH
5,2+CFREDSK-CDCPARS(2)
5981
BNM MAXS3
BRANCH IF HEAD DIFF NOT MINUS 5981
LTR 4,4
5981
BZ
MAXS4
BR IF EXTENT IS FULL
5981
BCTR 4,0
IF MINUS, DECR CYL DIFF
5981
AH
5,HMAX-CDCPARS(2) AND GET NO. TRKS MINUS 1
5981
MH
4,CCADJ-CDCPARS+2(2) MULT CYL BY MINUS TRKS/CYL
5981
LPR 4,4
5981
LA
5,1(4,5)
GET TOTAL FREE TRACKS
5981
CR
3,5
BH
MAXS2
LR
3,5
NEW MAX FREE TRACKS
5981
LR
8,2
BXLE 2,0,MAXS1
L
1,CFREDSK
AH
1,PDSTCNT-1
FREEDSK IS IN FORMAT CCHH
DASD
EX
1,EWS5
SEE IF WE ARE BEYOND MAX HEAD
BH
EWS9
A
1,CCADJ
INCREMENT CYLINDER, RESET HEAD
B
EWS1
CH
3,PDSTCNT-1
TRKS AVAILABLE VS.TRKS NEEDED 5981
BL
EWS4
NO ROOM IN FREE AREA
5981
L
0,CFREDSK
FIRST FREE TRACK
SVRAPE
, CFREDSK IS IN PROTECTED STORAGE
ST
1,CFREDSK
L
3,DSNXTF
LA
2,PSWL(3)
ST
2,DSNXTF

56000000
56160000
56320000
56480000
56640000
56800000
56960000
57120000
57280000
57440000
57600000
57760000
57920000
58080000
58240000
58400000
58560000
58720000
58880000
59040000
59200000
59360000
59520000
59680000
59840000
60000000
60160000
60320000
60480000
60640000
60800000
60960000
61120000
61280000
61440000
61600000
61760000
61920000
62080000
62240000
62400000
62560000
62720000
62880000
63040000
63200000
63360000
63520000
63680000
63840000
64000000
64160000
64320000
64480000
64640000
64800000
64960000
65120000
65280000
65440000

EWS7
*
EWS4
EWS8
EWS5
MESS1
MESS1L

AR
3,MR
USING PERSAVW,3
ST
0,PSCYL
CCHH
MVC PSLEN,PDSTCNT
NUMBER OF TRACKS
S
8,ADPAR
STH 8,PSFILE
FOR APLSUP AND UTILITY
B
EWS6
TYO ADDF1
B
EWS8
NO FREE STORAGE FOUND BY SPACE LOCATOR
TYO MESS1
EQU *
MVI ASDIRCHG,2
INDICATE SEARCH FAILURE
B
DSEXIT
CLI HMAX+1,0
A DIRTY TRICK
DROP 8
DC
Y(MESS1L+1)
ZTEXT 'NO SPACE'
ZEND

DASD

DASD

*
*
CHECK THAT USER IS ALLOWED ACCESS TO THIS LIBRARY
*
R0 = LIBRARY NUMBER IN QUESTION
*
ON EXIT, CC = 1 IF PUBLIC LIB, 0 OR 3 OTHERWISE
*
PROTCHK C
0,PUBPRI
PUBLIC LIB ALWAYS OKAY
BCR 4,LKR BL
PROTCH2 C
0,PTMAN
IF NOT PUBLIC, MUST MATCH
BCR 8,LKR
OR BE PRIVILEGED TERM
TM
IOB1,PRIVBIT
BCR 1,LKR
TERMINAL IS PRIVILEGED
*
AND / (SDOP=XXSAVE), (LIBNUMC GT 1000), LIBNUMC NE PTMAN
ILSAVE TYO ILSV1
CLI SDOP,XXLIB
LIB COMMAND HAS SPECIAL TERMINATION
BE
PRLIBZ
SDREJ
MVI ASDIRCHG,2
REJECT CODE
DASD
B
DSEXIT
DSIRMSG EQU *
ILSV1
DC
Y(ILSV2+1)
ILSV2
ZTEXT 'IMPROPER LIBRARY REFERENCE'
ZEND
WSNFN
TYO WNOTF1
B
SDREJ
WNOTF1 DC
Y(WNOTF2+1)
WNOTF2 ZTEXT 'WS NOT FOUND'
ZEND
DROP 3
*
ADD NEW LIBRARY OR MAN NUMBER
*
LIBNUM NOT FOUND IN ADD OPERATION
ADDNF
L
1,MANSTAR
SH
1,=Y(MANENTL)
CL
1,DSNXTF
MAKE CERTAIN SPACE EXITS
BNH ADDFULL
NO ROOM
ST
1,MANSTAR
AR
1,MR
NEW MAN AT FRONT OF TABLE
USING PERLIB,1
ST
0,LIBNUM
C
0,PUBPRI
)ADD 1000 IS ILLEGAL
BE
ILSAVE
MVC LIBLINK(MANENTL-4),NEWMAN INITIALIZE NEW MAN ENTRY
*
LIBRARY NUMBER FOUND ON ADD

65600000
65760000
65920000
66080000
66240000
66400000
66560000
66720000
66880000
67040000
67200000
67360000
67520000
67680000
67840000
68000000
68160000
68320000
68480000
68640000
68800000
68960000
69120000
69280000
69440000
69600000
69760000
69920000
70080000
70240000
70400000
70560000
70720000
70880000
71040000
71200000
71360000
71520000
71680000
71840000
72000000
72160000
72320000
72480000
72640000
72800000
72960000
73120000
73280000
73440000
73600000
73760000
73920000
74080000
74240000
74400000
74560000
74720000
74880000
75040000

ADDFND

MVC HISNAME,PDSWSN
FOR PRINTING AT SIGNON
LH
5,PDSCPUL
CPU TIME LIMIT
LTR 5,5
BZ
*+8
ZERO MEANS DON'T CHANGE
STH 5,SRALIM
DROP 1
LH
7,PDSWSQI
INCREMENT HIS SAVE QUOTA
BAL LKR,ADJQOT
DC
AL2(MANWSQ-MANWSA) MAKE ADJQOT CHANGE QUOTA
B
SETPASS
ADDFULL TYO ADDF1
MVI ASDIRCHG,2
REJECT CODE
DASD
B
DSEXIT
ADDF1
DC
Y(ADDF2+1)
ADDF2
ZTEXT 'LIBRARY TABLE FULL'
ZEND
*
*
PRINT CONTENTS OF A LIBRARY
*
USING PERSAVW,4
PRLIB
BAL 15,PROTCHK
PRLIBA CLC PSLINK,ZERO
BE
PRLIBZ
END OF LIBRARY PRINT
L
4,PSLINK
LA
1,PSNAME
M RELATIVE ADDRESS
ICALL SQUIRTM
ICALL LOUT
AR
4,MR
MAKE R4 ABSOLUTE
B
PRLIBA
PRLIBZ SVCC YYLIBZ
DROP 4
DSEXIT ST
0,OUT1
MAIN OUTPUT PARAMETER
TM
ASDIRCHG,1
DIRECTORY REWRITE BIT
DASD
BZ
DSEXZ
STM 0,3,GETTEM
*
UPDATE FREEDSK TABLE IN THIS DIRECTORY
UPDFR1 LM
0,2,CDCBXLE
LA
3,FREEDSK
UPDFR2 MVC 0(4,3),CFREDSK-CDCPARS(2)
LA
3,4(3)
BXLE 2,0,UPDFR2
NEXT LIBRARY
MVC WFLDATE,ZSYMDATE
INDICATE WHEN FREEDSK WAS UPDATED
LM
0,3,GETTEM
*
R0 CONTAINS DIRSRES IN CCHH FORMAT
DASD
DSEXZ
SVCC YYEOS
*
USING PERLIB,1
*
DELETE USER AND HIS WORKSPACES FROM SYSTEM
*
*
DELETE USER FROM MAN TABLE AND ADJUST MANSTAR
DELUS
L
2,MANSTAR
AR
2,MR
L
0,LIBLINK
POINTER TO SAVED WS LIST
MVC 0(MANENTL,1),0(2) MOVE FIRST ENTRY TO DELETED POS
SR
2,MR
GIVING OLD MANSTAR
LA
2,MANENTL(2)
ST
2,MANSTAR
SVI IS SVI+MANENTL
BALR LKR,0
SET RETURN POINT OF DSDRSUB
LR
4,0
L
0,PSLINK-PERSAVW(4,MR)

75200000
75360000
75520000
75680000
75840000
76000000
76160000
76320000
76480000
76640000
76800000
76960000
77120000
77280000
77440000
77600000
77760000
77920000
78080000
78240000
78400000
78560000
78720000
78880000
79040000
79200000
79360000
79520000
79680000
79840000
80000000
80160000
80320000
80480000
80640000
80800000
80960000
81120000
81280000
81440000
81600000
81760000
81920000
82080000
82240000
82400000
82560000
82720000
82880000
83040000
83200000
83360000
83520000
83680000
83840000
84000000
84160000
84320000
84480000
84640000

BXH
B
*
UNLKMK
LOCKMK
LOCK2
NEWPASS
*
LIBENDMK
PUBPRI
ZERO
*
ZSYMDATE
CDCBXLE
ADPAR
SDTAB
NOWS
NOLBM
ADDNL
DROP
SAVE
LOAD
COPY
ADD
LIB
OFF
DEL
LOCK
UNLK
PASS
*
NEWMAN

*
SDOP
*
*
*
SDPAR
COPYID
PERCORE

4,MR,DSDRSUB
LOCK2

UNLINK PERSAVW IF IT EXISTS

84800000
84960000
85120000
NI
PLMISC,255-LIBLOCK
85280000
B
LOCK2
85440000
OI
PLMISC,LIBLOCK
85600000
MVI ASDIRCHG,1
FORCE DIRECTORY REWRITE
DASD 85760000
SR
0,0
DASD 85920000
B
DSEXIT
86080000
MVC SOPASS,PDSPASS
CHANGE SIGNON PASSWORD
86240000
B
LOCK2
86400000
DROP 1
86560000
86720000
DS
0F
86880000
DC
F'-1' SEARCH TERMINATION LIB OR MAN NUMBER
87040000
DC
F'1000'
PUBLIC LIB NUM IS LESS THAN PUBPRI 87200000
DC
F'0'
87360000
87520000
ENTRY ZSYMDATE
87680000
DC
D'0'
87840000
ENTRY CDCBXLE
FOR TRANSFER VECTOR
88000000
DC
A(CDCL,LIBPZ,LIBPARS)
88160000
EQU CDCBXLE+8
88320000
DC
0F'0'
TABLE OF SD OPS
88480000
EQU X'80'
SKIP SEARCH FOR WS NAME
88640000
EQU X'40'
'WS NOT FOUND' IF LIB NOT FOUND
88800000
EQU X'20'
NON DISASTER IF LIB NOT FOUND
88960000
SDPAR NOLBM,DSDROP
89120000
SDPAR 0,DSSAVE
89280000
SDPAR NOLBM,DSLOAD
89440000
SDPAR NOLBM,DSLOAD
89600000
SDPAR NOWS+NOLBM+ADDNL,ADDFND
89760000
SDPAR NOWS,PRLIB
89920000
SDPAR NOWS,DSOFF
90080000
SDPAR NOWS,DELUS
90240000
SDPAR NOWS,LOCKMK
90400000
SDPAR NOWS,UNLKMK
90560000
SDPAR NOWS,NEWPASS
90720000
ORG
90880000
NEWMAN GIVES INITIAL VALUES OF MAN ENTRY
91040000
DC
F'0'
LIBLINK
91200000
DC
2H'0'
MANWSQ, MANWSA
91360000
DC
2F'0'
CUMCON,CUMCOM
91520000
DC
12X'00'
HISNAME
91680000
DC
8X'00'
SOPASS
91840000
DC
X'8000'
SRALIM
92000000
DC
X'0000'
PLMISC
92160000
DC
2F'0'
FUTURE ACCOUNTING
92320000
END OF NEW MAN
92480000
LTORG
92640000
EQU PDSOP
92800000
92960000
SPECIAL DISK PARAMETER AREA
93120000
LAYOUT IS PDSDDDD
93280000
ENTRY SDPAR
93440000
DS
0D,XL(PDSLEN)
COMMON PARAMETERS
93600000
ENTRY COPYID
93760000
DS
CL(L'PDSID)
93920000
COPY CDCPARS
94080000
DSECT
94240000

PCQUONT DS
H
PCADDR DS
AL3
PCTERM EQU *-1
DS
AL3
END
./ ADD
NAME=APLSDTRA
DTRA
TITLE 'D Y A D I C T R A N S P O S E
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
EXTRAN CSECT
PRINT OFF
APLDEFN, OPSECT
COPY APLDEFN
COPY OPSECT
TITLE 'D Y A D I C T R A N S P O S E
05/11/70'
PRINT ON,NOGEN
EXTRN ERROR
EXTRN FETCH
EXTRN FETCHINT
EXTRN STORE
EXTRN OPSPACE
SCRATCH DSECT
DS
2F
RHOR
DS
F
SINCR
DS
F
RX
DS
F
EXTRAN CSECT
*
*
*
DYADIC TRANSPOSE
*
*
R = P PHI S
*
*
TRANSPOSE OF S. R(;/I)=S(;/I(P))
*
*
RESTRICTIONS -*
(RHO P) = RHO RHO S
*
P IS DENSE
*
*
SCR
EQU 7
USING EXTRAN,9
USING OPSECT-16,LR
USING SCRATCH,SCR
RRR
EQU BINOSAVE
* SAVE LINK & CHECK COMPATIBILITY
ST
LKR,REGSAV
CLC LHRANK+2(2),=H'8' P MUST BE VECTOR OR SCALAR
BL
DOMOK
LA
1,ERANK
ICALL ERROR
DOMOK
L
1,LHXRHO
SLA 1,2
C
1,RHRANK
BE
XRHOOK
(RHO P) = RHO RHO S
LA 1,ELENGTH
ICALL ERROR
* GET SPACE FOR SCRATCH VECTORS
XRHOOK EQU *
MVC LCFTYPE,LHTYPE
SET UP FETCH ARGUMENTS

94400000
94560000
94720000
94880000
95040000
00480000
00960000
01440000
01920000
02400000
03360000
03840000
04320000
04800000
05280000
05760000
06240000
06720000
07200000
07680000
08160000
08640000
09120000
09600000
10080000
10560000
11040000
11520000
12000000
12480000
12960000
13440000
13920000
14400000
14880000
15360000
15840000
16320000
16800000
17280000
17760000
18240000
18720000
19200000
19680000
20160000
20640000
21120000
21600000
22080000
22560000
23040000
23520000
24000000
24480000
24960000
25440000
25920000
26400000

MVC RCFTYPE,RHTYPE
SR
2,2
LA
3,2
L
10,=A(OPSPACE)
BALR LKR,10
LA
SCR,M(1)
R7: ABSOLUTE PTR TO SCRATCH
L
2,INCR
INCREMENT INCR BECAUSE OF EXTRA
LA
2,4(2)
WORD IN EXECUTION STACT DUE TO
ST
2,INCR
SCRATCH VECTOR
* INITALIZE SCRATCH VECTORS
L
1,=F'-16'
SR
2,2
SR
3,3
SR
4,4
L
8,RHRANK
SLA 8,2
FILL
AR
8,1
BM
FILLED
LA
5,RHOR(8)
STM 1,4,0(5)
B
FILL
FILLED ST
1,RRR
INITALIZE RHO RHO R
L
1,LHBASE
FIND ORIGIN OF LH DATA
A
1,LHRANK
LA
1,MRHO-M(1)
ST
1,LHORG
* COMPUTE RHO R, FIRST SINCR
LA
5,1
R5 FOR X/RHO S
L
8,RHRANK
R8 FOR INDEX INTO RHO S
LR
2,8
R2 FOR INDEX INTO P
SRA 2,2
A
8,RHBASE
R8 NOW M-RELATIVE
RRLOOP S
8,=F'4'
S
2,=F'1'
BM
RRDONE
LM
3,4,LCFTYPE
ICALL FETCHINT
GET NEXT ELEMENT OF P
LR
1,0
S
1,IORIGIN
ADJUST P(I)
CL
1,RHRANK
MUST BE BETWEEN 0 AND REASONABLE
BNL PNOTDENS
UPPER LIMIT
SLA 1,4
MAKE IT A 4 WORD POINTER.
C
1,RRR
UPDATE RHO RHO R, WHICH IS ALWAYS
BNH RRRNCH
16 TOO LOW & HAS 16 FACTOR RATHER
ST
1,RRR
THAN 4.
RRRNCH L
10,SINCR(1)
AR
10,5
ST
10,SINCR(1)
L
4,MRHO(8)
LOAD RHO S
CL
4,RHOR(1)
COMPARE VS RHO R
BNL RRNCH
ST
4,RHOR(1)
STORE IF SMALLER
RRNCH
MR
4,4
MAKE NEW PRODUCT
B
RRLOOP
* CALCULATE SPACE NEEDED, FORM REAL SINCR, CHECK THAT P IS DENSE
RRDONE EQU *
L
6,RRR
R6: INDEX INTO RHO R, SINCR
SR
8,8
R8: +/SINCR X RHO R - 1
LA
1,1
R1: X/RHO R
LA
3,16
R3: INDEX DECREMENT VALUE

26880000
27360000
27840000
28320000
28800000
29280000
29760000
30240000
30720000
31200000
31680000
32160000
32640000
33120000
33600000
34080000
34560000
35040000
35520000
36000000
36480000
36960000
37440000
37920000
38400000
38880000
39360000
39840000
40320000
40800000
41280000
41760000
42240000
42720000
43200000
43680000
44160000
44640000
45120000
45600000
46080000
46560000
47040000
47520000
48000000
48480000
48960000
49440000
49920000
50400000
50880000
51360000
51840000
52320000
52800000
53280000
53760000
54240000
54720000
55200000

LTR 2,6
R2: SAVE RHO RHO R FOR LATER &
*
SET CC FOR NULL CASE
NEXTRHOR BM
ALLSET
L
5,RHOR(6)
R5: (RHO R)(I)
LTR 5,5
BC
10,DENS
PNOTDENS LA
1,ERANGE
ICALL ERROR
DENS
MR
0,5
FORM NEW X RHO R
L
4,SINCR(6)
GET 2 COPIES SINCR(I)
LR
10,4
SR
10,8
DECREMENT SINCR BY SUM
ST
10,SINCR(6)
BCTR 5,0
USE OLD SINCR TO COMPUTE
MR
4,4
SUM = SUM + SINCR X RHOR - 1
AR
8,5
SR
6,3
B
NEXTRHOR
* NOW TO RESERVE SPACE FOR R. R1 COINCIDENTALLY ALREADY
*
CONTAINS THE RIGHT THING. R2 IS CLOSE
ALLSET EQU *
ST
1,RXRHO
AR
2,3
SRA 2,2
LR
4,2
R4: SAVE RESRANK MOMENTARILY
L
3,RHTYPE
LR
5,3
R5: SAVE TYPE FOR THE NONCE
L
10,=A(OPSPACE)
BALR LKR,10
* SPACE RESERVED. CONSTRUCT RESULT DESCRIPTOR
STH 4,MRANK(1)
R4: INDEX FOR RHO R DESTINATION
STC 5,MTYPE(1)
R1: M-RELATIVE PTR TO S
LA
0,MRHO-M(4,1)
ST
0,RESORG
L
7,SVI
R7: SVI
L
7,M+8(7)
R7: M-RELATIVE PTR TO SCRATCH
LA
10,0(7)
MASK AND SAVE BECAUSE CAN'T HAVE
*
ABSOLUTE POINTER IN INNER LOOP
AR
7,MR
R7 IS ABSOLUTE PTR TO SCRATCH
LA
1,M(1)
R1: ABSOLUTE PTR TO S
L
6,RRR
R6: INDEX FOR RHO R IN SCRATCH
MOVERHOR S
4,=F'4'
BM
MOVED
L
8,RHOR(6)
ST
8,MRHO-M(4,1)
A
6,=F'-16'
B
MOVERHOR
MOVED
EQU *
L
1,RHBASE
SET UP ORIGIN OF S'S DATA
A
1,RHRANK
LA
1,MRHO-M(1)
ST
1,RHORG
* EFFECT TRANSFER FROM S TO R
L
0,RXRHO
LTR 0,0
BZ
RETURN
LR
3,5
R3: ALWAYS TYPE
SR
5,5
R5: I, INDEX OF R
SR
6,6
R6: J, INDEX OF S
L
7,RRR
COMPUTE M-RELATIVE START VALUE

55680000
56160000
56640000
57120000
57600000
58080000
58560000
59040000
59520000
60000000
60480000
60960000
61440000
61920000
62400000
62880000
63360000
63840000
64320000
64800000
65280000
65760000
66240000
66720000
67200000
67680000
68160000
68640000
69120000
69600000
70080000
70560000
71040000
71520000
72000000
72480000
72960000
73440000
73920000
74400000
74880000
75360000
75840000
76320000
76800000
77280000
77760000
78240000
78720000
79200000
79680000
80160000
80640000
81120000
81600000
82080000
82560000
83040000
83520000
84000000

AR
7,10
FOR K. STOP VALUE IS IN R10.
ST
7,RRR
RRR IS NOW SCRATCH+RRR, M-RELATIVE
TRANSFER LR
2,6
L
4,RHORG
ICALL FETCH
LR
2,5
L
4,RESORG
ICALL STORE
LA
5,1(5)
INCREMENT I
L
7,RRR
R7: SCRATCH(K), M-RELATIVE
QUEND
STEP
CR
7,10
ARE WE OFF LEFT END OF RX -BL
RETURN
YES. QUIT.
L
8,RX(MR)
INCREMENT RX(K) UP TO BUT NOT
LA
8,1(8)
INCLUDING RR(K)
ST
8,RX(MR)
C
8,RHOR(MR)
BL
NCH
SR
8,8
ST
8,RX(MR)
A
7,=F'-16'
B
STEP
PROPAGATE CARRY LEFTWARD
NCH
A
6,SINCR(MR)
B
TRANSFER
RETURN L
7,SVI
L
7,M+8(7)
MKG 7
L
LKR,REGSAV
BR
LKR
END
./ ADD
NAME=APLSDYIB
DYIB
TITLE 'DYADIC I-BEAM -- MOSTLY PRIV SYSTEM INTERFACE 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
EXCEINTF CSECT
EXTRN ERROR
EXTRN FETCH
EXTRN FETCHINT
EXTRN IM
EXTRN OPSPACE
EXTRN SUPPARS
MAPPED BY SUPPARD DSECT
2230
EXTRN WSLEN
PRINT OFF
APLDEFN,PERTERM,OPSECT,APLSUPC
2230
APLSUPC ,
MAPS SUPPARS AREA IN APLSUP
2230
VALCON EQU 0
AVOIDS ASM ERROR
2230
COPY APLDEFN
COPY PERTERM
COPY OPSECT
TITLE 'DYADIC I-BEAM -- MOSTLY PRIV SYSTEM INTERFACE 05/11/70'
PRINT ON,NOGEN
EJECT
*
*
DYADIC IBEAM.
*
*
LEFT OPERAND SPECIFIES THE FUNCTION TO BE PERFORMED.
*
RIGHT IS THE APPROPRIATE OPERAND.
*
*
*
FUNCTIONS..

84480000
84960000
85440000
85920000
86400000
86880000
87360000
87840000
88320000
88800000
89280000
89760000
90240000
90720000
91200000
91680000
92160000
92640000
93120000
93600000
94080000
94560000
95040000
95520000
96000000
96480000
96960000
97440000
97920000
98400000
00190000
00380000
00570000
00760000
01140000
01520000
01710000
01900000
02090000
02280000
02470000
02660000
02850000
03040000
03230000
03420000
03610000
03800000
03990000
04180000
04370000
04560000
04750000
04940000
05130000
05320000
05510000
05700000
05890000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

06080000
06270000
06460000
***
0 IBEAM L,A
FETCH DATA IN MAIN MEMORY
06650000
06840000
***
1 IBEAM L,A,D
STORE IN MAIN MEMORY
07030000
07220000
***
2 IBEAM L,A
M-RELATIVE FETCH
07410000
07600000
***
3 IBEAM L,A,D
M-RELATIVE STORE
07790000
07980000
***
4 IBEAM P
BOUNCE USER AT PORT
08170000
08360000
5 IBEAM T
DELAY FOR TIME INTERVAL
08550000
08740000
6 IBEAM Q,V
WSFNS INTERFACE
08930000
09120000
***
7 IBEAM I
FETCH A COLUMN OF PERTERMS
09310000
09500000
***
8 IBEAM L,A,M
'XOR' TO MAIN STORAGE
09690000
09880000
***
9 IBEAM L,A,M
'OR' TO MAIN STORAGE
10070000
10260000
*** 10 IBEAM L,A,M
'AND' TO MAIN STORAGE
10450000
10640000
*** 11 IBEAM P
RESET PORT
10830000
11020000
*** 12 IBEAM 0
SYSTEM SHUTDOWN
11210000
11400000
13 IBEAM Q
RESERVED
11590000
11780000
11970000
A - STARTING ADDRESS OF DATA
12160000
D - VECTOR OF DATA, FULL WORD INTEGERS
12350000
I - WORD INDEX OF WORD TO BE FETCHED FROM PERTERM
12540000
L - LENGTH OF DATA IN BYTES
12730000
M - VECTOR OF MASK, FULL WORD INTEGERS
12920000
P - PORT NUMBER
13110000
Q - CODE INDICATING SPECIFIC OPERATION
13300000
V - SCALAR INTEGER VALUE
13490000
Z - Z-SYSMOLS WITH COUNT IN INTEGER FORMAT
13680000
13870000
14060000
*** ALLOWED ONLY FROM PRIVILEGED TERMINALS.
14250000
EJECT
14440000
EXCEINTF CSECT
14630000
USING *,9
14820000
USING OPSECT-16,LR
15010000
SPACE
15200000
ST
LKR,TEMPRES
SAVE LINK OVER CALLS.
15390000
LA
8,SYNERR
15580000
*
15770000
*
NOW DECIDE WHICH FUNCTION TO ENTER.
15960000
*
16150000
L
4,LHBASE
FETCH LEFT OPERAND.
16340000
A
4,LHRANK
BASE + RANK
16530000
LA
4,MRHO-M(4)
+ HEADER LENGTH GIVES DATA POINTER. 16720000
L
3,LHTYPE
GET THE TYPE.
16910000
SR
2,2
POINTAT FIRST ELEMENT.
17100000
ICALL FETCHINT
GOT IT.
17290000

LR
SLL
CL
BCR
L
ST
*
*
*

CEINT1
*
*
*

*
*
*

CEINT2
*
*
*

*
*
*
CEINT3

1,0
1,2
1,FNTABLN
11,8 BNLR
5,FNTAB(1)
5,CURRES

MOVE TO R1
MULTIPLY BY 4 TO GET WORD INDEX.
SEE IF IT'S WITHIN BOUNDS.
BRANCH IF NOT
OTHERWISE, PICK UP ROUTINE ADDRESS.
SAVE THE ADDRESS

17480000
17670000
17860000
18050000
18240000
18430000
18810000
CHECK FOR A PRIVILEGED TERMINAL
19000000
19190000
TM
CURRES,PRIVREQ
SEE IF USER MUST BE PRIVILEGED
19380000
BZ
CEINT1
IF NOT PICK UP FIRST ARGUMENT
19570000
L
4,=A(SUPPARS)
PICK UP PERTERM BASE 2230 19760000
L
4,PTBASE-SUPPARD(4) FROM PROTECTED STORAGE.
2230 19950000
TM
IOB1-PERTERM(4),PRIVBIT SEE IF THIS GUY IS PRIVILEGED
20140000
BCR 8,8 BZR
NO, SLAP HIS WRIST
20330000
DS
0H'0'
20520000
20710000
FETCH FIRST RIGHT OPERAND INTO REG 7
20900000
21090000
L
4,RHBASE
FETCH FIRST RIGHT OPERAND
21280000
TM
CURRES,IBCHAR
TEST FOR Z-SYMBOLS ON RIGHT
21470000
BO
CEINT3
YES, GO CHECK TYPE, ET AL
21660000
A
4,RHRANK
BASE+RANK
21850000
LA
4,MRHO-M(4)
+ HEADER LENGTH GIVES DATA POINTER 22040000
L
3,RHTYPE
SPECIFY THE TYPE
22230000
SR
2,2
SPECIFY THE FIRST ELEMENT
22420000
ICALL FETCHINT
22610000
LTR 7,0
SAVE IN REG 7
22800000
BM
RNGERR
RANGE ERROR IF NEGATIVE
22990000
23180000
FETCH SECOND RIGHT OPERAND (IF NEEDED) INTO REG 6
23370000
23560000
L
8,RHXRHO
PREPARE FOR RIGHT LENGTH CHECK
23750000
TM
CURRES,IBARG2
IF NO SECOND ARGUMENT, RT LENGTH
23940000
BZ
CEINT2
MUST BE ONE
24130000
LA
2,1
OTHERWISE FETCH SECOND ARGUMENT
24320000
ICALL FETCH
FETCH BECAUSE OUR DEAR FRIEND
24510000
FETCHINT FUTZED UP REG 3 ON US
24700000
LR
6,0
24890000
BCTR 8,0
RT LENGTH MUST BE TWO
25080000
TM
CURRES,IBARGN
TEST FOR MORE THAN TWO RT ARGUMENTS 25270000
BO
*+8
IF MORE BRANCH
25460000
BCT 8,LNGTHERR
IF RT LENGTH WRONG, ERROR
25650000
SR
8,8
R8=0 NEEDED BY CEAND & CEOR
25840000
26030000
IF SECOND RT OPERAND IS M-REL, RANGE CHECK & MAKE ABSOLUTE
26220000
26410000
TM
CURRES,IBMREL
TEST IF M-REL & RANGE CHECK NEEDED 26600000
BCR 8,5
ARGUMENT ALREADY ABSOLUTE
26790000
L
2,=A(WSLEN)
TEST FOR VALID M-REL ADDR
26980000
L
2,0(2)
PICK UP WS LENGTH
27170000
LA
6,0(6)
CLEAR OUT HIGH ORDER BYTE
27360000
CR
6,2
27550000
BH
RNGERR
TOO BIG, ERROR
27740000
AR
6,MR
MAKE ADDR ABSOLUTE
27930000
BR
5
GO TO EXECUTION ROUTINE
28120000
28310000
RIGHT ARGUMENT IS IN Z-SYMBOLS
28500000
28690000
LA
1,M(4)
SIMULATE INDEXED CLI INSTRUCTION
28880000

CLI MTYPE-M(1),2
ARGUMENT MUST BE INTEGER
BCR 7,8 BNER
NO, SYNTAX ERROR
CLI MRANK+1-M(1),4
RANK MUST BE VECTOR
BCR 7,8 BNER
NO, SYNTAX ERROR
CLI MLSORG+4-M(1),0
INTERNAL COUNT MUST BE < 256
BCR 7,8 BNER
NO, SYNTAX ERROR
BR
5
ENTER APPROPRIATE ROUTINE
SPACE 2
SYNERR LA
1,ESYNTAX
FOR THE HELL OF IT.
ICALL ERROR
FOR THE HELL OF IT.
SPACE 2
RNGERR LA
1,ERANGE
OPERAND OUT OF RANGE.
ICALL ERROR
SPACE
LNGTHERR LA
1,ELENGTH
LENGTH ERROR
ICALL ERROR
EJECT
*
*
0 - LOOK AT ANY WORD IN STORAGE.
*
2 - M RELATIVE FETCH.
*
M-REL ADDR HAS BEEN MADE ABSOLUTE
*
CEDISP CL
7,=F'256'
CHECK FOR PROPER LENGTH
BH
RNGERR
IF TOO BIG RANGE ERROR
CERETURN LA
1,3(7)
COMPUTE WORD LENGTH
SRL 1,2
OF RESULT
LR
4,1
LA
2,4
RANK=VECTOR
LA
3,2
INTEGER TYPE
L
10,=A(OPSPACE)
GET SPACE
BALR LKR,10
L
2,TPRANK
ST
2,MTYPE(1)
RANK OF ONE, INTEGER TYPE
ST
4,MRHO(1)
STORE RHO
LA
1,MRHO+4-M(1)
DATA POINTER OF RESULT
ST
1,RESORG
L
LKR,TEMPRES
PICK UP LINK AND RETURN
AR
1,MR
LTR 7,7
IF COUNT IS ZERO RETURN.
BCR 8,LKR
BCTR 4,0
ZERO OUT LAST WORD OF
SLL 4,2
RESULT SO THAT WE DONT
AR
4,1
PASS GARBAGE
XC
0(4,4),0(4)
BCTR 7,0
FOR EXECUTE INSTRUCTION
EX
7,ZAPPER
MOVE DATA
BR
LKR
RETURN
*
ZAPPER MVC 0(*-*,1),0(6)
*
*
*
*
*
1 - STORE IN MAIN STORAGE
*
3 - STORE IN M-REL STORAGE
*
8 - XOR TO MAIN STORAGE
*
9 - OR TO MAIN STORAGE
*
10 - AND TO MAIN STORAGE
*
*
NOTE.. IF M-REL AND, OR, XOR ARE DESIRED,

29070000
29260000
29450000
29640000
29830000
30020000
30210000
30400000
30590000
30780000
30970000
31160000
31350000
31540000
31730000
31920000
32110000
32300000
32490000
32680000
32870000
33060000
33250000
33440000
33630000
33820000
34010000
34200000
34390000
34580000
34770000
34960000
35340000
35530000
35720000
35910000
36100000
36290000
36480000
36670000
36860000
37050000
37240000
37430000
37620000
38000000
38190000
38380000
38570000
38760000
38950000
39140000
39330000
39520000
39710000
39900000
40090000
40280000
40470000
40660000

*
*
*
*
CEXOR
CEOR
CEAND
CESTORE
*
*

ADD ENTRIES TO FNTAB WITH

IBMREL (& PRIVREQ) BITS.
LA
LA
LA
LA

8,CEXORZ-CEORZ(8)
8,CEORZ-CEANDZ(8)
8,CEANDZ-CESTOREZ(8)
14,(256-NDOPSECT+FACTSAVE+7)/8*8(14)
EXTEND R13 STACK TO GET 256 BYTE SCRATCH AREA
OPSECT ENTRIES BEYOND FACTSAVE ARE DESTROYED BELOW
CL
7,=F'256'
CHECK LENGTH
BH
RNGERR
IF TOO BIG RANGE ERROR
LTR 7,7
TEST FOR ZERO LENGTH
BZ
SVIADJ
IF ZERO, DON'T BOTHER
BCTR 7,0
SET UP FOR EXECUTE INSTRUCTION
LA
5,4(7)
GET LENGTH IN WORDS
SRL 5,2
LA
2,2
POINT TO NEXT OPERAND
AR
5,2
TOTAL NUMBER OF RT OPERANDS
CL
5,RHXRHO
ARE THERE ENOUGH OPERANDS?
BH
LNGTHERR
IF NOT ENOUGH, LENGTH ERROR
SR
5,2
INITIALIZE COUNTER
SR
10,10
INITIALIZE INDEX REG
CESTOR1 ICALL FETCH
GET NEXT OPERAND
ST
0,FACTSAVE(10)
SAVE IT IN SCRATCH AREA
LA
2,1(2)
BUMP OPERAND POINTER
LA
10,4(10)
BUMP INDEX REGISTER
BCT 5,CESTOR1
EXHAUST OPERANDS
TM
CURRES,IBMREL
TEST FOR M-REL ADDRESS
BO
TOCORE
IF SO, BYPASS TEST FOR IN WSS
L
1,=A(SUPPARS)
WE REFUSE TO PERMIT ANYONE TO
LM
1,2,PCBXLE-SUPPARD+4(1) DO AN ABS WS PATCH
LH
2,PCADDR-PERCORE(2) WITHIN AREA RESERVED FOR WSS.
SLL 2,8
LA
6,0(6)
CLEAR OUT HIGH BYTE
CR
6,2
BL
CESTORE3
BR IF BELOW FIRST WS
LH
1,PCADDR-PERCORE(1)
SLL 1,8
L
2,=A(WSLEN)
A
1,0(2)
POINT TO END OF LAST WS
CR
6,1
BL
RNGERR
BR IF BELOW END OF LAST WS
CESTORE3 IC
2,0(6,7)
LAZY HIGH CORE TEST
SVRAPE
TOCORE BAL 1,CESTOREX
SVIADJ L
5,SVI
NOW, PICK UP SVI.
SR
0,0
ST
0,M(5)
A 0 WORD MEANS NO RESULT.
A
5,=F'-4'
MOVE UP SVI
ST
5,SVI
AND PUT IT BACK.
L
LKR,TEMPRES
RETURN
BR
LKR
*
*
EXECUTED INSTRUCTIONS
*
CESTOREX EX
7,CESTOREZ(8)
BR
1
CESTOREZ MVC 0(*-*,6),FACTSAVE
CEANDZ NC
0(*-*,6),FACTSAVE

2230
2230
P042
P042
P042
P042
P042
P042
P042
P042
P042
P042

40850000
41040000
41230000
41420000
41610000
41800000
41990000
42180000
42370000
42560000
42750000
42940000
43130000
43320000
43510000
43700000
43890000
44080000
44270000
44460000
44650000
44840000
45030000
45220000
45410000
45600000
45790000
45980000
46170000
46360000
46550000
46740000
46930000
47120000
47310000
47500000
47690000
47880000
48070000
48260000
48450000
48640000
48830000
49020000
49210000
49400000
49590000
49780000
49970000
50160000
50350000
50540000
50730000
50920000
51110000
51300000
51490000
51680000
51870000
52060000

CEORZ
CEXORZ
*
*
*
*
*
*
CEBOUN

OC
XC

0(*-*,6),FACTSAVE
0(*-*,6),FACTSAVE

52250000
52440000
52630000
52820000
53010000
53200000
4 - BOUNCE TERMINAL SPECIFIED BY RIGHT OPERAND.
53390000
53580000
LR
1,7
MOVE TO R1 FOR YYBOUN
53770000
SVCC YYBOUN
BOUNCE SVC
53960000
B
SVIADJ
GO FIX UP STACK.
54150000
*
54340000
*
54530000
*
54720000
*
5 - VOLUNTARY SUSPENSION.
54910000
*
CALLER IS SUSPEMDED FOR TIME SPECIFIED IN RIGHT OPERAND.
55100000
*
UNITS - 300THS OF SECONDS.
55290000
*
55480000
CEDEL
TCOM DELAY,(7)
DELAY
55670000
B
SVIADJ
GO FIX UP STACK.
55860000
*
56050000
*
56240000
*
56430000
*
11 - RESET PORT
56620000
*
56810000
CERESET LR
1,7
MOVE PORT NUMBER TO R1
57000000
SVCC YYRSET
RESET SVC
57190000
B
SVIADJ
GO FIX UP STACK
57380000
*
57570000
*
57760000
*
57950000
*
12 - SYSTEM SHUTDOWN
58140000
*
58330000
CESHUT LTR 0,7
PASS PARM TO APLSUP
P042 58520000
BNZ RNGERR
RANGE ERROR IF RH OPER NOT 0
P042 58710000
SVCC YYEOD
0 = INITIATE SHUTDOWN
58900000
B
SVIADJ
59090000
*
71250000
*
71440000
*
71630000
*
6 - WSFNS INTERFACE -- RESTRICTED WS PATCH
71820000
*
A DESIRED LOCATION IS PATCHED AND THE OLD VALUE RETURNED 72010000
*
72200000
*
CODE FUNCTION
LOCATION
72390000
*
72580000
*
0
ORIGIN
IORIGIN
72770000
*
1
SETLINK
RNUMBER
72960000
*
2
DIGITS
OSIGDIG
73150000
*
3
WIDTH
OBUFLIM
73340000
*
4
FUZZ
CPUTFUZZ+4
73530000
*
73720000
*
73910000
CEWSFNS SLL 7,2
IS WSFNS CODE VALID
74100000
CL
7,CEWTABLN
74290000
BNL SYNERR
NO, CONFUSE HIM WITH SYNTAX ERROR
74480000
L
8,CEWTABL(7)
LOAD M-REL ADDRESS
74670000
SR
3,3
FIND OUT LENGTH (H OR F) OF SLOT
74860000
IC
3,CEWTABL(7)
75050000
EX
0,CEWLOAD(3)
PICK UP OLD VALUE TO RETURN
75430000
C
6,CEWLOW(7)
IS VALUE TOO SMALL
75620000

BL
RNGERR
YES, ERROR
C
6,CEWHIGH(7)
IS VALUE TOO BIG
BH
RNGERR
YES, ERROR
EX
0,CEWSAVE(3)
STORE NEW VALUE
ST
5,SAVER-4
SAVE OLD VALUE
LA
6,SAVER-4
PICK UP POINTER TO OLD VALUE
LA
7,4
NUMBER OF BYTES TO BE RETURNED
B
CERETURN
RETURN OLD VALUE & EXIT
SPACE 2
CEWLOAD L
5,M(8)
LH
5,M(8)
CEWSAVE ST
6,M(8)
STH 6,M(8)
*
CEWTABL DC
0F'0'
DC
AL1(0)
0 - ORIGIN
DC
AL3(IORIGIN-M)
DC
AL1(0)
1 - SETLINK
DC
AL3(RNUMBER-M)
DC
AL1(0)
2 - DIGITS
DC
AL3(OSIGDIG-M)
DC
AL1(4)
3 - WIDTH
DC
AL3(OBUFLIM-M)
DC
AL1(0),AL3(CPUTFUZZ+4-M)
CEWTABLN DC
A(*-CEWTABL)
*
*
CEWLOW DC
F'0'
LOW LIMIT - ORIGIN
DC
F'1'
LOW LIMIT - SETLINK
DC
F'1'
LOW LIMIT - DIGITS
DC
F'30'
LOW LIMIT - WIDTH
DC
F'0'
LOW LIMIT - FUZZ
*
CEWHIGH DC
F'1'
HIGH LIMIT - ORIGIN
DC
F'2147483646'
HIGH LIMIT - SETLINK
DC
F'16'
HIGH LIMIT - DIGITS
DC
F'130'
HIGH LIMIT - WIDTH
DC
F'2147483647'
HIGH LIMIT - FUZZ
*
*
*
*
7 - FETCH A COLUMN OF THE PERTERMS
*
CEPTERM LR
0,7
N
0,=F'3'
RANGE ERROR IF NOT ON WORD ALIGNMNT
BNZ RNGERR
OTHERWISE R0 = 0 (FOR PERTERM
L
4,=A(SUPPARS)
LENGTH CALCULATION
2230
LM
4,6,PTBXLE-SUPPARD(4)
2230
LR
1,5
COMPUTE LENGTH OF PERTERM
SR
1,6
DR
0,4
LA
1,1(1)
MAKE ONE-ORIGIN
LR
8,1
HOLD ONTO PERTERM LENGTH
LA
2,4
RANK = VECTOR
LA
3,2
TYPE = INTEGER
L
10,=A(OPSPACE)
GET SPACE FOR RESULTING VECTOR
BALR LKR,10
L
2,TPRANK
PLANT HEADER = INTEGER VECTOR
ST
2,MTYPE(1)
ST
8,MRHO(1)
RESULT RHO = LENGTH OF PERTERM

75810000
76000000
76190000
76380000
76570000
76760000
76950000
77140000
77330000
77520000
77710000
77900000
78090000
78280000
78470000
78660000
78850000
79040000
79230000
79420000
79610000
79800000
79990000
80180000
80370000
80560000
80750000
80940000
81130000
81320000
81510000
81700000
81890000
82080000
82270000
82460000
82650000
82840000
83030000
83220000
83410000
83600000
83790000
83980000
84170000
84360000
84550000
84740000
84930000
85120000
85310000
85500000
85690000
85880000
86070000
86260000
86450000
86830000
87020000
87210000

LA
2,MRHO+4(1)
ST
2,RESORG
RESULT POINTER
CEPTLOOP L
3,0(6,7)
PICK UP PROPER WORD
ST
3,0(2)
PUT INTO RESULT VECTOR
LA
2,4(2)
BUMP UP TO NEXT WORD
BXLE 6,4,CEPTLOOP
LOOP UNTIL ALL MOVED IN
L
LKR,TEMPRES
PICK UP RETURN ADDR
BR
LKR
RETURN
CPUTFUZZ EQU RFUZZ
*
*
CONSTANTS.
*
*
FNTAB FLAG SETTINGS.
IBMREL EQU X'80'
OPERAND OT BE M-RELATIVE.
PRIVREQ EQU X'40'
USER MUST BE PRIVILEGED
IBARG2 EQU X'20'
RIGHT ARGUMENT 2 REQUIRED
IBARGN EQU X'10'+IBARG2
MORE THAN TWO RT ARGS
IBCHAR EQU X'08'
ARGUMENT IS IN Z-SYMBOLS
*
FNTAB
DC
0F'0'
WORD ALLIGNMENT AREA.
DC AL1(PRIVREQ+IBARG2),AL3(CEDISP)
0 - FETCH ABSOLUTE
DC AL1(PRIVREQ+IBARGN),AL3(CESTORE)
1 - STORE ABSOLUTE
DC AL1(PRIVREQ+IBMREL+IBARG2),AL3(CEDISP)
2 - FETCH M-REL
DC AL1(PRIVREQ+IBMREL+IBARGN),AL3(CESTORE)
3 - STORE M-REL
DC AL1(PRIVREQ),AL3(CEBOUN)
4 - BOUNCE
DC AL1(0),AL3(CEDEL)
5 - DELAY
DC AL1(IBARG2),AL3(CEWSFNS)
6 - WSFNS INTERFACE
DC AL1(PRIVREQ),AL3(CEPTERM)
7 - FETCH COL OF PT
DC AL1(PRIVREQ+IBARGN),AL3(CEXOR)
8 - XOR TO ABSOLUTE
DC AL1(PRIVREQ+IBARGN),AL3(CEOR)
9 - OR TO ABSOLUTE
DC AL1(PRIVREQ+IBARGN),AL3(CEAND)
10 - AND TO ABSOLUTE
DC AL1(PRIVREQ),AL3(CERESET)
11 - RESET PORT
DC AL1(PRIVREQ),AL3(CESHUT)
12 - SHUTDOWN
DC AL1(0),AL3(SYNERR)
13 - RESERVED
FNTABLN DC
A(*-FNTAB)
MUST FOLLOW TABLE.
SPACE
LOCIM
DC
A(IM)
TPRANK DC
X'02000004'
LTORG
*
*
ONE COPY PER CORE SLOT
PERCORE DSECT
PCQUONT DS
1H
QUONT COUNTER
PCADDR DS
AL3
STARTING ADDRESS OF THIS SLOT
PCTERM EQU *-1
PERTERM BASE REGISTER
DS
AL3
HIGH ORDER BIT ON MEANS UNASSIGNED
DS
0D
*
END
./ ADD
NAME=APLSEPSI
EPSI
TITLE 'E P S I L O N
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXEPS
CSECT
COPY APLDEFN
COPY OPSECT
TITLE 'E P S I L O N
05/11/70'
PRINT ON,NOGEN

87400000
87590000
87780000
87970000
88160000
88350000
88540000
88730000
88920000
89110000
89300000
89490000
89680000
89870000
90060000
90250000
90440000
90630000
90820000
91010000
91200000
91390000
91580000
91770000
91960000
92150000
92340000
92530000
92720000
92910000
93100000
93290000
93480000
93670000
94620000
94810000
95000000
95190000
95380000
95570000
95760000
95950000
96140000
96330000
96520000
96710000
96900000
97090000
97280000
00520000
01040000
01560000
02080000
03120000
03640000
04160000
04680000
05200000
05720000

*
*
*
*
*
*
*
*
*
*
*
*
*
EXEPS

*
*
*

*
*
*

*
*
*
RANKIN

06240000
06760000
07280000
R = LH EPSI RH
07800000
08320000
CHARACTERISTIC OF LH ON RH.
08840000
09360000
(RHO R) = RHO LH.
09880000
10400000
R(I) = 1 IFF LH(I) IS CONTAINEDIN RH.
10920000
11440000
LH AND RH RANKS ARBITRARY.
11960000
12480000
SPACE
13000000
CSECT
13520000
USING *,9
14040000
USING OPSECT-16,LR
14560000
ST
LKR,REGSAV
SAVE LINK TO THE OUTSIDE WORLD.
15080000
SPACE
15600000
16120000
FIRST, GET SPACE
16640000
17160000
SPACE
17680000
L
1,LHXRHO
NUMBER OF RESULT COMPNENTS.
18200000
L
2,LHRANK
PICK UP RESULT RANK.
18720000
LA
3,1
TYPE - BOOLEAN.
19240000
L
10,=A(OPSPACE)
GET ENTRY TO COMMON GETSPACE ROUTINE 19760000
BALR LKR,10
AND CALL IT.
20280000
SPACE
20800000
21320000
SET UP HEADER.
21840000
22360000
SPACE
22880000
LR
8,1
MOVE PTR TP R8.
23400000
L
2,LHRANK
RESULT RANK.
23920000
ST
2,MTYPE(8)
STORED.
24960000
LA
2,1
RESULT TYPE - BOOLEAN.
25480000
STC 2,MTYPE(8)
STORED.
26000000
L
3,LHRANK
SEE IF THERE IS A RANK VECTOR
26520000
LTR 3,3
27040000
BZ
RANKIN
BRANCH IF NOT.
27560000
LA
1,MRHO(1)
POINT AT RANK VECTOR.
28080000
L
2,LHBASE
28600000
LA
2,MRHO(2)
OF RESULT AND LH OPERAND.
29120000
BCTR 3,0
MAKE RANK INTO SS COUNT.
29640000
EX
3,MOVRANK
AND MOVE IN THE RANK.
30160000
SPACE
30680000
31200000
NOW, SET UP FOR EXECUTION.
31720000
32240000
L
1,COMTYP
LOOK AT COMPUTE TYPE.
32760000
S
1,EPS2
-2
33280000
SLL 1,2
MAKE WORD INDEX,
33800000
L
5,CROUT(1)
PICK UP ROUTINE ADDRESS.
34320000
LA
2,32
34840000
ST
2,STRSHIFT
BOOLEAN SHIFTER.
35360000
A
8,LHRANK
35880000
LA
8,MRHO-M(8)
RESULT POINTER.
36400000
SPACE
36920000
L
1,LHBASE
37440000
DYADIC EPSILON

FINI
*
*
*

A
LA
ST
L
ST
SPACE
L
A
LA
ST
L
ST
SPACE
SR
ST
ST
SPACE
L
L
SPACE
LTR
BZ
LTR
BNZ
SPACE
L
BR
EJECT

LEFT IS SET UP.

1,RHBASE
1,RHRANK
1,MRHO-M(1)
1,RHORG
1,RCTYPE
1,RCFTYPE

RIGHT IS SET UP.

1,1
1,LINDX
1,RINDX

FETCH INDICES.

6,RHXRHO
7,LHXRHO

RESULT COUNT.

6,6
ALLZERO
7,7
LOOPS
LKR,REGSAV
LKR

BRANCH IF RH EMPTY.
OR IF LEFT ISN'T.
OTHERWISE, QUIT.

EPSILON EXECUTION.

SPACE
EQU
C
BE
SPACE
OUTER
LM
ICALL
LA
ST
STM
SR
ST
ST
L
INNER
LM
ICALL
QUEND
LA
ST
BR
NOHIT
BCT
LM
HIT
SLDL
BCT
ST
LA
LA
NOSTORE STM
BCT
LOOPS

1,LHRANK
1,MRHO-M(1)
1,LHORG
1,LCTYPE
1,LCFTYPE

*
5,CROUT+8
MIXED

SEE IF ONE OPERAND IS CHAR.

BRANCH IF SO.

2,4,LHFETCH
FETCH
2,1(2)
2,LINDX
0,1,DBLHOLD
1,1
1,RINDX
1,CURRES
6,RHXRHO
2,4,RHFETCH
FETCH

FETCH A LEFT.

2,1(2)
2,RINDX
5
6,INNER
0,2,GEARSHFT
0,1
2,NOSTORE
0,M(8)
8,4(8)
2,32
0,2,GEARSHFT
7,OUTER

BUMP INDEX.

SAVE IT.
INITIALIZE RESULT TO ZERO.
INNER LOOP COUNT.
FETCH A RIGHT.
GOT IT.

COMPARE
FALL THROUGH IF BNO HITS.
SHIFT.
BRANCH IF NOT YET FULL WORD.
OTHERWISE, STORE.
BUMP RESULT POINTER.
RESET SHIFT COUNT.
AND LOOP.

37960000
38480000
39000000
39520000
40040000
40560000
41080000
41600000
42120000
42640000
43160000
43680000
44200000
44720000
45240000
45760000
46280000
46800000
47320000
47840000
48360000
48880000
49400000
49920000
50440000
50960000
51480000
52000000
52520000
53040000
53560000
54080000
54600000
55120000
55640000
56160000
56680000
57200000
57720000
58240000
58760000
59280000
59800000
60320000
60840000
61360000
61880000
62400000
62920000
63440000
63960000
64480000
65000000
65520000
66040000
66560000
67080000
67600000
68120000
68640000

SPACE
*
*

*
*
*
FCOMPARE

DCOMPARE

MIXED

ALLZERO

STZ

*
*
*
MOVRANK
CROUT
EPS32
EPS2

./ ADD

69160000
69680000
FINISHED WHEN WE FALL THROUGH.
70200000
LM
0,2,GEARSHFT
FINAL SHIFT ABD STORE.
70720000
C
2,EPS32
SEE IF WE JUST DID ONE.
71240000
BE
FINI
BRANCH IF SO.
71760000
SLL 0,0(2)
OTHERWISE, SHIFT 72280000
ST
0,M(8)
AND STORE.
72800000
B
FINI
AND WE'RE DONE.
73320000
EJECT
73840000
74360000
TEST ROUTINES.
74880000
75400000
SPACE
75920000
C
0,DBLHOLD
FIXED OR CHARACTER.
76440000
BNE NOHIT
BRANCH IF NOR EQUAL.
76960000
LM
0,2,GEARSHFT
77480000
BCTR 1,0
SET RESULT TO 1.
78000000
B
HIT
AND RETURN
78520000
SPACE
79040000
SW
0,DBLHOLD
FLOATING.
79560000
STD 0,DBLSAVE
STORE DIFFERENCE.
80080000
CLC DBLSAVE+1(7),RFUZZ+1 LOOK AT RELATIVE DIFFERENCE.
80600000
BH
NOHIT
3564 81120000
LM
0,2,GEARSHFT
OTHERWISE, RESULT IS 1.
81640000
BCTR 1,0
SET RESULT TO 1.
82160000
B
HIT
82680000
SPACE
83200000
L
1,LHTYPE
CHARACTER - LOOK AT TYPES.
83720000
C
1,RHTYPE
IF NOT EQUAL, NO HITS.
84240000
BNE ALLZERO
84760000
L
5,CROUT
OTHERWISE, USE INTEGER COMPARE.
85280000
B OUTER
85800000
SPACE
86320000
LTR 7,7
SEE IF RESULT IS EMPTY.
86840000
BZ FINI
87360000
LA
7,31(7)
87880000
SRL 7,5
OTHERWISE, GET WORD COUNT.
88400000
SR
1,1
88920000
ST
1,M(8)
AND STORE ZEROS
89440000
LA
8,4(8)
89960000
BCT 7,STZ
A WORD AT A TIME.
90480000
B
FINI
91000000
EJECT
91520000
92040000
CONSTANTS.
92560000
93080000
MVC 0(0,1),0(2)
93600000
DC
0F'0'
94120000
DC
A(FCOMPARE)
94640000
DC
A(DCOMPARE)
95160000
DC
A(MIXED)
95680000
DC
F'32'
96200000
DC
F'2'
96720000
SPACE
97240000
EXTRN OPSPACE
97760000
EXTRN FETCH
98280000
LTORG
98800000
END
99320000
NAME=APLSERAF

ERAF
TITLE 'ERROR RECOVERY AND FRIENDS
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
SEVERAL CSECT
PRINT OFF
APLDEFN, ZSYMBOLS, PERTERM
PRINT NOGEN
COPY APLDEFN
COPY ZSYMBOLS
COPY PERTERM
TITLE 'ERROR RECOVERY AND ERROR MESSAGE PRINTER
05/11/70'
PRINT ON
SEVERAL CSECT
ENTRY ERROR
EXTRN DISPLAY
EXTRN GETSPACE
EXTRN MKGARB
EXTRN NONSTMTD
EXTRN SYNTXX
EXTRN TOBCD
EXTRN TYPEIN
*
PRINTS ERROR MESSAGE FOLLOWED BY FAULTED STATEMENT,
*
THEN RESTORES INTERPRETER TO APPROPRIATE STATE
*
(USUALLY, IMMEDIATE-EXECUTION MODE).
*
ON ENTRY, R1 CONTAINS ERROR CODE (A SMALL INTEGER).
ENTRY DFLTRNG
ENTRY DZERR
ENTRY DFLTFP
ENTRY DFLTXDZ
ENTRY BGATTNX
BGATTNX BALR LKR,0
TREAT DOUBLE ATTENTION OR CPU-TIMEUSING *,LKR
LIMIT-EXCEEDED (EITHER OF WHICH
ON
ATTN
LA
1,EINT
STOPS EXECUTION AT THE FIRST QUEND)
B
ERROR
VERY MUCH LIKE AN EXECUTION ERROR.
DROP LKR
DFLTRNG EQU *
DZERR
EQU *
DFLTFP EQU *
DFLTXDZ EQU *
LA
1,ERANGE
ERROR
L
LR,QR13STK
THIS IS AN IMITATION PROLOG THAT
BALR PR,0
RESETS R13 TO THE BASE OF
USING *,PR
AR
LR,MR
THE R13 STACK. WE AVOID UNNECESSARLA
TLR,(LEND-LOCALS+23)/8*8(LR) ILY LONG R13 STACK REUSING LOCALS-16,LR
QUIREMENTS THIS WAY.
*
IC
1,ERTYPE(1)
ST
1,ERNO
*
MARK ALL STACKED DATA BETWEEN SVI AND PARREL AS GARBAGE.
*
THE ROUTINE THAT CALLED ERROR M U S T CLEAN ITS OWN
*
HOUSE BEFORE CALLING ERROR -- E.G. ALL TEMPS MUST HAVE
*
M-POINTERS ON THE STACK ABOVE SVI.
ICALL ERAST
CUT THE STACK BACK TO SVI=PARREL-4
ICALL LOUTI
FORCE OUT POSSIBLE BUFFERRED TEXT
*
*
IN MOST OF THE FOLLOWING,
*
R2 = M-RELATIVE PARREL
*
R3 = CODESTRING SYLLABLE POINTER (FOR ERROR CARET)

00210000
00420000
00630000
00840000
01260000
01470000
01680000
01890000
02100000
02310000
02520000
02730000
02940000
03150000
03360000
03570000
03780000
03990000
04200000
04410000
04620000
04830000
05040000
05250000
05460000
05670000
05880000
06090000
06300000
06510000
06720000
06930000
07140000
07350000
07560000
07770000
07980000
08190000
08400000
08610000
08820000
09030000
09240000
09450000
09660000
09870000
10080000
10290000
10500000
10710000
10920000
11130000
11340000
11550000
11760000
11970000
12180000
12390000
12600000
12810000

*
*
*
*

R5 = DFN SYMBOL TABLE POINTER

R6 = BYTE 0 OF DFN M-ENTRY, HOLDING LOCK BIT
R7 = CODESTRING POINTER
SR
L
IC
STC
LH
L
ST
LTR
BZ

*
*
TM
BO
*
*
*
L
L
IC
LH
SLL
LA
ST
ST
B
*
*
ERR01
*
*
*
*
*
*
*
*
*
ERR03C

ERR03A
ERR03
ERR03B
ERR03E

6,6
2,PARREL
1,STFLAGS(2,MR)
1,ERFLAGS
3,STCPTR(2,MR)
7,STCODE(2,MR)
6,STCODE(2,MR)
1,7
ERR03C

WILL HOLD FUNCTION LOCK BIT

WE'LL NEED PARREL
MAKE STACK FLAGS ADDRESSABLE

R3 IS SYL INDEX WITHIN CODESTRING

PICK UP ADDRESS OF CODESTRING
ERASE CODESTRING POINTER FROM STACK
BGATTN MAY GET US
HERE AFTER CODESTRING HAS ALREADY
BEEN RETURNED TO THE DIRECTORY. IF
PTR IS 0, ASSUME THIS IS THE CASE.
ERFLAGS,STIMBIT
ARE WE IN AN IMMEDIATE-EXECUTION
ERR01
STATEMENT -NO.
RESTORE CODESTRING POINTER TO FUNCTION DIRECTORY,
AS IN END-OF-STATEMENT.
5,STFNSPTR(2,MR)
FIRST FIND FUNCTION SPTR IN STACK
8,M(5)
PICK UP FUNCTION MPTR FROM SYM TBL
6,MHEAD(8)
SAVE FUNCTION-PROTECT BIT IN R6
4,STLINE(2,MR)
GET LINE NUMBER
4,2
TIMES FOUR GIVES WORD INDEX
4,MFCODE-M(4,8)
R4 IS RELATIVE LOCATION IN DIRECTORY
1,M(4)
PUT BASE ADDRESS OF CODESTRING BACK
4,MHEAD(1)
LINK CODESTRING BACK TO DIRECTORY.
ERR03C

ERROR IN IMMEDIATE-EXECUTION STATEMENT

ICALL MKGARB
MARK CODESTRING GARBAGE
SR
2,2
SET UP PLINE TO PRINT 6 BLANKS
PRINT '(TYPE) ERROR'

OR

(IMM-EX, QUAD, UNLOCKED DFN,

TYPE NOT WS FULL OR INTERRUPT)
'(TYPE)'
(WS FULL OR INTERRUPT ON IMM-EX,
QUAD, OR DFN NOT UNWINDING)
'(DFN NAME) ERROR' (LOCKED DFN, NOT UNWINDING MODE)

OR

NOTHING

L
MVC
TM
BO
L
LA
CLI
BNH
EX
BZ
LR
BAL
BAL
LA
BAL
ATT
BAL
EQU

1,MPTBASE
2542
ERNO(1),ACTIVE-PERTERM(1) SAVE ATTENTION BIT
2542
RUNCTL,RCOLBIT
BYPASS ERROR-TYPE INDICATION
2542
ERR03E
IF IN UNWINDING MODE
1,ERNO
LOCATE TEXT OF ERROR TYPE
1,ERTEXT(1)
ERNO+3,EINTT-ERTEXT TYPE ONLY, IF WS FULL OR INTERRUPT
ERR03
6,ERLKTM
IF ERROR IN LOCKED FN,
ERR03A
1,5
ERROR TYPE IS FUNCTION NAME
LKR,PNSUB
LKR,SQUIRT
PRINT TYPE (EXCEPT FOR WS FULL, INT)
1,ERTEXT
'ERROR'
LKR,SQUIRT
OFF=ERR03B,RESET=YES RESET ATTENTION IF ON
2542
LKR,LOUT
PRINT THE LINE
2542
*

OR

(UNWINDING MODE)

13020000
13230000
13440000
13650000
13860000
14070000
14280000
14490000
14700000
14910000
15120000
15330000
15540000
15750000
15960000
16170000
16380000
16590000
16800000
17010000
17220000
17640000
18060000
18270000
18480000
18690000
19110000
19740000
19950000
20160000
20370000
20580000
20790000
21000000
21210000
21420000
21630000
21840000
22050000
22260000
22470000
22680000
22890000
23100000
23310000
23520000
23730000
23940000
24150000
24360000
24570000
24780000
24990000
25200000
25410000
25620000
25830000
26040000
26250000
26460000

EX
BZ
OI
ICALL
*
ERR02

ERR025

ERR027
ERR07
*

MVI
CLI
BNZ
TM
BZ
ATT
LEMP
LTR
BZ
LR
BAL
CLI
BE
CLI
BNE
LA
LR
ICALL
NI
ICALL

*
*
ERLKTM
ERTYPE

ERTEXT
EMFU
EINTT
ESYS
ESYN
EIND
ERAN
ELEN
EVAL
ERNG
EDEP
ENON
LOCALS

TM
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DSECT

6,ERLKTM
IF THIS IS A LOCKED FUNCTION,
ERR02
(IT'S NOT)
RUNCTL,RCOLBIT+RCTRABIT ENTER/STAY IN UNWIND MODE
SYNTXX

2542 26670000
26880000
C003 27090000
27300000
27510000
RUNCTL,0
OUT OF UNWINDING MODE
27720000
ERNO+3,ESYS-ERTEXT ON SYSTEM ERROR,
27930000
ERR025
28140000
ERNO,ATTENM
CHECK SAVED ATTENTION BIT
2542 28350000
ERR025
IF ATTENTION IS ON,
2542 28560000
RESET=YES
FIRST RESET ATTENTION, THEN... 2542 28770000
, LOAD A CLEAN WORKSPACE.
28980000
7,7
IF NO CODESTRING,
29190000
ERR07
INADVISABLE TO ATTEMPT DISPLAY.
29400000
1,2
SET UP PARREL OR 0 FOR PLINE TO
29610000
LKR,PLINE
PRINT F(N) OR SIX BLANKS
29820000
ERNO+3,ESYN-ERTEXT IF SYNTAX ERROR, ERROR SYL POINTER 30030000
ERR027
IS CORRECT. OTHERWISE,
30240000
NEXTOG,0
IF NEXTOG IS ON, ERROR SYL IS ONE
30450000
ERR027
30660000
3,1(3)
TO THE RIGHT.
30870000
2,7
STACKED CODESTRING POINTER
31080000
DISPLAY
RECREATE THE FAULTED LINE.
31290000
MX+3,256-4
A NOT-QUITE-SUPERFLUOUS CHECK THAT 31500000
MX IS ON A WORD BOUNDARY
31710000
TYPEIN
ALL DONE. 'CALL' TYPEIN AND LET
31920000
TYPEIN TAKE CARE OF DISCARDING THE 32130000
R13 STACK.
32340000
*+4,0
32550000
AL1(MFLKBIT)
32760000
AL1(ESYS-ERTEXT)
WHERE TO FIND TEXT OF ERROR TYPES
32970000
AL1(EMFU-ERTEXT)
33180000
AL1(ESYN-ERTEXT)
33390000
AL1(EIND-ERTEXT)
33600000
AL1(ERAN-ERTEXT)
33810000
AL1(ELEN-ERTEXT)
34020000
AL1(EVAL-ERTEXT)
34230000
AL1(0)
34440000
AL1(0)
34650000
AL1(0)
34860000
AL1(0)
35070000
AL1(ERNG-ERTEXT)
35280000
AL1(EDEP-ERTEXT)
35490000
AL1(EINTT-ERTEXT)
35700000
AL1(0)
35910000
AL1(0)
36120000
AL1(ENON-ERTEXT)
36330000
AL1(6,ZBLANK,ZE,ZR,ZR,ZO,ZR)
36540000
AL1(7,ZW,ZS,ZBLANK,ZF,ZU,ZL,ZL)
36750000
AL1(9,ZI,ZN,ZT,ZE,ZR,ZR,ZU,ZP,ZT)
36960000
AL1(6,ZS,ZY,ZS,ZT,ZE,ZM)
37170000
AL1(6,ZS,ZY,ZN,ZT,ZA,ZX)
37380000
AL1(5,ZI,ZN,ZD,ZE,ZX)
37590000
AL1(4,ZR,ZA,ZN,ZK)
37800000
AL1(6,ZL,ZE,ZN,ZG,ZT,ZH)
38010000
AL1(5,ZV,ZA,ZL,ZU,ZE)
38220000
AL1(6,ZD,ZO,ZM,ZA,ZI,ZN)
38430000
AL1(5,ZD,ZE,ZP,ZT,ZH)
38640000
AL1(5,ZN,ZO,ZN,ZC,ZE)
38850000
39060000

ERNO
DS
F
ERFLAGS DS
FL1
LEND
EQU *
EJECT
SEVERAL CSECT
ENTRY ERAST
ERAST
PROLOG
, ERASE EXECUTION AND DIAGRAM STACKS
*
DOWN TO PARREL AND 'STMT' DIAGRAM.
LM
2,3,SVI ,PARREL
FIND TOP OF STACK
*
START OUT BY GARBAGING 'PARAMETER 0'
LA
LKR,STPARAM(3)
WHICH MAY BE AN OP SUBSCRIPT
3590
C
LKR,QSYMBOT
CASE OF VERY OLD
3590
BNL ERA3
WS WITH STACK 4 BYTES TOO SHORT
L
1,M(LKR)
3590
SR
0,0
ST
0,M(LKR)
SYNT ERR HAS OP SUBSCRIPT
3590
B
ERA8
STASHED HERE WHILE THE EXPRESSION TO
*
ITS RIGHT WAS EVALUATED.
*
ERA3
LA
2,4(2)
NEXT STACK ENTRY IS 4 ABOVE SVI.
ST
2,SVI
IRRELEVANT EXCEPT FOR ERROR-RECOVERY
*
(IT KEEPS US FROM GETTING REPEATED
*
PROGRAM CHECKS ON THE SAME BAD STACK
*
ENTRY)
CR
2,3
HAVE WE REACHED PARREL -BNL ERA4
YES. STACK COLLAPSING IS DONE.
L
1,M(2)
NO. KILL THE NEXT STACK ENTRY.
ERA8
C
1,QF24BITS
THE ONLY STACK ENTRIES WE WANT TO
*
MARK ARE POSITIVE AND GREATER THAN
*
(2*24)-1. OTHERS ARE SIMPLY INDI*
RECT BST ENTRIES, OPERATORS, END-OF*
LIST FLAGS, OR SOME SUCH. WE WANT
*
TO CATCH ONLY EST ENTRIES.
BNH ERA3
NOT AN EST ENTRY.
ICALL MKGARB
GARBAGE IT.
B
ERA3
BACK FOR NEXT.
ERA4
S
3,QF4
GIVE SVI VALUE OF 4 LESS THAN PARREL
ST
3,SVI
L
1,DIASTPTR
STARTING AT PRESENT TOP OF STACK,
L
2,=A(NONSTMTD)
RUN DIAGRAM STACK BACK TO
XR
0,0
'STMT' DIAGRAM. LOOK FOR FIRST 3562
ERA6
IC
0,DIAST(1)
REFERENCE TO 'STMT' IN PRESENT 3562
C
0,0(2)
DIAGRAM
3562
ST
1,DIASTPTR
3562
BCTR 1,0
3562
BNL ERA6
IRETURN
TITLE 'PRINT WORKSPACE OR FUNCTION NAME
05/11/70'
SEVERAL CSECT
ENTRY PRWSNAME
PRWSNAME PROLOG PRWL,PRWLEND
MVC PWN(LWFLAB),0(1)
PUT FILE LABEL IN A KNOWN PLACE
LA
1,PWS4
CLI PWN+WFLNAME-WFLLIB,11
BH
PWS1
CHAR COUNT GTR 11 MEANS CLEAR WS
L
0,PWN+WFLLIB-WFLLIB
L
3,MPTBASE
C
0,PTMAN-PERTERM(3)
BE
PWS2
DON'T PRINT LIB NO. IF IT MATCHES
ICALL PRNUM,*
SIGNON NUMBER

39270000
39480000
39690000
39900000
40110000
40320000
40530000
40740000
40950000
41160000
41370000
41580000
41790000
42000000
42210000
42420000
42630000
42840000
43050000
43260000
43470000
43680000
43890000
44100000
44310000
44520000
44730000
44940000
45150000
45360000
45570000
45780000
45990000
46200000
46410000
46620000
46830000
47040000
47250000
47460000
47670000
47880000
48090000
48300000
48510000
48720000
48930000
49140000
49350000
49560000
49770000
49980000
50190000
50400000
50610000
50820000
51030000
51240000
51450000
51660000

LA
1,ZBLANK
ICALL TOPRINT,*
A BLANK TO SEPARATE NO. AND NAME
LA
1,PWN+WFLNAME-WFLLIB
PRINT NAME
ICALL SQUIRT,*
ICALL LOUT,*
IRETURN
SPACE 2
ENTRY PLINF
ENTRY PLINE
PRINT CURRENT FUNCTION NAME AND BRACKETED LINE NUMBER
L
1,PARREL
SET UP CURRENT FUNCTION AS ARGUMENT
FOR PLINE.
PRINT FUNCTION NAME AND BRACKETED LINE NUMBER, OR 6 BLANKS.
ON ENTRY, R1 = RELATIVE SETTING FOR STACKED FUNCTION INFO
OR 0
PROLOG PLOC,PLEND
STM 0,2,PLOC
SAVE REGISTERS
LTR 2,1
IF R1 IS ZERO
LA
1,PLINDENT
BZ
PLIN6
PRINT 6 BLANKS.
L
1,STFNSPTR(2,MR)
LOCATE FUNCTION PRINTNAME
N
1,QF24BITS
BZ
PLIN0
6 BLANKS ALSO IF FN SPTR IS ZERO
BAL LKR,PNSUB
GET ABS ADDR OF PRINTNAME
MVC PLOC+12(1),0(1)
SAVE LENGTH FOR RIGHT BRACKET PRINT
ICALL SQUIRT,*
SQUIRT THE PRINTNAME
LA
1,ZLBR
FUNCTION NAME PRINTED. NOW FOR
ICALL TOPRINT,*
THE BRACKETS
LH
0,STLINE(2,MR)
AND THE LINE NUMBER
ICALL PRNUM,*
LA
1,PLRBR
NOW THE RIGHT BRACKET AND ONE BLANK
CLI PLOC+12,1
BH
PLIN6
OR TWO IF 1-CHAR FN NAME, TO GET
LA
1,PLRBR2
TO COLUMN 7
ICALL SQUIRT,*
LM
0,2,PLOC
IRETURN
AND THAT'S ALL.
DROP PR

51870000
52080000
PWS2
52290000
PWS1
52500000
52710000
52920000
53130000
53340000
53550000
*
53760000
PLINF
53970000
*
54180000
*
54390000
*
54600000
*
54810000
PLINE
55020000
55230000
55440000
PLIN0
55650000
55860000
56070000
56280000
56490000
56700000
PLIN2
56910000
57120000
57330000
57540000
57750000
57960000
58170000
58380000
58590000
58800000
PLIN6
59010000
59220000
59430000
59640000
*
59850000
*
60060000
*
GET ABS ADDR OF PRINTNAME.
60270000
*
ON ENTRY, R1 = M-RELATIVE SYMBOL TABLE POINTER
60480000
PNSUB
ST
LKR,0(TLR)
WE NEED LINK REGISTER
60690000
BALR LKR,0
FOR ADDRESSABILITY
60900000
USING *,LKR
61110000
N
1,QF24BITS
61320000
C
1,QSYMBOT
IF FUNCTION NAME HAS BEEN SHADOWED, 61530000
BNL PNS1
61740000
S
1,QF4
IT POINTS TO STACK WHICH POINTS
61950000
L
1,M(1)
TO SYMBOL TABLE ENTRY (AND PNAME)
62160000
PNS1
L
LKR,0(TLR)
62580000
DROP LKR
62790000
LA
1,M+4(1)
ABS ADDR OF SECOND WORD IN SYM TBL 63000000
CLI 0(1),3
IS RESULT IF CHAR COUNT LEQ 3
63210000
BCR 13,LKR BNH
63420000
L
1,0(1)
ELSE RESULT IS POINTED TO BY R1
63630000
LA
1,MPNAME(1)
64050000
BR
LKR
64260000
*
64470000
PLINDENT DC
AL1(6)
64680000

DC
6AL1(ZBLANK)
DC
AL1(2,ZRBR,ZBLANK)
DC
AL1(3,ZRBR,ZBLANK,ZBLANK)
DC
AL1(8,ZC,ZL,ZE,ZA,ZR,ZBLANK,ZW,ZS)
DSECT
DS
XL(LWFLAB)
EQU *
DSECT
DS
4F
PLEND
EQU *
TITLE 'PRINT ONE CHARACTER OR TEXT STRING
05/11/70'
SEVERAL CSECT
ENTRY TOPRINT
*
ON ENTRY,
*
R1 = CHARACTER TO BE PRINTED.
*
DESTROYS ONLY R0, R1
TOPRINT LR
0,1
LH
1,OBUFPTR
PUT ONE CHARACTER INTO THE
STC 0,OBUF(1)
OUTPUT BUFFER.
LA
0,1(1)
BUMP BUFFER POINTER
STH 0,OBUFPTR
CH
0,OBUFLIM
IF WE'VE REACHED THE END OF THE
BALR 1,0
USING *,1
BH
LOUT
BUFFER, FORCE IT OUT.
DROP 1
BR
LKR
*
*
SQUIRT -- MOVE N CHARACTERS TO OUTPUT BUFFER
*
*
ON ENTRY, R1 = ADDRESS OF CHARACTERS TO BE MOVED.
*
IF ENTERED AT SQUIRT, ADDRESS IS ABSOLUTE.
*
IF ENTERED AT SQUIRTM, ADDRESS IS M-RELATIVE.
*
FIRST CHARACTER IS COUNT OF FOLLOWING CHARACTERS,
*
AND IS NOT MOVED.
*
IF THE NUMBER OF CHARACTERS EXCEEDS THE SPACE
*
REMAINING IN THE OUTPUT BUFFER, THE BUFFER IS FORCED
*
OUT AND THE CHARACTERS ARE INSERTED FOLLOWING SIX
*
BLANKS IN THE LEFT END.
*
DESTROYS REGISTER 0 .
ENTRY SQUIRT
ENTRY SQUIRTM
SQUIRTM AR
1,MR
ABSOLUTIZE POINTER
SQUIRT PROLOG SQL,SQLEND
STM 1,5,SQRS
SAVE REGS OVER SQUIRT
SR
2,2
LA
3,0(1)
LOSE BYTE 0 FOR COMPARISONS AT SQ04
IC
2,0(3)
PUT CHARACTER COUNT IN R2
LH
5,OBUFPTR
SQ03
LH
4,OBUFLIM
SR
4,5
R4 = REMAINING LENGTH IN LINE
CR
4,2
PREPARE TO MOVE
BL
SQ06
MIN OF STRING AND BUFFER LENGTHS
LR
4,2
SQ01
LA
0,0(4,5)
UPDATE POINTER
STH 0,OBUFPTR
AR
5,MR
GET ABSOLUTE BUFFER POINTER
EX
4,SQM
MOVE CHARACTER STRING TO BUFFER
*
(1 CHAR TOO MANY FROM LAZINESS)
SR
2,4
PLRBR
PLRBR2
PWS4
PRWL
PWN
PRWLEND
PLOC

64890000
65100000
65310000
65520000
65730000
65940000
66150000
66360000
66570000
66780000
66990000
67200000
67410000
67620000
67830000
68040000
68250000
68460000
68670000
68880000
69090000
69300000
69510000
69720000
69930000
70140000
70350000
70560000
70770000
70980000
71190000
71400000
71610000
71820000
72030000
72240000
72450000
72660000
72870000
73080000
73290000
73500000
73710000
73920000
74130000
74340000
74760000
74970000
75180000
75390000
75600000
75810000
76020000
76230000
76440000
76650000
76860000
77070000
77280000
77490000

SQ05
SQ06
SQ04

SQ08
SQM
*
SQ6BL
SQL
*
SQRS
SQLEND

BP
SQ04
LM
1,5,SQRS
IRETURN
LTR 5,5
BZ
SQ01
SR
4,4
AR
3,4
SR
5,5
CR
3,MR
BL
SQ08
CR
3,LR
BH
SQ08
SR
3,MR
ICALL LOUT,*
AR
3,MR
B
SQ03
ICALL LOUT,*
B
SQ03
MVC OBUF-M(0,5),1(3)
DC
DSECT

DS
EQU
TITLE
SEVERAL CSECT
ENTRY
XRHO
STM
BALR
*
USING
LR
LH
SR
LA
S
BM
L
BZ
SRL
XRHO3
M
LA
BCT
XRHO2
LM
BR
DROP
TITLE
ENTRY
ENTRY
ENTRY
LOUTI
CLI
BCR
LOUT
ST
BALR
USING
LH
LA
AR
LOUT1
BCTR

IS MOVE COMPLETED -YES.

77700000
77910000
78120000
IF NOT AT LEFT END OF LINE (TRUE
78330000
ONLY THE 1ST TIME THROUGH HERE),
78540000
FORCE OUT CURRENT LINE.
78750000
ADD MOVE LENGTH TO STRING ADDRESS
78960000
R5 HOLDS NEW OBUFPTR
79170000
79380000
WE MUST RELATIVIZE ANY ADDRESS
79590000
BETWEEN MR AND LR (OUR LOCALS, AND 79800000
LAST INFORMATION IN WS) -80010000
IT'S M-RELATIVE.
80220000
LOUT MIGHT SUSPEND US
80430000
AND MR MIGHT BE DIFFERENT HERE.
80640000
80850000
FOR ABSOLUTE (INTERP-RELATIVE) ADDRS 81060000
81270000
SOURCE STRING IS OFFSET BY 1
81480000
BECAUSE OF COUNT BYTE.
81690000
6AL1(ZBLANK)
81900000
82110000
82320000
5F
82530000
*
82740000
'X R H O -- P R O D U C T O V E R R H O V A R B' 82950000
83160000
XRHO
83370000
2,4,0(TLR)
COMPUTE PRODUCT OVER RANK VECTOR
83580000
4,0
OF ENTRY ADDRESSED BY R1
83790000
RETURNS RESULT IN R0, R1
84000000
*,4
84210000
2,1
MOVE MPTR TO R2
84420000
3,MRANK(2)
LOOK AT RANK
84630000
0,0
84840000
1,1
85050000
3,QF4
IS IT SCALAR -85260000
XRHO2
YES. RESULT IS 1.
85470000
1,MRHO(2)
IS IT VECTOR -85680000
XRHO2
YES. RESULT IS LENGTH.
85890000
3,2
HIGHER-DIMENSIONAL ARRAY. SET UP
86100000
0,MRHO+4(2)
MULTIPLY BY NEXT COMPONENT OF RHO
86310000
2,4(2)
BUMP MPTR
86520000
3,XRHO3
AND GO BACK FOR NEXT.
86730000
2,4,0(TLR)
FINISHED. RELOAD SAVED REGISTERS
86940000
LKR
AND EXIT.
87150000
4
87360000
'
PRINT-LINE OUTPUT ROUTINE -- USES TYO 05/11/70' 87570000
LOUT
87780000
LOUTI
87990000
LOUTN
88200000
OBUFPTR+1,0
SAME AS LOUT BUT IGNORE EMPTY LINE 88410000
8,LKR
88620000
2,0(TLR)
SAVE R2 WHILE WE FOOL AROUND
88830000
2,0
DELETING TRAILING BLANKS.
89040000
*,2
89250000
1,OBUFPTR
89460000
0,1(1)
89670000
1,MR
89880000
1,0
SCAN FROM RIGHT END OF BUFFER FOR
90090000

CLI
BNE
BCT
A
MVI
STH
L
DROP

OBUF-M(1),ZBLANK
LOUT2
0,LOUT1
0,QF1
OBUF-M+1(1),ZCR
0,OBUFPTR
2,0(TLR)
2

NONBLANKS.
FOUND ONE
NOTE THAT THIS JUST WORKS IF PTR=0

90300000
90510000
90720000
90930000
LOUT2
DROP IN CR FOLLOWING LAST NONBLANK 91140000
SS COUNT
91350000
RELOAD SAVED R2
91560000
91770000
*
91980000
LOUTN
LH
1,OBUFPTR
OUTPUT LINE, NO CARRIAGE RETURN
92190000
STH 1,LLLO
SAVE LINE LENGTH FOR CHAR EDITING
92400000
LA
0,ZEOB
92610000
STC 0,OBUF(1)
ALWAYS APPEND AN EOB
92820000
TYO OBUFPTR
SEND LINE TO APLSUP
93030000
SR
0,0
AND SET THE COUNT TO ZERO.
93240000
STH 0,OBUFPTR
93450000
STH 0,LGCPTR
QUAD' OUTPUT -- NO PREVIOUS OUTPUT 93660000
*
ON THIS LINE, EITHER.
93870000
QUEND
94080000
BR
LKR
94290000
TITLE 'PRNUM -- PRINT INTEGER NUMBER
05/11/70' 94500000
SEVERAL CSECT
94710000
*
94920000
*
CALL TOBCD TO PRINT INTEGER IN R0
95130000
*
95340000
ENTRY PRNUM
95550000
PRNUM
PROLOG PRNL,PRNLEND
95760000
STM 0,3,PRNREG
95970000
LA
2,2
INTEGER TYPE
96180000
SR
3,3
96390000
ICALL TOBCD
96600000
LM
0,3,PRNREG
96810000
IRETURN
97020000
SPACE
97230000
PRNL
DSECT
97440000
PRNREG DS
4F
97650000
PRNLEND EQU *
97860000
SPACE 2
98070000
SEVERAL CSECT
98280000
QF1
DC
F'1'
98490000
QF4
DC
F'4'
98700000
QF12
DC
F'12'
98910000
QF16
DC
F'16'
99120000
QF24BITS DC
A(X'FFFFFF')
99330000
LTORG
99540000
END
99750000
./ ADD
NAME=APLSFFSS
FFSS
TITLE 'F E T C H A N D S T O R E
05/11/70' 00350000
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
00700000
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
01050000
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
01400000
PRINT OFF
APLDEFN
02100000
FFSS
CSECT
02450000
COPY APLDEFN
02800000
TITLE 'F E T C H A N D S T O R E
05/11/70' 03150000
PRINT ON,NOGEN
03500000
FFSS
CSECT
03850000
ENTRY FETCH
04200000
ENTRY FETCHINT
04550000
EXTRN ERROR
04900000

*
*
FETCH (IDX,TYPE,BASE)
*
*
PUTS INTO REGISTERS 0 AND 1 THE VALUE AT BASE(IDX),
*
TYPE-CONVERTED ACCORDING TO TYPE.
*
ON ENTRY,
*
R2 = INDEX IN ELEMENTS (I.E. NOT BYTES)
*
R4 = BASE ADDRESS OF DATA IN M-ENTRY (M-RELATIVE)
*
R3 = TYPE-CONVERSION CODE, AS FOLLOWS -*
-- TO -*
B
I
F
C
*
*
BOOLEAN
1
5
6
*
*
-- FROM -INTEGER
7
2
8
*
*
FLOATING
9 10
3
*
*
CHARACTER *
*
*
4
*
*
11,12 FOR UNFUZZED FLOATING TO BOOLEAN AND
*
INTEGER RESPECTIVELY
*
*
ON EXIT,
*
R0,1 = RESULT, ALL TYPES
*
F0 = RESULT, IF FLOATING
*
F2 IS NOT SAVED IF THE FETCH CODE IS 9,10,11,12
*
ALL OTHER REGISTERS PRESERVED
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
FETCH AND STORE BYPASS THE LINKAGE MACROS
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
USING FEL,TLR
FETCHINT BALR 1,0
USING *,1
IC
3,TOINT-1(3)
GET INT CONVERSION TYPE FROM ARG TYP
FETCH
BALR 1,0
R1 HAS PRECARIOUS EXISTENCE AS BASE
USING *,1
STM 2,3,FRSV
SAVE R2, R3 OVER FETCH
CL
3,QF13
FOR DEBUGGING CHECK THAT TYPE IS
SLL 3,2
IN RANGE. THEN MAKE IT A WORD INDEX
BNH *+4(3)
AND BRANCH TO APPROPRIATE CONVERSION
B
SYSR
SYSTEM ERROR -- OUT-OF-RANGE TYPE.
B
BTOB
B
ITOI
B
FTOF
B
CTOC
B
BTOI
B
BTOF
B
ITOB
B
ITOF
B
FTOB
B
FTOI
B
FTOBNF
B
FTOINF
B
RNGERR
CHARACTER-NUMERIC CONVERSION
BTOI
EQU *
BOOLEAN-TO-INTEGER CONVERSION
LA
0,1
PRELOAD INTEGER 1 RESULT
LTR 2,2
BNZ NOTFIRST
IC
0,M(4)
IF FIRST ELEMENT THEN THIS IS FAST
SRL 0,7

05250000
05600000
05950000
06300000
06650000
07000000
07350000
07700000
08050000
08400000
08750000
09100000
09450000
09800000
10150000
10500000
10850000
11200000
11550000
11900000
12250000
12600000
12950000
13300000
13650000
14000000
14350000
14700000
15050000
15400000
15750000
16100000
16450000
16800000
17150000
17500000
17850000
18200000
18550000
18900000
19250000
19600000
19950000
20300000
20650000
21000000
21350000
21700000
22050000
22400000
22750000
23100000
23450000
23800000
24150000
24500000
24850000
25200000
25550000
25900000

L
BR
NOTFIRST SRDL
AR
IC
SRL
N
BNZ
LR
LM
BR
BTOF
EQU
LD
SRDL
AR
IC
SRL
N
LM
BNZ
LE
SR
SR
BR
BTOF1
L
SR
BR
BTOB
EQU
SRDL
AR
IC
SRL
SLL
N
LM
BR
FTOF
SLL
AR
AR
LM
STM
LD
LM
BR
CTOC
AR
IC
SLL
LM
BR
ITOI
SLL
AR
L
LM
BR
ITOB
SLL
AR
L
ITOB2
CL
SLL
BH

3,FRSV+4
LKR
2,3
2,4
2,M(2)
3,27
2,QBITS(3)
FRETS
0,2
2,3,FRSV
LKR
*
0,DONE
2,3
2,4
2,M(2)
3,27
2,QBITS(3)
2,3,FRSV
BTOF1
0,DZER
0,0
1,1
LKR
0,DONE
1,1
LKR
*
2,3
2,4
0,M(2)
3,29
0,24(3)
0,QFBIT0
2,3,FRSV
LKR
2,3
2,4
2,MR
0,1,0(2)
0,1,DTEMP
0,DTEMP
2,3,FRSV
LKR
2,4
0,M(2)
0,24
2,3,FRSV
LKR
2,2
2,4
0,M(2)
2,3,FRSV
LKR
2,2
2,4
0,M(2)
0,QF1
0,31
RNGERR

GET BYTE INDEX

BASE-RELATIVE
BIT IS IN THIS BYTE
MAKE RESIDUE A WORD INDEX
MASK OUT OTHER GARBAGE
IF NOT ZERO, QUIT WITH CONSTANT 1.
IT'S ZERO.
RESTORE SAVED R2,R3
BOOLEAN-TO-FLOATING CONVERSION
PRELOAD FLOATING 1 RESULT
GET BYTE INDEX
BASE-RELATIVE
BIT IS IN THIS BYTE
MAKE RESIDUE A WORD INDEX
MASK OUT OTHER GARBAGE
RESTORE SAVED R2,R3
IF NOT ZERO, RETURN 1.0
OTHERWISE WITH 0.0
LOSE BASE REGISTER
LOAD FLOATING 1.0
BOOLEAN-TO-BOOLEAN CONVERSION.
GET BYTE OF INTEREST
AND SHIFT COUNT
PUT BIT IN BIT 0 OF R0
AND MASK OUT GARBAGE.
RESTORE SAVED R2,R3
FLOATING-TO-FLOATING CONVERSION.
GET DOUBLEWORD INDEX
ABSOLUTE.
NOTE THAT FETCHED VALUE MAY NOT BE
ON A DOUBLEWORD BOUNDARY.
RESTORE SAVED R2,R3
CHARACTER-TO-CHARACTER CONVERSION.
PICK UP CHARACTER
AND LEFT-JUSTIFY IT.
RESTORE SAVED R2,R3
INTEGER-TO-INTEGER CONVERSION.
LOCATE WORD
PICK IT UP
RESTORE SAVED R2, R3
INTEGER-TO-BOOLEAN CONVERSION.
AS USUAL, GET M-RELATIVE ADDRESS
CHECK FOR VALUE OF 1 OR 0
PUT UNITS BIT IN SIGN
VALUE NOT 1 OR 0

26250000
26600000
26950000
27300000
27650000
28000000
28350000
28700000
29050000
29400000
29750000
30100000
30450000
30800000
31150000
31500000
31850000
32200000
32550000
32900000
33250000
33600000
33950000
34300000
34650000
35000000
35350000
35700000
36050000
36400000
36750000
37100000
37450000
37800000
38150000
38500000
38850000
39200000
39550000
39900000
40250000
40600000
40950000
41300000
41650000
42000000
42350000
42700000
43050000
43400000
43750000
44100000
44450000
44800000
45150000
45500000
45850000
46200000
46550000
46900000

LM
BR
ITOF
SLL
AR
L
AL
ST
LD
LE
SD
STD
LM
BR
FTOBNF EQU
FTOINF EQU
MVI
B
FTOB
EQU
FTOI
EQU
MVI
SLL
AR
AR
LM
STM
LD
LPDR
CE
BNL
STE
MVC
AD
AW
STD
L
LTER
BNL
LCR
LPER
AD
SDR
BZ
CLI
BE
LPER
LD
AD
CDR
BNH
LD
LPER
CD
BH
SR
TESTBOOL TM
BO
FRETS
LM
BR
SYSR
L
LA

2,3,FRSV
RESTORE SAVED R2, R3
LKR
2,2
INTEGER-TO-FLOATING CONVERSION.
2,4
0,M(2)
LOAD INTEGER
0,DUN231+4
MAKE EXCESS-2*31
0,DTEMP+4
LOAD AN UNNORMALIZED ZERO AROUND IT,
0,DTEMP
0,DUN231
WITH UNNORMALIZED ZERO PREFIX
PA
0,DUN231
REMOVE EXCESS AND NORMALIZE
0,DTEMP
0,3,DTEMP
LKR
*
UNFUZZED FLOATING-TO-BOOLEAN CONV.
*
UNFUZZED FLOATING-TO-INTEGER CONV.
FFLAG,0
FLAG FOR NO FUZZ IN CONVERSION
*+8
*
FLOATING-TO-BOOLEAN CONVERSION
*
FLOATING-TO-INTEGER CONVERSION
FFLAG,1
FLAG FOR FUZZED CONVERSION
2,3
GET DOUBLEWORD INDEX
2,4
M-RELATIVE
2,MR
ABSOLUTE
2,3,0(2)
2,3,DTEMP
0,DTEMP
LOAD TENTATIVE INTEGER
2,0
MAKE POSITIVE COPY
2,TWO31
IN RANGE ?
RNGERR
2,DTEMP1
DTEMP1+1(7),CNVTFUZZ+1 MOVE IN FUZZ BITS
2,DTEMP1
ADD IN RELATIVE FUZZ
2,RDUNZ
2,DTEMP2
0,DTEMP2+4
PICK UP AN INTEGER
0,0
*+8
0,0
MAKE 2'S COMPLEMENT IF NEGATIVE
0,0
2,DZER
RENORMALIZE INTEGER
0,2
GET REMAINDER
TESTBOOL
IF ZERO THEN EXACT INTEGER EXIT
FFLAG,0
IF NO FUZZING THEN RANGE ERROR
RNGERR
0,0
2,DTEMP1
LOAD RELATIVE FUZZ
2,DZER
NORMALIZE REL FUZZ
0,2
IF REMAINDER LT REL FUZZ THEN OK
TESTBOOL
0,DTEMP
0,0
0,CNVTFUZZ
IF INPUT IS GT ABS FUZZ RNG ERROR
RNGERR
0,0
OTHERWISE SET TO ZERO
FRSV+7,1
IF FLOATING TO BOOLEAN THEN
ITOB2
CONVERT INTEGER TO BOOLEAN
2,3,FRSV
RESTORE SAVED REGISTERS
LKR
LKR,=A(ERROR)
1,ESYSTEM

47250000
47600000
47950000
48300000
48650000
49000000
49350000
49700000
50050000
50400000
50750000
51100000
51450000
51800000
52150000
52500000
52850000
53200000
53550000
53900000
54250000
54600000
54950000
55300000
55650000
56000000
56350000
56700000
57050000
57400000
57750000
58100000
58450000
58800000
59150000
59500000
59850000
60200000
60550000
60900000
61250000
61600000
61950000
62300000
62650000
63000000
63350000
63700000
64050000
64400000
64750000
65100000
65450000
65800000
66150000
66500000
66850000
67200000
67550000
67900000

RNGERR
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
STORE

STB0

STINT

STFLT

STCH

BALR LKR,LKR
REALLY AN ICALL ERROR
PRINT GEN
LM
2,3,FRSV
SIGNAL RNG
EJECT
STORE (VALUE,IDX,TYPE,BASE)
PUTS INTO BASE(IDX) THE VALUE IN REGISTER R0 OR F0.
THE VALUE IS ASSUMED TO BE IN THE CORRECT TYPE.
A BIT OR CHARACTER IS LEFT-JUSTIFIED IN R0.

ENTRY
BALR
USING
STM
BCT
SRDL
SRL
LTR
BNM
IC
AR
AR
EX
LM
BR
IC
AR
AR
EX
LM
BR
BCT
SLL
AR
ST
LM
BR
BCT
SLL
AR
AR
STD
LM
STM
LM
BR
SRL
AR
STC

68250000
68600000
68950000
69300000
69650000
70000000
70350000
70700000
71050000
71400000
ON ENTRY,
71750000
R0 = VALUE, IF NOT FLOATING
72100000
F0 = VALUE, IF FLOATING
72450000
R2 = 0-ORIGIN INDEX IN ELEMENTS (I.E, NOT IN BYTES)
72800000
R3 = TYPE (1, 2, 3, OR 4)
73150000
R4 = BASE ADDRESS OF DATA (M-RELATIVE)
73500000
73850000
ON EXIT,
74200000
R0,1 GARBAGE
74550000
ALL OTHERS SAVED
74900000
STORE MUST NOT TURN ON FIXED OVERFLOW
75250000
STORE
75600000
1,0
ESTABLISH PRECARIOUS ADDRESSING
75950000
*,1
76300000
2,3,FRSV
SAVE R2, R3 OVER STORE
76650000
3,STINT
BRANCH ON TYPE TO APPROPRIATE STORE 77000000
2,3
BOOLEAN STORE. GET BYTE INDEX
77350000
3,29
AND BIT INDEX
77700000
0,0
SEGREGATE CASES. EASIER THAN LOGIC. 78050000
STB0
78400000
3,BITS(3)
STORE 1. PICK UP BIT IN BYTE
78750000
2,4
GET DATA ADDRESS
79100000
2,MR
ABSOLUTE
79450000
3,OI
AND OR IN THE BIT.
79800000
2,3,FRSV
RESTORE SAVED REGISTERS
80150000
LKR
80500000
3,UNBITS(3)
STORE 0.
80850000
2,4
GET DATA ADDRESS
81200000
2,MR
ABSOLUTE
81550000
3,NI
AND MASK OUT THE BIT.
81900000
2,3,FRSV
RESTORE SAVED R2, R3
82250000
LKR
82600000
3,STFLT
FALL THROUGH IF INTEGER
82950000
2,2
GET WORD INDEX
83300000
2,4
TO DATA, M-RELATIVE
83650000
0,M(2)
84000000
2,3,FRSV
RESTORE SAVED R2,R3
84350000
LKR
84700000
3,STCH
FALL THROUGH ON FLOATING
85050000
2,3
GET DOUBLE-WORD INDEX
85400000
2,4
TO DATA, M-RELATIVE
85750000
2,MR
AND ABSOLUTE
86100000
0,DTEMP
STORE F0 ON A DOUBLE-WORD
86450000
0,1,DTEMP
PICK IT UP AGAIN
86800000
0,1,0(2)
AND STORE IT ON A WORD BOUNDARY
87150000
2,3,FRSV
RESTORE SAVED R2, R3
87500000
LKR
87850000
0,24
CHARACTER STORE
88200000
2,4
GET M-RELATIVE DATA ADDRESS
88550000
0,M(2)
88900000

LM
2,3,FRSV
BR
LKR
BITS
DC
X'8040201008040201'
UNBITS DC
X'7FBFDFEFF7FBFDFE'
OI
OI
0(2),0
NI
NI
0(2),0
TOINT
DC
FL1'5,2,10,11'
QBITS
DC
F'128,64,32,16,8,4,2,1'
QF1
EQU QBITS+28
QF13
DC
F'13'
TWO31
DC
X'48800000'
DS
0D
DUN231 DC
X'4E00000080000000'
QFBIT0 EQU *-4
DZER
DC
D'0'
DONE
DC
D'1'
DCOMP
DC
X'4E00000100000000'
RDUNZ
DC
X'4E00000000000000' REALLY TRULY UNNORMALIZED ZERO
CNVTFUZZ DC
X'40000000000003FF'
LTORG
FEL
DSECT
DTEMP
DS
2D
FRSV
EQU DTEMP+8
DTEMP1 DS
D
DTEMP2 DS
D
FFLAG
DS
XL1
FEND
EQU *
END
./ ADD
NAME=APLSGOUT
GOUT
TITLE 'G E N E R A L O U T P U T R O U T I N E 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, PERTERM, ZSYMBOLS
GOUT
CSECT
COPY APLDEFN
COPY PERTERM
COPY ZSYMBOLS
TITLE 'G E N E R A L O U T P U T R O U T I N E 05/11/70'
PRINT NOGEN
PRINT ON
GOUT
CSECT
*
*
PRINT VALUE OF QUANTITY POINTED TO BY R1.
EXTRN ERROR
EXTRN FETCH
EXTRN LOUT
EXTRN LOUTI
EXTRN SQUIRT
EXTRN TOBCD
EXTRN TOPRINT
EXTRN XRHO
PROLOG GOUL,GOULND
* QUADP OUTPUT IS NOT TO BE GIVEN SPECIAL TREATMENT AS IN THE PAST A05
DSECT1 DSECT
A05
CLI SYL+1,1+2*ZQUADP
IF THIS IS QUAD-PRIME OUTPUT,
BNE GO10
MVC LGCPTR,OBUFPTR
RECORD CARRIER POSITION AT END OF
*
PREVIOUS OUTPUT.
GOUT
CSECT
A05

89250000
89600000
89950000
90300000
90650000
91000000
91350000
91700000
92050000
92400000
92750000
93100000
93450000
93800000
94150000
94500000
94850000
95200000
95550000
95900000
96250000
96600000
96950000
97300000
97650000
98000000
98350000
98700000
00370000
00740000
01110000
01480000
02220000
02590000
02960000
03330000
03700000
04070000
04440000
04810000
05180000
05550000
05920000
06290000
06660000
07030000
07400000
07770000
08140000
08510000
08880000
09250000
09620000
09990000
10360000
10730000
11100000
11470000
11840000

GO10

GO1

*
*
*
*
GOUT1

LTR
BP
BZ
L
DS
LA
TM
LA
BZ
LH
LA
LTR
BZ

1,1
GO1
GO9
1,M(1)
0H
2,MLIST(1)
0(2),MLSTBIT
2,1
GOUT2
2,MLSCT(1)
1,MLSORG-M(1)
2,2
GO2

IGNORE 0 ARG EXCEPT TO FORCE CR

IF THIS IS A LIST,
SET UP TO OUTPUT SEVERAL VALUES.
R1 IS M-RELATIVE POINTER TO MPTR
OF FIRST ITEM.
EXIT IMMEDIATELY IF LIST IS EMPTY

REENTRY TO PROCESS NEXT LIST ELEMENT.

R1 = M-RELATIVE ADDRESS OF NEXT ENTRY IN LIST M-ENTRY
R2 = COUNT OF REMAINING ENTRIES IN LIST
ST
1,LEAD
SAVE ADDRESS OF CURRENT MPTR
L
1,M(1)
LOOK AT MPTR
LTR 1,1
BNM GOUT2
POSITIVE IS GENUINE MPTR
L
1,M(1)
NEGATIVE IS INDIRECT MPTR
GOUT2
ST
2,LECT
SAVE LIST ENTRY COUNT
N
1,QF24BITS
IF MPTR IS ZERO,
BZ
GO8
LIST ELEMENT IS NULL. IGNORE IT.
LA
2,M(1)
OTHERWISE, MAKE SURE IT ITSELF
TM
MLIST-M(2),MLSTBIT ISN'T A LIST.
BO
SYNTERR
G01
ST
1,PSVD
SAVE ADDRESS OF PRINTEE
SR
2,2
SET UP INITIALLY
ST
2,WIDTH
FOR ZERO WIDTH (VECTOR) FORMAT
ST
2,KCT
AND FIRST DATA ELEMENT
IC
2,MTYPE(1)
ST
2,TYPE
SAVE DATA TYPE
ICALL XRHO
FIND TOTAL NO OF ELEMENTS IN R0, R1
LTR 1,1
IS ARRAY EMPTY -BZ
GO8
YES. PRINT A BLANK LINE (IF ANY).
L
4,PSVD
LH
3,MRANK(4)
PICK UP RANK OF QUANTITY
LA
2,MRHO-M-8(3,4)
COMPUTE ADDRESS OF PENULTIMATE RANK
*
ELEMENT
LA
4,MRHO-M(3,4)
COMPUTE BASE ADDRESS OF DATA
L
5,M+4(2)
PICK ULTIMATE RANK ELEMENT
* * * *
NOTE WELL -- R5 PRESERVED DOWN TO GOLM
LA
6,4
NEEDED LATER
CR
3,6
DO WE HAVE A VECTOR OR SCALAR -BNH GOSV
YES. PROCESS IT SEPARATELY.
*
VALUE IS NON-EMPTY ARRAY
LA
7,0(1,1)
SAVE XRHO TEMPORARILY
DR
0,5
COMPUTE COLUMN LENGTH
LR
3,5
REARRANGE FOR STM
STM 1,4,JCT+4
SAVE COLUMN LENGTH, ADDRESS OF PEN*
ULTIMATE RANK ELEMENT, ROW LENGTH,
*
AND DATA ADDRESS.
L
1,TYPE
BRANCHING ON TYPE, FIND WIDTH OF
IC
1,GO3-1(1)
PRINTED ELEMENTS.
AR
7,7
R7 IS JUST UNDER 4 * XRHO
*
R2 IS DATA ADDRESS FOR BXLE LOOPS.
BCT 7,GO4(1)
ALWAYS GOES
GO4
LA
4,2
BOOLEAN ARRAY. WIDTH IS 2.

12210000
12580000
12950000
13690000
14060000
14430000
14800000
15170000
15540000
15910000
16280000
16650000
17020000
17390000
17760000
18130000
18500000
18870000
19240000
19610000
19980000
20720000
21090000
21460000
21830000
22200000
22570000
22940000
23310000
23680000
24050000
24420000
24790000
25160000
25530000
25900000
26270000
26640000
27010000
27380000
27750000
28120000
28490000
28860000
29230000
29600000
29970000
30340000
30710000
31080000
31450000
31820000
32190000
32560000
32930000
33300000
33670000
34040000
34410000
34780000

GO7
*
*
GO5
GO5B

GO5A
GO5D
GO5C
GOP10
GOP10L
*
GO6

GO6B

GO6A
GO6F

GO6C
GO6E

*
GO6D

B
LA
B
AR
SR
L
LPR
CLR
BNL
LR
BXLE
LA
LA
CL
BL
BXLE
SRA
B
DC
EQU
AR
AR
AR
SDR
LE
LD
LDR
LA
LM
STM
LD
LPER
BZ
CDR
BNL
LDR
CDR
BNH
LDR
BXLE
LA
CDR
BNL
DD
BCT
B
LR
CDR
BNL
DD
BCT
S
C
BNL
SR
BNM

GOL
4,1
CHARACTER ARRAY. WIDTH IS 1.
GOL
INTEGER ARRAY. WIDTH OF PRINTED COLUMNS IS NUMBER OF
DIGITS IN LARGEST MAGNITUDE, PLUS 2.
7,4
SET UP LIMIT FOR BXLE
0,0
NOW SEARCH FOR MAXIMUM MAGNITUDE.
1,M(4)
GET NEXT ELEMENT
1,1
MAKE IT POSITIVE
0,1
GO5A
TAKE MAX
0,1
4,6,GO5B
BACK FOR THE NEXT.
7,GOP10L-GOP10+7
NOW COMPARE AGAINST POWERSOFTEN
4,8
0,GOP10-8(4)
GO5C
LARGER POWER OF TEN FOUND.
4,6,GO5D
BACK FOR NEXT OR FALL THROUGH ON 10
4,2
GET WIDTH FROM WORD INDEX
GOL
F'1,10,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9'
*
FLOATING-POINT ARRAY.
7,7
MAKE R7 DOUBLEWORD DATA LENGTH
7,4
NOW R7 IS BXLE LIMIT
6,6
R6 = 8
0,0
PREPARE TO FIND MAXIMUM AND MINIMUM
0,GOE1
4,GOD1016
ABSOLUTE VALUES, EXCLUDING ZERO.
6,4
NEEDED IN MAGNITUDE DETERMINATION
1,M(4)
0,1,0(1)
DATA ELEMENT
0,1,DTEMP
2,DTEMP
2,2
TAKE ABSOLUTE VALUE
GO6A
IGNORE ZEROES
0,2
CARRY MAXIMUM VALUE IN D0
*+6
0,2
4,2
CARRY MINIMUM NONZERO VALUE IN D4
GO6A
4,2
4,6,GO6B
4,21
MAGNITUDE DETERMINATION.
0,6
COMPARE MAX MAGNITUDE AGAINST
GO6C
SUCCESSIVELY SMALLER POWERS OF TEN
6,GOD10
(SLOWER THAN A TABLE BUT FAR SHORTER
4,GO6F
)
GO6EF
MAX MAGNITUDE TOO SMALL -- LSS 1E-4
2,4
SAVE MAX MAGNITUDE
4,6
REPEAT THE PROCESS FOR MIN MAGNITUDE
GO6D
6,GOD10
4,GO6E
MIN MAGNITUDE FALLS THROUGH, DETECTED AS WIDE SPREAD
2,QF5
GET TRUE POWER OF TEN
2,OSIGDIG
GO6EF
TOO BIG -- GEQ 10**OSIGDIG
2,4
GO6EF
SPREAD TOO WIDE -- GTR 4 ORDERS

35150000
35520000
35890000
36260000
36630000
37000000
37370000
37740000
38110000
38480000
38850000
39220000
39590000
39960000
40330000
40700000
41070000
41440000
41810000
42180000
42550000
42920000
43290000
43660000
44030000
44400000
44770000
45140000
45510000
45880000
46250000
46620000
46990000
47360000
47730000
48100000
48470000
48840000
49210000
49580000
49950000
50320000
50690000
51060000
51430000
51800000
52170000
52540000
52910000
53280000
53650000
54020000
54390000
54760000
55130000
55500000
55870000
56240000
56610000
56980000

GO6EF
GO6W
GOL

GOSV

GOSV1
*
GOL1
GOLF

GOLM
GOLN
*
GOL2

GOL3

GOL4

S
SLL
B
L
AH
A
STH
ST
ICALL
B
EQU
LR
LA
STM
SR
TRT
BNE
L
LA
STH
B
ST
SR
D
S
LTR
BNZ
LA
ICALL
B
BAL
LR
ST
CLI
BE
CLI
BNE
LA
ICALL
LH
AH
CH
BNH
BAL
LA
ICALL
LM
LA
ST
L
ICALL
STM
CLI
BNE
CLI
BNE
BAL
B

4,QF5
MIN MAGNITUDE PLACES THE DECIMAL PT
4,16
GO6W
4,=A(X'F80000')
BYTE 1 WILL BE X'FF'
4,OSIGDIG+2
INSERT FIELD WIDTH
4,=A(X'070007')
PLUS 7 FOR SIGN AND EXPONENT
4,MAXWIDTH
4,WIDTH
LOUTI
TRACE & MIXED OUTPUT LEAVE JUNK
GOLN
DON'T PRECEED MAXRIX BY BLANK LINE
*
SET UP TO OUTPUT SCALAR OR VECTOR
0,1
REARRANGE FOR STM
1,1
STORE ELEMENT COUNT, ROW COUNT,
0,4,JCT
GARBAGE, AND BASE ADDRESS OF DATA.
2,2
SET UP MAXIMUM WIDTH
TYPE+3(1),MWPT-1
GOSV1
FLOATING-POINT HANDLED SEPARATELY
2,OSIGDIG
2,6(2)
IT'S MAX NO. OF DIGITS PLUS SIX.
2,MAXWIDTH
GOL3
OFF TO THE OUTPUT LOOP -LOOP ENTRY FOR MULTIDIMENSIONAL ARRAYS
3,ICT
WE JUST FINISHED A ROW OF AN ARRAY.
2,2
FOR EACH PLANE, CUBE ETC OF WHICH
2,M(4)
THIS IS AN END
4,QF4
(DETERMINED BY NUMBER OF TRAILING
2,2
0'S IN SUBSCRIPT LIST OF NEXT ELEM),
GOLM
1,QZLFIDL
PRINT AN EXTRA SPACE.
SQUIRT
GOLF
6,LINE
FORCE OUT THIS ROW.
2,5
SET UP COLUMN COUNTER
TOP OF VECTOR AND ROW DISPLAY LOOP
2,JCT
TYPE+3,4
IF THIS IS NOT CHARACTER TYPE,
GOL3
WIDTH+3,0
AND WE ARE OUTPUTTING A VECTOR,
GOL3
1,Q2BL
THEN PRINT TWO BLANKS.
SQUIRT
1,OBUFPTR
CHECK TO SEE THAT WE'RE WELL AWAY
1,MAXWIDTH
FROM THE RIGHT MARGIN.
1,OBUFLIM
IF THE NEXT ELEMENT COULD RUN OVER
GOL4
THE MARGIN,
6,LINE
CLOSE THIS LINE.
1,INDENT
AND START A CONTINUATION LINE
SQUIRT
INDENTED SIX SPACES.
2,3,KCT
SET UP FOR ELEMENT FETCH.
0,1(2)
BUMP THE ELEMENT COUNTER TO THE
0,KCT
FOLLOWING ELEMENT.
4,BASE
FETCH
PUT NEXT ELEMENT IN DTEMP
0,1,DTEMP
TYPE+3,4
CHARACTER OUTPUT NEEDS EXTRA CARE
GOL5
DTEMP,ZCR
GOL5
6,LINE
GOL6

57350000
57720000
58090000
58460000
58830000
59200000
59570000
59940000
60310000
60680000
61050000
61420000
61790000
62160000
62530000
62900000
63270000
63640000
64010000
64380000
64750000
65120000
65490000
65860000
66230000
66600000
66970000
67340000
67710000
68080000
68450000
68820000
69190000
69560000
69930000
70300000
70670000
71040000
71410000
71780000
72150000
72520000
72890000
73260000
73630000
74000000
74370000
74740000
75110000
75480000
75850000
76220000
76590000
76960000
77330000
77700000
78070000
78440000
78810000
79180000

GOL5
*
GOL6

LM
2,3,TYPE
ICALL TOBCD
LM
BCT

2,5,JCT
2,GOL2

BCT

3,GOL1

*
*
GO8

SET UP ARGUMENTS FOR BCD CONVERT.

DO THE CONVERSION AND PUT RESULT IN
THE OUTPUT BUFFER.
PICK UP VARIOUS COUNTERS ETC
BACK FOR MORE IF ROW NOT FINISHED
FINISHED.
BRANCH ON ROW COUNT (COL LENGTH)
TO END-OF-ROW LOGIC.
RECALL LIST ADDRESS AND COUNT
BUMP ADDRESS TO NEXT LIST ELMENT

LM
1,2,LEAD
LA
1,4(1)
BCT 2,GOUT1
* QUADP OUTPUT IS NOT TO BE GIVEN SPECIAL TREATMENT AS IN THE PAST A05
DSECT2 DSECT
A05
CLI SYL+1,1+2*ZQUADP
QUAD-PRIME OUTPUT DOESN'T FORCE A CR
BE
GO2
GOUT
CSECT
A05
GO9
BAL 6,LINE
GO2
IRETURN
LINE
ICALL LOUT
PRINT THIS LINE.
ATT ON=GO2,RESET=NO
DISCONTINUE OUTPUT IF ATTENTION IS
BR
6
SET, BUT DON'T CLEAR IT.
SYNTERR LA
1,ESYNTAX
WE CAN'T HANDLE MULTILEVEL TESTS G01
ICALL ERROR
GO3
DC
AL1(GO4-GO4,GO5-GO4,GO6-GO4,GO7-GO4) ARRAY SETUP ADDRS
MWPT
DC
FL1'3,13,0,1'
MAXIMUM WIDTHS OF DISPLAY ITEMS
INDENT DC
AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK)
Q2BL
DC
AL1(2,ZBLANK,ZBLANK)
QZLFIDL DC
AL1(2,ZLF,ZILG)
LINEFEED AND IDLE CHAR (TIMING)
QF4
DC
F'4'
QF24BITS DC
A(X'FFFFFF')
QF5
DC
F'5'
GOE1
DC
E'1'
GOD10
DC
D'10'
GOD1016 DC
D'1E16'
LTORG
GOUL
DSECT
DTEMP
DS
D
PSVD
DS
F
PTR TO M-ENTRY BEING PRINTED
JCT
DS
5F
REMAINING ELEMENTS IN THIS ROW
ICT
EQU JCT+4
REMAINING ROWS IN ARRAY
PRBASE EQU JCT+8
ADDRESS OF PENULTIMATE RANK ELEMENT
COLNOS EQU JCT+12
NUMBER OF COLUMNS IN ARRAY (ROW LGT)
BASE
EQU JCT+16
DATA BASE ADDRESS
KCT
DS
3F
ELEMENT COUNT (1ST ARG TO FETCH)
TYPE
EQU KCT+4
TYPE (2ND ARG TO FETCH (AND TOBCD))
WIDTH
EQU KCT+8
CONTROL INFO (3RD ARG TO TOBCD)
MAXWIDTH DS
H
LEAD
DS
2F
LIST ENTRY ADDRESS (M-REL)
LECT
EQU LEAD+4
LIST ENTRY COUNT (=1 FOR NONLIST)
GOULND EQU *
END
./ ADD
NAME=APLSGRAD
GRAD
TITLE 'S O R T -- G R A D E U P + D O W N
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXMSORT CSECT
COPY APLDEFN
COPY OPSECT

79550000
79920000
80290000
80660000
81030000
81400000
81770000
82140000
82510000
82880000
83250000
83620000
83990000
84360000
84730000
85100000
85470000
85840000
86210000
86580000
86950000
87320000
87690000
88060000
88430000
88800000
89170000
89540000
89910000
90280000
90650000
91020000
91390000
91760000
92130000
92500000
92870000
93240000
93610000
93980000
94350000
94720000
95090000
95460000
95830000
96200000
96570000
96940000
97310000
97680000
98050000
00430000
00860000
01290000
01720000
02150000
03010000
03440000
03870000

EXMSORT
XZI
ZI
R1
R
I
ZR
ZERO
DECIDE
XBASE
ZBASE
COMPARE

EXUPGRD
EXDNGRD
COUPLE
ORG

AWRIGHT

TITLE
PRINT
ENTRY
ENTRY
EXTRN
EXTRN
CSECT
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
USING
USING
USING
USING
LA
BC
USING
LA
ST
BALR
USING
EQU
ST
L
IC
ST
L
LA
C
BC
LA
ICALL
EQU
LA
L
BALR
L
LR
QUEND
LR
A
AR
AR
MVC
MVI
L
LA
LR
L
BXLE
CLI
BC

'S O R T -- G R A D E
ON,NOGEN
EXUPGRD
EXDNGRD
ERROR
OPSPACE

U P

D O W N

05/11/70' 04300000
04730000
05160000
05590000
06020000
06450000
06880000
0
07310000
9
07740000
1
08170000
2
08600000
3
09030000
4
09460000
5
09890000
6
10320000
7
10750000
8
11180000
10
THIS IS THE COMPARE ADDRESS.
11610000
OPSECT-16,LR
12040000
X1,XBASE
12470000
Z1,ZBASE
12900000
*,9
13330000
1,ASCEND-1
THIS IS TO GET THE COMPARE ADDRESS. 13760000
15,COUPLE
14190000
*,9
14620000
1,DESCEND-1
GET THE COMPARE ADDRESS.
15050000
PR,FTEMP
SAVE CALLER'S BASE REGISTER
15480000
PR,0
GRAB IT FOR LOCAL USE
15910000
*,PR
16340000
*
16770000
LKR,DBLSAVE
DOUBLY SAVE LKR.
17200000
2,RHTYPE
INPUT TYPE. 1, 2, OR 3.
17630000
2,0(1,2)
SNATCH AN OFFSET FOR LATER.
18060000
2,DTEMP
STASH IT AWAY IN A SAFE PLACE.
18490000
1,RHXRHO
GET THE NUMBER OF THINGS THERE.
18920000
2,4
IT MUST BE A VECTOR.
19350000
2,RHRANK
IT MUST BE A VECTOR.
19780000
8,AWRIGHT
BRANCH IF IT IS OKAY.
20210000
R1,ERANK
20640000
ERROR
21070000
*
21500000
3,2
INTEGER TYPE.
21930000
10,=A(OPSPACE)
NOW GET SOME PLACE TO PUT THE ANS. 22360000
LKR,10
XX
22790000
XBASE,RHBASE
EXTABLISH A BASE FOR X.
23220000
ZBASE,1
LOAD THE RESULT BASE.
23650000
24080000
COMPARE,12
GET THE REAL COMPARE ADDRESS.
24510000
COMPARE,DTEMP
XX
24940000
XBASE,MR
MAKE THOSE THINGS ABSLOUTELY
25370000
ZBASE,MR
ACCESSIBLE.
25800000
MTYPE-M(8,ZBASE),MTYPE-M(XBASE) MOVE IN THE RANK VECTOR. 26230000
MTYPE-M(ZBASE),X'02'
26660000
I,MRHO-M(XBASE)
GET THE NUMBER OF THINGS IN X.
27090000
R,4
2.75 27520000
ZR,R
2.50 27950000
0,X800
X'80000000'
28380000
I,I,CLEAN
DOUBLE I AND TEST FOR IOTA ZERO.4.50 28810000
MTYPE-M(XBASE),X'01' BIT OPERANDS ARE DONE SEPARATELY. 29240000
8,BITTYS
SO GO DO IT IF IT IS BITS.
29670000

BCTR I,0
SUBTRACT ONE FOR BXLE.
3.25
ALR 0,R
3.25
ST
0,Z(ZR)
4.50
BXLE ZR,R,TAG1
5.50
BCT I,TAG3
BRANCH IF NOT ONE ELEMENT.
4.50
BC
15,T6
X HAS ONE ELEMENT, TAKE CARE OF IT.
CMPAI
L
XZI,X(ZI)
COMPARE X(ZI) TO X(ZR).
C
XZI,X(ZR)
SET THE CONDITION CODE ACCORDINLY.
BCR 7,LKR
EXIT IF NOT EQUAL.
CR
ZI,ZR
OTHERWISE, COMPARE THE RELATIVE
BCR 15,LKR
POSITIONS IN X TO DETERMINE ORDER.
CMPDI
L
0,X(ZR)
COMPARE X(ZR) TO X(ZI).
C
0,X(ZI)
BCR 7,LKR
CR
ZI,ZR
BCR 15,LKR
CMPAF
LA
1,X-4(ZI)
GET AN ABSOLUTE ADDRESS FOR MVC.
AR
1,ZI
MVC DTEMP(8),0(1)
ALIGN TO DOUBLEWORD
LD
0,DTEMP
LA
1,X-4(ZR)
GET AN ABSOLUTE ADDRESS FOR MVC.
AR
1,ZR
MVC DTEMP(8),0(1)
CD
0,DTEMP
BCR 7,LKR
CR
ZI,ZR
BCR 15,LKR
CMPDF
LA
1,X-4(ZR)
GET AN ABSOLUTE ADDRESS FOR MVC.
AR
1,ZR
MVC DTEMP(8),0(1)
LD
0,DTEMP
LA
1,X-4(ZI)
GET AN ABSOLUTE ADDRESS FOR MVC.
AR
1,ZI
MVC DTEMP(8),0(1)
A0707
CD
0,DTEMP
BCR 7,LKR
CR
ZI,ZR
BCR 15,LKR
CMPAB
BC
3,BITTY4
BRANCH IF THERE IS A CARRY.
CMPDB
BC
12,BITTY4
BRANCH IF THERE WAS NO CARRY.
BC
12,BITTY4
BRANCH IF THERE WAS NO CARRY.
BC
3,BITTY4
BRANCH IF THERE IS A CARRY.
***********************************************************************
* THIS PART OF THE PROGRAM SORTS A VECTOR OF TYPE ONE, A BIT ARRAY. ***
* THE REGISTER USAGE IS AS FOLLOWS.....
***
* XZI -- REGISTER R0 .. WORKING REGISTER FOR THE NEXT 32 BITS OF X. ***
* R1 .. A COUNTER FROM 32 DOWN TO ZERO, FOR REFILLING R0.
***
* R .. THIS REGISTER CONTAINS A ONE.
***
* I .. LIMIT FOR BXLE, = IORIGIN + #ELEMENTS -1.
***
* ZR .. INDEX OF NEXT RESULT WORD.
***
* ZI .. INDEX OF CURRENT INPUT WORD.
***
* ZERO .. CONTRARY TO ITS LABEL, THIS CONTAINS A FOUR FOR THIS PART.***
* DECIDE .. CURRENT INPUT INDEX. (STARTS AT IORIGIN).
***
* COMPARE .. THE ADDRESS OF THE BC FOR COMPARING CORRECTLY.
***
***********************************************************************
BITTYS LR
ZERO,R
HERE I PUT A FOUR IN ZERO.
BITTY
L
I,MRHO-M(XBASE)
GET THE NUMBER OF ELEMENTS IN X.
BCTR I,0
SUBTRACT ONE.
L
DECIDE,IORIGIN
THE INDEX ORIGIN.
AR
I,DECIDE
CAUSE I TO BE CORRECT INITIALLY.
TAG1

30100000
30530000
30960000
31390000
31820000
32250000
32680000
33110000
33540000
33970000
34400000
34830000
35260000
35690000
36120000
36550000
36980000
37410000
37840000
38270000
38700000
39130000
39560000
39990000
40420000
40850000
41280000
41710000
42140000
42570000
43000000
43430000
43860000
44290000
44720000
45150000
45580000
46010000
46440000
46870000
47300000
47730000
48160000
48590000
49020000
49450000
49880000
50310000
50740000
51170000
51600000
52030000
52460000
52890000
53320000
53750000
54180000
54610000
55040000
55470000

BITTY1

BITTY2
BITTY3
BITTY4

*
ASCEND

LA
LR
LR
BCT
SR
SR
QUEND
AR
AR
LA
L
AR
ALR
EX
ST
AR
BXLE
LA
CLI
BC
BC

DC
DC
DC
DESCEND DC
DC
DC
TAG3
ALR
TAG2
ST
BXLE
LA
SR
BAL
EXCNOT ST
LR
AL
SR
SR
QUEND
AR
AR
BXH
T0
EQU
T1
L
BXH
LA
T2
BXLE
T3
SRL
SLL
T3A
L
BXLE
BALR
BC
*
T3B
AL
T4
ST
LR
T5
SRL
SLL

R,1
ZI,ZERO
R1,R
R1,BITTY2
XBASE,MR
ZBASE,MR

NOW PUT A ONE IN R.

MAKE ZI A FOUR.
AVOID THE FIRST BCT.
BRANCH IF THE COUNT IS NOT OVER.
HERE I LET THE OTHER GUYS GET A
CHANCE TO DO SOMETHING.

XBASE,MR
ZBASE,MR
R1,32
XZI,X(ZI)
ZI,ZERO
XZI,XZI
0,0(COMPARE)
DECIDE,Z(ZR)
ZR,ZERO
DECIDE,R,BITTY1
COMPARE,8(COMPARE)
0(COMPARE),X'47'
8,BITTY
15,CLEAN

ADD BACK THE WORKSPACE BASE.

ADD BACK THE WORKSPACE BASE.
GET THE COUNT READY.
PUT THE 32 BITS IN THE REGISTER.
ADD FOUR TO ZI.
DOUBLE THE REGISTER AND TEST THE
OVERFLOW BIT TO SEE IF IT WAS A ZERO
OR A ONE. THEN STORE THE INDEX
WHEN APPROPRIATE AND EKE ZR.
KEEP GOING UNTIL X IS EXHAUSTED.
THIS IS A SNEAKY WAY TO REVERSE
THE COMPARISON FOR THE NEXT TIME
THROUGH THE LOOP AND AT THE SAME
TIME TEST FOR THE END OF THE DOUBLE
LOOP. X'47' IS THE OP CODE FOR BC.
BIT OPERANDS
INTEGER OPERANDS
FLOATING POINT NUMBERS
DESCENDING BITS
DESCENDING INTEGERS
DESCENDING FLOATING NUMBERS
3.25
4.50
5.50
SET ZI TO INITIAL VALUE.
2.75
3.25
SET UP DECIDE TO GO TO EXCNOT.
4.50
2.50

AL1(CMPAB-ORG)
AL1(CMPAI-ORG)
AL1(CMPAF-ORG)
AL1(CMPDB-ORG)
AL1(CMPDI-ORG)
AL1(CMPDF-ORG)
I,I
ZR,Z(ZR)
ZR,R,TAG2
ZI,4(I)
ZERO,ZERO
DECIDE,T0
ZI,Z(R)
ZI,ZR
ZI,X800
XBASE,MR
ZBASE,MR

RELATIVIZE NICELY
IN CASE OF QUANTUM END

XBASE,MR
ZBASE,MR
R,R,T3
*
ZR,Z(R)
ZR,ZERO,T2
R,2(R)
R,R,T1
R,3
R,2
ZR,Z(R)
ZR,ZERO,0(DECIDE)
LKR,COMPARE
COMPARE THE NUMBERS.
2,T5
EXCHANGE THE CONTENTS OF Z(I) AND Z(R). *
ZI,X800
ZI,Z(R)
ZI,ZR
R,3
R,2

5.50
4.50
5.50
2.75
5.50
5.50
5.00
4.50
5.00
3.50
.
4.50
2.50
5.50
5.00

55900000
56330000
56760000
57190000
57620000
58050000
58480000
58910000
59340000
59770000
60200000
60630000
61060000
61490000
61920000
62350000
62780000
63210000
63640000
64070000
64500000
64930000
65360000
65790000
66220000
66650000
67080000
67510000
67940000
68370000
68800000
69230000
69660000
70090000
70520000
70950000
71380000
71810000
72240000
72670000
73100000
73530000
73960000
74390000
74820000
75250000
75680000
76110000
76540000
76970000
77400000
77830000
78260000
78690000
79120000
79550000
79980000
80410000
80840000
81270000

BXH R,ZERO,T3A
5.50
SRL ZI,2
5.00
A
ZI,IORIGIN
BCTR ZI,0
ST
ZI,Z2(I)
4.50
LA
DECIDE,PORDER
2.75
SR
XBASE,MR
3.25
SR
ZBASE,MR
3.25
QUEND
AR
XBASE,MR
3.25
AR
ZBASE,MR
3.25
S
I,FOUR
4.00
T6
L
ZI,Z2(I)
4.50
N
ZI,KNOCK
5.75
LA
R,2
2.75
BXLE R,R,T0
5.50
SRL ZI,2
5.00
A
ZI,IORIGIN
BCTR ZI,0
ST
ZI,Z+4
4.00
*
END OF SORT, NOW FOR CLEAN UP AND EXIT.*
.
CLEAN
L
PR,FTEMP
RESTORE CALLER'S BASE REGISTER
L
LKR,DBLSAVE
NOW RETURN TO THE OTHER PROGRAM.
BCR 15,LKR
PORDER AL
ZR,X800
BALR LKR,COMPARE
COMPARE THE NUMBERS.
BC
4,T4
3.50
BC
15,T5
CNOP 0,4
FOUR
DC
XL4'00000004'
X800
DC
XL4'80000000'
KNOCK
DC
XL4'7FFFFFFF'
USED TO KNOCK OFF FIRST BIT.
LTORG
*
X1
DSECT
DC
XL12'000000000000000000000000'
X
DC
XL4'00000000'
Z1
DSECT
DC
XL12'000000000000000000000000'
Z
DC
XL4'00000000'
Z2
DC
XL4'00000000'
IN GENERAL, THIS IS USED FOR Z(I).
END
./ ADD
NAME=APLSINDX
INDX
TITLE 'INDEX SUBROUTINE, 09-19-67.'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&TAG
BASE &R,&N
&TAG
L
&R,&N.(LWX,MR)
BMW &R
MEND
MACRO
&TAG
BTAB0 &A,&B,&C,&D,&E,&F,&G,&H,&I,&J,&K,&L,&M,&N,&O,&P
CNOP 0,4
&TAG
DC
AL4(TYPERR)
TYPE ERROR.
DC
AL4(TYPERR)
TYPE ERROR.
DC
AL4(TYPERR)
TYPE ERROR.
DC
AL4(TYPERR)
TYPE ERROR.
DC
AL4(TYPERR)
TYPE ERROR.
DC
AL4(&A)
T5A

81700000
82130000
82560000
82990000
83420000
83850000
84280000
84710000
85140000
85570000
86000000
86430000
86860000
87290000
87720000
88150000
88580000
89010000
89440000
89870000
90300000
90730000
91160000
91590000
92020000
92450000
92880000
93310000
93740000
94170000
94600000
95030000
95460000
95890000
96320000
96750000
97180000
97610000
98040000
98470000
98900000
00060000
00120000
00180000
00240000
00300000
00360000
00420000
00480000
00540000
00600000
00660000
00720000
00780000
00840000
00900000
00960000
01020000
01080000

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
MEND
MACRO
&TAG
BTYP
&TAG
SR
IC
LR
IC
SLL
AR
SLL
L
BCR
MEND
MACRO
&L
BMW
&L
LTR
BC
L
BMW&SYSNDX N
MEND
MACRO
&TAG
CBC
&TAG
C
BC
MEND
MACRO
&TAG
CBTYP
&TAG
SR
IC
LR
IC
SLL
AR
IC
BC
CBT2&SYSNDX DC
DC
DC
DC
DC
DC
DC
DC
DC
DC

AL4(&B)
AL4(&C)
AL4(&D)
AL4(&E)
AL4(&F)
AL4(&G)
AL4(&H)
AL4(&I)
AL4(&J)
AL4(&K)
AL4(&L)
AL4(&M)
AL4(&N)
AL4(&O)
AL4(&P)
&ROWR,&COLR,&TABLE
R1,R1
R1,MTYPE(&COLR)
R0,R1
R0,MTYPE(&ROWR)
R0,2
R1,R0
R1,2
R1,&TABLE.(R1)
15,R1

ZERO OUT R1 FOR THE IC STEPS.

PICK UP COLUMN OF BRANCH MATRIX.
PREPARE TO GET THE ROW OF IT ALSO.
GET THE ROW OF THE BRANCH MATRIX.
MULTIPLY BY FOUR.
ADD TO THE COLUMN NUMBER.
MULTIPLY BY FOUR AGAIN.
LOAD THE BRANCH ADDRESS.
BRANCH TO THE RIGHT PLACE.

&GPR
&GPR,&GPR
2,BMW&SYSNDX
&GPR,MLIST(&GPR)
&GPR,STRIKE

SEE IF THIS IS A SMTB PTR.

BRANCH IF IT IS NOT.
LOAD THE ADDRESS OF THE M-ENTRY.
REMOVE THE 8 HIGH ORDER BITS.

&R,&F,&C,&TO
&R,&F.
&C,&TO.
&A,&B,&C,&D,&E,&F,&G,&H,&I,&J,&K,&L,&M,&N,&O,&P
R1,R1
R1,MTYPE(A)
R2,R1
R2,MTYPE(V)
R1,4
R1,R2
R1,CBT2&SYSNDX-5(R1)
15,CBT1&SYSNDX.(R1)
AL1(&A-CBT1&SYSNDX)
AL1(&B-CBT1&SYSNDX)
AL1(&C-CBT1&SYSNDX)
AL1(&D-CBT1&SYSNDX)
AL1(&E-CBT1&SYSNDX)
AL1(&F-CBT1&SYSNDX)
AL1(&G-CBT1&SYSNDX)
AL1(&H-CBT1&SYSNDX)
AL1(&I-CBT1&SYSNDX)
AL1(&J-CBT1&SYSNDX)

01140000
01200000
01260000
01320000
01380000
01440000
01500000
01560000
01620000
01680000
01740000
01800000
01860000
01920000
01980000
02040000
02100000
02160000
02220000
02280000
02340000
02400000
02460000
02520000
02580000
02640000
02700000
02760000
02820000
02880000
02940000
03000000
03120000
03180000
03240000
03300000
03360000
03420000
03480000
03540000
03600000
03660000
03720000
03780000
03840000
03900000
03960000
04020000
04080000
04140000
04200000
04260000
04320000
04380000
04440000
04500000
04560000
04620000
04680000
04740000

DC
AL1(&K-CBT1&SYSNDX)
DC
AL1(&L-CBT1&SYSNDX)
DC
AL1(&M-CBT1&SYSNDX)
DC
AL1(&N-CBT1&SYSNDX)
DC
AL1(&O-CBT1&SYSNDX)
DC
AL1(&P-CBT1&SYSNDX)
CBT1&SYSNDX EQU *
MEND
MACRO
&TAG
CRBC &R1,&R2,&C,&TO
&TAG
CR
&R1,&R2
BC
&C,&TO.
MEND
MACRO
&TAG
LODBC &R,&F,&C,&TO
&TAG
L
&R,&F.
LTR &R,&R
BC
&C,&TO.
MEND
MACRO
&TAG
LOOK &A,&B,&C
&TAG
DC
0C' '
MEND
MACRO
&TAG
LTRBC &R,&C,&TO
&TAG
LTR &R,&R
BC
&C,&TO.
MEND
MACRO
&TAG
LWTG
&TAG
BAL R2,LWMGLTR
DO THE LTR ON THIS ONE.
MEND
MACRO
&TAG
LWCG
&TAG
BAL R2,LWMGBCR
START WITH THE BCR.
MEND
MACRO
&TAG
LWUG
&TAG
BAL R2,LWMGN
START WITH THE AND OF STRIKE.
MEND
MACRO
&LABEL LWMOV &TO,&FROM,&COUNT,&WORKRG
*LABEL LWMOV &TO,&FROM,&COUNT,&WORKRG ALL OPERANDS ARE REGISTERS.
&LABEL LR
&WORKRG,R1
GOTTA SAVE R1.
AH
&COUNT,LW2&SYSNDX ADD A NEGATIVE 257 TO THE COUNT.
BC
4,LW4&SYSNDX
IF IT IS MINUS NOW THERE IS 1 MVC.
LA
R0,256
NOW WE CAN GO FOR THE BIG LOOP.
LA
R1,0(&TO,&COUNT)
GET THE LIMIT FOR THE GOODOLE BXLE.
LW1&SYSNDX MVC 0(256,&TO),0(&FROM) MOVE 256 BITES.
AR
&FROM,R0
EKE THE SOURCE BY HEX 100.
BXLE &TO,R0,LW1&SYSNDX TESTING FOR THE END OF THE LOOP.
BC
15,LW4&SYSNDX
LOOP IS ALL DONE NOW, GO TO LAST MVC
LW2&SYSNDX DC XL2'FEFF'
THIS IS A NEGATIVE 257.
LW3&SYSNDX MVC 0(0,&TO),0(&FROM) THIS IS THE LAST MVC.
LW4&SYSNDX EX &COUNT,LW3&SYSNDX EXECUTE THE MVC FOR LAST FRACTION.
LR
R1,&WORKRG
RESTORE R1.
MEND
MACRO
&TAG
LWXR &BAZMRL,&WORKREG
*
GET X/RHO(ARRAY) IN R1.
*

04800000
04860000
04920000
04980000
05040000
05100000
05160000
05220000
05280000
05340000
05400000
05460000
05520000
05580000
05640000
05700000
05760000
05820000
05880000
05940000
06000000
06060000
06120000
06180000
06240000
06300000
06360000
06420000
06480000
06540000
06600000
06660000
06720000
06780000
06840000
06900000
06960000
07020000
07080000
07140000
07200000
07260000
07320000
07380000
07440000
07500000
07560000
07620000
07680000
07740000
07800000
07860000
07920000
07980000
08040000
08100000
08160000
08220000
08280000
08340000

&TAG

LH
&WORKREG,MRANK(&BAZMRL)
AR
&WORKREG,&BAZMRL
LA
R1,1
LWXR&SYSNDX M R0,FIDLDL(&WORKREG,MR)
S
&WORKREG,INDFOUR
CR
&BAZMRL,&WORKREG
BC
4,LWXR&SYSNDX
MEND
MACRO
&TAG
ZERO1 &R,&F
&TAG
SR
&R,&R
ST
&R,&F.
MEND
MACRO
&TAG
ZERO2 &R,&F1,&F2
&TAG
SR
&R,&R
ST
&R,&F1.
ST
&R,&F2.
MEND
MACRO
&TAG
ZERO3 &R,&F1,&F2,&F3
&TAG
SR
&R,&R
ST
&R,&F1.
ST
&R,&F2.
ST
&R,&F3
MEND
MACRO
&TAG
ZERO4 &R,&F1,&F2,&F3,&F4
&TAG
SR
&R,&R
ST
&R,&F1.
ST
&R,&F2.
ST
&R,&F3.
ST
&R,&F4.
MEND
PRINT OFF
COPY APLDEFN
INDEX
CSECT
COPY APLDEFN
TITLE 'INDEX SUBROUTINE 09-19-67'
PRINT ON,GEN
EXTRN ERROR
EXTRN FETCH
EXTRN FETCHINT
EXTRN GETSPACE
EXTRN MKGARB
EXTRN STORE
INDEX
CSECT
PROLOG INDEXDMY,LWDSECT
ORGY
EQU *-6
THIS IS THE BASE ADDRESS.
***********************************************************************
*
TABLE OF USES OF VARIOUS SYMBOLS.
*
***********************************************************************
* SYMBOL
CONTENTS OR USE
*
*---------------------------------------------------------------------*
* SUM
CURRENT RELATIVE ADDRESS OF ELEMENT IN ARRAY BEING INDEXED. *
* IORIGIN
THE INDEX ORIGIN IN USE IN THE SYSTEM.
*
***********************************************************************
R0
EQU 0
R1
EQU 1
R2
EQU 2
R3
EQU 3

08400000
08460000
08520000
08580000
08640000
08700000
08760000
08820000
08880000
08940000
09000000
09060000
09120000
09180000
09240000
09300000
09360000
09420000
09480000
09540000
09600000
09660000
09720000
09780000
09840000
09900000
09960000
10020000
10080000
10140000
10200000
10260000
10320000
10380000
10500000
10560000
10620000
10680000
10740000
10800000
10860000
10920000
10980000
11040000
11100000
11160000
11220000
11280000
11340000
11400000
11460000
11520000
11580000
11640000
11700000
11760000
11820000
11880000
11940000
12000000

R4
R5
R6
R7
R8
R9
R10
LWX
SVIA
SVIA1
SVIA2
SVIA3
SVIA4
SVIX
SVIX1
SVIX2
SVIX3
SVIX4
SVIV
SVIV1
SVIV2
SVIV3
EI3
VK
VCMPS0
VCMPS1
JK
JI
WK
SUM
ONEREG
I
A
V
LOOPRG
SON

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
MVI
L
LTR
BC
MVI
L
C
BC
* VALUE IS THE
L
L
LR
ICALL
L
O
ST
L
BAL
LA
ST
INDXA
EQU
QUEND
LOOK
L

4
5
6
7
8
9
10
15
4
SVIA+4
SVIA+8
SVIA+12
SVIA+16
8
SVIX+4
SVIX+8
SVIX+12
SVIX+16
12
SVIV+4
SVIV+8
SVIV+12
R1
R2
R2
R3
R5
R6
R6
R7
R8
R8
R9
R10
15
X'FF'
S,0
LWX,SVI
R1,R1
7,INDXA
S,X'FF'
A,4(LWX,MR)
A,12(LWX,MR)
7,INDXA
SAME AS A, COPY A TO AN UNNAMED ARRAY FOR VALUE. *
A,M(A)
R1,4(A,MR)
R2,R1
GETSPACE
LWX,SVI
R1,FOURCON
FLAG THIS AS A TEMPORARY RESULT.
R1,12(LWX,MR)
R4,4(LWX,MR)
R6,LWMOVES
R4,12(LWX)
R4,0(R1,MR)
*
IF ANYBODY WANTS IT, NOW IS THE TIME TO GET IT.
'INDXA, STACK.',4(LWX),15(LWX)
A,4(LWX,MR)
BASE A AND SEE IF IT IS

12060000
12120000
12180000
12240000
12300000
12360000
12420000
12480000
12540000
12600000
12660000
12720000
12780000
12840000
12900000
12960000
13020000
13080000
13140000
13200000
13260000
13320000
13380000
13440000
13500000
13560000
13620000
13680000
13740000
13800000
13860000
13920000
13980000
14040000
14100000
14160000
14220000
14280000
14340000
14400000
14460000
14520000
14580000
14640000
14700000
14820000
14940000
15000000
15060000
15120000
15180000
15240000
15360000
15420000
15480000
15540000
15600000
15660000
15720000
15780000

INDXB

*
*
*
*
*
*
*
*
*
*
*
*
*

VALID1

VALID2
VALID3

VALID4

LTR
BC
L
LTR
BC
DS
LOOK
L
LOOK
LH
LA
LH
SLL
CR
BC
C
BNL
SPACE

A,A
2,INDXB
A,M(A)
A,A
8,VALUERR
0H
'A',M(A),M+63(A)
I,8(LWX,MR)
'I',M(I),M+63(I)
R6,MRANK(A)
R4,4
R5,MRANK(I)
R5,2
R6,R5
7,RNKERR
R6,=A(VK1)
NONCERR
2

AN UNDEFINED SYMBOL.
XX
XX
XX
XX

I CANNOT CURRENTLY BE NAMED.

A228J
SET R6 TO RHO RHO A TIMES 4.
IN GENERAL, R4 ALWAYS CONTAINS A 4.
NOW LET'S SEE HOW MANY LIST ELEMENTS
WE HAVE. IT SHOULD BE THE SAME AS
THE NUMBER OF DIMENSIONS OF A.
RANK ERROR.
MORE THAN 15 DIMENSIONS
IS NONCE ERROR -- NOT ENOUGH STACK.
6002
6002
VALIDITY-CHECK THE ARRAY BEING SUBSCRIPTED.
6002
THE FOLLOWING TESTS ARE MADE:
6002
1. DOES THE LENGTH OF THE M-ENTRY, AS INDICATED 6002
BY MCOUNT, AGREE WITH THE PRODUCT OF THE
6002
ARRAY'S DIMENSIONS AND ITS DATA TYPE.
6002
2. IS THE MCOUNT FIELD SUCH THAT THE END OF THE 6002
M-ENTRY WOULD BE BEYOND MX.
6002
3. DOES AN OVERFLOW OCCUR INTO THE HIGH ORDER
6002
REGISTER WHILE TAKING THE PRODUCT OF THE
6002
ARRAY'S DIMENSIONS.
6002
VIOLATORS ARE GIVEN A DOMAIN ERROR.
6002
6002
MVI OFLOWSW,X'00'
INITIALIZE OVERFLOW SWITCH
6002
LR
VCMPS0,R6
4 TIMES RANK OF A
6002
LA
VCMPS1,0(A,MR)
ABSOLUTIZE A
6002
TM
0(VCMPS1),MLSTBIT CANNOT INDEX A LIST
6002
BO
SYNTERR
6002
SR
R1,R1
6002
IC
R1,MTYPE(A)
GET BITS PER ELEMENT,
6002
IC
R1,RIGHTBYT-1(R1)
BASED ON MTYPE
6002
M
R0,MRHO-M-4(VCMPS0,VCMPS1) TIMES / RHO A
6002
LTR R0,R0
6002
BNZ VALID2
6002
LTR R1,R1
6002
BNM VALID3
6002
MVI OFLOWSW,X'FF'
MULTIPLY HAS OVERFLOWED --FLAG 6002
L
R1,STRIKE
ASSURE A NON-ZERO MULTIPLICAND 6002
SR
VCMPS0,R4
DECREMENT MRHO INDEX
6002
BP
VALID1
FALL THRU AT END OF MRHO
6002
CLI OFLOWSW,X'FF'
HAS OVERFLOW BEEN FLAGGED
6002
BNE VALID4
NO.
6002
OR
R0,R1
YES. DOMAIN ERROR IF PRODUCT 6002
BNZ TYPERR
NOT 0.
6002
A
R1,=F'31'
ROUNDUP TO WORD BOUNDARY
6002
SRL R1,5
CONVERT BITS TO WORDS
6002
SLL R1,2
CONVERT WORDS TO BYTES
6002
AR
R1,R6
ADD LENGTH OF RANK VECTOR
6002
LA
VCMPS0,MRHO-M
6002
AR
R1,VCMPS0
ADD LENGTH OF STANDARD INFO
6002
C
R1,MCOUNT(A)
VALIDATE AGAINST M-ENTRY LGTH 6002
BNE TYPERR
6002

15840000
15900000
16020000
16080000
16140000
16200000
16260000
16320000
16440000
16500000
16560000
16620000
16680000
16740000
16800000
16860000
16920000
16980000
17040000
17100000
17160000
17220000
17280000
17340000
17400000
17460000
17520000
17580000
17640000
17700000
17760000
17820000
17880000
17940000
18000000
18060000
18120000
18180000
18240000
18300000
18360000
18420000
18480000
18540000
18600000
18660000
18720000
18780000
18840000
18900000
18960000
19020000
19080000
19140000
19200000
19260000
19320000
19380000
19440000
19500000

INDX1A
IND2

INDX2

*
*
*
*

*
*
*
*
*
*
*
*

LA
CL
BH
SPACE
TM
BC
CR
BC
EQU
EQU
ST
ST
LA
ST
LA
ST
SR

R1,0(R1,A)
R1,MX
TYPERR
2
S,SON
7,INDX1A
R4,R6
8,AISVEC
*
*
A,AS
I,IS
R0,WK1
R0,WKS
R0,VK1
R0,VKS
SUM,SUM

DOES M-ENTRY END UP BEYOND MX

YES

6002
6002
6002
6002

SEE IF A IS A VECTOR, AND IF SO

TREAT THAT AS A SPECIAL CASE.

SAVE THIS ADDRESS FOR LATER.

AND THIS ONE.
SET UP WKS FOR THE FIRST TIME.
XX
SIMILARLY, SET UP VKS
XX
THIS REGISTER IS MAINTAINED ALL
THE WAY THROUGH TO THE END.
ST
SUM,SCRAM
ZERO OUT THE CHECK SUM.
LA
R1,1
SET UP A FEW OTHER THINGS NOW.
ST
R1,ACMPS
XX
ST
R1,VCMPS
XX
AR
A,R5
GET SET FOR THE BIG LOOP.
AR
I,R5
A IS USED FOR LOOP CONTROL.
EQU *
HERE IT IS, THE BIG LOOP.
LOOK 'INDX2, DSECT.',FUG1,FUG2
SR
A,R4
SR
I,R4
IN THIS SECTION I CALCULATE THINGS
IN THE MATRIX E FOR USE IN THE REAL
INDEXING LOOP. ALSO I FIGURE OUT
HOW MUCH SPACE TO ALLOCATE FOR V.
L
JK,MRHO(I)
JK CARRIES THE M-RELATIVE ADDRESS
LTR JK,JK
OF THE M-ENTRY THAT CORRESPONDS TO
BC
2,INDX3A
THE CURRENT LIST ENTRY, M(I).
BC
4,INDX3
BRANCH IF IT IS NAMED.
HERE THE LIST ELEMENT WAS EMPTY, SO
L
VCMPS1,MRHO(A)
USE THE MATCHING COMPONENT OF RHO A
L
VK,VKS
VK IS THE CURRENT SUBSCRIPT FOR F,
ST
VCMPS1,F(VK)
WHICH IS USED TO COLLECT THE RANK
VECTOR FOR THE RESULT, V, SO THAT I
WONT HAVE TO GO THROUGH THIS BIG
LOOP MORE THAN ONCE.
SR
VK,R4
THIS LOOP IS A RIGHT TO LEFT SCAN.
ST
VK,VKS
VKS IS USED TO HOLD VK WHEN THERE
IS NO REGISTER AVAILABLE FOR IT.
C
VCMPS1,ONE
IF THE NUMBER OF COMPONENTS IN ANY
BC
8,INDX7
GIVEN SUBSCRIPT POSITION IS ONE,
THEN I DONT MAKE ANY ENTRIES IN THE
MATRIX E FOR IT. INSTEAD, I PROCESS
THAT SUBSCRIPT DIRECTLY, AND FIX
SUM TO REFLECT THIS CASE.
L
WK,SCRAM
SCRAMBLE.
ALR WK,WK
XX
XR
WK,VCMPS1
XX
ST
WK,SCRAM
XX
L
WK,WKS
WK IS THE INDEX FOR THE CURRENT
ST
JK,E(WK)
ROW IN E. JK IS NOW A ZERO.
ST
JK,E+8(WK)
MAKE THESE TWO COLUMNS ZERO.
BC
15,INDX5
THEN GO TO FILL IN THE REST OF THIS

19560000
19620000
19680000
19740000
19800000
19860000
19920000
19980000
20040000
20100000
20160000
20220000
20280000
20340000
20400000
20460000
20520000
20580000
20640000
20700000
20760000
20820000
20880000
20940000
21000000
21060000
21120000
21180000
21240000
21300000
21360000
21420000
21480000
21540000
21600000
21660000
21720000
21780000
21840000
21900000
21960000
22020000
22080000
22140000
22200000
22260000
22320000
22380000
22440000
22500000
22560000
22620000
22680000
22740000
22800000
22860000
22920000
22980000
23040000
23100000

*
INDX3

ROW IN E.
LWX,SVI
JK,4(LWX,MR)
SEE IF A IS AN INDEX.
JK,M(JK)
JK IS A BASE FOR A NAMED ARRAY. 3561
7,INDX3C
S,SON
INDX3C
BRANCH IF SUBSCRIPTED FETCH
3561
NONCERR
ERROR IF SUBSCRIPED STORE
3561
INDX3A
0H
'I ELEMENT',M(I),M+63(I)
VCMPS1,0(JK,MR)
USING A LIST AS AN ELEMENT OF 3561
0(VCMPS1),MLSTBIT
AN INDEX LIST IS INVALID.
3561
SYNTERR
3561
INDX3C
*
3561
JI,MRANK(JK)
FROM HERE TO INDX4 IS SETUP FOR THE
VCMPS1,1
INDX4 LOOP, WHICH GOES ALONG
JI,JI
COLLECTING THE COMPONENTS OF THE
8,INDX6
RANK VECTOR OF THIS SUBSCRIPT ARRAY
R1,I
THE TWO STORES INTO E(WK) AND
R1,IS
E+8(WK) ARE USED IN THE LOOP AT
R2,WKS
INDX8, WHICH FILLS IN MORE OF E.
R1,E(R2)
THIS IS REALLY E(WK).
JI,E+8(R2)
AND THIS IS REALLY E+8(WK).
JI,JK
JI IS THE LOOP CONTROL FOR INDX4.
R4,R4
I NEED A NEGATIVE FOUR TO USE BXH.
R1,VKS
R1 HOLDS VK IN THIS LOOP.
R0,SCRAM
SCRAMBLE.
INDX4
VCMPS0,MRHO-4(JI) CURRENT ELEMENT OF THE RANK VECTOR.
R1,R1
CHECK FOR OVERFLOW OF F
3069
NONCERR
BRANCH IF TABLE OVERFLOW
3069
VCMPS0,VCMPS0
3069
INDXERR
BRANCH IF NEGATIVE DIMENSION
3069
VCMPS0,F(R1)
OF THE CURRENT LIST ELEMENT.
R1,R4
SUBTRACT FOUR.
VCMPS0,ONE
8,INDX4BXH
R0,R0
DO A NOT EQUAL REDUCTION.
R0,VCMPS0
XX
VCMPS0,VCMPS0
MULTIPLY VCMPS1 BY THE CURRENT
*
ELEMENT OF THE RANK VECTOR OF THE
*
CURRENT LIST ELEMENT ARRAY.
BXLE VCMPS0,VCMPS1,INDX4BXH FALL THRU ON POS VCMPS0
3069
L
VCMPS1,STRIKE
OVFLOW - SET TO CAUSE WS FULL 3069
INDX4BXH BXH JI,R4,INDX4
JK IS THE COMPARAND FOR TERMINATION.
***********
END OF THE INDX4 LOOP. ***********
ST
R0,SCRAM
ST
R1,VKS
NOW PUT VK BACK IN ITS HOME.
LA
R4,4
GET BACK A PLUS FOUR IN R4.
C
VCMPS1,ONE
HERE I CHECK FOR A SUBSCRIPT ARRAY
BC
8,INDX6
HAVING ONLY ONE COMPONENT, AND IF IT
*
DOES I ADJUST SUM AND DO NOT PASS
*
THE CURRENT ROW OF E.
INDX5
L
WK,WKS
BUT, IF IT WAS NOT ONE, THEN I FILL
ST
VCMPS1,E+12(WK)
IN SOME THINGS IN THIS ROW.
ST
VCMPS1,E+16(WK)
XX
L
R1,MRHO(A)
XX
ST
R1,E+20(WK)
XX
L
R1,ACMPS
XX
ST
R1,E+4(WK)
XX
S
WK,TWENTY8
GO TO THE PREVIOUS ROW IN E.
L
C
L
BC
TM
BZ
B
DS
LOOK
LA
TM
BO
EQU
LH
LA
LTR
BC
LR
S
L
ST
ST
AR
LCR
L
L
L
LTR
BM
LTR
BM
ST
AR
C
BC
ALR
XR
MR

23160000
23220000
23280000
23400000
23460000
23520000
23580000
23640000
23700000
23760000
23820000
23880000
23940000
24000000
24060000
24120000
24180000
24240000
24300000
24360000
24420000
24480000
24540000
24600000
24660000
24720000
24780000
24840000
24900000
24960000
25020000
25080000
25140000
25200000
25260000
25320000
25380000
25440000
25500000
25560000
25620000
25680000
25740000
25800000
25860000
25920000
25980000
26040000
26100000
26160000
26220000
26280000
26340000
26400000
26460000
26520000
26580000
26640000
26700000
26760000

ST
WK,WKS
XX
M
VCMPS0,VCMPS
THIS IS COLLECTING X/RHO V.
BXLE VCMPS0,VCMPS1,*+8 FALL THRU ON POS VCMPS0
3069
L
VCMPS1,STRIKE
OVFLOW - SET TO CAUSE WS FULL 3069
ST
VCMPS1,VCMPS
XX
BC
15,INDX7A
AND GO TO TEST FOR END OF BIG LOOP.
**********************************************************************
* IN THIS SECTION, I HAVE FOUND THAT THE CURRENT SUBSCRIPT ARRAY ONLY *
* HAS ONE ELEMENT. SO I AVOID USING A ROW IN E FOR THIS SUBSCRIPT
*
* POSITION BY TAKING THAT ELEMENT, SUBTRACTING THE INDEX ORIGIN FROM *
* IT, AND MULTIPLYING BY THE WEIGHTING FACTOR FOR THE SUBSCRIPT
*
* POSITION. I THEN ADD THE RESULT TO SUM, WHICH WILL CONTAIN THE
*
* CURRENT VECTOR SUBSCRIPT OF THE LINEARIZED ARRAY A IN THE REAL
*
* INDEXING LOOP.
*
**********************************************************************
INDX6FG DC
AL1(INDX6B-INDX6A) THESE OFFSETS ARE FOR BRANCHING
DC
AL1(INDX6A-INDX6A) ON THE TYPE OF THIS ONE-COMPONENT
DC
AL1(INDX6C-INDX6A) ARRAY.
DC
AL1(INDX6E-INDX6A) XX
DC
AL1(INDX6D-INDX6A) XX
CNOP 0,4
INDX6
LR
R1,R4
THIS IS TO INSURE THAT THE LEFT 24
IC
R1,MTYPE(JK)
BITS ARE ZERO.
AH
JK,MRANK(JK)
GO FOR THE ADDRESS OF ELEMENT 0.
IC
R1,INDX6FG(R1)
GET THE REATIVE OFFSET FOR DECODING
LA
R3,INDX6F
THE TYPE, AND THE CONTINUATION ADDR
BC
15,INDX6A(R1)
DECODE.
INDX6A AR
JK,MR
THIS IS TYPE 1, BIT ARRAY.
TM
12(JK),X'80'
IF IT IS A ZERO, LEAVE A ZERO IN R1
BCR 8,R3
LA
R1,1
IF IT WAS A ONE, PUT A ONE IN R1.
BCR 15,R3
INDX6B BC
15,TYPERR
THIS IS A TYPE ERROR, TYPE ZERO.
INDX6C L
R1,MRHO(JK)
TYPE 2, INTEGER ARRAY.
BCR 15,R3
EXIT.
INDX6D BC
15,TYPERR
THIS IS TYPE 4, A TYPE ERROR.
INDX6E SR
R2,R2
TYPE 3, A FLOATING POINT ARRAY.
LA
R4,MRHO-M(JK)
USE THE FETCH PROGRAM FOR THIS ONE.
LA
R3,10
XX
ICALL FETCH
XX
LA
R4,4
PUT THAT 4 BACK.
LR
R1,R0
RESULT GOES IN R1, LIKE THE OTHERS.
INDX6F EQU *
RESULT IS IN R1 NOW.
S
R1,IORIGIN
SUBTRACT THE INDEX ORIGIN.
CL
R1,MRHO(A)
TEST TO SEE IF IT IS IN RANGE.
BC
10,INDXERR
IF NOT, IT IS AN INDEXX ERROR.
M
R0,ACMPS
ALL RIGHT, NOW MULTIPLY BY THE
AR
SUM,R1
WEIGHTING FACTOR AND EKE SUM.
********** TEST FOR THE END OF THE SETUP LOOP. *******
INDX7
L
R1,ACMPS
GET THE WEIGHTING FACTOR FOR THE
INDX7A M
R0,MRHO(A)
NEXT TIME AROUND THE LOOP, IF THERE
ST
R1,ACMPS
IS ONE.
C
A,AS
OF RHO A, AND TEST FOR THE END OF
BC
2,INDX2
THE HOUSEKEEPING LOOP.
L
WK,WKS
GIVE WKLIM ITS VALUE.
ST
WK,WKLIM
XX
TM
S,SON
BC
7,RTEST
SR
R2,R2
FIGURE OUT EXACTLY HOW MUCH SPACE
LR
R1,R2
IS NEEDED FOR V.

26820000
26880000
26940000
27000000
27060000
27120000
27180000
27240000
27300000
27360000
27420000
27480000
27540000
27600000
27660000
27720000
27780000
27840000
27900000
27960000
28020000
28080000
28140000
28200000
28260000
28320000
28380000
28440000
28500000
28560000
28620000
28680000
28740000
28800000
28860000
28920000
28980000
29040000
29100000
29160000
29220000
29280000
29340000
29400000
29460000
29520000
29580000
29640000
29700000
29760000
29820000
29880000
29940000
30000000
30060000
30120000
30180000
30240000
30300000
30360000

IC
R1,MTYPE(A)
THEN GET THAT AMOUNT OF SPACE.
IC
R1,RIGHTBYT-1(R1) XX
M
R0,VCMPS
XX
BXH R0,R1,WSFULL
BRANCH IF R0 POSITIVE
3069
A
R1,SEVEN
ROUND TO THE NEXT BYTE.
3069
SRL R1,3
XX
CL
R1,STRIKE
CHECK FOR TOO-LARGE COUNT
3069
BNL WSFULL
XX
3069
LA
R1,12+FEND-F(R1)
ADD IN SPACE FOR THE RANK VECTOR.
S
R1,VKS
XX
ICALL GETSPACE
NOW GET THE SPACE
QUEND
***** NOW FILL IN THE TYPE, RHO RHO V, AND RHO V OF THE NEW V. ********
INDX8
L
LWX,SVI
* PERMUTE THE STACK TO OBTAIN
* V AT SVI+12 INSTEAD OF I,
* I AT SVI+8 INSTEAD OF A,
* A AT SVI+4 INSTEAD OF V.
LA
R4,0(LWX,MR)
GET AN ABSOLUTE ADDRESS.
LM
R1,R3,4(R4)
LOAD V,A, AND I IN R1,R2, AND R3.
ST
R1,12(R4)
STORE V IN ITS NEW PLACE.
STM R2,R3,4(R4)
STORE A AND I IN THEIR PLACES.
L
R0,M(R3)
XX
S
R0,FOUR
XX
ST
R0,M(R3)
XX
L
R0,M(R1)
XX
A
R0,EIGHT
XX
ST
R0,M(R1)
XX
LTR R2,R2
CHANGE THE A STACK POINTER ONLY IF
BC
4,INDX8A
IT IS AN UNNAMED ARRAY.
L
R0,M(R2)
XX
S
R0,FOUR
XX
ST
R0,M(R2)
INDX8A EQU *
BAL R1,BASES
BASE I, A, AND V.
LA
R0,1
GET A ONE IN R0.
LR
R1,R0
MAKE SURE THE LEFT 24 BITS ARE ZERO.
IC
R1,MTYPE(A)
ALR R1,R1
GET THE ENTRY FOR THE DOWN SECTION.
LH
R2,DOWNBTAB-2(R1) XX
AR
R2,12
XX
ST
R2,DOWNADR
XX
SLL R1,23
LEFT JUSTIFY THE TYPE.
LA
R3,FEND-F
S
R3,VKS
R3 NOW HAS 4 X RHO RHO V.
AR
R1,R3
ST
R1,MTYPE(V)
SR
R3,R0
SUBTRACT A ONE.
BC
4,INDX8B
LA
R1,12(V,MR)
L
R4,VKS
LA
R4,4+F(R4)
EX
R3,INDX8MVC
INDX8B EQU *
LA
V,13(V,R3)
COMMON EQU *
LOOK 'COMMON, DSECT.',FUG1,FUG2
LA
DOWNY,INDXFIN
THIS IS IN CASE OF EMPTY OR SCALARS.
L
R0,VCMPS
IF THE SUBSCRIPT FOR A IS AN EMPTY
LTR R0,R0
ARRAY, FINISH QUICK.

30420000
30480000
30540000
30600000
30660000
30720000
30780000
30840000
30900000
30960000
31020000
31080000
31140000
31200000
31260000
31320000
31380000
31440000
31500000
31560000
31620000
31680000
31800000
31860000
31920000
32040000
32100000
32160000
32220000
32280000
32400000
32460000
32520000
32580000
32640000
32700000
32760000
32820000
32880000
32940000
33000000
33060000
33120000
33180000
33240000
33300000
33360000
33420000
33480000
33540000
33600000
33660000
33720000
33780000
33840000
33900000
33960000
34020000
34080000
34140000

BCR
LA
C
BC
AH
LA
LA
ST
L
LA
BCR
INDX7K L
LTR
BC
L
AR
L
BMW
SR
IC
AR
LH
AR
ST
LA
ST
SR
ST
BC
INDX7L LA
ST
INDX7M S
C
BC
AH
LA
LA
MVI
LA
L
LA
LA
ST
BC
INDX8MVC MVC
RTEST
L
BASE
LA
LH
AR
LA
LR
SR
CR
BC
RTEST1 L
CR
BC
ALR
XR

8,DOWNY
WK,WK1
WK,WKLIM
7,INDX7K
A,MRANK(A)
A,12(A)
R5,8
DOWNY,DOWNYSV
LOOPRG,DOWNADR
ONEREG,1
15,LOOPRG
R2,E+8(WK)
R2,R2
8,INDX7L
R3,E(WK)
R3,I
R3,MRHO(R3)
R3
R4,R4
R4,MTYPE(R3)
R4,R4
R4,FTCHBTAB-2(R4)
R4,12
R4,E+24(WK)
R3,12(R3,R2)
R3,E+8(WK)
R0,R0
R0,E(WK)
15,INDX7M
R1,NOW1
R1,E+24(WK)
WK,TWENTY8
WK,WKLIM
2,INDX7K
A,MRANK(A)
A,12(A)
R5,8
SWICH,X'00'
WK,WK1
LOOPRG,DOWNADR
ONEREG,1
DOWNY,BEGIN
DOWNY,DOWNYSV
15,BEGIN
0(1,R1),0(R4)
LWX,SVI
V,12
R4,4
JI,MRANK(V)
JI,V
R3,1
R1,R3
R2,R2
JI,V
8,RTEST3
R0,MRHO-4(JI)
R0,R3
8,RTEST2
R2,R2
R2,R0

XX
SEE IF THE MATRIX E HAS
ANYTHING IN IT.
GO IF IT DOES.

GET THE ADDRESS OF THE SUBSCRIPT.

MAKE IT AN ABSOLUTE ADDRESS.

GET ADDRESS OF ELEMENT ZERO.

34200000
34260000
34320000
34380000
34440000
34500000
34560000
34620000
34680000
34740000
34800000
34860000
34920000
34980000
35040000
35100000
35160000
35220000
35280000
35340000
35400000
35460000
35520000
35580000
35640000
35700000
35760000
35820000
35880000
35940000
36000000
36060000
36120000
36180000
36240000
36300000
36360000
36420000
36480000
36540000
36600000
36660000
36720000
36780000
36840000
36900000
36960000
37020000
37080000
37140000
37200000
37260000
37320000
37380000
37440000
37500000
37560000
37620000
37680000
37740000

RTEST2

RTEST3

RTEST4

RTEST5
OKAY

* FETCH

OKAY1

OKAY2

MR
R0,R0
BXLE R0,R1,RTEST2
FALL THRU IF R0 POS
L
R1,STRIKE
OVFLOW - SET R1 TO CAUSE WSFULL
SR
JI,R4
CR
JI,V
BC
2,RTEST1
CL
R1,STRIKE
CHECK FOR X/RHO V TOO LARGE
BNL WSFULL
BRANCH IF TOO LARGE
ST
R1,VCMPS2
CR
R1,R3
BC
8,RTEST4
C
R1,VCMPS
BC
7,LNGERR
C
R2,SCRAM
BC
7,RNKERR
EQU *
LA
R1,0(V,MR)
TM
8(R1),X'02'
BC
8,OKAY
LA
R2,0(A,MR)
CLI 8(R2),X'02'
BC
2,OKAY
BC
7,CHK13
CLI 8(R1),X'03'
BC
8,CHK23
EQU *
QUEND
SR
R1,R1
IC
R1,MTYPE(A)
LR
R2,R1
IC
R2,MTYPE(V)
AH
V,MRANK(V)
LA
V,12(V)
SLL R1,2
L
R3,VCMPS2
C
R3,ONE
BC
7,OKAY2
THE SINGLE ELEMENT OF V AND STASH IT AWAY FOR LATER. *
L
R0,OKAY1-4(R1)
ST
R0,DOWNADR
AR
R1,R2
IC
R3,DIDLTYP-5(R1)
LTR R3,R3
BC
8,TYPERR
LR
R4,V
SR
R2,R2
ICALL FETCH
STM R0,R1,VALUE
BC
15,COMMON
CNOP 0,4
DC
AL4(DOWNS51)
DC
AL4(DOWNS52)
DC
AL4(DOWNS53)
DC
AL4(DOWNS54)
EQU *
AR
R1,R2
AR
R1,R1
LH
R1,DOWNBTAB-2(R1)
AR
R1,12
ST
R1,DOWNADR

37800000
3069 37860000
3069 37920000
37980000
38040000
38100000
3069 38160000
3069 38220000
38280000
38340000
38400000
38460000
38520000
38580000
38640000
38700000
38760000
38820000
38880000
38940000
39000000
39060000
39120000
39180000
39240000
39300000
39360000
39420000
39480000
39540000
39600000
39660000
39720000
39780000
39840000
39900000
39960000
40020000
40080000
40140000
40200000
40260000
40320000
40380000
40440000
40500000
40560000
40620000
40680000
40740000
40800000
40860000
40920000
40980000
41040000
41100000
41160000
41220000
41280000
41340000

BC
15,COMMON
EQU *
LH
R1,MRANK(V)
LA
R2,4
SR
R1,R2
AR
R1,V
LA
R1,12(R1,MR)
L
R3,VCMPS2
SLL R3,2
AR
R3,R1
LA
R0,1
LA
R5,CHK12C
BC
15,CHK12B
CHK12A CL
R0,0(R1)
BCR 4,R5
CHK12B BXLE R1,R2,CHK12A
BC
15,CHKFIN
CHK13 TM
8(R1),X'01'
BC
8,CHK12
LA
R3,11
TRY TO MAKE IT TYPE 1 WITHOUT FUZZ
ON
RNG,CHK13C
CHK13X LH
R4,MRANK(V)
LA
R4,12(R4,V)
L
R2,VCMPS2
LOAD THE NUMBER OF COMPONENTS IN V.
LTR R2,R2
BC
8,CHKFIN
LA
R5,1
LCR R5,R5
BC
15,CHK13B
CHK13A EQU *
ICALL FETCH
QUEND
CHK13B BXH R2,R5,CHK13A
ON
RNG
BC
15,CHKFIN
CHK13C LA
R3,12
TRY TO MAKE IT TYPE 2 WITHOUT FUZZ
ON
RNG,CHK13E
CHK13D ICALL FETCH
BXH R2,R5,CHK13D
ON
RNG
CHK12C LA
R6,COPY21
IT IS OKAY AS A TYPE 2, CONVERT IT.
LA
R2,2
BC
15,COPY
CHK13E LA
R6,COPY31
HAVE TO COPY IT OVER TO TYPE 3.
LA
R2,3
ON
RNG
BC
15,COPY
CHK23
LA
R3,12
ON
RNG,CHK23C
BC
15,CHK13X
CHK23C LA
R2,3
I HAVE TO CONVERT IT TO Y TYPE 3.
LA
R6,COPY32
ON
RNG
***********************************************************************
* ROUTINE TO COPY A OVER TO A NEW ARRAY, POSSIBLY CHANGING THE TYPE *
* AS THE COPYING TAKES PLACE. THE ONLY CASE WHERE THE TYPE IS NOT
*
* CHANGED IN A COPY IS WHEN A(I) GETS A, OR A(A) GETS X.
*
* REGISTER 6 CONTAINS THE ADDRESS OF THE APPROPRIATE CONVERSION SECTION
* TO BE PERFORMED DURING THE COPY, AND R2 CONTAINS THE TYPE OF THE NEW*
* ARRAY. AFTER COPY IS DONE IT GOES TO CHKFIN, TO FILL IN DOWNADR.
*
CHK12

41400000
41460000
41520000
41580000
41640000
41700000
41760000
41820000
41880000
41940000
42000000
42060000
42120000
42180000
42240000
42300000
42360000
42420000
42480000
42540000
42600000
42660000
42720000
42780000
42840000
42900000
42960000
43020000
43080000
43140000
43200000
43260000
43320000
43380000
43440000
43500000
43560000
43620000
43680000
43740000
43800000
43860000
43920000
43980000
44040000
44100000
44160000
44220000
44280000
44340000
44400000
44460000
44520000
44580000
44640000
44700000
44760000
44820000
44880000
44940000

***********************************************************************
COPY
LR
R1,R2
IC
R1,RIGHTBYT-1(R2) FIGURE OUT EXACTLY HOW MUCH SPACE
M
R0,ACMPS
THE NEW ARRAY WILL TAKE UP.
LA
R1,7(R1)
ROUND UP TO EVEN BYTE.
SRL R1,3
XX
LH
R3,MRANK(A)
LA
R1,12(R1,R3)
ICALL GETSPACE
L
LWX,SVI
NO STACK POINTER FROM THE GETSPACE.
L
R5,4(LWX,MR)
GET SYMBOL TABLE ADDRESS.
L
A,0(R5,MR)
GET THE ADDRESS OF THE OLD M-ENTRY.
A
R1,FIVECON
ST
R1,0(R5,MR)
FIX THE SYMBOL TABLE TO POINT TO THE
L
R0,0(A,MR)
NEW ARRAY.
ST
R0,0(R1,MR)
MAKE NEW EMTRY POINT ON SYMBOL TABLE
LR
R0,R2
SLL R0,24
GET THE TYPE LEFT JUSTIFIED.
AR
R0,R3
AND PLACE THE NUMBER OF DIMENSIONS.
ST
R0,8(R1,MR)
FILL IN TYPE AND RHO RHO.
LA
R4,12(A,MR)
SOURCE IS R4.
LA
V,12(R1,R3)
LA
R1,12(R1,MR)
BCTR R3,0
EX
R3,INDX8MVC
LR
R1,A
LWUG
LA
A,13(A,R3)
A IS NOW READY FOR COPYING.
L
R5,ACMPS
BCR 15,R6
BRANCH TO THE RIGHT PLACE.
COPY21 SLL R5,2
LA
R4,4
SR
V,R4
AR
R5,V
LA
R3,32
SR
R2,R2
L
R1,0(A,MR)
COPY21A BXH V,R4,COPYFIN
COPY FROM A TO V.
COPY21B LR
R0,R2
SLDL R0,1
ST
R0,0(V,MR)
BCT R3,COPY21A
LA
R3,32
AR
A,R4
L
R1,0(A,MR)
BXLE V,R4,COPY21B
BC
15,COPYFIN
* REGISTER USAGES. *
* R0 -- TRANSIT REGISTER.
* R1 -- TEMPORARY HOLDER FOR BITS FROM A.
* R2 -- A CONSTANT ZERO.
* R3 -- COUNT DOWN FROM 32, TO TELL WHEN R1 IS USED UP.
* R4 -- A CONSTANT FOUR FOR THE BXH.
* R5 -- LIMIT FOR V, (INITIAL V BASE =BASE+12+MRANK)+4 X NEG 1 PLUS RHO
* A INITIALLY, ADDRESS OF ELEMENT ZERO OF OLD ARRAY.
* V -- INITIALLY, ELEMENT ZERO OF NEW ARRAY.
COPY31 SLL R5,3
LA
R4,8
SR
V,R4
AR
R5,V

45000000
45060000
45120000
45180000
45240000
45300000
45360000
45420000
45480000
45540000
45600000
45720000
45840000
45900000
46020000
46080000
46140000
46200000
46260000
46320000
46380000
46440000
46500000
46560000
46620000
46680000
46740000
46800000
46860000
46920000
46980000
47040000
47100000
47160000
47220000
47280000
47340000
47400000
47460000
47520000
47580000
47640000
47700000
47760000
47820000
47880000
47940000
48000000
48060000
48120000
48180000
48240000
48300000
48360000
48420000
48480000
48540000
48600000
48660000
48720000

LA
R3,32
LA
R2,X'208'
SR
R6,R6
L
R1,0(A,MR)
COPY31A BXH V,R4,COPYFIN
COPY31B ST
R6,4(V,MR)
SR
0,0
ALR 1,1
BC
12,*+8
L
0,FLOAT1
ST
R0,0(V,MR)
BCT R3,COPY31A
LA
R3,32
LA
A,4(A)
L
R1,0(A,MR)
BXLE V,R4,COPY31B
BC
15,COPYFIN
COPY32 SLL R5,3
LA
R4,8
SR
V,R4
AR
R5,V
COPY32A BXH V,R4,COPYFIN
COPY32B L
R1,0(A,MR)
LA
R0,X'48'
LTR R1,R1
BC
10,COPY32C
LCR R1,R1
BC
1,COPY32E
LA
R0,X'C8'
COPY32C SLDL R0,24
STM R0,R1,VALUE
SDR 0,0
AD
0,VALUE
STD 0,VALUE
LA
R1,0(V,MR)
MVC 0(8,R1),VALUE
LA
A,4(A)
BXLE V,R4,COPY32B
BC
15,COPYFIN
COPY32E LA
R1,0(V,MR)
MVC 0(8,R1),NEGNUM
LA
A,4(A)
BC
15,COPY32A
CHKFIN EQU *
COPYFIN LA
R1,OKAY
BC
15,BASES
*************** EVALUATION, DOWN.
DOWNBTAB DC
AL2(DOWNBIT-ORGY)
DC
AL2(DOWNINT-ORGY)
DC
AL2(DOWNFLP-ORGY)
DC
AL2(DOWNCHAR-ORGY)
DC
AL2(DOWNS11-ORGY)
DC
AL2(DOWNS12-ORGY)
DC
AL2(DOWNS13-ORGY)
DC
AL2(TYPERR-ORGY)
DC
AL2(DOWNS21-ORGY)
DC
AL2(DOWNS22-ORGY)
DC
AL2(DOWNS23-ORGY)
DC
AL2(TYPERR-ORGY)
DC
AL2(DOWNS31-ORGY)

LOAD UP THE FIRST 32 BITS.

BRANCH NO CARRY

REFILL COUNTER.

SHOULD I COMPLEMENT THE NUMBER.

***********
HEAP BIG BRANCH TABLE.

48780000
48840000
48900000
48960000
49020000
49080000
49140000
49200000
49260000
49320000
49380000
49440000
49500000
49560000
49620000
49680000
49740000
49800000
49860000
49920000
49980000
50040000
50100000
50160000
50220000
50280000
50340000
50400000
50460000
50520000
50580000
50640000
50700000
50760000
50820000
50880000
50940000
51000000
51060000
51120000
51180000
51240000
51300000
51360000
51420000
51480000
51540000
51600000
51660000
51720000
51780000
51840000
51900000
51960000
52020000
52080000
52140000
52200000
52260000
52320000

DOWNS11

DOWNS11A

DOWNS12

DOWNS51A

DOWNS13
DOWNS13A

DC
DC
DC
DC
DC
DC
DC
EQU
LR
SRDL
SRL
AR
AR
SR
IC
SRL
NR
BC
IC
EX
LTR
BCR
LA
LA
BCR
IC
EX
LTR
BCR
LA
LA
BCR
EQU
LR
SRDL
SRL
AR
AR
L
LA
BXLE
EQU
IC
EX
BCR
LA
LA
ST
LR
LR
LA
ICALL
L
LA
AR
LR
SRDL
SRL
AR
AR

AL2(DOWNS32-ORGY)
AL2(DOWNS33-ORGY)
AL2(TYPERR-ORGY)
AL2(TYPERR-ORGY)
AL2(TYPERR-ORGY)
AL2(TYPERR-ORGY)
AL2(DOWNS44-ORGY)
*
R2,SUM
R2,3
R3,29
R2,A
R2,MR
R5,ONEREG
R1,M(V)
R1,0(R5)
R1,ONEREG
7,DOWNS11A
R3,BITBIT0(R3)
R3,ANDIMED
R5,R5
7,DOWNY
V,1(V)
R5,8
15,DOWNY
R3,BITBIT1(R3)
R3,ORIMED
R5,R5
7,DOWNY
V,1(V)
R5,8
15,DOWNY
*
R2,SUM
R2,3
R3,29
R2,A
R2,MR
R1,0(MR,V)
V,4(V)
R1,R1,DOWNS12A
*
R3,BITBIT1(R3)
R3,ORIMED
15,DOWNY
R5,0
R0,DOWNS13A
R0,DOWNADR
R2,R5
R4,V
R3,9
FETCH
DOWNY,DOWNYSV
LOOPRG,DOWNS13A
R5,ONEREG
R2,SUM
R2,3
R3,29
R2,A
R2,MR

52380000
52440000
52500000
52560000
52620000
52680000
52740000
52800000
52860000
52920000
52980000
53040000
53100000
53160000
53220000
53280000
53340000
53400000
53460000
53520000
53580000
53640000
53700000
53760000
53820000
53880000
53940000
54000000
54060000
54120000
54180000
54240000
54300000
54360000
54420000
54480000
54540000
54600000
54660000
54720000
54780000
54840000
54900000
54960000
55020000
55080000
55140000
55200000
55260000
55320000
55380000
55440000
55500000
55560000
55620000
55680000
55740000
55800000
55860000
55920000

DOWNS12A

DOWNS13B
DOWNS21

DOWNS21A
DOWNS22

DOWNS23
DOWNS23A

DOWNS31

LTR
BC
EQU
IC
EX
BCR
IC
EX
BCR
LA
AR
AR
SR
IC
SRL
BC
LA
AR
NR
ST
BCR
EQU
LA
AR
AR
L
ST
LA
BCR
LA
LA
ST
LR
LA
LR
ICALL
LA
AR
AR
ST
AR
LA
L
BCR
LR
SLL
AR
SR
IC
SRL
NR
BZ
LA
SLDL
AR
STM
LTR
BCR
LA
AR

R0,R0
7,DOWNS13B
*
R3,BITBIT0(R3)
R3,ANDIMED
15,DOWNY
R3,BITBIT1(R3)
R3,ORIMED
15,DOWNY
R2,0(SUM,SUM)
R2,R2
R2,A
R5,ONEREG
R1,M(V)
R1,0(R5)
7,DOWNS21A
R5,8
V,ONEREG
R1,ONEREG
R1,M(R2)
15,DOWNY
*
R1,0(SUM,SUM)
R1,R1
R1,A
R0,M(V)
R0,M(R1)
V,4(V)
15,DOWNY
R5,0
R0,DOWNS23A
R0,DOWNADR
R2,R5
R3,10
R4,V
FETCH
R2,0(SUM,SUM)
R2,R2
R2,A
R0,M(R2)
R5,ONEREG
LOOPRG,DOWNS23A
DOWNY,DOWNYSV
15,DOWNY
R2,SUM
R2,3
R2,A
R5,ONEREG
R1,M(V)
R1,0(R5)
R1,ONEREG
*+8
R1,X'410'(R1)
R0,52
R2,MR
R0,R1,0(R2)
R5,R5
7,DOWNY
R5,8
V,ONEREG

55980000
56040000
56100000
56160000
56220000
56280000
56340000
56400000
56460000
56520000
56580000
56640000
56700000
56760000
56820000
56880000
56940000
57000000
57060000
57120000
57180000
57240000
57300000
57360000
57420000
57480000
57540000
57600000
57660000
57720000
57780000
57840000
57900000
57960000
58020000
58080000
58140000
58200000
58260000
58320000
58380000
58440000
58500000
58560000
58620000
58680000
58740000
58800000
58860000
58920000
58980000
59040000
59100000
59160000
59220000
59280000
59340000
59400000
59460000
59520000

BCR
DOWNS32 LR
SLL
AR
AR
L
LA
LTR
BC
LCR
BC
LA
DOWNS32A SLDL
STM
SDR
AD
STD
MVC
LA
BCR
DOWNS32B MVC
LA
BCR
DOWNS33 LR
SLL
AR
LA
AR
MVC
AR
BCR
DOWNS44 EQU
LA
IC
STC
AR
BCR
DOWNS51 LR
SRDL
SRL
AR
AR
TM
BC
IC
EX
BCR
DOWNS52 LA
AR
AR
L
ST
BCR
DOWNS53 LR
SLL
AR
AR
LM
STM
BCR

15,DOWNY
R2,SUM
R2,3
R2,A
R2,MR
R1,M(V)
R0,X'48'
R1,R1
10,DOWNS32A
R1,R1
1,DOWNS32B
R0,X'C8'
R0,24
R0,R1,VALUE
0,0
0,VALUE
0,VALUE
0(8,R2),VALUE
V,4(V)
15,DOWNY
0(8,R2),NEGNUM
V,4(V)
15,DOWNY
R2,SUM
R2,3
R2,A
R1,0(MR,V)
R2,MR
0(8,R2),0(R1)
V,R5
15,DOWNY
*
R1,0(SUM,A)
R0,M(V)
R0,M(R1)
V,ONEREG
15,DOWNY
R2,SUM
R2,3
R3,29
R2,A
R2,MR
VALUE,X'80'
7,DOWNS51A
R3,BITBIT0(R3)
R3,ANDIMED
15,DOWNY
R2,0(SUM,SUM)
R2,R2
R2,A
R0,VALUE
R0,M(R2)
15,DOWNY
R2,SUM
R2,3
R2,A
R2,MR
R0,R1,VALUE
R0,R1,0(R2)
15,DOWNY

IS THE NUMBER NEGATIVE?

IF IT WAS NEGATIVE, COMPLEMENT IT.
TGEST FOR MINUS 2*32.
AND SET THE SIGN TO MINUS.

MINUS 2*32.
EKE V PLUS FOUR.

59580000
59640000
59700000
59760000
59820000
59880000
59940000
60000000
60060000
60120000
60180000
60240000
60300000
60360000
60420000
60480000
60540000
60600000
60660000
60720000
60780000
60840000
60900000
60960000
61020000
61080000
61140000
61200000
61260000
61320000
61380000
61440000
61500000
61560000
61620000
61680000
61740000
61800000
61860000
61920000
61980000
62040000
62100000
62160000
62220000
62280000
62340000
62400000
62460000
62520000
62580000
62640000
62700000
62760000
62820000
62880000
62940000
63000000
63060000
63120000

DOWNS54 LA
R1,0(SUM,A)
IC
R0,VALUE
STC R0,M(R1)
BCR 15,DOWNY
DOWNBIT LR
R1,SUM
TYPE 1, BIT ARRAY.
LR
R2,SUM
XX
N
R1,SEVEN
SRL R2,3
AR
R2,MR
IC
R0,0(R2,A)
IC
R1,BITBIT1(R1)
NR
R0,R1
LA
R2,0(V,MR)
BC
8,DOWNBIT1
IC
R3,BITBIT3-1(R5)
EX
R3,ORIMED
BCTR R5,DOWNY
LA
R5,8
LA
V,1(V)
BCR 15,DOWNY
DOWNBIT1 IC
R3,BITBIT4-1(R5)
EX
R3,ANDIMED
BCTR R5,DOWNY
LA
R5,8
LA
V,1(V)
BCR 15,DOWNY
BITBIT0 DC
XL8'7FBFDFEFF7FBFDFE'
BITBIT1 DC
XL8'8040201008040201'
BITBIT3 DC
XL8'0102040810204080'
BITBIT4 DC
XL8'FEFDFBF7EFDFBF7F'
ORIMED OI
0(R2),X'00'
ANDIMED NI
0(R2),X'00'
DOWNINT LA
R1,0(SUM,SUM)
AR
R1,R1
AR
R1,MR
L
R1,0(R1,A)
ST
R1,0(V,MR)
LA
V,4(V)
BCR 15,DOWNY
DOWNFLP LR
R1,SUM
SLL R1,3
AR
R1,MR
AR
R1,A
LA
R2,0(V,MR)
MVC 0(8,R2),0(R1)
AR
V,R5
BCR 15,DOWNY
DOWNCHAR LA
R1,0(SUM,MR)
IC
R0,0(R1,A)
STC R0,0(V,MR)
AR
V,ONEREG
BCR 15,DOWNY
DOWNY
EQU R4
USUALLY CONTAINS ADDRESS OF BEGIN.
* EI3 IS R1, SUM IS R7,WK IS R6,THERE IS AN 8 IN R5 EXCEPT DURING BIT
* INDEXING, A IS IN R9, V IS IN R10, AND THERE IS A 1 IN R8. LOOPRG IS
* REGISTER FIFTEEN.
BEGIN
LA
WK,WK1
QUEND
MORE
S
SUM,E(WK)
LOOK 'MORE',FUG1,FUG2

63180000
63240000
63300000
63360000
63420000
63480000
63540000
63600000
63660000
63720000
63780000
63840000
63900000
63960000
64020000
64080000
64140000
64200000
64260000
64320000
64380000
64440000
64500000
64560000
64620000
64680000
64740000
64800000
64860000
64920000
64980000
65040000
65100000
65160000
65220000
65280000
65340000
65400000
65460000
65520000
65580000
65640000
65700000
65760000
65820000
65880000
65940000
66000000
66060000
66120000
66180000
66240000
66300000
66360000
66420000
66480000
66540000
66600000
66660000
66720000

L
EI3,E+12(WK)
AR
EI3,ONEREG
CL
EI3,E+16(WK)
BC
4,HERE
SR
EI3,EI3
LA
LOOPRG,WKDEC
HERE
ST
EI3,E+12(WK)
L
R3,E+24(WK)
BALR R3,R3
NOW
S
R1,IORIGIN
CL
R1,E+20(WK)
BC
10,INDXERR
NOW1
M
R0,E+4(WK)
ST
R1,E(WK)
AR
SUM,R1
BCR 15,LOOPRG
* SECTION TO OBTAIN ELEMENTS OF SUBSCRIPT ARRAYS.
*
* R1 CONTAINS THE INDEX OF THE ELEMENT DESIRED, /-ORIGIN, AND THE
*
* RESULT IS PLACED IN REGISTER 1 AS A FIXED POINT INTEGER.
*
* AT E+8(WK) IS THE M-RELATIVE ADDRESS OF ELEMENT ZERO OF THE
*
* SUBSCRIPT ARRAY. R3 CONTAINS THE ADDRESS TO BRANCH TO AFTERWARDS. *
FTCHBIT LR
R2,R1
HERE I GET AN ELEMENT OUT OF A BIT
N
R2,SEVEN
ARRAY.
SRL R1,3
R1 NOW HAS A RELATIVE BYTE ADDRESS.
A
R1,E+8(WK)
ADD IN THE ADDRESS OF ELEMENT ZERO.
IC
R0,M(R1)
OBTAIN THE BYTE CONTAINING THE BIT.
LR
R1,ONEREG
GET SET FOR A ONE, THEN SEE IF IT IS
IC
R2,BITBIT1(R2)
REALLY A ONE.
NR
R0,R2
IF THE RESULT OF THIS AND IS A ONE,
BCR 7,R3
THEN THE DESIRED BIT IS A ONE.
SR
R1,R1
HOWEVER, HERE I FIND IT IS NOT A ONE
BCR 15,R3
SO I SET R1 TO ZERO AND EXIT.
FTCHINT SLL R1,2
FETCH AN ELEMENT OUT OF AN INTEGER
A
R1,E+8(WK)
ARRAY.
L
R1,M(R1)
THIS ONE IS EASY, JUST GET IT.
BCR 15,R3
THEN LEAVE.
FTCHFLP ST
R3,SAVEM1
THIS ONE IS HARDER, FETCHING AN
L
R4,E+8(WK)
ELEMENT OUT OF A FLOATING POINT
LR
R2,R1
ARRAY AND CONVERTING IT FIXED.
LA
R3,10
FOR THIS I USE THE FETCH PROGRAM.
ST
LOOPRG,FUDGE
LOOPRG IS 15, SO I HAVE TO SAVE IT.
ICALL FETCH
L
LOOPRG,FUDGE
NOW RESTORE REGISTERS 15 AND 3 TO
L
R3,SAVEM1
WHAT THEY WERE INITIALLY.
LR
R1,R0
LEAVE THE ELEMENT IN R1 INSTEAD OF 0
LA
DOWNY,BEGIN
DOWNY IS R4, SO I HAVE TO RESTORE IT
BCR 15,R3
THEN JUST LEAVE.
FTCHBTAB DC
AL2(FTCHBIT-ORGY) TYPE 1, BITS.
DC
AL2(FTCHINT-ORGY) TYPE 2, INTEGER.
DC
AL2(FTCHFLP-ORGY) TYPE 3, FLOATING POINT.
DC
AL2(INDXERR-ORGY) TYPE 4, A MISTAKE.
WKDEC
S
WK,TWENTY8
C
WK,WKLIM
L
LOOPRG,DOWNADR
BC
2,MORE
KEEP GOING AS LONG AS WK IS BIGGER.
XI
SWICH,X'FF'
BCR 7,LOOPRG
GO USE THE FIRST ONE.
**********************************************************************
* THIS IS THE GENERAL CLEANUP PRIOR TO LEAVING THE INDEXING PROGRAM.*
**********************************************************************

66780000
66840000
66900000
66960000
67020000
67080000
67140000
67200000
67260000
67320000
67380000
67440000
67500000
67560000
67620000
67680000
67740000
67800000
67860000
67920000
67980000
68040000
68100000
68160000
68220000
68280000
68340000
68400000
68460000
68520000
68580000
68640000
68700000
68760000
68820000
68880000
68940000
69000000
69060000
69120000
69180000
69240000
69300000
69360000
69420000
69480000
69540000
69600000
69660000
69720000
69780000
69840000
69900000
69960000
70020000
70080000
70140000
70200000
70260000
70320000

INDXFIN L
LWX,SVI
LOAD THAT BACK INTO 15.
L
R1,4(LWX,MR)
NOW IF A IS NOT A NAMED ARRAY,
LWTG
INDXFIN1 L
R1,8(LWX,MR)
NOW I USE THE MKGARB PROGRAM TO DO
ICALL MKGARB
L
LWX,SVI
THE INDEX LIST.
A
LWX,EIGHT
CHANGE THE STACK POINTER.
ST
LWX,SVI
AND I LEAVE V ON THE STACK.
ELFIN
IRETURN
AISVEC EQU *
L
R6,MRHO(A)
LOAD THE NUMBER OF ELEMENTS IN A.
L
R2,MRHO(R8)
NOW SEE IF IT IS AN EMPTY LIST.
LTR R2,R2
XX
BC
8,MPTYLS
XX
BC
4,EVAL41
BRANCH IF I IS A NAMED ARRAY.
EVAL17 LA
R1,0(R2,MR)
CLI 8(R1),X'02'
BC
7,IND2
LA
R1,0(A,MR)
CLI 8(R1),X'04'
BC
8,EVAL50
CLI 8(R1),X'02'
BC
7,IND2
EVALII EQU *
SR
R7,R7
R7 IS ZERO FOR THIS CASE.
LA
R3,16(R9,MR)
ABSOLUTE ADDRESS OF ELEMENT 0 OF A.
LA
R9,INDXERR
LOAD THE INDEX ERROR ADDRESS FOR BCR
LH
R5,MRANK(R2)
M-RELATIVE ADDRESS OF I.
AR
R2,R5
ADD IN THE NUMBER OF DIMS.
LA
R2,8(R2,MR)
ABS ADDR OF ELEMENT 0 OF I, LESS 4.
LA
R4,4
PUT A CONSTANT FOUR IN R4.
SR
R8,R8
GET A MINUS ONE IF ONE ORIGIN
S
R8,IORIGIN
INDEXING, ZERO IF ZERO INDEXING.
LCR R5,R5
COMPLEMENT R5 (RHO RHO I) AND TEST
BC
8,EVAL25
BRANCH IF I IS A SCALAR FROM LCR.
L
R1,4(R2,R5)
LOAD LAST ELEMENT OF RANK VECTOR.
LTR R1,R1
3069
BM
INDXERR
BRANCH IF MINUS DIMENSION
3069
AR
R5,R4
EKE NEGATIVE OF RHO RHO I BY 4.
BC
8,LOOP24
BRANCH IF I IS A VECTOR.
LOOP23 M
R0,4(R2,R5)
I IS MORE THAN A VEC, MPY BY DIM LNG
LTR R0,R0
3069
BM
INDXERR
BRANCH IF MINUS DIMENSION
3069
BZ
*+8
BRANCH IF NO MPY OVERFLOW
3069
L
R1,STRIKE
OVFLOW - SET TO CAUSE WSFULL
3069
AR
R5,R4
EKE NEG NUMB BY FOUR AGAIN.
BC
4,LOOP23
IF IT HAS NOT BECOME ZERO YET, DO MO
LOOP24 CL
R1,STRIKE
IS X/RHO I TOO LARGE
3069
BNL WSFULL
BRANCH IF TOO LARGE
3069
SLL R1,2
MPY X/RHO I BY 4
3069
LA
R5,0(R1,R2)
ABS ADDR OF LAST ELEMENT IN I.
***********************************************************************
* BASIC INDEXING LOOP FOR EVALUATION OF A SUBSCRIPTED VECTOR, ONE
*
* ORIGIN INDEXING, WHERE BOTH A AND I ARE INTEGER ARRAYS.
*
***********************************************************************
BC
15,EVAL27
COMMENCE INDEXING LOOP.
EVAL25 AR
R2,R4
ADD A FOUR TO GET IT RIGHT.
EVAL26 LR
R1,R8
A MINUS ONE FOR 1-ORIGIN INDEXING.
A
R1,0(R2)
ADD SUBSCRIPT TO MINUS ONE.
CLR R1,R6
TEST FOR SUBSCRIPT OUT OF RANGE.

70380000
70440000
70500000
70560000
70620000
70680000
70740000
70800000
70860000
70920000
70980000
71040000
71100000
71160000
71220000
71340000
71400000
71460000
71520000
71580000
71640000
71700000
71760000
71820000
71880000
71940000
72000000
72060000
72120000
72180000
72240000
72300000
72360000
72420000
72480000
72540000
72600000
72660000
72720000
72780000
72840000
72900000
72960000
73020000
73080000
73140000
73200000
73260000
73320000
73380000
73440000
73500000
73560000
73620000
73680000
73740000
73800000
73860000
73920000
73980000

BCR 10,R9
XX
SLL R1,2
MPY BY FOUR AND
L
R0,0(R1,R3)
FETCH A(I).
ST
R0,0(R2,R7)
STORE IT IN THE RIGHT PLACE.
EVAL27 BXLE R2,R4,EVAL26
TEST FOR THE END OF THE LOOP.
* THE REGISTER USAGE IN THIS LOOP IS AS FOLLOWS:
* R0 ... TRANSFER REGISTER FOR ELEMENT OF A
* R1 ... CURRENT INDEX ELEMENT.
* R2 ... ABSOLUTE ADDRESS OF CURRENT INDEX ELEMENT.
* R3 ... ABSOLUTE ADDRESS OF ELEMENT ZERO OF A.
* R4 ... A CONSTANT -- PLUS FOUR.
* R5 ... ABSOLUTE ADDRESS OF LAST EKEMENT OF I.
* R6 ... THE NUMBER OF ELEMENTS IN A.
* R7 ... THE ABSOLUTE ADDRESS OF ELEMENT ZERO OF THE PLACE TO RECEIVE *
* THE EVALUATED RESULT, MINUS THE ABSOLUTE ADDRESS OF ELEMENT ZERO OF I
* R9 ... THE ADDRESS OF WHERE TO GO WHEN AN INDEX ERROR IS DETECTED.
CLEEN1 L
R1,SVIA(LWX,MR)
THIS IS TO CLEAN UP THE STACK AND
LWTG
CLEEN2 AR
LWX,R4
GET A OFF THE STACK.
ST
LWX,SVI
XX
L
R1,4(LWX,MR)
GET RID OF THE LIST, BUT SAVE I.
N
R1,STRIKE
I IS NOW V.
L
R2,MRHO(R1)
O
R2,FOURCON
FLAG THIS THING AS A TEMPORARY.
ST
R2,4(LWX,MR)
LA
R3,4(LWX)
ST
R3,0(R2,MR)
LA
R2,ELFIN
DO NOT COME BACK, INSTEAD EXIT.
BC
15,LWMGN
***********************************************************************
* COME HERE IF THE SUBSCRIPT LIST WAS EMPTY ON EVALUATION.
*
***********************************************************************
MPTYLS EQU *
L
R1,SVIX(LWX,MR)
LWUG
EVAL28 L
R1,SVIA(LWX,MR)
ST
R1,SVIX(LWX,MR)
LTR R1,R1
BC
4,EVAL29
L
R2,0(R1,MR)
A
R2,FOUR
ST
R2,0(R1,MR)
EVAL29 A
LWX,FOUR
ST
LWX,SVI
IRETURN
***********************************************************************
* I IS A NAMED INTEGER ARRAY, A IS A VECTOR, AND I IS TO BE COPIED
*
* OVER TO AN UNNAMED M-ENTRY OF INTEGERS.
*
***********************************************************************
EVAL41 DS
0H
L
R2,0(R2,MR)
LA
R1,0(R2,MR)
CLI 8(R1),X'02'
BC
7,IND2
LA
R1,0(A,MR)
CLI 8(R1),X'04'
BC
8,EVAL50
CLI 8(R1),X'02'
BC
7,IND2
EVAL30 EQU *

74040000
74100000
74160000
74220000
74280000
74340000
74400000
74460000
74520000
74580000
74640000
74700000
74760000
74820000
74880000
74940000
75000000
75060000
75120000
75180000
75240000
75300000
75360000
75420000
75480000
75540000
75600000
75660000
75720000
75780000
75840000
75900000
75960000
76020000
76080000
76140000
76200000
76260000
76320000
76440000
76500000
76560000
76620000
76680000
76740000
76800000
76860000
76920000
76980000
77040000
77100000
77220000
77280000
77340000
77400000
77460000
77520000
77580000
77640000
77700000

L
R1,MCOUNT(R2)
SR
R2,R2
ICALL GETSPACE
L
LWX,SVI
L
R8,SVIX1(LWX,MR)
LIST ADDRESS.
N
R8,STRIKE
GET RID OF THOSE LEFT 8 BITS.
L
R4,MRHO(R8)
GET THE OLD ARRAY ADDRESS.
LA
R6,BOBO
LTR R4,R4
BC
2,GOOCH
LWMOVES DS
0H
L
R4,M(R4)
GOOCH
DS
0H
L
R3,MCOUNT(R4)
GET THE BYTE COUNT OF THIS ARRAY.
AR
R4,MR
GET AN ABSOLUTE ADDRESS.
LA
R5,0(R1,MR)
GET ANOTHER ABSOLUTE ADDRESS HERE.
LWMOV R5,R4,R3,R2
MOVE ALL THAT STUFF TO ANOTHER PLACE
BCR 15,R6
BOBO
EQU *
O
R1,FOURCON
FLAG THIS AS A TEMPORARY.
ST
R1,MRHO(R8)
LA
R0,MRHO-M(R8)
GET THE ADDRESS OF THE LIST ELEMENT.
ST
R0,0(MR,R1)
MAKE M-ENTRY POINT TO LIST ELEMENT.
A
LWX,FOUR
ST
LWX,SVI
L
R9,SVIA(LWX,MR)
BMW R9
L
R6,MRHO(R9)
LOAD THE NUMBER OF ELEMENTS IN A.
BC
15,EVALII
NOW IT IS JUST LIKE AN UNNAMED I.
***********************************************************************
* THIS SECTION IS TO PROCESS A VECTOR SUBSCRIPTED BY AN INTEGER ARRAY,*
* WHEN THE VECTOR IS A CHARACTER VECTOR.
***********************************************************************
EVAL50 DS
0H
LH
R3,MRANK(R2)
NUMBER OF DIMENSIONS OF I.
AR
R2,R3
ADD FOUR X DIMS OF I.
AR
R2,MR
MAKE AN ABSOLUTE ADDRESS.
LA
R4,4
GET A CONSTANT FOUR IN R4.
LCR R5,R3
OBTAIN MINUS THE NUMBER OF DIMS.
L
R1,12(R2,R5)
GET EITHER THE LENGTH ALONG THE
*
LAST DIMENSION OR THE FIRST ELEMENT
*
IN CASE I IS A SCALAR.
BC
8,EVAL58
BRANCH IF I IS A SCALAR.
LTR R1,R1
3069
BM
INDXERR
BRANCH IF MINUS DIMENSION
3069
AR
R5,R4
ADD FOUR TO THE ADDRESS.
BC
8,LOOP26
BRANCH IF I IS A VECTOR.
LOOP25 M
R0,12(R2,R5)
MPY DIMENSION LENGTHS TOGETHER.
LTR R0,R0
3069
BM
INDXERR
BRANCH IF MINUS DIMENSION
3069
BZ
*+8
BRANCH IF NO MPY OVERFLOW
3069
L
R1,STRIKE
OVFLOW - SET TO CAUSE WSFULL
3069
AR
R5,R4
ADD 4 TO THE NEGATIVE NUMBER.
BC
4,LOOP25
CONTINUE MPY UNTIL ALL X TOGETHER.
LOOP26 CL
R1,STRIKE
IS X/RHO I TOO LARGE
3069
BNL WSFULL
BRANCH IF TOO LARGE
3069
ST
R1,SAVEM1
SAVE NO. ELEMENTS IN I
3069
* NOW I HAVE TO GET SOME SPACE FOR THE RESULT. *
* SPACE = 12+MRANK(R2)+R1.
*
LA
R1,12(R1,R3)
XX

77760000
77820000
77880000
77940000
78000000
78060000
78120000
78180000
78240000
78300000
78360000
78420000
78480000
78540000
78600000
78660000
78720000
78780000
78840000
78900000
78960000
79080000
79140000
79200000
79260000
79320000
79380000
79440000
79500000
79560000
79620000
79680000
79740000
79800000
79860000
79920000
79980000
80040000
80100000
80160000
80220000
80280000
80340000
80400000
80460000
80520000
80580000
80640000
80700000
80760000
80820000
80880000
80940000
81000000
81060000
81120000
81180000
81240000
81300000
81360000

SR
R2,R2
ICALL GETSPACE
* NOW THE STACK LOOKS LIKE THIS:
* 4+SVI -- NEW M-POINTER;
* 8+SVI -- ARRAY POINTER;
* 12+SVI -- ILIST POINTER.
L
LWX,SVI
L
R3,8(LWX,MR)
BMW R3
L
R6,MRHO(R3)
L
R2,12(LWX,MR)
L
R8,MRHO(R2)
LTR R2,R8
BC
2,EVAL55
L
R2,0(R2,MR)
EVAL55 DS
0H
L
R7,4(LWX,MR)
AR
R7,MR
AR
R2,MR
LH
R1,10(R2)
EX
R1,EVILMV
MVI 8(R7),X'04'
L
R5,SAVEM1
LA
R7,11(R7,R1)
LA
R4,4
LA
R3,16(R3,MR)
LA
R9,0(R5,R5)
AR
R2,R9
AR
R2,R9
LA
R2,08(R1,R2)
LA
R9,INDXERR
LTR R5,R5
BC
8,EVAL53
SR
R8,R8
S
R8,IORIGIN
EVAL54 LR
R1,R8
A
R1,0(R2)
CLR R1,R6
BCR 10,R9
IC
R0,0(R1,R3)
STC R0,0(R5,R7)
SR
R2,R4
BCT R5,EVAL54
EVAL53 L
R3,12(LWX,MR)
N
R3,STRIKE
L
R1,MRHO(R3)
LWTG
LR
R1,R3
BAL R2,LWMGMK
L
R1,8(LWX,MR)
LWTG
L
R1,4(LWX,MR)
O
R1,FOURCON
ST
R1,12(LWX,MR)
LA
LWX,8(LWX)
ST
LWX,SVI
AR
LWX,R4
ST
LWX,0(R1,MR)
IRETURN
EVILMV MVC 8(4,R7),8(R2)

MAKE R2 ZERO.
GET SOME SPACE.
*
*
*
*
RESTORE MY STACK POINTER.
GET THE POINTER TO THE ARRAY A.
BASE MY WORKSPACE.
NUMBER OF ELEMENTS IN A.
ILIST POINTER.
THE POINTER TO I.
LETS SEE IF IT IS A NAMED ARRAY.
BRANCH IF IT IS NOT.
IT IS, NOW GET THE REAL ADDRESS.
THE LOCATION OF THE NEW PLACE.
MAKE THAT ADDRESS ABSOLUTE.
MAKE THIS ONE ABSOLUTE TOO.
FOUR X NUMBER OF DIMS IN I AGAIN.
GET THOSE DIMENSIONS RIGHT.
MAKE THE TYPE 4, FOR CHARACTERS.
NUMBER OF ELEMENTS IN I.
R7 IS NOW ALL SET FOR THE LOOP.
PUT A CONSTANT FOUR IN R4.
ABSOLUTE ADDRESS OF ELEMENT A(0).
R2 GETS R2+R1+12+4 X R5.
XX
XX
XX
ADDRESS OF INDEX ERROR PLACE.
LETS SEE HOW MANY THINGS ARE IN I.
IT BRANCHES IF I IS IOTA ZERO.
IT WAS NOT IOTA ZERO, NOW
SET UP R8 WITH MINUS IORIGIN.
LOAD THAT NEGATIVE ONE.
2.50
ADD THE SUBSCRIPT.
4.00
SEE IF IT IS IN RANGE.
3.00
BRANCH ON INDEX ERROR.
2.75
GET A(I).
5.50
STORE IT AWAY.
5.00
GO GET THE NEXT SUBSCRIPT.
3.25
LOOP CLOSURE.
4.50

GET IT INTO THE RIGHT REGISTER.

MARK UNCONDITIONALLY GARBAGE.

MARK THIS A TEMPORARY RESULT.

REMOVE A AND ILIST FROM THE STACK.
XX
MAKE A BACK POINTER TO THE STACK.
RIGHT BACK POINTER.
MOVE RANK VECTOR FROM I.

81420000
81480000
81540000
81600000
81660000
81720000
81780000
81840000
81900000
81960000
82020000
82140000
82200000
82260000
82380000
82440000
82500000
82620000
82680000
82740000
82800000
82860000
82920000
82980000
83040000
83100000
83160000
83220000
83280000
83340000
83400000
83460000
83520000
83580000
83640000
83700000
83760000
83820000
83880000
83940000
84000000
84060000
84120000
84180000
84240000
84300000
84360000
84420000
84480000
84540000
84600000
84660000
84720000
84780000
84840000
84900000
84960000
85080000
85140000
85200000

EVAL58

*
* R0 -* R1 -* R2 -* R3 -* R4 -* R5 -* R6 -* R7 -* R8 -* R9 -EVAL59

EVAL60
BASES

LWMGLTR
LWMGBCR
LWMGN
LWMGMK
WSFULL
SYNTERR
INDXERR
RNKERR
LNGERR
TYPERR
NONCERR
VALUERR
ERRCALL
ONE
FOUR
FIVECON
SEVEN

S
R1,IORIGIN
PROCESS COOL SCALAR SUBSCRIPT.
CLR R1,R6
USUAL RANGE TEST FOR INDEX ERROR.
BC
10,INDXERR
XX
AR
R1,R9
ADD BASE FOR A.
IC
R0,16(R1,MR)
GET A(I).
L
R1,12(R8,MR)
GET ADDRESS OF ILIST AND USE THE
STC R0,12(R8,MR)
SPACE OCCUPIED BY THE LIST TO STORE
LWTG
THE INITIAL REGISTER CONTENTS IN THE ABOVE LOOP ARE:
USED FOR DATA TRANSFERS, INITIAL CONTENTS DO NOT MATTER;
DITTO;
ABSOLUTE ADDRESS OF LAST ELEMENT OF INDEX ARRAY;
ABSOLUTE ADDRESS OF A(0);
A CONSTANT FOUR;
NUMBER OF ELEMENTS IN THE INDEX ARRAY;
NUMBER OF ELEMENTS IN ARRAY BEING INDEXED;
ABSOLUTE ADDRESS OF ELEMENT ZERO OF RESULT) MINUS ONE;
USED FOR SUBTRACTING ONE IF THE INDEX ORIGIN IS ONE;
THE ADDRESS OF WHERE TO GO IF THERE IS AN INDEX ERROR.
LA
R0,8(LWX)
CREATE STACK POINTER FOR NEW THING.
ST
R0,0(R8,MR)
XX
LM
R0,R1,SIXTEEN
GET BYTE COUNT AND TYPE AND RANK.
ST
R0,4(R8,MR)
PLACE THE BYTE COUNT RIGHT.
ST
R1,8(R8,MR)
AND THE TYPE AND RANK.
L
R1,4(LWX,MR)
NOW I HAVE TO GET RID OF A IF NEC.
LWTG
AR
LWX,R4
EKE LWX BY FOUR AND STORE THE
ST
LWX,SVI
NEW SVI.
IRETURN
L
LWX,SVI
BASE A,4
BASE I,8
BASE V,12
BCR 15,R1
LTR R1,R1
SEE IF IT IS A NAMED ARRAY.
BCR 4,R2
IF IT IS, LEAVE IT ALONE.
N
R1,STRIKE
REMOVE THE BITS SO MKG WILL WORK.
MKG R1
BCR 15,R2
GO TO FROM WHENCE IT CAME.
LA
R1,EMFULL
WS FULL
3069
B
ERRCALL
3069
LA
R1,ESYNTAX
3561
B
ERRCALL
3561
LA
R1,EINDEX
INDEX ERROR.
BC
15,ERRCALL
LA
R1,ERANK
RANK ERROR.
BC
15,ERRCALL
LA
R1,ELENGTH
LENGTH ERROR.
BC
15,ERRCALL
LA
R1,ERANGE
DOMAIN ERROR
BC
15,ERRCALL
LA
R1,ENONCE
NONCE ERROR.
BC
15,ERRCALL
LA
R1,EVALUE
VALUE ERROR, TOO BAD.
ICALL ERROR
CNOP 0,4
DC
XL4'00000001'
DC
XL4'00000004'
A CONSTANT FOUR.
DC
XL4'05000000'
DC
XL4'00000007'
A SEVEN FOR SUNDRY USES.

85260000
85320000
85380000
85440000
85500000
85560000
85620000
85680000
85740000
85800000
85860000
85920000
85980000
86040000
86100000
86160000
86220000
86280000
86340000
86400000
86460000
86520000
86580000
86640000
86700000
86760000
86820000
86880000
86940000
87000000
87060000
87120000
87180000
87240000
87300000
87360000
87420000
87480000
87540000
87600000
87660000
87720000
87780000
87840000
87900000
87960000
88020000
88080000
88140000
88200000
88260000
88320000
88380000
88440000
88500000
88560000
88620000
88680000
88740000
88800000

EIGHT
RIGHTBYT
STRIKE
SIXTEEN
*
*
*
FOURCON
TWENTY8
FLOAT1
NEGNUM
DIDLTYP

DC
DC
DC
DC

XL4'00000008'
XL4'01204008'
(1/8,4,8,1)
XL4'00FFFFFF'
TO REMOVE THE LEFT EIGHT BITS.
XL4'00000010'
SIXTEEN IN BASE SIXTEEN.
BEWARE, THE CONSTANT SIXTEEN AND THE FOLLOWING
*
CONSTANT FOURCON ARE LOADED WITH A LOAD MULTIPLE
*
INSTRUCTION, AND SO MUST NOT BE SEPARATED.
*
XL4'04000000'
XL4'0000001C'
TWENTY EIGHT IN BASE SIXTEEN REPRESE
E'1'
XL8'C910000000000000' MINUS 2*32.
XL4'01070900'
XL4'05020A00'
XL4'06080300'
XL4'00000004'

88860000
88920000
88980000
89040000
89100000
89160000
89220000
DC
89280000
DC
89340000
DC
89400000
DC
89460000
DC
89520000
DC
89580000
DC
89640000
DC
89700000
LTORG
89760000
INDEXDMY DSECT
89820000
FUG1
EQU *
89880000
VALUE
DC
XL8'0000000000000000'
89940000
AS
DC
XL4'00000000'
90000000
IS
DC
XL4'00000000'
90060000
VKS
DC
XL4'00000000'
90120000
WKS
DC
XL4'00000000'
90180000
WKLIM
DC
XL4'00000000'
90240000
E
DC
(16*8)XL4'00000000' SPACE FOR TEMPS, ONE SET PER DIM
90300000
EEND
EQU *-28
90360000
WK1
EQU EEND-E
90420000
F
DC
16XL4'00000000'
THIS SPACE IS TO COLLECT RANK VECTOR 90480000
FEND
EQU *-4
90540000
VK1
EQU FEND-F
90600000
ACMPS
DC
XL4'00000000'
90660000
VCMPS
DC
XL4'00000000'
90720000
DOWNADR DC
XL4'00000000'
90780000
DOWNYSV DC
XL4'00000000'
90840000
SAVEM1 DC
XL4'00000000'
90900000
FUDGE
DC
XL4'00000000'
90960000
SCRAM
DC
XL4'00000000'
91020000
VCMPS2 DC
XL4'00000000'
91080000
SWICH
DC
XL1'00'
91140000
S
DC
XL1'00'
91200000
OFLOWSW DC
XL1'00'
MULTIPLY-OVERFLOW SWITCH
6002 91260000
LWDSECT EQU *
91320000
FUG2
EQU *
91380000
END
91440000
./ ADD
NAME=APLSMDIV
MDIV
TITLE 'DOMINO -- M A T R I X
D I V I D E'
00150000
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
00300000
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
00450000
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
00600000
EXMMATD CSECT
00900000
PRINT OFF
APLDEFN, OPSECT
01050000
COPY APLDEFN
01200000
COPY OPSECT
01350000
TITLE 'DOMINO -- M A T R I X
D I V I D E'
01500000
EXMMATD CSECT
01650000
PRINT ON
01800000
ENTRY EXDMATD
01950000
EXTRN ERROR
02100000
EXTRN FETCH
02250000
EXTRN OPSPACE
02400000

EXTRN SQRT
USING OPSECT-16,13
*
*
*

ENTRY FOR MONADIC MATRIX DIVIDE

USING
ST
MVI
L
LA
L
ST
MH
LA
ST
BAL

*
*
*

EXMMATD,9
LKR,MDLKR
DYDFLAG,0
6,RHBASE
6,12(6)
1,M(6)
1,PPP
1,PPP+2
2,8
2,RRANK
9,MDCOM

STORE RETURN
SET MONADIC FLAG

P = NUMBER OF COL'S OF RESULT

RANK OF RESULT IS 2
MERGE INTO COMMON ROUTINE

ENTRY FOR DYADIC MATRIX DIVIDE

USING EXDMATD,9
EXDMATD ST
LKR,MDLKR
STORE RETURN
*
CONFORMABILITY AND RANK CHECKING
MVI DYDFLAG,1
SET DYADIC FLAG
L
2,LHBASE
LA
2,12(2)
CLI LHRANK+3,8
BH
RANKERR
LHRANK GT 2
BE
GETP
CLI LHRANK+3,4
BL
RANKERR
LHRANK LESS THAN 1
LA
1,1
ST
1,PPP
SET P=NO OF RIGHT HAND SIDES TO 1
B
GETRRANK
GETP
L
1,M+4(2)
ST
1,PPP
STORE NO OF RIGHT HAND SIDES IN P
GETRRANK L
1,LHRANK
ST
1,RRANK
L
6,RHBASE
LA
6,12(6)
L
3,M(6)
C
3,M(2)
BNE LENERR
UNEQUAL NUMBER OF ROWS IN A AND B
L
1,LHXRHO
MDCOM
A
1,RHXRHO
NUMBER OF WORDS FOR A,B
ST
1,MDTEMP
START OF COMMON ROUTINE
CLI RHRANK+3,8
BNE RANKERR
RHRANK NOT 2
L
3,M(6)
ST
3,MM
MM = NUMBER OF ROWS OF A
L
4,M+4(6)
ST
4,N
N = NUMBER OF COLS OF A
CR
3,4
BL
LENERR
A HAS FEWER ROWS THAN COLUMNS
CLI INDBASE,0
BNE INDXERR
OPERATOR INDEX NOT ELIDED
*
*
GET SPACE TO DO ALL WORK IN
*
R1 HAS NUMBER OF DOUBLE WORDS IN A AND B
LA
1,1(1)
ONE MORE IF NEEDED TO GO TO DBL
*
WORD BOUNDARY

02550000
02700000
02850000
03000000
03150000
03300000
03450000
03600000
03750000
03900000
04050000
04200000
04350000
04500000
04650000
04800000
04950000
05100000
05250000
05400000
05550000
05700000
05850000
06000000
06150000
06300000
06450000
06600000
06750000
06900000
07050000
07200000
07350000
07500000
07650000
07800000
07950000
08100000
08250000
08400000
08550000
08700000
08850000
09000000
09150000
09300000
09450000
09600000
09750000
09900000
10050000
10200000
10350000
10500000
10650000
10800000
10950000
11100000
11250000
11400000

L
A
C
BNL
L
AR
A
L
LA
SRL
AR
LA
LA
L
BALR
ST
LA
LA
N
ST
L
SLL
AR
ST
L
SLL
ST
L
SLL
ST
AR
ST
L
SLL
CR
BNL
LR
AR
ST
A
ST
*
*

2,N
2,PPP
2,MM
*+8
2,MM
1,2
1,N
2,N
2,1(2)
2,1
1,2
2,2
3,3
10,=A(OPSPACE)
LKR,10
1,RBASE
1,20(1)
1,4(1)
1,ALLBUT7
1,ABDATA
2,MDTEMP
2,3
1,2
1,YBASE
2,N
2,3
2,N8
3,PPP
3,3
3,P8
3,2
3,NP8
2,MM
2,3
3,2
*+6
3,2
1,3
1,FACTBASE
1,N8
1,PPBASE

N+P
TEMP VECTOR Y IS M MAX N+P DBL WDS

N WORDS FOR FACTOR

N/2 WORDS FOR PIVOT RECORD

RANK IS 2
TYPE IS FLOATING
BASE FOR WORKING SPACE
NORMAL DATA BASE
DATA STARTS ON DBL WORD BOUNDARY
NO OF WORDS IN A,B
TIMES 8
BASE FOR Y VECTOR
8*N
8*P
8*(N+P)

BASE FOR VECTOR OF SCALE FACTORS

BASE FOR INTERCHANGE ARRAY

SET UP RESULT DSECT AND M-ENTRY

LA
1,3
ST
1,RSTYPE
L
1,N
L
6,RBASE
ST
1,M+12(6)
STORE 1ST DIMENSION
L
1,PPP
CLI RRANK+3,8
BNE *+8
ST
1,M+16(6)
STORE 2ND DIMENSION IF ANY
MH
1,N+2
ST
1,RXRHO
LTR 1,1
BNZ CONT
REAL WORK TO DO
L
10,RBASE
A
10,RRANK
LA
10,12(10)
R10 POINTS TO FIRST WD AFTER RES
B
CLEANUP
FINISH CLEANUP FOR EMPTY RESULT

11550000
11700000
11850000
12000000
12150000
12300000
12450000
12600000
12750000
12900000
13050000
13200000
13350000
13500000
13650000
13800000
13950000
14100000
14250000
14400000
14550000
14700000
14850000
15000000
15150000
15300000
15450000
15600000
15750000
15900000
16050000
16200000
16350000
16500000
16650000
16800000
16950000
17100000
17250000
17400000
17550000
17700000
17850000
18000000
18150000
18300000
18450000
18600000
18750000
18900000
19050000
19200000
19350000
19500000
19650000
19800000
19950000
20100000
20250000
20400000

CONT

*
*
*

*
*

L
MH
LA
SR
A
ST

3,NP8
3,MM+2
4,8
3,4
3,ABDATA
3,MNP8

COMPUTE A LOOP CONTROL CONSTANT

BASE+(8*M*(N+P))-8, LAST ELEMENT

OF A,B (B JOINED TO RIGHT OF A)

SELECT ADJOINING ROUTINE

CLI DYDFLAG,1
BNE ADJ2
MUST GENERATE IDENTITY FOR B
CLI RHTYPE+3,3
BNE ADJ2
A NOT FLOATING, MUST BE FETCHED
CLI LHTYPE+3,3
BNE ADJ2
B NOT FLOATING, MUST BE FETCHED

CAN USE MVC LOOPS TO ADJOIN B TO A

L
7,ABDATA
L
8,RHBASE
LA
8,12(8)
A
8,RHRANK
BASE OF DATA FOR A
L
6,N8
MH
6,MM+2
AR
6,8
UPPER LIMIT FOR A
L
10,LHBASE
LA
10,12(10)
A
10,LHRANK
BASE OF DATA FOR B
ADJLOOP1 L
2,N8
LENGTH OF ROW OF A
LR
3,8
AR
3,MR
ABSOLUTE SOURCE POINTER TO A
LR
4,7
AR
4,MR
ABSOLUTE SINK
BAL LKR,MVCLOOP
MOVE ROW OF A
A
8,N8
A
7,N8
INCREMENT POINTERS
L
2,P8
LENGTH OF ROW OF B
LR
3,10
AR
3,MR
ABSOLUTE SOURCE FOR A
LR
4,7
AR
4,MR
ABSOLUTE SINK
BAL LKR,MVCLOOP
MOVE ROW OF B
A
10,P8
A
7,P8
INCREMENT POINTERS
QUEND
CR
8,6
TEST AND LOOP
BL
ADJLOOP1
B
GO
DONE HOUSEKEEPING
*
*
ADJOIN ROUTINE USED IF A OR B MUST BE FETCHED OR IF
*
B MUST BE GENERATED
ADJ2
L
10,ABDATA
BASE FOR WORKING DATA
L
8,RHBASE
LA
8,12(8)
A
8,RHRANK
ST
8,MDTEMP
BASE FOR DATA IN A
CLI DYDFLAG,1
BNE MON1
L
8,LHBASE
LA
8,12(8)
A
8,LHRANK

20550000
20700000
20850000
21000000
21150000
21300000
21450000
21600000
21750000
21900000
22050000
22200000
22350000
22500000
22650000
22800000
22950000
23100000
23250000
23400000
23550000
23700000
23850000
24000000
24150000
24300000
24450000
24600000
24750000
24900000
25050000
25200000
25350000
25500000
25650000
25800000
25950000
26100000
26250000
26400000
26550000
26700000
26850000
27000000
27150000
27300000
27450000
27600000
27750000
27900000
28050000
28200000
28350000
28500000
28650000
28800000
28950000
29100000
29250000
29400000

ST
8,MDTEMP+4
BASE FOR DATA IN B
SR
8,8
ROW COUNTER = 0
LA
6,1
ADJLOOP2 SR
5,5
COL CNTR = 0
L
7,N
SR
7,6
LIMIT FOR LOOP
L
4,MDTEMP
INITIALIZE FETCH FOR A
L
3,RCTYPE
LR
2,8
MH
2,N+2
MOVEA
ICALL FETCH
STD 0,M(10)
STORE ELEMENT
LA
10,8(10)
INCREMENT AB POINTER
AR
2,6
INCREMENT FETCH INDEX
BXLE 5,6,MOVEA
INCR COL CNTR & LOOP
SR
5,5
COL CNTR = 0
L
7,PPP
SR
7,6
LIMIT FOR LOOP
L
4,MDTEMP+4
LR
2,8
MH
2,PPP+2
INITIALIZE FETCH FOR B
L
3,LCTYPE
FETCH TYPE FOR B
MOVEB
CLI DYDFLAG,1
BE
CALLF
SDR 0,0
PICK UP IDENTITY ELEMENT
CR
8,5
BNE STORB
LD
0,DONE
LOAD DIAGONAL ELEMENT
B
STORB
CALLF
ICALL FETCH
FETCH ELEMENT OF B
STORB
STD 0,M(10)
STORE ELEMENT OF B
LA
10,8(10)
INCREMENT AB POINTER
AR
2,6
INCREMENT FETCH INDEX
BXLE 5,6,MOVEB
INCR COL CNTR & LOOP
AR
8,6
INCR ROW CNTR
QUEND
C
8,MM
TEST & LOOP
BL
ADJLOOP2
*
*
NOW START REAL WORK OF MATRIX DIVIDE OPERATOR
GO
L
8,ABDATA
R8 CONTAINS DATA BASE
*
*
INITIALIZE COL INTERCHANGE RECORD
LA
0,8
LA
3,4
L
1,N8
SR
1,0
UPPER LIMIT FOR LOOP
L
4,PPBASE
SR
2,2
INITPP ST
2,M(4)
PP(I) = 8*I
AR
4,3
BXLE 2,0,INITPP
*
*
*
COMMON LOOP CONTROL USED UNTIL BACKSOLVE PART OF THE PROGRAM
*
ROW LOOP, R4 IS POINTER R2 IS ROW INCR 8*(N+P)
*
R3 IS LIMIT MNP8
*
COLUMN LOOP, R5 IS COL POINTER, R6 IS INCR 8 ,
*
R7 IS COL LIMIT (EITHER 8*(N-1) OR 8*(N+P-1) )
L
2,NP8
MON1

29550000
29700000
29850000
30000000
30150000
30300000
30450000
30600000
30750000
30900000
31050000
31200000
31350000
31500000
31650000
31800000
31950000
32100000
32250000
32400000
32550000
32700000
32850000
33000000
33150000
33300000
33450000
33600000
33750000
33900000
34050000
34200000
34350000
34500000
34650000
34800000
34950000
35100000
35250000
35400000
35550000
35700000
35850000
36000000
36150000
36300000
36450000
36600000
36750000
36900000
37050000
37200000
37350000
37500000
37650000
37800000
37950000
38100000
38250000
38400000

L
LA
L
SR
*
*
*
*
*

MD0

MD01

MD02

MD3

MD35

MD4

3,MNP8
6,8
7,N8
7,6

SET COLUMN LOOP TO N

SCALE COLUMNS SO THAT EACH COLUMN HAS AT LEAST ONE ELEMENT

WHICH IS THE MAXIMUM IN ITS ROW.
GET ROW MAXIMUMS
L
4,ABDATA
L
8,YBASE
SDR 6,6
LR
10,4
SR
5,5
SDR 0,0
SDR 4,4
LD
2,M(10)
LPER 2,2
ADR 4,2
CDR 0,2
BNL *+6
LDR 0,2
AR
10,6
BXLE 5,6,MD01
STD 0,M(8)
CDR 6,4
BNL *+6
LDR 6,4
AR
8,6
QUEND
BXLE 4,2,MD0
LD
0,CPUTFUZZ
AD
0,EPSILON
MDR 6,0
STD 6,MAXNORM
GET SCALE FACTOR
SDR 6,6
SR
5,5
L
10,FACTBASE
L
4,ABDATA
AR
4,5
L
8,YBASE
SDR 0,0
LD
2,M(4)
CDR 2,6
BE
MD35
DD
2,M(8)
LPER 2,2
CDR 0,2
BNL *+6
LDR 0,2
AR
8,6
BXLE 4,2,MD3
STD 0,M(10)
L
4,ABDATA
AR
4,5
LD
2,M(4)
DDR 2,0
STD 2,M(4)
BXLE 4,2,MD4

SET ROW CONTROL

SET COL CONTROL
INITIALIZE ROW SUM
LOAD NEXT COL ELEMENT

3070

ADD TO ROW SUM

3070

REPLACE IF LARGER
COL LOOP
SAVE ROW MAX IN Y
COMPARE WITH MAX ROW SUM
REPLACE IF LARGER

3070
3070

ROW LOOP
ABSOLUTE FUZZ
ADD 16**-13 IN CASE FUZZ IS 0
MULTIPLY MAXNORM BY FUZZ
CRITERION FOR SINGULARITY

3070
3070
3070

F6 HAS FLOATING 0
SET COL CONTROL

3070

SET ROW CONTROL

COMPARE WITH ZERO

SKIP DIVIDE IF ZERO
DIVIDE BY MAX ROW ELEMENT

3070
3070

SCALE FACTOR IS MAX OF THESE RATIOS

3070
SAVE IN FACTOR
SET ROW CONTROL AGAIN
SCALE COLUMN
ROW LOOP

38550000
38700000
38850000
39000000
39150000
39300000
39450000
39600000
39750000
39900000
40050000
40200000
40350000
40500000
40650000
40800000
40950000
41100000
41250000
41400000
41550000
41700000
41850000
42000000
42150000
42300000
42450000
42600000
42750000
42900000
43050000
43200000
43350000
43500000
43650000
43800000
43950000
44100000
44250000
44400000
44550000
44700000
44850000
45000000
45150000
45300000
45450000
45600000
45750000
45900000
46050000
46200000
46350000
46500000
46650000
46800000
46950000
47100000
47250000
47400000

AR
10,6
QUEND
BXLE 5,6,MD02
*
*
*
*
*

COL LOOP

START MAJOR LOOP TO DO HOUSEHOLDER TRANSFORMATIONS

R0 CONTAINS POINTER TO KTH COLUMN 8*(K-1)
R1 CONTAINS POINTER TO KTH ROW BASE+8*(N+P)*(K-1)

SR
0,0
L
1,ABDATA
INITIALIZE R0, R1
TRNGIZE LR
8,1
INITIALIZE PIVOT ROW & COLUMN
LR
10,0
L
7,N8
SET COLUMN LIMIT TO N
SR
7,6
*
LOOP FOR MAXIMUM PIVOT ELEMENT
LR
5,0
SDR 0,0
INITIALIZE TO 0
MD1
LR
4,1
AR
4,5
MD2
LD
2,M(4)
LPER 2,2
ABS A(I,J)
CDR 0,2
BNL BIGR
BRANCH IF F0 ALREADY MAX
LDR 0,2
F0 = NEW MAX
LR
8,4
REMEMBER ITS POSITION
LR
10,5
BIGR
BXLE 4,2,MD2
ROW LOOP
QUEND
BXLE 5,6,MD1
COL LOOP
*
*
MAX ELEMENT IN F0, MATRIX IS ESSENTIALLY SINGULAR IF
*
IT IS LESS THAN THE MAXIMUM ROW SUM TIMES
*
CPUTFUZZ + EPSILON.
*
CD
0,MAXNORM
BNH RNGERR
SR
8,10
ST
8,MDPI
STORE PIVOT ROW INDICATOR
CR
0,10
BE
NOCOLI
*
DO COLUMN INTERCHANGE
L
5,PPBASE
LR
8,10
SRL 8,1
AR
8,5
POINTER TO PP(PJ)
LR
4,0
SRL 4,1
AR
4,5
POINTER TO PP(J)
L
5,M(8)
L
6,M(4)
INTERCHANGE PIVOT RECORDS
ST
6,M(8)
ST
5,M(4)
LA
6,8
RESTORE R6 TO 8
L
4,ABDATA
CONTROL FOR INTERCHANGE LOOP
AR
10,4
AR
4,0
MD5
LD
0,M(4)
ACTUAL INTERCHANGE
LD
2,M(10)
STD 2,M(4)
STD 0,M(10)

47550000
47700000
47850000
48000000
48150000
48300000
48450000
48600000
48750000
48900000
49050000
49200000
49350000
49500000
49650000
49800000
49950000
50100000
50250000
50400000
50550000
50700000
50850000
51000000
51150000
51300000
51450000
51600000
51750000
51900000
52050000
3070 52200000
3070 52350000
52500000
52650000
52800000
52950000
53100000
53250000
53400000
53550000
53700000
53850000
54000000
54150000
54300000
54450000
54600000
54750000
54900000
55050000
55200000
55350000
55500000
55650000
55800000
55950000
56100000
56250000
56400000

NOCOLI
*

*
*
NOROWI

MD11

*
*
*
*

AR
10,2
BXLE 4,2,MD5
C
1,MDPI
BE
NOROWI
DO ROW INTERCHANGE
STM 0,3,MDTEMP
LR
3,1
AR
3,MR
L
4,YBASE
AR
4,MR
BAL LKR,MVCLOOP
L
2,NP8
L
3,MDPI
AR
3,MR
L
4,MDTEMP+4
AR
4,MR
BAL LKR,MVCLOOP
L
2,NP8
L
3,YBASE
AR
3,MR
L
4,MDPI
AR
4,MR
BAL LKR,MVCLOOP
LM
0,3,MDTEMP
READY
LR
AR
LD
STD
SDR
LD
MDR
ADR
BXLE
STD
LDR
STM
L
BALR
LM
LD
LTER
BM
LCER
STD
MDR
LD
SDR
LD
DDR
SD
LR
AR
STD

ROW LOOP

ABS POINTER TO KTH ROW

ABS POINTER TO Y
MOVE KTH ROW TO Y
ABS POINTER TO PIVOT ROW
ABS POINTER TO KTH ROW
MOVE PIVOT ROW TO KTH ROW
ABS POINTER TO Y
ABS POINTER TO PIVOT ROW
MOVE Y TO PIVOT ROW

TO DO ACTUAL HOUS. TRANSFORMATION

4,0
4,1
4,M(4)
4,AKK
CURRENT A(K,K)
0,0
2,M(4)
2,2
LOOP TO FORM SUM OF SQUARES OF
0,2
KTH COLUMN STARTING AT A(K,K)
4,2,MD11
0,SIGMA
SIGMA = SUMSQ
2,0
0,3,MDTEMP
4,=A(SQRT)
GET SQRT SIGMA
3,4
0,3,MDTEMP
4,AKK
4,4
*+6
0,0
SET SIGN OPPOSITE THAT OF AKK
0,ALFA
STORE AS ALFA
0,4
2,SIGMA
2,0
6,DONE
BETA= 1/SIGMA-ALFA*AKK
6,2
BETA IS IN F6
4,ALFA
4,0
4,1
4,M(4)
DURING REST OF CALC OF HOUS TRANS
A(K,K) IS AKK-ALFA

LOOP TO FORM Y VECTOR, ESSENTIALLY AN INNER PRODUCT

OF THE KTH COLUMN WITH THE LOWER RIGHT SUBMATRIX.
LR
5,0
R5 CORRESPONDS TO OUTER LOOP J

56550000
56700000
56850000
57000000
57150000
57300000
57450000
57600000
57750000
57900000
58050000
58200000
58350000
58500000
58650000
58800000
58950000
59100000
59250000
59400000
59550000
59700000
59850000
60000000
60150000
60300000
60450000
60600000
60750000
60900000
61050000
61200000
61350000
61500000
61650000
61800000
61950000
62100000
62250000
62400000
62550000
62700000
62850000
63000000
63150000
63300000
63450000
63600000
63750000
63900000
64050000
64200000
64350000
64500000
64650000
64800000
64950000
65100000
65250000
65400000

MD14

MD15

MD14A
*
*
MD17

MD18

MD17A
*
*

*
*
*
*
*
*
*
*
*
*
*

L
SR
B
LR
AR
LR
AR
SDR
LD
MD
ADR
AR
BXLE
MDR
L
AR
STD
QUEND
BXLE

7,NP8
7,6
MD14A
4,1
4,5
10,1
10,0
0,0
2,M(10)
2,M(4)
0,2
10,2
4,2,MD15
0,6
4,YBASE
4,5
0,M(4)

CHANGE COLUMN LIMIT TO N+P

5,6,MD14

INCR J AND LOOP

FINAL I VALUE
R10 I INDEX FOR A(I,K)
S = 0
A(I,K)
*A(I,J)
S = S+PRODUCT
INCREMENT I FOR KTH COL
INCR I FOR JTH COL & LOOP
S = S*BETA
Y(J) = S

LOOP TO FORM OUTER PRODUCT AND SUBTRACT

LR
5,0
SAME LOOP STRUCTURE AS ABOVE
B
MD17A
L
4,YBASE
AR
4,5
LD
6,M(4)
F6 = Y(J)
LR
4,1
AR
4,5
INITIALIZE I
LR
10,1
AR
10,0
LD
2,M(4)
A(I,J)
LD
0,M(10)
A(I,K)
MDR 0,6
*Y(J)
SDR 2,0
STD 2,M(4)
STORE NEW A(I,J)
AR
10,2
INCR I IN 2 FORMS
BXLE 4,2,MD18
AND LOOP
QUEND
BXLE 5,6,MD17
INCR J AND LOOP
RESTORE K,K ELEMENT & LOOP TO NEXT HOUS. TRANSFORMATION
LR
4,0
AR
4,1
LD
0,ALFA
STD 0,M(4)
A(K,K) = ALFA
A
1,NP8
AR
0,6
INCR K IN R0,R1
C
0,N8
BL
TRNGIZE
BACK
R0 =
R1 =
R2 =
R3 =
R4 =
R5 =
R6 =
R7 =
R8 =

SOLVE IN PLACE ONE COLUMN AT A TIME

L,RIGHT HAND SIDE CNTR STORED AS 8*(N+L)
I COLUMN INDICATOR
I ROW INDICATOR
I COL DECREMENT AND LIMIT -8
TEMP
J COL INDICATOR (INNER LOOP)
J COL INCREMENT
8
J COL LIMIT
I ROW INCREMENT NP8

65550000
65700000
65850000
66000000
66150000
66300000
66450000
66600000
66750000
66900000
67050000
67200000
67350000
67500000
67650000
67800000
67950000
68100000
68250000
68400000
68550000
68700000
68850000
69000000
69150000
69300000
69450000
69600000
69750000
69900000
70050000
70200000
70350000
70500000
70650000
70800000
70950000
71100000
71250000
71400000
71550000
71700000
71850000
72000000
72150000
72300000
72450000
72600000
72750000
72900000
73050000
73200000
73350000
73500000
73650000
73800000
73950000
74100000
74250000
74400000

*
NEXTL

MD25

MD26

FIN26

*
*

MD30

R10 USED AS TEMPORARY

L
0,N8
L
1,N8
LA
3,8
LCR 3,3
AR
1,3
L
8,NP8
LR
2,8
MH
2,N+2
SR
2,8
A
2,ABDATA
L
4,YBASE
AR
4,1
LR
5,1
AR
5,2
L
7,N8
SR
7,6
AR
7,2
LR
10,2
AR
10,0
LD
0,M(10)
LR
10,4
AR
10,6
BXH 5,6,FIN26
LD
2,M(5)
MD
2,M(10)
SDR 0,2
AR
10,6
B
MD26
LR
10,2
AR
10,1
DD
0,M(10)
STD 0,M(4)
SR
2,8
AR
4,3
QUEND
BXH 1,3,MD25

EQUIVALENT TO L=0

R2 POINTS TO NTH ROW

R4 POINTS TO Y(N)
SET R5-R7 TO CONTROL INNER LOOP

ROW POINTER
PLUS N+L
F0 = A(I,N+L)
INITIALIZE R10 FOR Y POINTER
INCR AND TEST END OF LOOP
F0 = F0-A(I,J)*Y(J)
LOOP
ROW POINTER
COLUMN POINTER
F0 = F0/A(I,I)
Y(I) = F0
DECREMENT ROW POINTER
DECR COL POINTER AND LOOP

RESCALE AND UNDO INTERCHANGES

L
1,PPBASE
L
5,N8
SR
5,6
SRL 5,1
AR
5,1
R5 IS LIMIT FOR POINTER TO PP
L
7,YBASE
BASE FOR Y
LA
4,4
R4 NOW INCR FOR PP POINTER
L
10,M(1)
J = 8*PP(I)
LR
3,10
A
3,FACTBASE
POINTER TO FACTOR(J)
MH
10,NP8+2
CHANGE R10 TO ROW POINTER
SRL 10,3
DIVIDE OUT EXTRA FACTOR OF 8
A
10,ABDATA
AR
10,0
LD
0,M(7)
F0 = Y(I)
DD
0,M(3)
F0 = F0/FACTOR(J)
STD 0,M(10)
A(J,N+L) = F0
AR
7,6
BXLE 1,4,MD30
INCR I AND LOOP
AR
0,6
C
0,NP8

74550000
74700000
74850000
75000000
75150000
75300000
75450000
75600000
75750000
75900000
76050000
76200000
76350000
76500000
76650000
76800000
76950000
77100000
77250000
77400000
77550000
77700000
77850000
78000000
78150000
78300000
78450000
78600000
78750000
78900000
79050000
79200000
79350000
79500000
79650000
79800000
79950000
80100000
80250000
80400000
80550000
80700000
80850000
81000000
81150000
81300000
81450000
81600000
81750000
81900000
82050000
82200000
82350000
82500000
82650000
82800000
82950000
83100000
83250000
83400000

BL
*
*

MOVEOVER

*
*
CLEANUP

*
*
*
*
*
*
*
MVCLOOP

MOVEIT
EXFINM
MDMVC
*
*
LENERR
RANKERR
INDXERR
RNGERR
ERRXIT

NEXTL

LOOP FOR NEXT RIGHT HAND SIDE

83550000
83700000
MOVE RESULT TO FRONT OF M-ENTRY
83850000
L
10,RBASE
84000000
LA
10,12(10)
84150000
A
10,RRANK
R10 POINTS TO FIRST WORD OF RESULT 84300000
L
5,ABDATA
84450000
L
6,NP8
84600000
LR
7,6
84750000
MH
7,N+2
84900000
AR
7,5
R7 IS ROW LIMIT
85050000
A
5,N8
85200000
L
2,P8
85350000
LR
3,5
85500000
AR
3,MR
ABS POINTER TO ROW OF B PART
85650000
LR
4,10
85800000
AR
4,MR
ABS POINTER TO ROW OF RESULT
85950000
BAL LKR,MVCLOOP
MOVE ONE ROW
86100000
A
10,P8
86250000
BXLE 5,6,MOVEOVER
ROW LOOP
86400000
86550000
FINISH RESULT SETUP AND RESET MX
86700000
ST
10,MX
CUT BACK MX TO END OF RESULT
86850000
L
6,RBASE
87000000
LR
1,10
87150000
SR
1,6
87300000
ST
1,M+4(6)
STORE BYTE COUNT FOR RESULT M-ENTRY 87450000
L
3,RRANK
87600000
ST
3,M+8(6)
STORE RESULT RANK
87750000
LA
3,3
87900000
STC 3,MTYPE(6)
STORE RESULT TYPE - FLOATING
88050000
L
LKR,MDLKR
88200000
BR
LKR
RETURN
88350000
88500000
GENERAL MVC LOOP
88650000
R2 = LENGTH OF MOVE
88800000
R3 = SOURCE OF MOVE (ABSOLUTE)
88950000
R4 = SINK OF MOVE (ABSOLUTE)
89100000
R0,R1,R5 = CONTROL FOR LOOP
89250000
R0-R5 ARE DESTRYED BY THIS SUBROUTINE
89400000
LA
0,256
89550000
S
2,MD257
89700000
LA
1,0(4,2)
UPPER LIMIT FOR MVC LOOP
89850000
BM
EXFINM
DO WITH SHORT MOVE
90000000
MVC 0(256,4),0(3)
DO A LONG MOVE
90150000
AR
3,0
INCREMENT SOURCE
90300000
BXLE 4,0,MOVEIT
INCREMENT SINK
90450000
EX
2,MDMVC
FINISH WITH SHORT MOVE
90600000
BR
LKR
RETURN
90750000
MVC 0(0,4),0(3)
MOVE INDEXED BY R2
90900000
91050000
ERROR ROUTINES
91200000
LA
1,ELENGTH
91350000
B
ERRXIT
91500000
LA
1,ERANK
91650000
B
ERRXIT
91800000
LA
1,EINDEX
91950000
B
ERRXIT
92100000
LA
1,ERANGE
92250000
ICALL ERROR
92400000

*
*
MD257
ALLBUT7
DONE
EPSILON
CPUTFUZZ
*

CONSTANTS
DC
F'257'
DC
X'FFFFFFF8'
DC
D'1.0'
DC
X'3410000000000000'
16 ** -13
DC
D'0.0'
FOR SINGULARITY CHECKING

LTORG
DSECT
ORG FACTSAVE
MDLKR
DS
F
MM
DS
F
PPP
DS
F
N
DS
F
P8
DS
F
N8
DS
F
NP8
DS
F
MNP8
DS
F
MDPI
DS
F
ABDATA DS
F
YBASE
DS
F
PPBASE DS
F
FACTBASE DS
F
DYDFLAG DS
F
MAXNORM DS
D
AKK
DS
D
SIGMA
DS
D
ALFA
DS
D
MDTEMP DS
4D
LEND
EQU *
END
./ ADD
NAME=APLSMFT1
MFT1
TITLE 'APL 360-OS MFT R E S I D E N T S V C S'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
SPACE 3
IGCINIT CSECT
CVTDCB EQU X'74'
CVTBTERM EQU X'34'
TCBUSER EQU X'A8'
TCBOTC EQU X'84'
TCBFTJST EQU X'2C'
SVCOPSW EQU X'20'
SVCNPSW EQU X'60'
DCBDEBAD EQU 44
DEBDVMOD EQU 32
DEBDCBAD EQU 24
SPACE 3
BALR 9,0
USING *,9
CLI CVTDCB(3),X'20'
IS THIS MFT?
BNE IGCFAIL
KILL IT HERE.
LTR 2,0
BNZ IGCFMSK
L
5,SAVP44
L
6,8(1)
CLC 0(4,5),0(6)
BNE IGCFAIL
IGCST
ST
1,TCBUSER(4)
OPSECT

92550000
92700000
92850000
93000000
93150000
93300000
3070 93450000
93600000
93750000
93900000
94050000
94200000
94350000
94500000
94650000
94800000
94950000
95100000
95250000
95400000
95550000
95700000
95850000
96000000
96150000
96300000
96450000
96600000
96750000
96900000
97050000
97200000
01330000
02660000
03990000
05320000
06650000
07980000
09310000
10640000
11970000
13300000
14630000
15960000
17290000
18620000
19950000
21280000
22610000
23940000
25270000
26600000
27930000
29260000
30590000
31920000
33250000
34580000
35910000

L
5,TCBOTC(4)
C
5,TCBFTJST(4)
BNE IGCFAIL APL HAS A TWO TASK STRUCTURE
ST
1,TCBUSER(5)
BR
14
IGCFMSK X
0,DEBDCBAD(1)
N
0,=A(X'FFFFFF')
BNZ IGCFAIL
LR
0,1
X
0,DCBDEBAD(2)
N
0,=A(X'FFFFFF')
BNZ IGCFAIL
MVI DEBDVMOD(1),0
BR
14
DROP 9
SPACE 3
DC
0D'0'
DOUBLE WORD ALIGNMENT NEEDED FOR MFT
ENTRY IGCMAP
IGCMAP BALR 9,0
USING *,9
L
5,SAVP44
L
2,TCBUSER(4)
LM
6,8,0(2)
CLC 0(4,5),0(8)
BNE IGCFAIL
MVC 0(8,6),SVCOPSW
ST
7,SVCOPSW+4
NC
SVCOPSW(4),SVCNPSW
BR
14
DROP 9
SPACE 3
*
* THIS IS AN INVALID CALL TO THE APL SVC'S
*
THE CALLING TASK WILL BE TERMINATED
*
WITH A S-FXX ABEND, WHERE XX IS THE SVC NUMBER
*
IGCFAIL LR
0,4
ADDRESS OF TCB TO BE TERMINATED
LA
1,X'F00'
IC
1,SVCOPSW+3
GET SVC CODE
SLL 1,12
L
15,CVTBTERM(3)
BR
15
SPACE 3
EXTRN SVCSAV
SAVP44 DC
A(SVCSAV+44)
LTORG
END
./ ADD
NAME=APLSMIBM
MIBM
TITLE 'MONADIC I-BEAM -- MOSTLY NONPRIV SYSTEM INFO 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
EXMHIST CSECT
EXTRN ERROR
EXTRN FETCHINT
EXTRN GCOL
EXTRN GETIME
EXTRN HDIR
EXTRN IODCON
EXTRN OPSPACE

37240000
38570000
39900000
41230000
42560000
43890000
45220000
46550000
47880000
49210000
50540000
51870000
53200000
54530000
55860000
57190000
58520000
59850000
61180000
62510000
63840000
65170000
66500000
67830000
69160000
70490000
71820000
73150000
74480000
75810000
77140000
78470000
79800000
81130000
82460000
83790000
85120000
86450000
87780000
89110000
90440000
91770000
93100000
94430000
95760000
97090000
98420000
00270000
00540000
00810000
01080000
01350000
01890000
02160000
02430000
02700000
02970000
03240000
03510000

EXTRN SUPPARS
MAPPED BY SUPPARD DSECT
2230
PRINT OFF APLDEFN, ZSYMBOLS, OPSECT, PERTERM, APLSUPC 2230
APLSUPC ,
MAPS SUPPARS AREA IN APLSUP
2230
EQU 0
AVOIDS ASM ERROR
2230
COPY APLDEFN
COPY ZSYMBOLS
COPY OPSECT
COPY PERTERM
TITLE 'MONADIC I-BEAM -- MOSTLY NONPRIV SYSTEM INFO 05/11/70'
PRINT ON,NOGEN

03780000
04050000
04320000
VALCON
04590000
04860000
05130000
05400000
05670000
05940000
06210000
*
06480000
*
IBEAM OPERANDS
06750000
*
07020000
*
0-18 HISTOGRAMS
07290000
*
19
CUMULATIVE KEYING TIME IN 60THS
07560000
*
20
TIME OF DAY IN 60THS OF SECONDS.
07830000
*
21
COMPUTE TIME SINCE SIGNON IN 60THS.
08100000
*
22
STORAGE REMAINING (MINGL+SVI-MX).
08370000
*
23
NUMBER OF USERS SIGNED ON.
08640000
*
24
USER'S SIGN ON TIME.
08910000
*
25
DATE.
09180000
*
26
CURRENT VALUE OF LINE COUNTER.
09450000
*
27
LINE COUNTER STACK.
09720000
*
28
TERMINAL TYPE CODE
09990000
*
29
USER ACCOUNT NUMBER
10260000
*
10530000
*
99
FETCH I/O DEBUG TRACE TABLE
10800000
*
11070000
SPACE
11340000
EXMHIST CSECT
11610000
USING *,9
11880000
USING OPSECT-16,LR
12150000
ST
LKR,TEMPRES
SAVE LINK.
12420000
SPACE
12690000
L
2,RHXRHO
MAKE SURE RH OPERAND IS 1 ELEMENT. 12960000
BCT 2,RANKERR
IF NOT 1 ELEMENT, RANK ERROR
13230000
*
R2 = 0 NOW FOR FETCHINT (ARG 1)
13500000
L
4,RHBASE
OTHERWISE, FETCH IT.
13770000
A
4,RHRANK
14040000
LA
4,MRHO-M(4)
14310000
L
3,RHTYPE
14580000
ICALL FETCHINT
NOW HAVE IT IN R0.
14850000
SPACE
15120000
LTR 8,0
TEST FOR NEGATIVE.
15390000
BM
RNGERR
BRANCH IF SO.
15660000
C
8,HST19
SEE IF HISTOGRAMS ARE DESIRED
15930000
BL
IBHIST
IF SO, GO DO IT
16200000
C
8,HST99
SEE IF SYSTEM PROGRAMMER INFORMATION 16470000
*
IS DESIRED.
16740000
BE
CEIODBUG
YES, I/O TRACE
17010000
*
DROP THRU TO USER INFORMATION IBEAMS
17280000
EJECT
17550000
*
17820000
*
MISCELLANEOUS INFORMATION -- IBEAM 19 THRU 29
18090000
*
18360000
S
8,HST19
GET DOWN INTO RANGE
18630000
SLL 8,2
MULTIPLY OPERAND BY 4.
18900000
C
8,IBEND
SEE IF IT EXISTS.
19170000
BNL RNGERR
BRANCH IF NOT.
19440000
L
5,IBTAB(8)
PICK UP ROUTINE ADDRESS
19710000

AR
TM
BCR

8,9
CONVERT INDEX TO ABS ADDR
20250000
IBTAB-EXMHIST(8),VECTRSLT IF VECT RESULT, DON'T GET
20520000
1,5 BOR
SPACE FOR SCALER, LET HIM GET SPACE. 20790000
*
21060000
*
GETSPACE FOR SCALAR INTEGER RESULT.
21330000
*
21600000
LA
1,1
NEED SPACE FOR 1 ELEMENT.
21870000
SR
2,2
SCALAR.
22140000
LA
3,2
INTEGER.
22410000
L
10,=A(OPSPACE)
GET ENTRY TO COMMON GETSPACE.
22680000
BALR LKR,10
AND CALL IT.
22950000
SPACE
23220000
ST
1,RBASE
SAVE THE M-POINTER.
23490000
L
2,TPRANK0
23760000
ST
2,MTYPE(1)
INTEGER TYPE, SCALAR RANK
24300000
LA
7,MRHO-M(1)
POINTER TO RESULT ELEMENT.
24570000
ST
7,RESORG
24840000
L
4,MPTBASE
LOAD PERTERM BASE IN CASE NEEDED
25110000
BR
5
JUMP INTO APPROPRIATE ROUTINE
25380000
EJECT
25650000
*
25920000
*
CUMULATIVE KEYING TIME IN 60THS
26190000
*
26460000
IBKTIME L
1,PTMTIM3-PERTERM(4)
26730000
IBTCOM A
1,HST3
ROUND UP TIME
27000000
SR
0,0
CLEAR HIGH REGISTER
27270000
D
0,HST5
CONVERT TO 60THS
27540000
IBXIT
ST
1,M(7)
STORE RESULT
27810000
L
LKR,TEMPRES
AND RETURN.
28080000
BR
LKR
28350000
SPACE 2
28620000
*
28890000
*
TIME OF DAY IN 60THS OF SECONDS.
29160000
*
29430000
IBTOD
ICALL GETIME
GET TIME OF DAY IN TIMER UNITS (R1) 29700000
B
IBTCOM
29970000
SPACE 2
30240000
*
30510000
*
COMPUTE TIME SINCE SIGNON IN 60THS OF SECONDS.
30780000
*
31050000
IBCT
SVCC YYQZ
FORCE APLSUP TO UPDATE CPU TIME
31320000
L
1,PTICTME-PERTERM(4) COMPUTE TIME THIS INTERVAL
31590000
A
1,PTABTM-PERTERM(4) ADD ACTUAL BILLING TIME
31860000
B
IBTCOM
32130000
SPACE 2
32400000
*
32670000
*
UNUSED STORAGE IN BYTES.
32940000
*
33210000
IBSTRG L
1,SVI
BOTTOM OF STAC2.
33480000
S
1,MX
TOP OF M-ENTRIES.
33750000
A
1,MINGL
UNCOLLECTED GARBAGE.
34020000
B
IBXIT
34290000
SPACE 2
34560000
*
34830000
*
NUMBER OF USERS SIGNED ON.
35100000
*
35370000
IBUSERS L
4,=A(SUPPARS)
2230 35640000
LM
4,6,PTBXLE-SUPPARD(4)
2230 35910000
USING PERTERM,6
36180000
SR
1,1
INITIALIZE RESULT
36450000

ALOOP
LPEND

B
TM
BO
LA
BXLE
DROP
B
SPACE

LPEND
IOB1,NSIGNM
LPEND
1,1(1)
6,4,ALOOP
6
IBXIT
2

DON'T COUNT OPERATOR.

TEST FOR SIGN ON.
BRANCH IF NOT.
OTHERWISE, INCREMENT COUNT
LOOP.

*
*
*
IBSOT

SIGN ON TIME.

*
*
*
IBDATE

PRESENT DATE.

*
*
*
IBSTAR

CURRENT VALUE OF LINE COUNTER.

L
1,PTSOTM-PERTERM(4) PICK UP SIGN ON TIME
B
IBTCOM
SPACE 2

L
MVC
TR
TR
PACK
CVB
B
SPACE

L
LH
B
SPACE

1,=V(ZSYMDATE)
GET POINTER TO DATE IN ZSYMBOLS.
DBLSAVE(6),COMPTR MOVE IN A COMPRESSION TANLE,
DBLSAVE(6),0(1)
COMPRESS OUT SLASHES.
DBLSAVE(6),TRDAT
DBLHOLD(8),DBLSAVE(6)
1,DBLHOLD
CONVERT TO BINARY INTEGER
IBXIT
2

3,PARREL
1,STLINE(MR,3)
IBXIT
2

*
*
LINE POINTER STACK.
*
*
RUN BACK THROUGH STFREG,
*
IBLSTACK SR
6,6
L
3,PARREL
IBLSTK1 L
3,STFREG(MR,3)
LTR 3,3
BZ
IBLSTK3
LA
6,4(6)
B
IBLSTK1
IBLSTK3 BAL 8,GETVECT
L
3,PARREL
IBLSTK5 LH
2,STLINE(MR,3)
L
3,STFREG(MR,3)
LTR 3,3
BCR 8,LKR BZR
ST
2,0(7)
LA
7,4(7)
B
IBLSTK5
*
*
*
*
TERMINAL TYPE CODE
*
*
1 = 2741 2 = TS41
*

GO THROUGH PARREL,
TO PICK UP CURRENT LINE COUNTER.

GETTING STLINE AT EACH LEVEL.

FIRST WE COUNT THE ENTRIES
STFREG POINTS TO NEXT ENTRY
IF ZERO, NO MORE
INCRIMENT BYTE COUNT
GET SPACE FOR VECTOR RESULT
PICK UP LINE NUMBER
STFREG POINTS TO NEXT ENTRY
ZERO MEANS WE'RE DONE
SAVE RESULT
POINT TO NEXT RESULT

3 = 1050 4 = 1052-7

36720000
36990000
37260000
37530000
37800000
38070000
38340000
38610000
38880000
39150000
39420000
39690000
39960000
40230000
40500000
40770000
41040000
41310000
41580000
41850000
42120000
42390000
42660000
42930000
43200000
43470000
43740000
44010000
44280000
44550000
44820000
45090000
45360000
45630000
45900000
46170000
46440000
46710000
46980000
47250000
47520000
47790000
48060000
48330000
48600000
48870000
49140000
49410000
49680000
49950000
50220000
50490000
50760000
51030000
51300000
51570000
51840000
52110000
52380000
52650000

IBTTYPE SR
1,1
PICK UP PTTYPE CODE
IC
1,PTTYPE-PERTERM(4)
LA
1,PERDEVXL-4(1)
SCALE FOR ORIGIN-1 INDEXING
SR
0,0
D
0,=A(PERDEVXL)
IC
1,IBTTTAB-1(1)
CONVERT TO OUR CODE NUMBER
B
IBXIT
*
*
*
*
USER ACCOUNT NUMBER
*
IBMANNO L
1,PTMAN-PERTERM(4)
B
IBXIT
*
*
*
*
*
OBTAIN HISTOGRAMS FROM APLSUP
*
IBHIST BAL 7,PRIVTEST
USER MUST BE PRIVILEGED.
SLL 8,3
MULTIPLY BY 8
L
4,=A(HDIR)
POINT TO HISTOGRAM DIRECTORY
C
8,0(4)
IS HISTOGRAM DEFINED
BNL RNGERR
NOPE, ERROR
AR
8,4
LM
5,6,4(8)
LOAD ADDRESS, COUNT
CR
5,4
IF ADDR LT HDIR, HISTOGRAM TABLES
BL
RNGERR
APPEAR TO HAVE BEEN OMITTED.
BAL 8,GETVECT
RESERVE SPACE FOR VECTOR RESULT
BAL 8,MOVER
BLAST IN INFORMATION
BR
LKR
RETURN
*
*
*
*
CEIODBUG FETCHES THE IODBUGG TABLE FROM APLSUP.
*
*
THE I/O TRACE TABLE (IODBUGG) IS A REVOLVING TRACE TABLE
*
WHICH RECORDS ALL I/O INTERRUPTS & ALL SIO DONE BY APLSUP,
*
FOR ANALYSIS IN SYSTEM & HARDWARE DEBUGGING.
*
*
IODBUGG MUST BE FETCHED WITH ALL INTERRUPTS DISABLED TO
*
GUARANTEE THE RELIABILITY OF THE RESULT. SVRAPE PUTS US
*
IN SUPERVISOR STATE, PROTECT KEY = 0, ALL INTERRUPTS DISABLED
*
(WE REALLY DON'T NEED SUPVR STATE OR KEY=0), THEREFORE WE
*
MUST BE DAMN CAREFUL IN THE FOLLOWING ROUTINE. NOTE THAT
*
SVRAPE RESERVES THE USE OF R2 & R14 FOR ITS OWN USE.
*
*
THE RESULT IS A VECTOR OF ENTRIES ORDERED FROM LEAST TO
*
MOST RECENT. SEE THE IODBUG DSECT IN APLSUP FOR THE
*
FORMAT & LENGTH OF EACH ENTRY.
*
CEIODBUG BAL 7,PRIVTEST
USER MUST BE PRIV TO ENTER THESE
L
4,=A(IODCON)
MOST SACRED GROUNDS.
LM
5,6,4(4)
LOAD START,END
SR
6,5
COMPUTE TOTAL LENGTH OF RESULT
BAL 8,GETVECT
GET SPACE FOR VECTOR RESULT
SVRAPE ,
REQUEST ANAMOLOUS PROTECTION EXCEP
BAL 1,IODBRAPE
LINK TO ROUTINE TO DO THE WORK
BR
LKR
RETURN

52920000
53190000
53460000
53730000
54000000
54270000
54540000
54810000
55080000
55350000
55620000
55890000
56160000
56430000
56700000
56970000
57240000
57510000
57780000
58050000
58320000
58590000
58860000
59130000
59400000
59670000
59940000
60210000
60480000
60750000
61020000
61290000
61560000
61830000
62100000
62370000
62640000
62910000
63180000
63450000
63720000
63990000
64260000
64530000
64800000
65070000
65340000
65610000
65880000
66150000
66420000
66690000
66960000
67230000
67500000
67770000
68040000
68310000
68580000
68850000

*
IODBRAPE LM
4,6,0(4)
PICK UP INDEX, START, END
SR
6,4
R6 = LENGTH (END-INDEX)
LR
3,5
SAVE START OVER MOVER
LR
5,4
R5 = START (INDEX)
BAL 8,MOVER
MOVE PART 1
LR
5,3
R5 = START (START)
LR
6,4
SR
6,3
R6 = LENGTH (INDEX-START)
BAL 8,MOVER
MOVE PART 2
BR
1
EXIT BACK TO SVRAPE IN APLSUP
*
*
*
GETVECT RESERVES SPACE FOR INTEGER VECTOR
*
R6 = BYTE COUNT (ACTUAL)
R8 = LINK REGISTER
*
R7 = RETURNS ADDRESS
R15 = RESTORED FROM TEMPRES
*
R0 R1 R2 R3 R10 = SCRATCHED
*
GETVECT LR
1,6
PICK UP LENGTH IN BYTES
LA
2,4
RESULT WILL BE VECTOR
LR
3,2
CHAR TYPE SAVES US A LITTLE WORK
L
10,=A(OPSPACE)
BALR LKR,10
OPSPACE REALLY GETS US THE SPACE
L
2,TPRANK
BUILD RESULT OVERHEAD AS INTEGER
ST
2,MTYPE(1)
VECTOR.
LA
2,3(6)
HE SHOULD (BUT MIGHT NOT) BE ON A
SRL 2,2
WORD MULTIPLE.
ST
2,MRHO(1)
NUMBER OF ELEMENTS IN VECTOR
LA
7,MRHO+4(1)
ST
7,RESORG
ABSOLUTE RESULT POINTER
L
LKR,TEMPRES
BR
8
*
*
*
*
MOVER BLASTS AN AREA OF CORE TO THE RESULT
*
R0 = SCRATCH (256)
R5 = FROM ADDRESS
*
R6 = COUNT (ACTUAL)
R7 = TO ADDRESS
*
R8 = LINK REGISTER
*
ON EXIT R7 IN UPDATED
*
MOVER
LA
0,256
INITIALIZE
BCTR 6,0
CONVERT TO SS COUNT
MOVEX
CR
6,0
IS COUNT LESS THAN 256
BL
MOVEZ
YES, MOVE RESIDUE (IF ANY)
MVC 0(256,7),0(5)
MOVE 256 BYTES
SR
6,0
DECREMENT COUNT BY 256
AR
5,0
INCREMENT FROM ADDR BY 256
AR
7,0
INCREMENT TO ADDR BY 256
B
MOVEX
LOOP BACK FOR MORE
*
MOVEZ
LTR 6,6
EVERYTHING MOVED
BCR 4,8 BL
YES, RETURN
EX
6,MOVESOME
NOT QUITE DONE, MOVE RESIDUE
LA
7,1(6,7)
INCREMENT TO ADDR BY RESIDUE
BR
8
DONE, RETURN
SPACE 3
*
PRIVTEST REJECTS WITH ERROR ANY USER NOT PRIVILEGED.
*
PRIVTEST L
2,=A(SUPPARS)
ADDR OF SUPERVISOR PARMS
2230

69120000
69390000
69660000
69930000
70200000
70470000
70740000
71010000
71280000
71550000
71820000
72090000
72360000
72630000
72900000
73170000
73440000
73710000
73980000
74250000
74520000
74790000
75060000
75600000
75870000
76140000
76410000
76680000
76950000
77220000
77490000
77760000
78030000
78300000
78570000
78840000
79110000
79380000
79650000
79920000
80190000
80460000
80730000
81000000
81270000
81540000
81810000
82080000
82350000
82620000
82890000
83160000
83430000
83700000
83970000
84240000
84510000
84780000
85050000
85320000

*
*
*
RNGERR

L
USING
TM
BCR

2,PTBASE-SUPPARD(2) ADDR OF PERTERM FOR CURR USER 2230

PERTERM,2
IOB1,PRIVBIT
DOES HE HAVE FULL PRIV
1,7 BOR
YES, HE'S OK
NOPE, FALL THRU TO ERROR MESSAGE

LA
B

1,ERANGE
ERRORXIT

RANGE ERROR (DOMAIN ERROR) REPORT

*
RANKERR LA
1,ERANK
RANK ERROR REPORT
ERRORXIT ICALL ERROR
EJECT
*
*
CONSTANTS AND LIKE THAT.
*
SPACE
MOVESOME MVC 0(0,7),0(5)
SPACE
HST3
DC
F'3'
HST5
DC
F'5'
HST19
DC
F'19'
HST99
DC
F'99'
*
VECTRSLT EQU X'01'
IBEND
DC
A(IBTEND-IBTAB)
IBTAB
EQU *
ORDER IS IMPORTANT.
DC
A(IBKTIME)
19
DC
A(IBTOD)
20
DC
A(IBCT)
21
DC
A(IBSTRG)
22
DC
A(IBUSERS)
23
DC
A(IBSOT)
24
DC
A(IBDATE)
25
DC
A(IBSTAR)
26
DC
AL1(VECTRSLT)
27
DC
AL3(IBLSTACK)
27
DC
A(IBTTYPE)
28
DC
A(IBMANNO)
29
IBTEND EQU *
SPACE
FRACMASK DC
X'00FFFFFF'
TPRANK0 DC
X'02000000'
TPRANK DC
X'02000004'
IBTTTAB DC
AL1(2,1,0,3,4)
TS41,2741,AMBIG,1050,1052
PERDEVXL EQU X'14'
LENGTH OF PERDEVXG ENTRY
COMPTR DC
X'000103040607'
TRDAT
EQU *-Z0
DC
C'0123456789'
*
LTORG
END
./ ADD
NAME=APLSMRIO
MRIO
TITLE 'M O N A D I C R H O A N D I O T A
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXMIOTA CSECT
COPY APLDEFN

85590000
85860000
86130000
86400000
86670000
86940000
87210000
87480000
87750000
88020000
88290000
88560000
88830000
89100000
89370000
89640000
89910000
90180000
90450000
90720000
90990000
91260000
91530000
91800000
92070000
92340000
92610000
92880000
93150000
93420000
93690000
93960000
94230000
94500000
94770000
95040000
95310000
95580000
95850000
96120000
96390000
96660000
96930000
97200000
97470000
97740000
98010000
98280000
98550000
98820000
99090000
99360000
00980000
01960000
02940000
03920000
05880000
06860000
07840000

COPY OPSECT
PRINT ON,NOGEN
TITLE 'M O N A D I C R H O A N D I O T A
05/11/70'
EXTRN OPSPACE
EXTRN FETCH
EXTRN ERROR
EXMIOTA CSECT
, INTERVAL VECTOR GENERATOR
USING *,9
USING OPSECT-16,LR
ST
LKR,DBLSAVE
SAVE LINK.
L
1,RHXRHO
WE'RE GETTING SPACE.
C
1,OC1
OPERAND MUST HAVE 1 ELEMENT.
LA
1,ERANK
BNE RANKEROR
TOO BAD.
L
4,RHBASE
GET BASE.
LA
4,MRHO-M(4)
ADD IN HEAD LENGTH.
A
4,RHRANK
AND RANK.
L
3,RCTYPE
PICK UP CONVERSION TYPE.
SR
2,2
WANT FIRST ELEMENT.
ICALL FETCH
SO FETCH IT.
LTR 0,0
BNL GIVEM
TEST FOR NEGATIVE.
LA
1,ERANGE
IF TRUE, DOMAIN ERROR
RANKEROR EQU *
ICALL ERROR
GIVEM
EQU *
ST
0,LHXRHO
AND SAVE IT.
LR
1,0
MOVE TO R1.
LA
2,4
RANK IS VECTOR.
LA
3,2
TYPE IS INTEGER.
L
10,=A(OPSPACE)
GET ENTRY INTO COMMON GETSPACE.
BALR LKR,10
AND ENTER IT.
LA
7,MRHO(1)
ABSOLUTE PTR TO RESULT.
L
6,LHXRHO
PICK UP OUR COUNT.
ST
6,MRHO(1)
LTR 6,6
BNH HEDEM
IF ZERO OR NEG, EMPTY VECTOR.
IOTEM
LR
5,6
SLL 5,2
LR
8,6
MOVE VALUE OVER.
BCTR 8,0
DECREMENT IT BY 1.
A
8,IORIGIN
ADD INDEX ORIGIN.
ST
8,0(7,5)
STORE RESULT.
BCT 6,IOTEM
HEDEM
EQU *
L
6,TWO4
INTEGER TYPE, RANK 4.
ST
6,MTYPE(1)
L
LKR,DBLSAVE
PICK UP LINK.
BR
LKR
AND RETURN.
*
OC1
DC
F'1'
TWO4
DC
X'02000004'
EJECT
*
*
MONADIC RHO - RANK VECTOR.
*
EXMRHO EQU *
ENTRY EXMRHO
USING *,9
USING OPSECT-16,LR

08820000
09800000
10780000
11760000
12740000
13720000
14700000
15680000
16660000
17640000
18620000
19600000
20580000
21560000
22540000
23520000
24500000
25480000
26460000
27440000
28420000
29400000
30380000
31360000
32340000
33320000
34300000
35280000
36260000
37240000
38220000
39200000
40180000
41160000
42140000
43120000
44100000
45080000
46060000
47040000
48020000
49000000
49980000
50960000
51940000
53900000
55860000
56840000
57820000
58800000
59780000
60760000
61740000
62720000
63700000
64680000
65660000
66640000
67620000
68600000

DUNIT

ST
L
SRL
LA
LA
L
BALR
LR
L
ST
L
LR
SRA
ST
BZ
L
LA
LA
BCTR
EX
L
BR

LKR,DBLSAVE
1,RHRANK
1,2
2,4
3,2
10,=A(OPSPACE)
LKR,10
7,1
6,TOO4
6,MTYPE(7)
6,RHRANK
4,6
6,2
6,MRHO(7)
DUNIT
5,RHBASE
5,MRHO(5)
7,MRHO+4(7)
4,0
4,MOVEMIN
LKR,DBLSAVE
LKR

SAVE LINK.
PICK UP OPERAND RANK.
DIVIDE BY 4 TO GET ELEMENTS.
RANK IS VECTOR.
TYPE IS INTEGER.
PICK UP ENTRY TO COMMON GETSPACE.
AND ENTER IT.
RANK AND TYPE.
AND PUT THEM IN.
PICK UP OPERAND RANK AGAIN.
SAVE THIS.
DIVIDE BY 4.
INTO FIRST DIMENSION.
PICK UP RH M-POINTER.
ABSOLUTE POINTER.
ABSOLUTE PTR TO RESULT.
TAKE ACRE OF OFFSET.
MOVE IN RANK VECTOR.
PICK UP LINK.
AND RETURN.

*
MOVEMIN MVC 0(0,7),0(5)
MOVER.
DC
0F'0'
TOO4
DC
X'02000004'
EJECT
LTORG
EJECT
END
./ ADD
NAME=APLSMSOP
MSOP
TITLE 'M I S C M A T H S C A L A R O P S
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
GBLB &HIPREC
&HIPREC = 1 IF HIGH PRECISION TAN &
*
TANH ROUTINES (WHICH USE MORE CORE)
*
ARE DESIRED.
&HIPREC SETB (1)
&HIPREC SETB (0)
PRINT OFF
COPY APLDEFN
MSCOPS&HIPREC CSECT
COPY APLDEFN
TITLE 'EXCIRCLE
A P L / 3 6 0
D Y A D I C
C I R C L E'
PRINT ON,NOGEN
MSCOPS&HIPREC CSECT
*
*
DYADIC CIRCLE FUNCTION
*
*
CALL GR1 = LEFT ARGUMENT (INTEGER)
*
FR2 = RIGHT ARGUMENT (DOUBLE FLOATING)
*
*
RETN FR0 = RESULT (DOUBLE FLOATING)
*
*
EXTRN ERROR
ENTRY EXCIRCLE
USING *,9
PROGRAM BASE
USING LOCAL,TLR
SCRATCH AREA
EXCIRCLE ST
LKR,SAVELKR
SAVE LKR IN CASE WE CALL SOMEONE

69580000
70560000
71540000
72520000
73500000
74480000
75460000
76440000
77420000
79380000
80360000
81340000
82320000
83300000
84280000
85260000
86240000
87220000
88200000
89180000
90160000
91140000
92120000
93100000
94080000
95060000
96040000
97020000
98000000
98980000
00060000
00120000
00180000
00240000
00300000
00360000
00420000
00480000
00540000
00660000
00720000
00780000
00840000
00900000
00960000
01020000
01080000
01140000
01200000
01260000
01320000
01380000
01440000
01500000
01560000
01620000
01680000
01740000
01800000

STD
LPDR
AD
AW
STD
AD
LPDR
SDR
LPER
CD
BH
L
CD
BH
LCR
LD
LA
CL
BNL
AR
LH
B

2,BUFF
SAVE ARG FOR POSSIBLE FUTURE TESTS
2,0
GET POSITIVE COPY
2,CNVTFUZZ
ADD ABSOLUTE FUZZ
2,DUNZERO
TRUNCATE
2,BUFF2
STORE INTEGER
2,DUNZERO
RENORMALIZE
4,0
GET POSITIVE COPY OF ARG
2,4
GET REMAINDER
2,2
2,CNVTFUZZ
RNGERR
DOMAIN ERROR IF LARGER THAN FUZZ
1,BUFF2+4
GICK UP INTEGER IN R1
0,LNV
COMPARE WITH -.69....
*+6
COMPLEMENT IF NECESSARY
1,1
2,BUFF
RESTORE RIGHT ARGUMENT
1,((CIRCZERO-CIRCLOW)/2)(1) MAKE ALL VALID ARG +, 0
1,=A((CIRCHIGH-CIRCLOW)/2) IS ARGUMENT WITHIN DOMAIN?
RNGERR
NO, DOMAIN ERROR
1,1
LOOK UP ROUTINE DISPLACEMENT
1,CIRCLOW(1)
EXCIRCLE(1)

*
*
DYADIC CIRCLE TRANSFER VECTOR
*
CIRCLOW DS
0H
DC
AL2(ATANH-EXCIRCLE) -7 HYPERBOLIC ARC TANGENT
DC
AL2(ACOSH-EXCIRCLE) -6 HYPERBOLIC ARC COSINE
DC
AL2(ASINH-EXCIRCLE) -5 HYPERBOLIC ARC SINE
DC
AL2(CIRM4-EXCIRCLE) -4 ((X**2)-1)**.5
DC
AL2(ATAN-EXCIRCLE)
-3 ARC TANGENT
DC
AL2(ACOS-EXCIRCLE)
-2 ARC COSINE
DC
AL2(ASIN-EXCIRCLE)
-1 ARC SINE
CIRCZERO DC
AL2(CIR0-EXCIRCLE)
0 (1-X**2)**.5
DC
AL2(SIN-EXCIRCLE)
+1 SINE
DC
AL2(COS-EXCIRCLE)
+2 COSINE
DC
AL2(TAN-EXCIRCLE)
+3 TANGENT
DC
AL2(CIR4-EXCIRCLE)
+4 ((X**2)+1)**.5
DC
AL2(SINH-EXCIRCLE)
+5 HYPERBOLIC SINE
DC
AL2(COSH-EXCIRCLE)
+6 HYPERBOLIC COSINE
DC
AL2(TANH-EXCIRCLE)
+7 HYPERBOLIC TANGENT
CIRCHIGH EQU *
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
-7 O X'
*
*
HYPERBOLIC ARC TANGENT
*
*
-7 CIRCLE X
*
*
1. IF /X/ GREATER OR = 0.169 USE
*
ATANH(X) = 0.5*LOG((1+X)/(1-X))
*
2. OTHERWISE USE
*
ATANH(X) = ATANH15(X)
*
ATANH
LPDR 0,2
CD
0,ATANHC9
BNL ATANHIGH
BAL 4,ATANH15
BR
LKR
ATANHIGH LD
0,ONE
LDR 4,0

01860000
01920000
01980000
02040000
02100000
02160000
02220000
02280000
02340000
02400000
02460000
02520000
02580000
02640000
02700000
02760000
02820000
02880000
02940000
03000000
03060000
03120000
03180000
03240000
03300000
03360000
03420000
03480000
03540000
03600000
03660000
03720000
03780000
03840000
03900000
03960000
04020000
04080000
04140000
04200000
04260000
04320000
04380000
04440000
04500000
04560000
04620000
04680000
04740000
04800000
04860000
04920000
04980000
05040000
05100000
05160000
05220000
05280000
05340000
05400000

SDR
ADR
DDR
ICALL
L
HDR
BR
SPACE

4,2
2,0
2,4
EXMLOG,*
LKR,SAVELKR
0,0
LKR
3

COMPUTE LOG
RETURN

*
*
ATANH15(X) = X/1-(X**2)/3-4*(X**2)/5-9*(X**2)/7-16*(X**2)/
*
9-25*(X**2)/11-36*(X**2)/13-49*(X**2)/15
*
ATANH15 LDR 6,2
MDR 6,6
LCDR 0,6
MD
0,ATANHC0
AD
0,ATANHC1
LCDR 4,6
DDR 4,0
AD
4,ATANHC2
LCDR 0,6
DDR 0,4
AD
0,ATANHC3
LCDR 4,6
DDR 4,0
AD
4,ATANHC4
LCDR 0,6
DDR 0,4
AD
0,ATANHC5
LDR 4,6
DDR 4,0
SD
4,ATANHC6
DDR 6,4
AD
6,ONE
DDR 2,6
LDR 0,2
BR
4
RETURN
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
-6 O X'
*
*
HYPERBOLIC ARC COSINE
*
*
-6 CIRCLE X
*
*
ACOSH(X) = LOG(X+SQRT(-1+X**2))
*
ACOSH
LDR 6,2
FR6 TRANSPARENT TO SQRT
MDR 2,2
SD
2,ONE
BAL 3,SQRT
SQRT (-1+X**2)
LDR 2,6
ADR 2,0
B
EXMLOG
CALL LOG (WHICH WILL THEN EXIT)
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
-5 O X'
*
*
HYPERBOLIC ARC SINE
*
*
-5 CIRCLE X
*
*
1. IF /X/ GREATER OR = 0.169 USE
*
ASINH(X) = (LOG(/X/+SQRT(1+X**2))) / X / /X/

05460000
05520000
05580000
05640000
05700000
05760000
05820000
05880000
05940000
06000000
06060000
06120000
06180000
06240000
06300000
06360000
06420000
06480000
06540000
06600000
06660000
06720000
06780000
06840000
06900000
06960000
07020000
07080000
07140000
07200000
07260000
07320000
07380000
07440000
07500000
07560000
07620000
07680000
07740000
07800000
07860000
07920000
07980000
08040000
08100000
08160000
08220000
08280000
08340000
08400000
08460000
08520000
08580000
08640000
08700000
08760000
08820000
08880000
08940000
09000000

*
*
*
ASINH

ASINHRTN

ASINHIGH

*
*
*
*
*
*
*
*
*
*
*
*
ATAN

ATANSK1

ATANSK2

2. OTHERWISE USE
ASINH = (ATAN15(/X/)/SQRT(1+X**2))/ X / /X/

09060000
09120000
09180000
LPDR 6,2
FR6 TRANSPARENT TO SQRT
09240000
MDR 2,2
09300000
AD
2,ONE
09360000
BAL 3,SQRT
SQRT (1+X**2)
09420000
CD
6,ATANHC9
09480000
BNL ASINHIGH
DETERMINE WHICH METHOD
09540000
DDR 6,0
09600000
LDR 2,6
09660000
BAL 4,ATANH15
09720000
L
LKR,SAVELKR
09780000
TM
BUFF,X'80'
RESULT = RESULT * SIGNUM (X)
09840000
BCR 8,LKR BZR
09900000
LCER 0,0
09960000
BR
LKR
RETURN
10020000
ADR 0,6
METHOD1
10080000
LDR 2,0
10140000
ICALL EXMLOG,*
COMPUTE LOG
10200000
B
ASINHRTN
10260000
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
-3 O X' 10320000
10380000
ARCTANGENT FUNCTION
10440000
10500000
-3 CIRCLE X
10560000
10620000
1. REDUCE THE CASE TO THE 1ST OCTANT BY USING
10680000
ATAN(-X) = -ATAN(X), ATAN(1/X) = PI/2-ATAN(X).
10740000
2. REDUCE FURTHER TO THE CASE /X/ LESS THAN TAN(PI/12) 10800000
BY ATAN(X) PI/6+ATAN((X*SQRT3-1)/(X+SQRT3)).
10860000
3. FOR THE BASIC RANGE ( X LESS THAN TAN(PI/12)), USE
10920000
A FRACTIONAL APPROXIMATION.
10980000
11040000
LPDR 0,2
SET SIGN POSITIVE
11100000
LD
4,ONE
11160000
SR
1,1
GR1, GR2 FOR DISTINGUISHING CASES
11220000
LA
2,ATANQQ
11280000
CER 0,4
11340000
BNP ATANSK1
11400000
LDR 2,4
IF X GREATER THAN 1, TAKE INVERSE
11460000
DDR 2,0
AND INCREMENT GR1 BY 16
11520000
LDR 0,2
11580000
LA
1,16
11640000
CE
0,UNFLO
IF ARG LESS THAN 16**-7, ANS=ARG.
11700000
BNP ATANRDY
THIS AVOIDS UNDERFLOW EXCEPTION
11760000
CE
0,TAN15
11820000
BNP ATANSK2
11880000
LDR 2,0
IF X GREATER THAN TAN(PI/12),
11940000
MD
0,RT3M1
REDUCE X TO (X*SQRT3-1)/(X+SQRT3) 12000000
SDR 0,4
COMPUTE X*SQRT3-1 AS
12060000
ADR 0,2
X*(SQRT3)-1+X
12120000
AD
2,RT3
TO GAIN ACCURACY
12180000
DDR 0,2
12240000
LA
2,8(2)
INCREMENT GR2 BY 8
12300000
LDR 6,0
COMPUTE ATAN OF REDUCED ARGUMENT BY 12360000
MDR 0,0
ATAN(X) = X+X*X**2*F, WHERE
12420000
LD
4,ATANC7
F = C1+C2/(X**2+C3+C4/
12480000
ADR 4,0
(X**2+C5+C6/(X**2+C7)))
12540000
LD
2,ATANC6
12600000

DDR 2,4
12660000
AD
2,ATANC5
12720000
ADR 2,0
12780000
LD
4,ATANC4
12840000
DDR 4,2
12900000
AD
4,ATANC3
12960000
ADR 4,0
13020000
LD
2,ATANC2
13080000
DDR 2,4
13140000
AD
2,ATANC1
13200000
MDR 0,2
13260000
MDR 0,6
13320000
ADR 0,6
13380000
ATANRDY AD
0,0(1,2)
DEPENDING ON THE CASE,
13440000
LNR 1,1
EITHER ADD 0 OR PI/6, OR
13500000
SD
0,ATANQQ(1)
SUBTRACT FROM PI/3 OR PI/2
13560000
LPER 0,0
13620000
B
ASINHRTN
RETURN WITH R = R * SIGNUM (R)
13680000
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
-1 -2 O X' 13740000
*
13800000
*
ARC SINE FUNCTION
13860000
*
13920000
*
-1 CIRCLE X
13980000
*
14040000
*
ARC COSINE FUNCTION
14100000
*
14160000
*
-2 CIRCLE X
14220000
*
14280000
*
1. IF X BETWEEN 0 AND 1/2, COMPUTE ARCSIN BY RATIONAL
14340000
*
2. IF X BETWEEN 1/2 AND 1,
14400000
*
ARCSIN(X) = PI/2-2*ARCSIN(SQRT((1-X)/2))
14460000
*
3. IF X NEGATIVE, ARCSIN(X) = - ARCSIN(/X/)
14520000
*
4. ARCCOS(X) = PI/2-ARCSIN(X)
14580000
*
14640000
ACOS
MVI SWITCH,X'00'
SET SWITCH TO COS
14700000
B
ACOSJOIN
14760000
ASIN
MVI SWITCH,X'80'
SET SWITCH TO SIN
14820000
ACOSJOIN LDR 6,2
14880000
LPDR 2,2
/X/ TO FR2
14940000
CE
2,HALF
IF /X/ SMALLER THAN 1/2, SKIP TO
15000000
BNH MINMAX
MINMAX SECTION
15060000
LNER 2,2
COMPUTE 1-/X/
15120000
AD
2,ONE
15180000
BM
RNGERR
IF /X/ GREATER THAN 1, ERROR
15240000
HDR 6,2
LET Z = SQRT((1-/X/)/2),
15300000
ADR 2,2
KEEP Z**2 IN FR6 AND COMPUTE
15360000
BAL 3,SQRT
15420000
B
ACOSMRG
MERGE WITH MINMAX EVALUTION
15480000
MINMAX OI
SWITCH,X'40'
15540000
LDR 0,2
15600000
CE
0,UNFLO
IF /X/ IS SMALLER THAN 16**-7,
15660000
BH
*+6
SUBSTITUTE 0 FOR X**2 TO AVOID
15720000
SDR 6,6
UNDERFLOW MESSAGE.
15780000
MDR 6,6
FOR /X/ LE 1/2, GET X**2 IN FR6
15840000
ACOSMRG LD
4,ACOSC5
COMMON CIRCIUT
15900000
ADR 4,6
COMPUTE ARCSIN(/X/)
15960000
LD
2,ACOSD4
OR 2*ARCSIN(Z) AS THE CASE MAY B 16020000
DDR 2,4
16080000
AD
2,ACOSC4
FR0 CONTAINS /X/ OR 2*Z
16140000
ADR 2,6
FR6 CONTAINS X**2 OR Z**2
16200000

LD
DDR
AD
ADR
LD
DDR
AD
ADR
LD
DDR
AD
MDR
MDR
TM
BNM
SD
SD

4,ACOSD3
4,2
4,ACOSC3
4,6
2,ACOSD2
2,4
2,ACOSC2
2,6
4,ACOSD1
4,2
4,ACOSC1
4,6
4,0
SWITCH,X'C0'
ACOSSIGN
4,ONE
0,PO2M1

*
ACOSSIGN ADR 0,4
LPDR 0,0
TM
BUFF,X'80'
BCR 8,LKR BZR
LNER 0,0
TM
SWITCH,X'80'
BCR 1,LKR BOR
AD
0,PI
BR
LKR
TITLE 'EXCIRCLE
D Y A D I
*
*
((X**2)+1)**.5 FUNCTION
*
*
4 CIRCLE X
*
CIR4
CD
2,K8E16
LDR 0,2
BCR 11,LKR
LD
0,ONE
LDR 4,0
SDR 0,2
ADR 4,2
MDR 2,4
ADR 2,0
B
CIRSQRT
*
*
*
(1-X**2)**.5 FUNCTION
*
*
0 CIRCLE X
*
CIR0
LD
0,ONE
LDR 4,0
SDR 0,2
ADR 2,4
MDR 2,0
B
CIRSQRT
*
*
*
((X**2)-1)**.5 FUNCTION
*
*
-4 CIRCLE X

USE MINIMAX APPROXIMATION OF FORM,

ARCSIN(W) = W+F*W**3 WHERE
F = C1+D1/(WSQ+C2+D2/(WSQ+C3+D3
/(WSQ+C4+D4/(WSQ+C5))))

POSTPONE COMBINING FR4 AND FR0

IF ARSIN FOR BIG /X/ OR
ARCOS FOR SMALL /X/, SUBTRACT
THE WORK FROM PI/2. DO THIS
CAREFULLY TO REDUCE ROUND-OFF
ERROR.
AT THIS POINT COMBINE FR6 AND FR0
TO COMPLETE COMPUTATION OF ANS FOR
/X/
IF ARG IS POSITIVE, DONE
IF ARG NEG AND ARSIN, SWITCH SIGN
IF ARG NEGATIVE AND ARCOS,
SUBTRACT FR0 FROM PI
RETURN
C I R C L E

-4 0 4 O X'

IS IT WORTH THE BOTHER?

5988
5988
BNLR -- NO, RESULT IS ARGUMENT 5988
((1-X)+(X(1+X)))*.5
5988

GO TAKE SQRT OF FR2

((1-X)*(1+X))*.5

16260000
16320000
16380000
16440000
16500000
16560000
16620000
16680000
16740000
16800000
16860000
16920000
16980000
17040000
17100000
17160000
17220000
17280000
17340000
17400000
17460000
17520000
17580000
17640000
17700000
17760000
17820000
17880000
17940000
18000000
18060000
18120000
18180000
18240000
18300000
18360000
18420000
18480000
18540000
18600000
18660000
18720000
18780000
18840000
18900000
18960000
19020000
19080000
19140000
19200000
19260000
19320000
19380000
19440000
19500000
19560000
19620000
19680000
19740000
19800000

*
CIRM4

CD
2,K8E16
SHOULD WE DO IT?
5988
LDR 0,2
5988
BCR 11,LKR
BNLR -- NO, ANSWER IS ARGUMENT 5988
LD
0,ONE
((X-1)*(X+1))*.5
5988
LDR 4,0
ADR 4,2
SDR 2,0
MDR 2,4
CIRSQRT BAL 3,SQRT
TAKE SQRT OF FR2
BR
LKR
RETURN
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
1 2 O X'
*
*
SINE FUNCTION
*
*
1 CIRCLE X
*
*
COSINE FUNCTION
*
*
2 CIRCLE X
*
*
1. DIVIDE MAGNITUDE OF ARG BY PI/4 TO FIND OCTANT
*
AND FRACTION.
*
2. IF COSINE, ADD 2 TO OCTANT NUMBER.
*
3. IF SINE, ADD 0(4) TO OCTANT NUMBER FOR +ARG(-ARG).
*
4. COMPUTE SINE OR COSINE OF FRACTION*PI/4 DEPENDING
*
ON THE OCTANT.
*
5. IF OCTANT NUMBER IS FOR LOWER PLANE, MAKE SIGN -.
*
*
*
LOW PREC TAN ASSUMES FR6 UNCHANGED BY SIN
*
COS
LA
0,2
FOR COSINE, OCTANT CRANK IS 2
*
COS(X) = SIN(PI/2+X)
B
COSMERGE
ADJUST BASE REGISTER AND MERGE
SIN
SR
0,0
FOR SINE, OCTANT CRANK IS 0 IF + ARG
*
OCTANT CRANK IS 4 IF - ARG
TM
BUFF,X'80'
SIN(-X) = SIN(PI+X)
BZ
COSMERGE
LA
0,4
COSMERGE LDR 0,2
PICK UP THE ARGUMENT
LPER 0,0
FORCE SIGN OF ARG TO +
CE
0,MAX
BNL RNGERR
ERROR IF /X/ GRT THAN OR = PI*2**50
DD
0,PIOV4
DIVIDE BY PI/4 AND SEPARATE INTEGER
LDR 2,0
PART AND FRACTION PART OF QUOTIENT
AW
2,DUNZERO
FORCE CHARACTERISTIC X'4E'
STD 2,BUFF2
INTEGER PART UNNORMALIZED = OCTANT
AD
2,DUNZERO
INTEGER PART NORMALIZED = OCTANT
SDR 0,2
FRACTION PART TO FR0
AL
0,BUFF2+4
ADJUST OCTANT NUMBER WITH CRANK
ST
0,BUFF2
AND SAVE IT
TM
BUFF2+3,X'01'
IF ODD OCTANT, TAKE COMPLEMENT
BZ
COSEVEN
OF FRACTION TO OBTAIN MODIFIED ARG
SD
0,ONE
COSEVEN LPDR 4,0
SR
1,1
GR1 = 0 FOR COSINE POLYNOMIAL
TM
BUFF2+3,X'03'
THIS IS FOR OCTANT 2, 3, 6, 7
BM
*+8
GR1 = 8 FOR SINE POLYNOMIAL
LA
1,8
THIS IS FOR OCTANT 1, 4, 5, OF 8

19860000
19920000
19980000
20040000
20100000
20160000
20220000
20280000
20340000
20400000
20460000
20520000
20580000
20640000
20700000
20760000
20820000
20880000
20940000
21000000
21060000
21120000
21180000
21240000
21300000
21360000
21420000
21480000
21540000
21600000
21660000
21720000
21780000
21840000
21900000
21960000
22020000
22080000
22140000
22200000
22260000
22320000
22380000
22440000
22500000
22560000
22620000
22680000
22740000
22800000
22860000
22920000
22980000
23040000
23100000
23160000
23220000
23280000
23340000
23400000

CE
4,UNFLO
IF X IS LESS THAN 16$$-7, SET X TO 0
BH
*+6
THIS PREVENTS UNDERFLOW
SDR 0,0
MDR 0,0
COMPUTE SINE OR COSINE OF MODIFIED
LDR 2,0
ARG USING PROPER CHEBYSHEV
MD
0,COSC7(1)
INTERPOLATION POLYNOMIAL
AD
0,COSC6(1)
MDR 0,2
SIN(X)/X POLYNOMIAL OF DEG 6 IN X**2
AD
0,COSC5(1)
COS(X) POLYNOMIAL OF DEG 7 IN X**2
MDR 0,2
AD
0,COSC4(1)
MDR 0,2
AD
0,COSC3(1)
MDR 0,2
AD
0,COSC2(1)
MDR 0,2
AD
0,COSC1(1)
LTR 1,1
BZ
COSF
MDR 0,4
COMPLETE SINE POLYNOMIAL BY
B
COSSIGN
MULTIPLYING BY X
COSF
MDR 0,2
COMPLETE COSINE POLYNOMIAL
AD
0,ONE
(ONE MORE DEGREE)
COSSIGN TM
BUFF2+3,X'04'
IF MODIFIED OCTANT IS IN
BCR 8,LKR BZR
LOWER PLANE, SIGN IS NEGATIVE
LNER 0,0
BR
LKR
RETURN
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
3 O X'
AIF (NOT &HIPREC).HIPREC5
*
*
TANGENT FUNCTION
*
*
3 CIRCLE X
*
*
1. DIVIDE MAGNITUDE OF ARG BY PI/4 TO FIND OCTANT AND
*
FRACTION. REDUCED ARGUMENT W IS EITHER THIS
*
FRACTION OR ITS COMPLEMENT. THE MAGNITUDE OF THE
*
ANSWER IS TAN(W*PI/4).
*
2. IF /ARG/ IS EQUAL OR GREATER THAN PI*2**50,
*
DOMAIN ERROR.
*
3. IF ARG IS SO CLOSE TO ONE OF SINGULARITIES OF THE
*
FUNCTION THAT THE COMBINED EFFECT OF COMPUTATIONAL
*
ERROR AND MINMAL INPUT ERROR CAN CAUSE RELATIVE
*
ERROR OF 1/5, DOMAIN ERROR.
*
TAN
MVC BUFFQ(8),INDEX
INITIALIZE TESTING GUAGE
LD
4,ONE
PRELOAD FR4 WITH 1.0
LPDR 0,2
OBTAIN /ARG/ IN FR0
CE
0,MAX
BNL RNGERR
IF /ARG/ TOO BIG, DOMAIN ERROR.
DD
0,PIOV4
LET W = /ARG/ DIVIDED BY PI/4
STE 0,BUFF2
MVC BUFFQ(1),BUFF2 GIVE CHAR OF QUOTIENT TO TESTING GUAGE
MVI BUFF2+7,X'00'
CLEAR LOW PART OF OCTANT
CER 0,4
BL
TANJOIN
LDR 2,0
IF QUOTIENT HAS INTEGER PART,
AW
2,SCALER
ISOLATE IT IN FR2 (UNNORMALIZED),
STD 2,BUFF2
SAVE IT (LAST BITS ARE FOR OCTANT)
AD
2,SCALER
NORMALIZE IT AND SUBTRACT IT FROM

23460000
23520000
23580000
23640000
23700000
23760000
23820000
23880000
23940000
24000000
24060000
24120000
24180000
24240000
24300000
24360000
24420000
24480000
24540000
24600000
24660000
24720000
24780000
24840000
24900000
24960000
25020000
25080000
25140000
25200000
25260000
25320000
25380000
25440000
25500000
25560000
25620000
25680000
25740000
25800000
25860000
25920000
25980000
26040000
26100000
26160000
26220000
26280000
26340000
26400000
26460000
26520000
26580000
26640000
26700000
26760000
26820000
26880000
26940000
27000000

SDR 0,2
FR0 TO OBTAIN FRACTION PART.
TM
BUFF2+7,X'01'
BE
TANJOIN
IF EVEN OCTANT, MODIFIED ARG W RDY
SDR 0,4
IF ODD OCTANT, W= 1-FRACTION
TANJOIN LPDR 6,0
LEAVE W IN FR6, AND + OR -W IN FR0
LD
2,TANB3
CE
6,TANUNFLO
BL
TANSKIP
LET U=WSQ IF W IS AT LEAST 2**-46
MDR 0,0
AND COMPUTE TWO POLYNOMIALS
LDR 4,0
AD
4,TANA2
P(W) = W*(A0+A1*U+A2*U**2+U**3)
MDR 4,0
AD
4,TANA1
Q(W) = B0+B1*U+B2*U**2+B3*U**3
MDR 2,0
AD
2,TANB2
IF W IS LESS THAN 2**-46, LET
MDR 2,0
U = + OR -W, AND SUBSTITUTE AS
AD
2,TANB1
FOLLOWS TO AVOID INTERMEDIATE
TANSKIP MDR 2,0
UNDERFLOW OF SQUARING W.
AD
2,TANB0
MDR 0,4
P(W) = W*(A0+U)
AD
0,TANA0
Q(W) = B0+B3*U
MDR 0,6
TM
BUFF2+7,X'03'
BM
TANXX
DDR 0,2
IF OCTANT IS 0 OR 3 (MOD 4),
B
TANSIGN
THE ANSWER IS TAN(W*PI/4)=P(W)/Q(W)
*
TANXX
CD
6,BUFFQ
IF OCTANT IS 1 OR 2 (MOD 4), AND IF
BNH RNGERR
W IS TOO SMALL, SINGULAR TROUBLE
DDR 2,0
OTHERWISE, THE ANSWER IS
LDR 0,2
COTAN(W*PI/4)=Q(W)/P(W)
*
TANSIGN TM
BUFF2+7,X'02'
IF OCTANT IS 2 OR 3 (MOD 4),
BZ
ASINHRTN
CHANGE SIGN OF ANSWER
LCER 0,0
B
ASINHRTN
*
AGO .HIPREC6
.HIPREC5 ANOP
*
*
TANGENT FUNCTION
*
*
3 CIRCLE X
*
*
TAN(X) = SIN(X)/COS(X)
*
TAN
BAL LKR,COS
COMPUTE COS(X)
LDR 6,0
FR6 TRANSPARENT TO SIN
LD
2,BUFF
BAL LKR,SIN
COMPUTE SIN(X)
DDR 0,6
TAN(X) = SIN(X)/COS(X)
L
LKR,SAVELKR
RESTORE LINK REGISTER
BR
LKR
RETURN
.HIPREC6 ANOP
TITLE 'EXCIRCLE
D Y A D I C
C I R C L E
5 6 O X'
*
*
HYPERBOLIC SINE FUNCTION
*
*
5 CIRCLE X
*

27060000
27120000
27180000
27240000
27300000
27360000
27420000
27480000
27540000
27600000
27660000
27720000
27780000
27840000
27900000
27960000
28020000
28080000
28140000
28200000
28260000
28320000
28380000
28440000
28500000
28560000
28620000
28680000
28740000
28800000
28860000
28920000
28980000
29040000
29100000
29160000
29220000
29280000
29340000
29400000
29460000
29520000
29580000
29640000
29700000
29760000
29820000
29880000
29940000
30000000
30060000
30120000
30180000
30240000
30300000
30360000
30420000
30480000
30540000
30600000

*
*
*
*
*
*
*
*
*
COSH

HYPERBOLIC COSINE FUNCTION

MVI
B
SINH
MVI
COSHJOIN LDR
LPDR
TM
BZ
CE
BNL
CE
BL
MDR
LDR
MD
AD
MDR
AD
MDR
AD
MDR
AD
MDR
AD
MDR
MDR
ADR
BR
COSHEXP1 LPER
COSHEXP2 CE
BH
AD
LDR
ST
*
ICALL
L
LD
DDR
TM
BO
LPER
B
SINHXX LNER
COSHXX LDR
ADR
MD
ADR
ADR
COSHSIGN LTER
BCR
LNER

6 CIRCLE X
SINH(X) = (E**X-E**(-1))/2
COSH(X) = (E**X+E**(-1))/2
SINH FOR SMALL X IS COMPUTED DIRECTLY BY POLYNOMIAL.
FOR OTHER CASES, ELABORATE USE OF $EXP IS MADE.
SWITCH,X'00'
COSHJOIN
SWITCH,X'01'
4,2
0,2
SWITCH,X'01'
COSHEXP1
0,LIMIT
COSHEXP2
0,COSHC6
COSHSIGN
0,0
2,0
0,COSHC6
0,COSHC5
0,2
0,COSHC4
0,2
0,COSHC3
0,2
0,COSHC2
0,2
0,COSHC1
0,2
0,4
0,4
LKR
4,4
0,MAXI
RNGERR
0,LNV
2,0
LKR,SAVELKR2
EXMEXP,*
LKR,SAVELKR2
2,VSQ
2,0
SWITCH,X'01'
SINHXX
2,2
COSHXX
2,2
6,0
0,2
0,DELTA
0,2
0,6
4,4
10,LKR
0,0

SET INSTR SWITCH TO 'COSH'

JOIN WITH COMMON CIRCUIT
SET INSTR SWITCH TO 'SINH'
OBTAIN ARG X IN FR4
/X/ TO FR0
IF COSH ENTRY, SKIP
IF SINH, AND /X/ GE 0.88137, SKIP
IF SINH, AND /X/ LE 0.1626E-9, AVOID
INTERMEDIATE UNDERFLOW, ANS = X
FOR SINH OF MODEST ARGUMENT, USE
SINH(X) = X+X*XSQ*F(XSQ)
WHERE F(XSQ) IS A POLYNOMIAL
OF DEGREE 5 IN XSQ
USE OF EXPONENTIAL FOR THESE
ARGUMENTS WOULD RESULT IN A
LOSS OF ACCURACY
RETURN
COSH(X) IS ALWAYS POSITIVE
IF /X/ TOO LARGE, GIVE ERROR
SAVE LKR AGAIN TO KEEP OUR GOOD
FRIEND LOW-PRECISION TANH HAPPY.
CALL EXP
RESTORE LINK REG
COMPUTE V**2/EXP(/X/+LOG(V))

COSH
SINH
SPECIAL MANEUVER TO MINIMIZE ROUNDING
ERROR IN EFECTIVELY EVALUATING
(E**X + OR - E**-X)/2
HERE DELTA IS SUCH THAT 1+DELTA=1/2V,
V IS CHOSEN SLIGHTLY LESS THAN 0.5
IF X IS NEGATIVE, SINH(X) = -SINH(/X/)

30660000
30720000
30780000
30840000
30900000
30960000
31020000
31080000
31140000
31200000
31260000
31320000
31380000
31440000
31500000
31560000
31620000
31680000
31740000
31800000
31860000
31920000
31980000
32040000
32100000
32160000
32220000
32280000
32340000
32400000
32460000
32520000
32580000
32640000
32700000
32760000
32820000
32880000
32940000
33000000
33060000
33120000
33180000
33240000
33300000
33360000
33420000
33480000
33540000
33600000
33660000
33720000
33780000
33840000
33900000
33960000
34020000
34080000
34140000
34200000

BR
LKR
TITLE 'EXCIRCLE
D Y A D I C
AIF (&HIPREC EQ 0).HIPREC1
*
*
*
*
*
*
*
*
*
TANH

TANHSIGN

TANHBIG
TANHSML

.HIPREC1
*
*
*
*

34260000
34320000
34380000
34440000
HYPERBOLIC TANGENT FUNCTION
34500000
34560000
7 CIRCLE X
34620000
34680000
1. IF /X/ LESS THAN 0.54931, USE A FRACTION APPROX.
34740000
2. IF /X/ GREATER THAN 20.101, ANSWER IS +1 OR -1.
34800000
3. FOR OTHER VALUE OF X, USE EXTERNAL DEXP FUNCTION.
34860000
34920000
LDR 6,2
OBTAIN ARGUMENT X
34980000
LD
4,ONE
FR4 AND FR6 TRANSPARENT TO DEXP
35040000
LPER 2,2
/X/ TO FR2
35100000
CE
2,MLIM
35160000
BNH TANHSML
IF /X/ LESS THAN 0.54931, JUMP
35220000
CE
2,HLIM
IF /X/ GREATER THAN 20.101
35280000
BNL TANHBIG
ANS = + OR -1, JUMP
35340000
ADR 2,2
FOR /X/ BETWEEN 0.54931 AND 20.101, 35400000
/ANS/ = 1-2/(1+E**/2X/)
35460000
BAL LKR,EXMEXP
CALL EXP
35520000
L
LKR,SAVELKR
35580000
ADR 0,4
35640000
LDR 2,4
35700000
ADR 2,2
35760000
DDR 2,0
35820000
LDR 0,4
35880000
SDR 0,2
35940000
LTER 6,6
TANH(/X/) READY, ADJUST SIGN
36000000
BCR 10,LKR
36060000
LNER 0,0
36120000
BR
LKR
RETURN
36180000
LDR 0,4
CASE OF BIG ARGUMENT
36240000
B
TANHSIGN
36300000
LDR 0,2
36360000
CE
2,UNFLO
IF /X/ LESS THAN 2**-28, ANS = ARG. 36420000
BC
12,TANHSIGN
36480000
MDR 0,0
/X/ SMALLER THAN 0.54931
36540000
LD
4,TANHC5
TANH(X) = X+X*F, WHERE
36600000
ADR 4,0
F = C0*X**2/(X**2+C1+C2/
36660000
LD
2,TANHC4
(X**2+C3+C4/(X**2+C5)))
36720000
DDR 2,4
36780000
AD
2,TANHC3
36840000
ADR 2,0
36900000
LD
4,TANHC2
36960000
DDR 4,2
37020000
AD
4,TANHC1
37080000
ADR 4,0
37140000
MD
0,TANHC0
37200000
DDR 0,4
37260000
MDR 0,6
37320000
ADR 0,6
37380000
BR
LKR
RETURN
37440000
AGO .HIPREC2
37500000
ANOP
37560000
37620000
HYPERBOLIC TANGENT FUNCTION
37680000
37740000
7 CIRCLE X
37800000
C I R C L E

7 O X'

*
*
*
*
*
*
TANH

TANH1

TANH2

1. IF /X/ GT 18.368400, RETURN + OR - 1.

2. IF 2 LT /X/ LE 18.368400,
TANH(X) = SIGN(X)*1-2/1+EXP( /2*X/ ).
3. IF /X/ GE 2, TANH(X) = SINH(X) / COSH(X).
LPDR
LD
CD
BH
CE
BH
BAL
LD
STD
BAL
DD
L
BR
LDR
ADR
ICALL
ADR
LD
DDR
SDR
LDR
B

0,2
6,ONE
0,TANHC18
TANH2
0,TWO
TANH1
LKR,COSH
2,BUFF
0,BUFF
LKR,SINH
0,BUFF
LKR,SAVELKR
LKR
2,0
2,2
EXMEXP,*
0,6
2,TWO
2,0
6,2
0,6
ASINHRTN

TAKE ABS VALUE OF ARG

FR 6 PRESERVED BY EXMEXP
IF ARG GT 18.36840028483855,
USE LARGE METHOD.
IF ARG BETWEEN 2 AND 18.3684002848
USE INTERMEDIATE METHOD.
COSH(X)
SINH(X)
TANH(X) = SINH(X)/COSH(X)
RETURN
INTERMEDIATE METHOD (2.)
COMPUTE EXP( /X*X/ )

RETURN R = R * SIGNUM (R)

*
.HIPREC2 ANOP
*
DROP 9,TLR
TITLE 'EXEXP
D Y A D I C
E X P O N E N T I A T I O N'
*
*
EXPONENTIATION.. C = A EXP B
*
ENTRY EXEXP
USING LOCAL,TLR
USING *,9
EXEXP
ST
LKR,SAVELKR
MVI RESSIGN,0
STM 5,8,BUFF
LD
4,ONE
USED FREQUENTLY
LTER 2,2
BP
BPOSITIV
BM
BNEG
LDR 0,4
ZERO B GIVES RESULT OF 1
BR
LKR
BNEG
LDR 6,4
B NEG, RECIPROCATE A
LTER 0,0
AND MAKE B POSITIVE
BZ
RNGERR
0*NEGATIVE GIVES DOMAIN ERROR
*
CANNOT RELY ON DIV BY 0 IN F0 GIVING DOMAIN ERROR
DDR 6,0
LDR 0,6
LPDR 2,2
BPOSITIV STD 0,A
STD 2,B
CD
2,HALF
TRAP FOR FAST SQRT
BNE BN2
LDR 2,0

37860000
37920000
37980000
38040000
38100000
38160000
38220000
38280000
38340000
38400000
38460000
38520000
38580000
38640000
38700000
38760000
38820000
38880000
38940000
39000000
39060000
39120000
39180000
39240000
39300000
39360000
39420000
39480000
39540000
39600000
39660000
39720000
39780000
39840000
39900000
39960000
40020000
40080000
40140000
40200000
40260000
40320000
40380000
40440000
40500000
40560000
40620000
40680000
40740000
40800000
40860000
40920000
40980000
41040000
41100000
41160000
41220000
41280000
41340000
41400000

BN2

*
*

*
*
*
LOOP

SKPMPY

DIDIT
*
TESTA
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

IT

BAL
B
AW
STD
LTER
BNZ
AD
SE

3,SQRT
EXPDUN
2,DUNZERO
2,DSTORE
2,2
TESTA
2,DUNZERO
2,B

41460000
41520000
IF B IS A TRUE INTEGER WE CAN DO
41580000
EFFICIENT POWERING.
41640000
41700000
MUCH TOO BIG FOR THAT
41760000
RENORMALIZE INTEGER PART OF ABS B
41820000
DON'T NEED TO COMPARE LOW-ORDER PART 41880000
SINCE NUMBER BIGGER THAN 1534 WILL 41940000
BE REJECTED ANYWAY
42000000
BNZ TESTA
NONINTEGER
42060000
L
3,DSTORE+4
NOW R3 = ABS B
42120000
CL
3,LARGINT
SEE IF B IS SMALL ENOUGH.
42180000
BH
TESTA
BRANCH IF NOT.
42240000
42300000
F0 IS STILL A
42360000
F4 IS 1.0
42420000
ST
3,FTEMP
STORE EXPONENT SO WE CAN LOOK AT IT. 42480000
TM
FTEMP+3,1
SEE IF LOW ORDER BIT IS 1.
42540000
BZ
SKPMPY
IF NOT, FORGET IT.
42600000
MDR 4,0
IF SO, MULTIPLY RES BY CUR POWER.
42660000
SRA 3,1
NOW, SHIFT EXP RIGHT ONE.
42720000
BZ
DIDIT
IF IT'S NOW ZERO, WE'RE DONE.
42780000
MDR 0,0
IF NOT, SQUARE.
42840000
B
LOOP
AND SEE IF WE NEED IT.
42900000
LDR 0,4
42960000
BR
LKR
43020000
43080000
LTER 0,0
0*POSITIVE IS JUST 0
43140000
BCR 8,LKR BZR
43200000
BP
EXPIT
43260000
43320000
HERE WE HANDLE THE CASE A LT ZERO.
43380000
DETERMINT IF B IS RATIONAL (=P/Q), THEN ..
43440000
P ODD, Q ODD, - C = -(ABS A) EXP B.
43500000
P EVEN, Q ODD - C = (ABS A) EXP B
43560000
P ODD, Q EVEN - C = UNDEFINED.
43620000
43680000
B IRRATIONAL - C = -(ABS A) EXP B
43740000
43800000
REGISTERS ..
43860000
FLOATING ..
43920000
0 - B
43980000
2 - T
44040000
4 - 1.0
44100000
6 - E
44160000
GENERAL ..
44220000
5 - N
44280000
44340000
LA
5,EXEXPLIM
MAX NUMBER OF ITERATIONS (TO AVOID 44400000
'RATIONALS' WITH ABSURDLY LARGE
44460000
NUMERATORS AND DENOMINATORS)
44520000
LD
6,RELERR
TOLERANCE FOR RATIONAL VS IRRAT
44580000
SR
4,4
ASSUME DENOMINATOR IS EVEN
44640000
LD
2,B
SET T TO B.
44700000
CDR 2,4
44760000
BNL FLOORT
INITIAL EXPONENT GEQ 1.0
44820000
LDR 0,2
LSS 1.0. INVERT IT TO GET THINGS
44880000
LA
4,3
STARTED AND ASSUME EVEN/ODD
44940000
LDR 2,4
NEXT STEP OF CONTINUED FRACTION EXPN 45000000

DDR
MDR
MDR
LDR
AW
STD
AD
SDR
LA
N
AR
IC

2,0
6,2
6,2
0,2
2,DUNZERO
2,DSTORE
2,DUNZERO
0,2
3,1
3,DSTORE+4
4,3
4,PGT(4)

DONE.
ERROR BOUND GROWS AS SQUARE OF TERM
IN CONTINUED FRACTION EXPANSION
T TO B.
TRUNCATE QUOTIENT
TO DETERMINE PARITY OF FLOOR
RENORMALIZE TO GET FRACTIONAL PART
INTO F0
TEST ITS PARITY

45060000
45120000
FLOORT
45180000
45240000
45300000
45360000
45420000
45480000
45540000
45600000
45660000
FOLLOW THE GRAPH BELOW
45720000
*
45780000
*
NOW, COMPUTE NEW ERROR TERM.
45840000
ERRCHK AD
6,RELERR
E = 16**-13 + E * T**2
45900000
CDR 6,0
SEE IF B LT E.
45960000
BNL RAT
BRANCH IF SO.
46020000
BCT 5,IT
OTHERWISE, LOOP ON N.
46080000
B
IRATNL
B IS ASSUMED IRRATIONAL
46140000
*
46200000
*
IF B IS RATIONAL, WE HAVE THREE POSSIBILITIES.
46260000
RAT
IC
4,RT(4)
46320000
B
RAT(4)
46380000
IRATNL MVI RESSIGN,1
PICK NEGATIVE REAL ROOT
46440000
REVA
NI
A,X'7F'
LOG REQUIRES A TO BE POSITIVE
46500000
*
46560000
*
HERE, WE PERFORM THE EXPONENTIATION, USING FORTRAN XPN.
46620000
EXPIT
LD
2,A
46680000
ICALL EXMLOG,*
46740000
MD
0,B
46800000
LDR 2,0
46860000
ICALL EXMEXP,*
46920000
CLI RESSIGN,0
NOW POSSIBLY INVERT SIGN OF RESULT 46980000
BE
EXPDUN
47040000
LNER 0,0
CASE OF NEGATIVE BASE, IRRATIONAL
47100000
*
EXP OR RATIONAL ODD/ODD EXP
47160000
EXPDUN LM
5,8,BUFF
47220000
L
LKR,SAVELKR
47280000
BR
LKR
47340000
ERR
B
RNGERR
47400000
RT
DC
AL1(ERR-RAT,ERR-RAT,RAT-RAT,REVA-RAT,REVA-RAT,RAT-RAT) 47460000
DC
AL1(IRATNL-RAT,IRATNL-RAT)
47520000
*
47580000
DROP 9,TLR
47640000
EJECT
47700000
EXEXPLIM EQU 10
MAX NO OF TERMS IN CONT FRAC EXPANS 47760000
PGT
DC
FL1'3,6,3,0,7,0,1,4,1'
47820000
*
47880000
*
PGT REPRESENTS THE DIRECTED GRAPH BELOW. EVEN INTEGER
47940000
*
QUOTIENTS DEVELOPED IN THE RATIONAL APPROXIMATOR TAKE US
48000000
*
ACROSS THE DIAGRAM ((0,3),(1,6),(4,7)) AND ODD INTEGER
48060000
*
QUOTIENTS TAKE US AROUND ((0,6,4),(1,3,7)). FUNNY NUMBERING 48120000
*
OF VERTICES PROVIDES A RELATIVELY COMPACT TRANSLATE TABLE.
48180000
*
THE 4- AND 2-BITS OF THE VERTEX NUMBERS DETERMINE PARITY OF
48240000
*
NUMERATOR AND DENOMINATOR OF THE RATIONAL APPROXIMANTS.
48300000
*
48360000
*
48420000
*
0 - O/E
48480000
*
*
48540000
*
***
48600000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

* * *
* * *
* * *
*
*
*
1 - O/E ************************************* 7 - O/O
* *
*
*
*
* *
* * *
*
* * *
*
*
*
*
*
* * *
*
* * *
* *
* * *
* *
*
*
*
* *
* * *
* *
* * *
*
* * *
*
*
*
*
*
* * *
*
* * *
* *
*
*
*
* *
4 - E/O ************************************* 6 - O/O
*
*
*
* * *
* * *
* * *
***
*
3 - E/O
TITLE 'SQRT

*
*
*
*
*
*
*
*
*
*

SQRT

A P L / 3 6 0

S Q U A R E

R O O T'

SQUARE ROOT FUNCTION

1. WRITE X = M*16**(2P+Q), M MANTISSA, Q = 0 OR 1.
2. THEN SQRT(X) = SQRT(M*16**-Q)*16**(P+Q).
P+Q IS THE EXPONENT OF THE ANSWER.
CALLING SEQUENCE

BAL

3,SQRT

FR 6 IS PRESERVED BY SQRT.
ENTRY
USING
USING
BALR
LDR
LTDR
BL
BCR
MVC
STE
L
AL
SRDL
STC
STC
LE
AE
ME
LTR
BC
AER
AER
DER

SQRT
SQRT+2,4
LOCAL,TLR
4,0
0,2
OBTAIN ARGUMENT
4,2
RNGERR
IF NEGATIVE ARG, ERROR
8,3
IF ARG IS 0, ANSWER IS 0, RETURN
SQRTB(4),SQRTBBBB PUT B WHERE WE CAN PLAY WITH IT
4,BUFFQ
0,BUFFQ
COMPUTE TARGET CHARACTERISTIC - 8
0,BIAS
= X'31000000' CHAR OF X'41' MINUS 2*8
0,25
LOW GR0 = X'40' +P+Q-8
0,BUFFQ
GIVE THIS CHARACTERISTIC TO M AND B
0,SQRTB
THIS SEEMINGLY ARTIFICIAL CHAR WAS
2,BUFFQ
CHOSEN TO AID THE FINAL ROUNDING
2,SQRTB
(M+B)*16**(P+Q-8)
2,SQRTA
A*(M+B)*16**(P+Q), A IS SCALED BY 8
1,1
10,*+8
IF Q=1, 1ST APPROX. Y0 IS READY
2,2
IF Q=0, MULTIPLY BY 4 TO OBTAIN Y0
2,2
4,2
NEWTON-RAPHSON ITERATIONS

48660000
48720000
48780000
48840000
48900000
48960000
49020000
49080000
49140000
49200000
49260000
49320000
49380000
49440000
49500000
49560000
49620000
49680000
49740000
49800000
49860000
49920000
49980000
50040000
50100000
50160000
50220000
50280000
50340000
50400000
50460000
50520000
50580000
50640000
50700000
50760000
50820000
50880000
50940000
51000000
51060000
51120000
51180000
51240000
51300000
51360000
51420000
51480000
51540000
51600000
51660000
51720000
51780000
51840000
51900000
51960000
52020000
52080000
52140000
52200000

AUR
HER
LER
DER
AUR
HER
LDR
DDR
AWR
HDR
DDR
SDR
HER
SU
AU
ADR
BR
DROP
TITLE 'EXMEXP
*
*
*
*
*
*
EXMEXP

4,2
4,4
2,0
2,4
2,4
2,2
4,0
4,2
4,2
4,4
0,4
0,4
0,0
0,SQRTB
0,SQRTB
0,4
3
4,TLR
M O N A D

Y1 = (Y0+ARG/Y0)/2 IN SHORT PRECISION

Y2 = (Y1+ARG/Y1)/2 IN SHORT PRECISION

Y3 = (Y2+ARG/Y2)/2 IN LONG PRECISION

Y4 = (ARG/Y3-Y3)/2-D+D+Y3 FOR ROUNDING
1ST APPROX IS SO CHOSEN THAT
ARG/Y3-Y3 IS LESS THAN 16**(P+Q-8)
HENCE 'HER' IS GOOD ENOUGH
-D+D IS TO CHOP OFF EXCESS DIGITS
OF NEGATIVE VALUE (ARG/Y3-Y3)/2
RETURN
I C

E X P O N E N T I A L'

MONADIC EXPONENTIAL FUNCTION

EXMEXP MAY BE CALLED AS AN OPERATOR OR VIA ICALL.
FR4 AND FR6 ARE PRESERVED BY EXMEXP.
ENTRY
USING
BALR
USING

EXMEXP
LOCAL,TLR
4,0
*,4

LDR
CE
BH
CE
BNH

0,2
0,MEXPMAX
RNGERR
0,MEXPMIN
MEXPSML

DD
STE
LER
AU
STE
SDR
AE
SDR
L

0,LOGE2
0,BUFFQ
2,0
2,MEXPSCAL
2,FIELDS
2,2
2,FIELDS
0,2
2,FIELDS

Y = X*LOG2(E) BY ACCURATE DIVISION

SAVE SIGN OF Y
DECOMPOSE Y = (-4A'-B'-C'/16)-D'
BY FORCING CHARACTERISTIC OF X'45'
-4A'-B'-C'/16 IN FIELDS, UNNORMALIZD

TM
BO
SD
LA
LCR

BUFFQ,X'80'
MEXPRDY
0,ONO16
2,1(2)
2,2

IF Y NEGATIVE, SKIP
IF Y NON-NEGATIVE,
-D = /D'/-1/16
-4A-B-C/16 = -(-4A'-B'-(C'+1)/16)
NOW IN ANY CASE, B, C, AND D ARE +

WE ESTABLISH OUR OWN ADDRESSABILITY

FOR THE CONVENIENCE OF THE ROUTINES
WHICH CALL US.
PUT ARG IN REGISTER 0
MAX = 63 * LOG16 = 174.67309
IF ARGUMENT GREATER THAN THIS, ERROR
MIN = -65 * LOG16 = -180.21867
IF ARG LESS THAN THIS, GIVE ANS = 0

NORMALIZE THIS AND SUBTRACT IT

FROM Y TO OBTAIN -D' IN FR0

*
MEXPRDY SR
SRDL
SRL
SRDL
SLL
LCR
SR
SLDL

3,3
2,4
3,25
2,2
2,24
0,2
2,2
2,2

C IN HIGH GR3
B IN HIGH GR3, C IN LOW GR3
A (IN SCALE B7) IN R0, CHAR MODIFIER
B IN GR2, 8*C IN GR3

52260000
52320000
52380000
52440000
52500000
52560000
52620000
52680000
52740000
52800000
52860000
52920000
52980000
53040000
53100000
53160000
53220000
53280000
53340000
53400000
53460000
53520000
53580000
53640000
53700000
53760000
53820000
53880000
53940000
54000000
54060000
54120000
54180000
54240000
54300000
54360000
54420000
54480000
54540000
54600000
54660000
54720000
54780000
54840000
54900000
54960000
55020000
55080000
55140000
55200000
55260000
55320000
55380000
55440000
55500000
55560000
55620000
55680000
55740000
55800000

*
LDR
ME
AD
MDR
AD
MDR
AD
MDR
AD
MDR
AD
MDR
AD
AD

2,0
0,MEXPC6
0,MEXPC5
0,2
0,MEXPC4
0,2
0,MEXPC3
0,2
0,MEXPC2
0,2
0,MEXPC1
0,2
0,HALF
0,HALF

COMPUTE 2**-D BY USE OF

CHEBYSHEV INTERPOLATION
POLYNOMIAL OF DEGREE 6

ADD C0 = 1. IN 2 STEPS
TO PROTECT LAST DIGIT

*
LTR 3,3
MULTIPLY 2**(-C/16)
BZ
MEXPSK2
IN DOING SO, AVOID
CE
0,ONE
MULTIPLICATION BY 1.
BL
MEXPSK1
LD
0,MCONST-8(3)
B
MEXPSK2
MEXPSK1 MD
0,MCONST-8(3)
MEXPSK2 LTR 2,2
MULTIPLY 2**(-B)
BZ
MEXPSK3
BY HALVING B TIMES
HDR 0,0
BCT 2,*-2
MEXPSK3 STD 0,BUFFQ
ADD A TO CHARACTERISTIC
A
0,BUFFQ
ST
0,BUFFQ
SDR 0,0
NORMALIZE THE ANSWER JUST IN CASE
AD
0,BUFFQ
*
BR
LKR
RETURN
MEXPSML SDR 0,0
IF X IS VERY LARGE NEGATIVE,
BR
LKR
GIVE 0 ANSWER
*
DROP 4,TLR
TITLE 'EXDLOG
D Y A D I C
L O G A R I T H M'
*
*
DYADIC LOGARITHM FUNCTION
*
*
A LOG B <= (LOG B) DIV LOG A
*
ENTRY EXDLOG
USING EXDLOG,9
EXDLOG LR
10,LKR
R10 IS PRESERVED BY MLOG
LDR 6,2
FR6 IS PRESERVED BY MLOG
LDR 2,0
LD
0,LOGTEN
CD
2,TEN
MAKE A QUICK CHECK FOR VERY
BE
EXDLOGX
LD
0,LOGTWO
COMMON LEFT ARGUMENTS
CD
2,TWO
BE
EXDLOGX
ICALL EXMLOG,*
COMPUTE LOG A
EXDLOGX LDR 2,6
LDR 6,0
ICALL EXMLOG,*
COMPUTE LOG B
DDR 0,6
(LOG B) DIV LOG A

55860000
55920000
55980000
56040000
56100000
56160000
56220000
56280000
56340000
56400000
56460000
56520000
56580000
56640000
56700000
56760000
56820000
56880000
56940000
57000000
57060000
57120000
57180000
57240000
57300000
57360000
57420000
57480000
57540000
57600000
57660000
57720000
57780000
57840000
57900000
57960000
58020000
58080000
58140000
58200000
58260000
58320000
58380000
58440000
58500000
58560000
58620000
58680000
58740000
58800000
58860000
58920000
58980000
59040000
59100000
59160000
59220000
59280000
59340000
59400000

LR
BR

LKR,10
LKR

*
DROP 9
TITLE 'EXMLOG
*
*
*
*
*
*
*
*
*
*
*
*
EXMLOG

M O N A D I C

L O G A R I T H M'

MONADIC LOGARATHM FUNCTION

WRITE X = (16**P)*(2**-Q)*M, Q BETWEEN 0 AND 3, AND
M BETWEEN 1/2 AND 1. DEFINE A=1, B=0 IF M IS GREATER
THAN SQRT1/2, OTHERWISE A=1/2, B=1.
WRITE Z = (M-A)/(M+A), THEN
LOG(X) = (4P-Q-B)*LOG(2)+LOG((1+Z)/(1-Z))
EXMLOG MAY BE CALLED AS AN OPERATOR OR VIA ICALL.
FR6 AND R10 ARE PRESERVED BY EXMLOG.
ENTRY
USING
BALR
USING

EXMLOG
LOCAL,TLR
4,0
*,4

STD
LM
MVC
LTR
BNH
SRDL
SLL
STH
SR
SLDL
IC
SLDL
STM
MVI

2,BUFFQ
0,1,BUFFQ
IPART(8),IPSTART
2,0
RNGERR
2,24
2,2
2,IPART+2
2,2
2,4
2,TABLE(2)
0,0(2)
0,1,BUFFQ
BUFFQ,X'40'

LA
LD
CE
BH
SR
LA

1,8
0,BUFFQ
0,MLOGLIM
MLOGRDY
1,1
2,1(2)

WE ESTABLISH OUR OWN ADDRESSABILITY

FOR THE CONVENIENCE OF THE ROUTINES
WHICH CALL US.
PUT ARG INTO R0, R1
SET UP FLOAT CONVERTER
IF 0 OR NEGATIVE, ERROR
CHAR IN LOW R2, 1ST DIGIT IN HIGH R3
FLOAT 4*CHAR AND SAVE IT
1ST DIGIT IN R2
NUMBER OF LEADING ZEROS (=Q) IN R2
M = FRACTION * 2 ** Q IN CELL BUFFQ

*
MLOGRDY LDR
SD
SD
AD
DDR
STD
*
MDR
LDR
MD
AD
MDR
AD
MDR
AD
MDR

PICK UP M INTO FR0

IF M GREATER THAN SQRT(2)/2, R1 = 8.
IF M LESS THAN SQRT2/2, R1=0
AND CRANK R2 BY 1. Q+B IN R2

2,0
0,HALF
0,ZERO(1)
2,HALF(1)
0,2
0,BUFFQ

COMPUTE Z = (M-A)/(M+A), A = 1 OR .5
SUBTRACT A IN 2 STEPS TO PROTECT
THE LAST DIGIT.
M+A HAS ONLY 53 BITS. NOT SERIOUS

0,0
2,0
2,MLOGC7
2,MLOGC6
2,0
2,MLOGC5
2,0
2,MLOGC4
2,0

COMPUTE LOG((1+Z)/(1-Z)
BY CHEBYSHEV INTERPOLATION
POLYNOMIAL (IN ZSQ) OF DEGREE 7

59460000
59520000
59580000
59640000
59700000
59760000
59820000
59880000
59940000
60000000
60060000
60120000
60180000
60240000
60300000
60360000
60420000
60480000
60540000
60600000
60660000
60720000
60780000
60840000
60900000
60960000
61020000
61080000
61140000
61200000
61260000
61320000
61380000
61440000
61500000
61560000
61620000
61680000
61740000
61800000
61860000
61920000
61980000
62040000
62100000
62160000
62220000
62280000
62340000
62400000
62460000
62520000
62580000
62640000
62700000
62760000
62820000
62880000
62940000
63000000

AD
MDR
AD
MDR
AD
MDR
LD
MDR
ADR
ADR

2,MLOGC3
2,0
2,MLOGC2
2,0
2,MLOGC1
2,0
0,BUFFQ
2,0
2,0
2,0

LD
LA
STH
SE
MD
ADR
BR

0,IPART
2,256(2)
2,IPART+2
0,IPART
0,MLOGE2
0,2
LKR

F = ZSQ*(C1+ZSQ*(C2...+ZSQ*C7)...)
LOG((1+Z)/(1-Z)) = Z*(2+F)
= Z+Z+Z*F
TO GAIN ACCURACY

*
4*CHARACTERISTIC IN FR0
ADD 4*(BASE CHARAC=64) TO Q+B,
FLOAT THIS AND SUBTRACT FROM FR0
TO OBTAIN 4P-Q-B
MULTIPLY LOG(2) BASE E
AND ADD TO LOG((1+Z)/(1-Z))

*
DROP 4,TLR
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

TITLE 'EXBINOM
D Y A D I C
DYADIC SHRIEK FUNCTION

ENTRY
USING
USING
EXBINOM LR
ST
MVI
LDR
CD
BNL
AD
CDR
BNE
OI
LDR
CD
BNL
AD
CDR
BNE
OI
LDR
SDR

S H R I E K'

A!B IS DEFINED TO BE (!B)/(!A)*!B-A WITH SPECIAL

INTERPRETATION WHEN NEGATIVE INTEGERS OCCUR.
IF EITHER A OR B IS NON-INTEGRAL (OR BOTH) THE
GAMMA FUNCTION IS USED TO COMPUTE A!B. IF ANY OF THE
ARGUMENTS ARE OUT OF THE DOMAIN OF MONADIC ! A
PRECALCULATION IS DONE TO AVOID OVERFLOW IF POSSIBLE.
IF BOTH A AND B ARE INTEGERS THEN THERE ARE 3
REGIONS OF THE A,B LATTICE WHERE A!B IS NONZERO:
(1) IF B>=A>=0 THE USUAL DEFINITION APPLIES,
(2) IF A>0,B<0 THE DEFINITION IS GIVEN BY
((-1)**A)*A!A-B+1 (USING (1) ),
(3) IF A<=B<0 THE DEFINITION IS GIVEN BY
((-1)**A-B)*(-B+1)!-A+1 (USING (1) ).
EXBINOM
EXBINOM,10
SHLOCAL,TLR
10,9
LKR,BINSAVE
BINFLAG,0
4,0
4,BIBIGNO
RNGERR
4,DMKFLOOR
4,0
*+8
BINFLAG,BININTA
4,2
4,BIBIGNO
RNGERR
4,DMKFLOOR
4,2
*+8
BINFLAG,BININTB
4,2
4,0

ZERO SIGN AND INTEGER FLAGS

A TOO LARGE

DOMAIN ERROR

A IS AN INTEGER
B TOO LARGE

DOMAIN ERROR

B IS AN INTEGER
C = B-A

63060000
63120000
63180000
63240000
63300000
63360000
63420000
63480000
63540000
63600000
63660000
63720000
63780000
63840000
63900000
63960000
64020000
64080000
64140000
64200000
64260000
64320000
64380000
64440000
64500000
64560000
64620000
64680000
64740000
64800000
64860000
64920000
64980000
65040000
65100000
65160000
65220000
65280000
65340000
65400000
65460000
65520000
65580000
65640000
65700000
65760000
65820000
65880000
65940000
66000000
66060000
66120000
66180000
66240000
66300000
66360000
66420000
66480000
66540000
66600000

TM
BO
BZ
TM
BO
LTER
BNL
USE0
SDR
BR
BIBINT LTER
BNL
B
BIBOTHI LDR
MDR
LTER
BH
BL
LTER
BNZ
LD
BR
BIABN
LTER
BL
SDR
*
LCDR
SD
LDR
BISSF
AW
STD
TM
BZ
OI
BIALLPI LDR
SDR
CDR
BL
LDR
SDR
LD
SDR
FACTOR AD
AD
CDR
BH
MDR
DDR
QUEND
B
SETSIGN TM
BCR
LCDR
BR
BIABP
LDR
SDR
BL
LTER
BNL
AD
*

BINFLAG,BININTA+BININTB
BIBOTHI
BITESTC
BINFLAG,BININTB
BIBINT
0,0
ONLY A IS AN INTEGER
BINOI
IF POSITIVE IGNORE
0,0
IF NEGATIVE RESULT IS ZERO
LKR
2,2
ONLY B IS AN INTEGER
BINOI
IF POSITIVE IGNORE
RNGERR
4,0
A & B BOTH INTEGERS
4,2
4,4
BIABP
BIABN
0,0
USE0
X SHRIEK 0 = 0
0,ONE
0 SHRIEK X = 1
LKR
0,0
EITHER A OR B IS NEGATIVE
USE0
A NEGATIVE IMPLIES ZERO RESULT
2,0
B NEGATIVE IS MAPPED ONTO POSITIVE
QUADRANT EXCEPT FOR SIGN
2,2
2,ONE
B = A-(B+1)
4,0
4,DUNZERO
A ODD IMPLIES A NEGATIVE RESULT
4,BITEMP
BITEMP+7,X'01'
LAST BIT ON ?
*+8
BINFLAG,BISIGN
4,2
STANDARD CASE B>=A>=0 INTEGERS
4,0
B-A
0,4
*+6
4,0
C = A MAX B-A
2,4
B-C
0,ONE
6,6
4,ONE
6,ONE
6,2
SETSIGN
0,4
MULTIPLY BY RATIOS
0,6
(B-C+1)/1,(B-C+2)/2,...,B/(B-C)
FACTOR
BINFLAG,BISIGN
8,LKR BZR
0,0
LKR
4,2
4,0
USE0
2,2
BIALLPI
2,ONE

PRODUCES AN EXACT INTEGER

CHANGE SIGN IF NEEDED
A TIMES B IS POSITIVE
RESULT IS ZERO IF A>B
BOTH A & B ARE NEGATIVE INTEGERS
THE RESULT MAPS ONTO THE POSITIVE

66660000
66720000
66780000
66840000
66900000
66960000
67020000
67080000
67140000
67200000
67260000
67320000
67380000
67440000
67500000
67560000
67620000
67680000
67740000
67800000
67860000
67920000
67980000
68040000
68100000
68160000
68220000
68280000
68340000
68400000
68460000
68520000
68580000
68640000
68700000
68760000
68820000
68880000
68940000
69000000
69060000
69120000
69180000
69240000
69300000
69360000
69420000
69480000
69540000
69600000
69660000
69720000
69780000
69840000
69900000
69960000
70020000
70080000
70140000
70200000

*
LCDR
AD
LCDR
LDR
B
BITESTC LTER
BNL
LDR
AD
CDR
BE
BINOI
CDR
*
BNL
LDR
LD
LDR
CDR
BNL
LDR
AVOFLW CD
BL
CD
BNL
MDR
DDR
SD
SD
SD
QUEND
B
CALLFACT STD
STD
STD
LA
*
LDR
BALR
LD
SD
STD
BALR
LD
STD
BALR
DD
*
*
LD
DD
MDR
L
LR
BR
*
DROP
*
*
*

QUADRANT EXCEPT FOR SIGN

70260000
70320000
70380000
B = -(A+1)
70440000
A = -(B+1)
70500000
IF B-A IS ODD THEN RESULT IS NEG
70560000
TEST IF C IS A NEGATIVE INTEGER
70620000
70680000
70740000
70800000
70860000
ZERO RESULT IF C NEG INTEGER
70920000
AT LEAST 1 NON-INTEGERAL ARGUMENT
70980000
WILL USE GAMMA FUNCTION
71040000
*+6
71100000
4,0
C = A MAX B-A
71160000
0,ONE
71220000
6,2
71280000
6,4
71340000
*+6
71400000
6,4
D = C MAX B
71460000
6,FIFTY5
71520000
CALLFACT
71580000
6,BIDOMLIM
71640000
RNGERR
D TOO LARGE DOMAIN ERROR
71700000
0,2
GET PRODUCT OF RATIOS UNTIL D IS
71760000
0,4
WITHIN THE DOMAIN OF MONADIC !
71820000
6,ONE
71880000
4,ONE
71940000
2,ONE
72000000
72060000
AVOFLW
72120000
0,BITEMP
E = PREVIOUS FACTOR
72180000
2,BIRSAVE
B
72240000
4,BILSAVE
C
72300000
9,EXFACT
72360000
WE ASSUME R10 NOT ALTERED BY EXFACT
72420000
2,4
72480000
LKR,9
72540000
2,BIRSAVE
B
72600000
2,BILSAVE
B-C
72660000
0,BILSAVE
SHRIEK C
72720000
LKR,9
72780000
2,BIRSAVE
72840000
0,BIRSAVE
SHRIEK B-C
72900000
LKR,9
72960000
0,BILSAVE
(SHRIEK B)/SHRIEK C
73020000
ORDER OF THIS COMPUTATION MINIMIZES 73080000
THE CHANCE OF OVERFLOW
73140000
2,BITEMP
73200000
2,BIRSAVE
73260000
0,2
73320000
LKR,BINSAVE
73380000
9,10
73440000
LKR
73500000
73560000
10,TLR
73620000
73680000
MASKS FOR BINFLAG
73740000
73800000
6,2
0,ONE
2,0
0,6
BISSF
4,4
BINOI
6,4
6,DMKFLOOR
4,6
USE0
4,0

BININTA EQU X'01'

A IS INTEGER
BININTB EQU X'02'
B IS INTEGER
BISIGN EQU X'04'
TITLE 'EXFACT
M O N A D I C
S H R I E K'
*
*
MONADIC SHRIEK FUNCTION
*
*
THE ARGUMENT IS SCALED BETWEEN 0 AND 1, COMPUTING THE
*
FACTORIAL. IF POSATIVE INTEGER, RETURN FACTORIAL OF X.
*
IF NEGATIVE OR NON-INTEGER, COMPUTE GAMMA(X+1).
*
*
DOMAIN ERRORS WILL FALL OUT NATURALLY DURING CALCULATION
*
*
DYADIC SHRIEK ASSUMES R10 IS NOT ALTERED.
*
ENTRY EXFACT
USING SHLOCAL,TLR
SCRATCH AREA ABOVE R14 IN M
USING *,9
EXFACT LD
4,ONE
LDR 0,4
LTER 2,2
BCR 8,LKR BZR
IF SHRIEK 0, RESULT IS 1
BM
EXFACT5
IF X NEGATIVE, SPECIAL HANDLING
CDR 2,0
BCR 8,LKR BER
IF SHRIEK 1, RESULT IS 1
BL
GAMMA
IF X LT 1, COMPUTE GAMMA X
LDR 0,2
B
*+6
EXFACT1 MDR 0,2
SCALE UNTIL X IN RANGE 0 TO 1
SDR 2,4
CDR 2,4
BH
EXFACT1
BCR 8,LKR BER
IF X INTEGER, RETURN FACTORIAL
LDR 4,0
SAVE REDUCTION FACTOR IN FR4
GAMMA
SD
2,HALF
COMPUTE GAMMA FUNCTION
LD
0,GAMAA6
X IS IN (0,1). COMPUTE GAMMA X+1
MDR 0,2
BY MEANS OF MINIMAX FRACTION OF
LD
6,GAMAB6
DEGREE (7,7) FOR Z IN (-0.5,0.5)
ADR 6,2
LM
1,3,INDEX
Z(A0+A1*Z+A2*Z**2+...+A6*Z**6)
GAMALOOP AD
0,GAMAA5(1)
C0 + ------------------------------MDR 0,2
B0+B1*Z+B2*Z**2+...+B6*Z**6+Z**7
MDR 6,2
AD
6,GAMAB5(1)
BXLE 1,2,GAMALOOP
DDR 0,6
AD
0,GAMAC0
MDR 0,4
BR
LKR
RETURN TO OPCONTROL
*
EXFACT5 ADR 2,4
NEGATIVE ARGUMENT
MDR 0,2
INCREASE ARG BY USING RELATION
LTER 2,2
!X-1 = (!X)/!X
BM
EXFACT5
BZ
RNGERR
DDR 4,0
B
GAMMA
*
DROP 9
TITLE '
R N G E R R
A N D
C O N S T A N T S'

73860000
73920000
73980000
74040000
74100000
74160000
74220000
74280000
74340000
74400000
74460000
74520000
74580000
74640000
74700000
74760000
74820000
74880000
74940000
75000000
75060000
75120000
75180000
75240000
75300000
75360000
75420000
75480000
75540000
75600000
75660000
75720000
75780000
75840000
75900000
75960000
76020000
76080000
76140000
76200000
76260000
76320000
76380000
76440000
76500000
76560000
76620000
76680000
76740000
76800000
76860000
76920000
76980000
77040000
77100000
77160000
77220000
77280000
77340000
77400000

RNGERR

BALR
USING
LA
ICALL
DROP

9,0
*,9
1,ERANGE
ERROR
9

ESTABLISH ADDRESSABILITY
DOMAIN ERROR

*
*
LTORG
*
*
*
*
ATANHC0
ATANHC1
ATANHC2
ATANHC3
ATANHC4
ATANHC5
ATANHC6
ATANHC9
*
*
*
ATANC1
ATANC2
ATANC3
ATANC4
ATANC5
ATANC6
ATANC7
RT3M1
*
*
*
COSC7

CONSTANTS FOR ATANH & ASINH

DC
DC
DC
DC
DC
DC
DC
DC
DC

0D'0'
X'413227B4C470D956'
X'4114500000000000'
X'41320FEDCBA98765'
X'4114400000000000'
X'4131C71C71C71C71'
X'4114000000000000'
X'4130000000000000'
D'0.169'

15*16*4/49*9*25
13*9*25/36*16*4
11*16*4/9*25
9*9/16*4
7*4/9
5/4
3

CONSTANTS FOR ATAN

DC
DC
DC
DC
DC
DC
DC
DC
DC

DC
DC
COSC6
DC
DC
COSC5
DC
DC
COSC4
DC
DC
COSC3
DC
DC
COSC2
DC
DC
COSC1
DC
PIOV4
DC
DUNZERO DC
DC
UNFLO
DC
MAX
DC
AIF
*
*
*
DS
TANA2
DC

0D'0'
X'BF1E31FF1784B965'
X'C0ACDB34C0D1B35D'
X'412B7CE45AF5C165'
X'C11A8F923B178C78'
X'412AB4FD5D433FF6'
X'C02298BB68CFD869'
X'41154CEE8B70CA99'
X'40BB67AE8584CAA8'

-0.7371899082768562E-2
-0.6752198191404210
0.2717991214096480E+1
-0.1660051565960002E+1
0.2669186939532663E+1
-0.1351430064094942
0.1331282181443987E+1
SQRT(3)-1

CONSTANTS FOR SIN & COS

X'B66C992E84B6AA37'
X'3778FCE0E5AD1685'
X'387E731045017594'
X'B978C01C6BEF8CB3'
X'BA69B47B1E41AEF6'
X'3B541E0BF684B527'
X'3C3C3EA0D06ABC29'
X'BD265A599C5CB632'
X'BE155D3C7E3C90F8'
X'3EA335E33BAC3FBD'
X'3F40F07C206D6AB1'
X'C014ABBCE625BE41'
X'C04EF4F326F91777'
X'40C90FDAA22168C2'
X'4E00000000000000'
0D'0'
X'3A100000'
X'4DC90FDA'
(NOT &HIPREC).HIPREC0

COS
SIN
COS
SIN
COS
SIN
COS
SIN
COS
SIN
COS
SIN
COS
SIN

C7
C6
C6
C5
C5
C4
C4
C3
C3
C2
C2
C1
C1 -2F
C0

CONSTANTS FOR TAN

0D
X'C325FD4A87357CAF' -

607.8306953515

77460000
77520000
77580000
77640000
77700000
77760000
77820000
77880000
77940000
78000000
78060000
78120000
78180000
78240000
78300000
78360000
78420000
78480000
78540000
78600000
78660000
78720000
78780000
78840000
78900000
78960000
79020000
79080000
79140000
79200000
79260000
79320000
79380000
79440000
79500000
79560000
79620000
79680000
79740000
79800000
79860000
79920000
79980000
80040000
80100000
80160000
80220000
80280000
80340000
80400000
80460000
80520000
80580000
80640000
80700000
80760000
80820000
80880000
80940000
81000000

TANA1
TANA0
TANB3
TANB2
TANB1
TANB0
.HIPREC0
*
*
*

DC
DC
DC
DC
DC
DC
ANOP

X'44AFFA6393159226'
X'C58AFDD0A41992D4'
X'422376F171F72282'
X'C41926DBBB1F469B'
X'4532644B1E45A133'
X'C5B0F82C871A3B68'

+ 4505093889630777
-569309.0400634512 +3F IN ABS
+
35.4646216610
- 6438.8583240077
+206404.6948906228
-724866.7829840012

81060000
81120000
81180000
81240000
81300000
81360000
81420000
81480000
CONSTANTS FOR SINH AND COSH
81540000
81600000
DC
0D'0'
81660000
COSHC6 DC
X'38B2D4C184418A97'
0.1626459177981471(-9)
81720000
COSHC5 DC
X'3A6B96B897BA1636'
0.2504995887597646(-7)
81780000
COSHC4 DC
X'3C2E3BC881345D91'
0.2755733025610683(-5)
81840000
COSHC3 DC
X'3DD00D00CB06A6F5'
0.1984126981270711(-3)
81900000
COSHC2 DC
X'3F2222222222BACE'
0.8333333333367232(-2)
81960000
COSHC1 DC
X'402AAAAAAAAAAA4D'
0.1666666666666653 +2F
82020000
VSQ
DC
X'403FDF9434F03D26'
0.2495052937740537 = V**2
82080000
LNV
DC
X'C0B1B30000000000'
-0.6941375732421875 = LOG(V)
82140000
DELTA
DC
X'3E40F0434B741C6D'
0.0009908832830238 = 1/2V-1+F
82200000
MAXI
DC
X'42AF5DC0'
175.366
82260000
LIMIT
DC
X'40E1A1B8'
0.881374
82320000
*
82380000
*
CONSTANTS FOR TANH
82440000
*
82500000
DC
0D'0'
82560000
AIF (&HIPREC EQ 0).HIPREC3
82620000
TANHC0 DC
X'C0F6E12F40F5590A'
-0.9643735440816707
82680000
TANHC1 DC
X'419DA5D6FD3DBC84'
0.9852988232825539E+1
82740000
TANHC2 DC
X'C31C504FEF537AF6'
-0.4530195153485250E+3
82800000
TANHC3 DC
X'424D2FA31CAD8D00'
0.7718608264195518E+2
82860000
TANHC4 DC
X'C3136E2A5891D8E9'
-0.3108853383729134E+3
82920000
TANHC5 DC
X'4219B3ACA4C6E790'
0.25701850308319156E+2
82980000
MLIM
DC
X'408C9F95'
83040000
HLIM
DC
X'421419DB'
83100000
AGO .HIPREC4
83160000
.HIPREC3 ANOP
83220000
TANHC18 DC
D'18.36840028483855'
83280000
.HIPREC4 ANOP
83340000
*
83400000
*
CONSTANTS FOR ASIN AND ACOS
83460000
*
83520000
DC
0D'0'
83580000
ACOSC1 DC
X'3F180CD96B42A610'
0.00587162904063511
83640000
ACOSD1 DC
X'C07FE6DD798CBF27'
-0.49961647241138661
83700000
ACOSC2 DC
X'C1470EC5E7C7075C'
-4.44110670602864049
83760000
ACOSD2 DC
X'C1489A752C6A6B54'
-4.53770940160639666
83820000
ACOSC3 DC
X'C13A5496A02A788D'
-3.64565146031194167
83880000
ACOSD3 DC
X'C06B411D9ED01722'
-0.41896233680025977
83940000
ACOSC4 DC
X'C11BFB2E6EB617AA'
-1.74882357832528117
84000000
ACOSD4 DC
X'BF99119272C87E78'
-0.03737027365107758
84060000
ACOSC5 DC
X'C11323D9C96F1661'
-1.19625261960154476
84120000
PO2M1
DC
X'40921FB54442D184'
PI/2 - 1.0
84180000
PI
DC
X'413243F6A8885A30'
PI -F
84240000
TAN15
DC
X'40449851'
84300000
*
84360000
*
MISC CONSTANTS
84420000
*
84480000
LARGINT DC
F'1534'
CONSTANT FOR EXEXP
84540000
K8E16
DC
D'8E16'
SIGNIFICANCE TEST FOR 4,-4 CIRC 5988 84600000

CNVTFUZZ
*
TABLE
ZERO
HALF
*
ONE
RT3
ATANQQ

DC

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
TWO
DC
DC
TANUNFLO DC
*
*
*
DC
BIAS
DC
SQRTBBBB DC
SQRTA
DC
*
*
*
DC
RELERR DC
*
*
*
DC
LOGE2
DC
ONO16
DC
MEXPSCAL DC
MEXPC6 DC
MEXPC5 DC
MEXPC4 DC
MEXPC3 DC
MEXPC2 DC
MEXPC1 DC
MCONST DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
MEXPMAX DC
MEXPMIN DC
*
*
*

X'353FF00000000000' NORMALIZED FUZZ, WE ONLY NEED ABS

FUZZ FOR LEFT ARG OF CIRCLE
X'0303020201010101' THESE 4 CONSTANTS MUST BE TOGETHER
X'0000000000000000' THESE 4 CONSTANTS MUST BE TOGETHER
X'4080000000000000' THESE 4 CONSTANTS MUST BE TOGETHER
X'4110000000000000' THESE 4 CONSTANTS MUST BE TOGETHER
X'4110000000000000'
THESE
X'411BB67AE8584CAB'
SQRT(3) SIX
X'0000000000000000'
0
CONSTANTS
X'40860A91C16B9B2C'
PI/6
MUST
X'C0921FB54442D184'
-PI/2+1
BE
X'BFC152382D736574'
-PI/3-F)+1
CONSECUTIVE
X'4120000000000000'
2.0
0F'0'
X'35400000'
2**-46

84660000
84720000
84780000
84840000
84900000
84960000
85020000
85080000
85140000
85200000
85260000
85320000
85380000
85440000
85500000
85560000
CONSTANTS FOR SQRT
85620000
85680000
0F'0'
85740000
X'31000000'
85800000
X'00423A2A'
0.2587, TARGET CHAR -8 TO BE AFFIXED 85860000
X'48385F07'
092202*16**8
85920000
85980000
CONSTANTS FOR DYADIC EXPONENTIATION
86040000
86100000
D'0'
86160000
X'4000000000000010'
86220000
86280000
CONSTANTS FOR MONADIC EXPONENTIAL
86340000
86400000
0D'0'
86460000
X'40B17217F7D1CF79' LOG 2(BE) TRUNCATED
86520000
X'4010000000000000'
86580000
X'45000000'
86640000
X'3D9E0F1E'
.1507368551403575E-3
86700000
X'3E575D42BB7276D4' .1333073417706260E-2
86760000
X'3F276553A5F9BC94' .9618117095313700E-2
86820000
X'3FE35846A61AEE7A' .5550410840231345E-1
86880000
X'403D7F7BFF0289DE' .2402265069563678
86940000
X'40B17217F7D1CC79' .6931471805599346
87000000
X'40F5257D152486CC'
2**(-1/16)
87060000
X'40EAC0C6E7DD2439'
2**(-2/16)
87120000
X'40E0CCDEEC2A94E1'
2**(-3/16)
87180000
X'40D744FCCAD69D6B'
2**(-4/16)
87240000
X'40CE248C151F8481'
2**(-5/16)
87300000
X'40C5672A115506DB'
2**(-6/16)
87360000
X'40BD08A39F580C37'
2**(-7/16)
87420000
X'40B504F333F9DE65'
2**(-8/16)
87480000
X'40AD583EEA42A14B'
2**(-9/16)
87540000
X'40A5FED6A9B15139'
2**(-10/16)
87600000
X'409EF5326091A112'
2**(-11/16)
87660000
X'409837F0518DB8A9'
2**(-12/16)
87720000
X'4091C3D373AB11C3'
2**(-13/16)
87780000
X'408B95C1E3EA8BD7'
2**(-14/16)
87840000
X'4085AAC367CC487B'
2**(-15/16)
87900000
X'42AEAC4E'
174.6731
87960000
X'C2B437DF'
-180.2187
88020000
88080000
CONSTANTS FOR DYADIC LOGARITHM
88140000
88200000

LOGTWO
LOGTEN
TEN
*
*
*

DC
DC
DC
DC

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
MLOGLIM DC
*
*
*
INDEX
DC
DC
DC
DC
GAMAA6 DC
GAMAA5 DC
DC
DC
DC
DC
DC
GAMAB6 DC
GAMAB5 DC
DC
DC
DC
DC
DC
GAMAC0 DC
*
*
*
DC
DMKFLOOR DC
FIFTY5 DC
BIBIGNO DC
BIDOMLIM DC
*
*
*
*
*
*
LOCAL
DSECT
BUFFQ
DS
ORG
FIELDS DS
SQRTB
DS
IPSTART
MLOGE2
MLOGC7
MLOGC6
MLOGC5
MLOGC4
MLOGC3
MLOGC2
MLOGC1

0D'0'
X'40B17217F7D1CF7A'
X'4124D763776AAA2B'
X'41A0000000000000'

LOG 2
LOG 10
10.0

CONSTANTS FOR MONADIC LOGARITHM

0D'0'
X'4600000000000000'
X'40B17217F7D1CF7B' LOG 2 (BASE E) + 1 IN LAST DIGIT
X'4025E9B17CA9B973'
.1480971268990510
X'40273337E26DBA7F'
.1531252792171731
X'402E8CD32A425C06'
.1818363168880382
X'4038E38A00083F6B'
.2222219705656678
X'4049249251450212'
.2857142876064318
X'40666666665EBAA3'
.3999999999930233
X'40AAAAAAAAAAAD6C'
.666666666666764
0E'0'
X'40B504F3'
1/SQRT 2
CONSTANTS FOR MONADIC SHRIEK
F'0'
(1) THESE 3 WORDS MUST BE TOGETHER
F'8'
(2) THESE 3 WORDS MUST BE TOGETHER
F'40'
(3) THESE 3 WORDS MUST BE TOGETHER
0D'0'
X'C0C1B71B59A1A1F6' A6 = - 0.7567002385928
X'41B33F20CFA73CB3' A5 =
11.2029121505218
X'4153CF867C239860' A4 =
5.2381653641874
X'C23EBA40FFB0397B' A3 = - 62.7275543027149
X'43441182D7048BE6' A2 = 1089.0944433381650
X'43C3CDE7AC8F2232' A1 = 3132.8690610495717 -3F
X'42E8A532ACC72020' A0 = 232.6453044878145
X'C1A5004D879829C5' B6 = - 10.3125739380508
X'41E62A3573ECF95D' B5 =
14.3853048828456
X'42C97F1D84DC37A0' B4 = 201.4965441739693
X'C327558408F56C71' B3 = - 629.3447351061687
X'C358DA535E278586' B2 = -1421.6453534644901
X'4411F52476FDA8AB' B1 = 4597.1424406563556
X'441C1A16BED21CC5' B0 = 7194.0888491935961
X'40E2DFC48DA77B56' GAMMA(1.5) = 0.8862269254527580 +F
CONSTANTS FOR DYADIC SHRIEK
0D'0'
X'4F00000000000000'
D'55.0'
X'4E80000000000000'
D'1.0E5'
SCRATCH AREA FOR DYADIC CIRCLE, SQUARE ROOT,
MONADIC & DYADIC EXP, MONADIC & DYADIC LOG
ASSUMPTIONS ARE MADE ABOUT ORDERING
,
D
BUFFQ+4
F
F

************************************
** THESE LOCATIONS ARE USED BY
** MEXP, MLOG, & SQRT. THEY
** THEREFORE SHOULD BE USED ONLY
** WITH CAUTION BY ROUTINES WHICH

88260000
88320000
88380000
88440000
88500000
88560000
88620000
88680000
88740000
88800000
88860000
88920000
88980000
89040000
89100000
89160000
89220000
89280000
89340000
89400000
89460000
89520000
89580000
89640000
89700000
89760000
89820000
89880000
89940000
90000000
90060000
90120000
90180000
90240000
90300000
90360000
90420000
90480000
90540000
90600000
90660000
90720000
90780000
90840000
90900000
90960000
91020000
91080000
91140000
91200000
91260000
91320000
91380000
91440000
91500000
91560000
91620000
91680000
91740000
91800000

** CALL ANY OF THEM.

91860000
**
91920000
************************************ 91980000
92040000
THE FOLLOWING SHOULD NOT BE USED
92100000
BY MEXP, MLOG, OR SQRT.
92160000
92220000
DS
D
CIRCLE PUTS ARG HERE INITIALLY
92280000
DS
D
92340000
DS
0CL1
SWITCH FOR ASIN & ACOS
92400000
DS
F
SAVE AREA FOR LINK REGISTER
92460000
DS
F
SLOT FOR LKR WITHIN SINH & COSH
92520000
DS
D
SLOT FOR DYADIC EXP
92580000
DS
D
SLOT FOR DYADIC EXP
92640000
DS
D
SLOT FOR DYADIC EXP
92700000
DS
F
SLOT FOR DYADIC EXP
92760000
DS
X
SWITCH FOR DYADIC EXP
92820000
92880000
92940000
SCRATCH AREA FOR DYADIC SHRIEK & MONADIC SHRIEK
93000000
93060000
DSECT
93120000
DS
D
MONADIC SHRIEK BUFFER
93180000
DS
D
93240000
DS
D
93300000
DS
D
93360000
DS
D
93420000
DS
X
93480000
93540000
93600000
93660000
END
93720000
./ ADD
NAME=APLSMTRA
MTRA
TITLE 'M O N A D I C T R A N S P O S E
05/11/70' 00920000
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
01840000
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
02760000
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
03680000
EXMTRAN CSECT
04600000
PRINT OFF
APLDEFN, OPSECT
05520000
COPY APLDEFN
07360000
COPY OPSECT
08280000
PRINT ON,NOGEN
09200000
OPSECT DSECT
10120000
ORG BINOSAVE
11040000
ROOSAV DS
F
11960000
SINCR
DS
3F
12880000
RX
DS
3F
13800000
RR
DS
3F
14720000
ORG
15640000
TITLE 'M O N A D I C T R A N S P O S E
05/11/70' 16560000
EXTRN OPSPACE
17480000
EXTRN STORE
18400000
EXTRN FETCH
19320000
EXMTRAN CSECT
20240000
USING OPSECT-16,LR
21160000
USING *,9
22080000
L
2,RHRANK
RANK LSS 2 MEANS DO NOTHING
23000000
LA
7,8
R7 AN 8
23920000
CR
2,7
24840000
BNL STOR
25760000
IPART
*
*
*
*
*
BUFF
BUFF2
SWITCH
SAVELKR
SAVELKR2
A
B
DSTORE
FTEMP
RESSIGN
*
*
*
*
SHLOCAL
SHBUFF
BILSAVE
BIRSAVE
BINSAVE
BITEMP
BINFLAG
*
*
*

ORG
DS

SQRTB
D

STOR

* ERROR
* ERROR
* ERROR
* ERROR

TRANSFER

MVI TEMPRGT,0
L
0,SVI
A
0,INCR
S
0,=F'4'
ST
0,SVI
SR
0,0
ST
0,INCR
BR
LKR
ST
LKR,ROOSAV
L
1,RHXRHO
L
3,RHTYPE
LR
5,2
LR
6,3
L
10,=A(OPSPACE)
BALR LKR,10
STH 5,MRANK(1)
STC 6,MTYPE(1)
LA
0,MRHO-M(5,1)
ST
0,RESORG
L
4,RHBASE
LA
2,MRHO-M(5,4)
ST
2,RHORG
S
5,=F'5'
AR
1,MR
AR
4,MR
EX
5,MOVE
L
8,MRHO-M-3(5,4)
ON PREVIOUS STATEMENT
ST
8,RR+4
L
7,MRHO-M+1(5,4)
ON PREVIOUS STATEMENT
ST
7,RR+8
ST
7,MRHO-M-3(5,1)
ON PREVIOUS STATEMENT
ST
8,MRHO-M+1(5,1)
ON PREVIOUS STATEMENT
ST
8,SINCR+8
MR
6,8
L
1,RHXRHO
LTR 1,1
BZ
ENDTRAN
SR
0,0
ST
0,RX
MVC RX+4(8),RX
DR
0,7
ST
1,RR
SR
7,8
LA
0,1
ST
0,SINCR
SR
0,7
ST
0,SINCR+4
L
3,RHTYPE
SR
5,5
SR
6,6
L
8,RHORG
LR
2,6
LR
4,8
ICALL FETCH
LR
2,5
L
4,RESORG

VECTOR OR SCALAR ARGUMENT

RETURN ARGUMENT AS RESULT.

R5 RANK
R6 TYPE
GET SPACE FOR RESULT
R1 BASE
R0 RESORG
R4 RHBASE
R2 RHORG
4+1
MVC MRHO-M(0,1),MRHO-M(4)
PENULT DIM OF ARG
IS HARMLESS ****************************
LAST DIM OF ARGUMENT
IS HARMLESS ****************************
R7 PENULT DIM OF RESULT
IS HARMLESS ****************************
R8 LAST DIM OF RESULT
IS HARMLESS ****************************
ALSO DISTANCE TWIXT ELEMS OF A COLUM
R7 X/LAST 2 DIMS

CLEAR RX

R5 INDEX IN RESULT
R6 INDEX IN ARGUMENT
IDLE REGISTERS ARE THE DEVIL'S
PLAYGROUND

26680000
27600000
28520000
29440000
30360000
31280000
32200000
33120000
34040000
34960000
35880000
36800000
37720000
38640000
39560000
40480000
41400000
42320000
43240000
44160000
45080000
46000000
46920000
47840000
48760000
49680000
50600000
51520000
52440000
53360000
54280000
55200000
56120000
57040000
57960000
58880000
59800000
60720000
61640000
62560000
63480000
64400000
65320000
66240000
67160000
68080000
69000000
69920000
70840000
71760000
72680000
73600000
74520000
75440000
76360000
77280000
78200000
79120000
80040000
80960000

ICALL STORE
LA
6,1(6)
INCREMENT SX
LA
10,8
INCRX
L
7,RX(10)
INCREMENT RX
LA
7,1(7)
C
7,RR(10)
BL
INCREX
SR
7,7
ST
7,RX(10)
S
10,=F'4'
BNL INCRX
ENDTRAN L
LKR,ROOSAV
BR
LKR
INCREX ST
7,RX(10)
A
5,SINCR(10)
QUEND
B
TRANSFER
MOVE
MVC MRHO-M(0,1),MRHO-M(4)
END
./ ADD
NAME=APLSMVT1
MVT1
TITLE 'APL 360-OS MVT R E S I D E N T S V C S'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
SPACE 3
IGCINIT CSECT
CVTDCB EQU X'74'
CVTBTERM EQU X'34'
TCBUSER EQU X'A8'
TCBOTC EQU X'84'
TCBJSTCB EQU X'7C'
SVCOPSW EQU X'20'
SVCNPSW EQU X'60'
DCBDEBAD EQU 44
DEBDVMOD EQU 32
DEBDCBAD EQU 24
SPACE 3
BALR 9,0
USING *,9
CLI CVTDCB(3),X'10'
IS THIS MVT?
BNE IGCFAIL
KILL IT HERE.
LTR 2,0
BNZ IGCFMSK
L
5,SAVP44
L
6,8(1)
CLC 0(4,5),0(6)
BNE IGCFAIL
IGCST
ST
1,TCBUSER(4)
L
5,TCBOTC(4)
C
5,TCBJSTCB(4)
BNE IGCFAIL APL HAS A TWO TASK STRUCTURE
ST
1,TCBUSER(5)
BR
14
SPACE 3
IGCFMSK X
0,DEBDCBAD(1)
N
0,=A(X'FFFFFF')
BNZ IGCFAIL
LR
0,1
X
0,DCBDEBAD(2)
N
0,=A(X'FFFFFF')
BNZ IGCFAIL

81880000
82800000
83720000
84640000
85560000
86480000
87400000
88320000
89240000
90160000
91080000
92000000
92920000
93840000
94760000
95680000
96600000
97520000
98440000
01350000
02700000
04050000
05400000
06750000
08100000
09450000
10800000
12150000
13500000
14850000
16200000
17550000
18900000
20250000
21600000
22950000
24300000
25650000
27000000
28350000
29700000
31050000
32400000
33750000
35100000
36450000
37800000
39150000
40500000
41850000
43200000
44550000
45900000
47250000
48600000
49950000
51300000
52650000
54000000

MVI DEBDVMOD(1),0
BR
14
DROP 9
SPACE 3
ENTRY IGCMAP
IGCMAP BALR 9,0
USING *,9
L
5,SAVP44
L
2,TCBUSER(4)
LM
6,8,0(2)
CLC 0(4,5),0(8)
BNE IGCFAIL
MVC 0(8,6),SVCOPSW
ST
7,SVCOPSW+4
NC
SVCOPSW(4),SVCNPSW
BR
14
DROP 9
SPACE 3
* THIS IS AN INVALID CALL TO THE APL SVC'S
*
THE CALLING TASK WILL BE TERMINATED
*
WITH A S-FXX ABEND, WHERE XX IS THE SVC NUMBER
*
IGCFAIL LR
0,4
ADDRESS OF TCB TO BE TERMINATED
LA
1,X'F00'
IC
1,SVCOPSW+3
GET SVC CODE
SLL 1,12
L
15,CVTBTERM(3)
BR
15
SPACE 3
EXTRN IEASCSAV
SAVP44 DC
A(IEASCSAV+44)
LTORG
END
./ ADD
NAME=APLSOCTL
OCTL
TITLE 'O P E R A T O R C O N T R O L
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&L
FETCHES &R2,&R3,&R4,&R5
DC
A(&R2,&R3,&R4,&R5)
MEND
SPACE
PRINT OFF
APLDEFN
OPEXEC CSECT
COPY APLDEFN
PRINT ON,NOGEN
COPY OPSECT
TITLE 'O P E R A T O R C O N T R O L
05/11/70'
OPEXEC CSECT
*
*
EXECUTION ROUTINE CALLING CONVENTIONS.
*
*
*
THE FOLLOWING VALUES ARE ALWAYS CALCULATED PRIOR TO
*
OPERATOR CALL BY OPEXEC:
*
*
OPERATOR, OPINDEX
*
TYPINFO: OPRN, LCTYPE, RCTYPE, RSTYPE, COMTYP
*
(ARTHTP RESULTS)

55350000
56700000
58050000
59400000
60750000
62100000
63450000
64800000
66150000
67500000
68850000
70200000
71550000
72900000
74250000
75600000
76950000
78300000
79650000
81000000
82350000
83700000
85050000
86400000
87750000
89100000
90450000
91800000
93150000
94500000
95850000
97200000
98550000
00090000
00180000
00270000
00360000
00450000
00540000
00630000
00720000
00810000
00990000
01080000
01170000
01260000
01350000
01440000
01530000
01620000
01710000
01800000
01890000
01980000
02070000
02160000
02250000
02340000
02430000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

02520000
INCR
02610000
TEMPRGT, TEMPLFT 1 INDICATES TEMP.
02700000
LHSCALAR, RHSCALAR 1 INDICATES SCALAR
02790000
BLOWN
1 INDICATES BLOWUP RECOVERY IN PROG 02880000
RESS.
02970000
TEMPIND
1 INDICATES TEMP INDEX.
03060000
03150000
LHBASE, LHRANK, LHXRHO, LHTYPE
03240000
RHBASE, RHRANK, RHXRHO, RHTYPE
03330000
INDBASE, INDRANK, INDXRHO, INDTYPE
03420000
IF INDXRHO = 1, INDEX, ADJUSTED BY IORIGIN.
03510000
IF INDXRHO NOT = 1, CONTENTS ARE MEANINGLESS.
03600000
INDBASE IS SET TO 0 FOR ELIDED OPERATOR INDEX OR 1 IF
03690000
AN OPERATOR INDEX EXISTS. (UPPER BYTE)
03780000
03870000
03960000
CALLING SEQUENCE IS:
04050000
04140000
L
9,EXECUTION ROUTINE ADDRESS.
04230000
BALR
LKR,9
04320000
04410000
04500000
REGISTERS IN USE.
04590000
04680000
1. SCALAR OPERATORS..
04770000
R1 OR F0
LEFT OPERAND
04860000
R2 OR F2
RIGHT OPERAND
04950000
--RESULT TO BE RETURNED IN R1 OR F0.
05040000
R0 TO R4
MAY OTHERWISE BE USED AS SCRATCH
05130000
R5 TO R6
MUST BE PRESERVED.
05220000
R7
STORE ROUTINE ADDRESS, MUST BE
05310000
PRESERVED.
05400000
R8
MAIN LOOP LOOP COUNT, MUST BE
05490000
PRESERVED
05580000
R9
EXECUTION ROUTINE ADDRESS, MUST
05670000
BE PRESERVED.
05760000
R10
UNUSED.
05850000
R11
BASE REG FOR M-ARRAY, MUST BE
05940000
PRESERVED.
06030000
R12
BASE REG FOR PROGRAM, MUST BE
06120000
PRESERVED.
06210000
R13
BASE REG FOR LOCAL VARIABLES,
06300000
MUST BE PRESERVED.
06390000
R14
TOP OF SPACE NEEDED FOR LOCAL
06480000
VARIABLES, MUST BE PRESERVED.
06570000
R15
LINK REG, MUST BE PRESERVED.
06660000
F0 TO F6
MAY OTHERWISE BE USED AS SCRATCH.
06750000
06840000
06930000
2. NON-SCALAR OPERATORS.
07020000
07110000
R11 TO R15
MUST BE PRESERVED.
07200000
ALL OTHERS
MAY BE USED AS SCRATCH.
07290000
07380000
NON SCALAR OPERATORS MUST GET THEIR OWN SPACE. SEE
07470000
OPSPACE SECTION, THIS LISTING
07560000
07650000
07740000
EJECT
07830000

*
***********************************************************************
*
*
OPERATOR EXECUTION CONTROL.
*
***********************************************************************
*
DODOP
PROLOG OPSECT,NDOPSECT
ENTRY DODOP
EXTRN MATRIX
EXTRN REDUCE
*
ON ENTRY, SVI POINTS TO NEXT AVAILABLE STACK ENTRY.
*
L
9,SVI
SO WE NEED IT.
AR
9,MR
ABSOLUTE POINTER IN 9.
LM
15,1,8(9)
OPERATOR AND RIGHT HAND BASE.
LA
5,16
LOAD INCREMENT FOR SVI.
ST
5,INCR
STORE THE INCREMENT.
STM 15,0,OPERATOR
SAVE OPERATOR AND ITS INDEX
*
*
FIRST, FIND OUT WHAT OPERANDS LOOK LIKE.
*
LA
LKR,LJWSEND
SET UP EXIT FROM SETUP ROUTINE.
LJWSET LM
2,7,LJWSCONS
LISTBIT, 1, STRIKE, -4, ONE, ZERO.
LR
8,3
GET THE ONE IN R8, TO FLAG TEMPORARY
BXH 1,7,LJWS1
BRANCH IF TIS NOT NAMED
LR
8,7
MAKE IT ZERO, IT IS NAMED.
L
1,M(1)
GET THE SYMBOL TABLE POINTER.
LJWS1
NR
1,4
STRIKE THE HIGH ORDER 8 BITS.
BC
8,VALERR
IF IT IS ZERO IT IS NOT DEFINED.
AR
1,MR
MAKE IT ABSOLUTELY ADDRESSABLE.
N
2,MLIST-M(1)
SEE IF IT IS THE FORBIDDEN LIST.
BC
7,SYNTERR
TOO BAD IF IT IS
G01
LH
4,MRANK-M(1)
GET NUMBER OF DIMENSIONS.
BXLE 4,5,LJWS3
BRANCH IF IT IS SCALAR.
L
3,MRHO-M(1,4)
LOAD THE LAST DIMENSION LENGTH.
BXLE 4,5,LJWS3
SKIP MULTIPLY IF ONLY ONE DIM.
LJWS2
M
2,MRHO-M(1,4)
OTHERWISE MULTIPLY THEM TOGETHER.
BXH 4,5,LJWS2
LOOP CLOSURE.
LJWS3
LR
4,6
MAKE FOUR AVAILABLE FOR IC.
IC
4,MTYPE-M(1)
INSERT THE TYPE.
LH
2,MRANK-M(1)
GET THE RANK BACK.
SR
1,MR
MAKE THE BASE M-RELATIVE AGAIN.
CR
3,6
SEE IF THERE IS ONE COMPONENT.
BCR 8,LKR
ALL IS WELL IF THERE IS.
LR
6,7
OTHERWISE MAKE R6 ZERO.
BCR 2,LKR
SEE IF IT IS NOT EMPTY.
C
4,OP4
CHARACTER TYPE STAYS AS IT IS,
BCR 8,LKR
LA
4,2
BUT NUMERIC EMPTIES ARE MADE INTEGER
BCR 15,LKR
THEN EXIT.
LJWS4
EQU *
LJWSEND EQU *
STC 8,TEMPRGT
SET TEMP INDICATOR.
STC 6,RHSCALAR
STORE SCALAR INDICATOR.
STM 1,4,RHBASE
STORE ALL THAT STUFF.
*
*
NOW, DO ABOUT THE SAME FOR LH OPERAND.
*
L
1,4(9)
LOAD THE LEFT HAND BASE.

07920000
08010000
08100000
08190000
08280000
08370000
08460000
08550000
08640000
08730000
08820000
08910000
09000000
09090000
09180000
09270000
09360000
09450000
09540000
09630000
09720000
09810000
09900000
09990000
10080000
10170000
10260000
10440000
10530000
10620000
10710000
10800000
10890000
10980000
11070000
11160000
11250000
11340000
11430000
11520000
11610000
11700000
11790000
11880000
11970000
12060000
12150000
12240000
12330000
12420000
12510000
12600000
12690000
12780000
12870000
12960000
13050000
13140000
13230000
13320000

BAL
STC
STC
STM
BAL

LKR,LJWSET
8,TEMPLFT
6,LHSCALAR
1,4,LHBASE
LKR,PICKINDX

SET UP LEFT SIDE.

STORE TEMPORARY INDICATOR.
STORE SCALAR INDICATOR.
STORE THAT GOOD STUFF.

13410000
13500000
13590000
13680000
13770000
*
13860000
*
NOW, CALL ARTHTP.
13950000
*
14040000
SR
0,0
DON'T FORCE A TYPE.
14130000
*
14220000
*
BLOWUP MAY RETURN HERE.
14310000
*
14400000
ENTRY BLOWRTN
14490000
BLOWRTN LR
1,0
FETCH THE RIGHT OR ONLY OPERATOR
14580000
IC
1,OPERATOR+3
14670000
L
2,LHTYPE
,LEFT HAND TYPE.
14760000
L
3,RHTYPE
AND RIGHT HAND TYPE.
14850000
ICALL ARTHTP
AND CALL.
14940000
STM 1,5,TYPINFO
AND SAVE IT ALL.
15030000
L
2,OPERATOR
15120000
C
2,=F'256'
DYADIC OR MATRIX
15210000
BNH BCOT
DYADIC - DO SAME OLD DULL STUFF
15300000
L
9,=A(MATRIX)
THE NEW EXCITING WORLD
15390000
BALR LKR,9
OFF TO THE MATRIX PRODUCT
15480000
BC
15,LWCLEAN
CLEAN UP STACK
15570000
BCOT
L
5,=A(INDICTR)
GET ENTRY IN OPERATOR INFO TABLE
15660000
LA
5,1(2,5)
15750000
TM
0(5),INDEXED
TEST FOR INDEX ALLOWED.
15840000
BO
NOXCHK
BRANCH IF SO.
15930000
L
1,OPINDEX
16020000
LTR 1,1
OTHERWISE,
16110000
BNZ SYNTERR
SYNTAX ERROR IF INDEXED.
16200000
NOXCHK TM
0(5),SCALAROP
SEE IF THIS IS A SCALAR OP.
16290000
BNZ SCOP
BRANCH IF SO.
16380000
L
9,OPRN
OTHERWISE,
16470000
BALR LKR,9
CALL OPERATOR EXECUTION ROUTINE.
16560000
BC
15,LWCLEAN
GO TO CLEANUP.
16650000
*
16740000
*
NOW, CHECK FOR CONFORMABILITY, AND COMPUTE RESULT RANK.
16830000
SCOP
L
2,LHRANK
16920000
CLI LHSCALAR,0
IS LEFT ARG ONE-COMPONENT -17010000
BE
SCOP1
NO.
17100000
CLI RHSCALAR,0
YES. HOW ABOUT RIGHT ARG -17190000
BZ
USRHRANK
MULTICOMPONENT. RESULT HAS RH RANK. 17280000
C
2,RHRANK
BOTH ONE-COMPONENT.
17370000
BNL USLHRANK
RESULT RANK IS HIGHER OF ARG RANKS. 17460000
B
USRHRANK
17550000
SCOP1
CLI RHSCALAR,0
LEFT ARG MULTICOMPONENT.
17640000
BNZ USLHRANK
OK IF RIGHT ARG SCALAR
17730000
C
2,RHRANK
OTHERWISE COMPARE RANKS
17820000
BNE RANKBAD
RANK ERROR IF UNEQUAL
17910000
L
3,LHBASE
RANKS EQUAL, NOW COMPARE DIM
18000000
L
4,RHBASE
SO CALCULATE BASE ADDRESSES.
18090000
LA
3,MRHO(3)
18180000
LA
4,MRHO(4)
18270000
BCTR 2,0
18360000
EX
2,CMPLC
WHICH IS A CLC.
18450000
BNE RANKEROR
BRANCH IF THEY'RE NOT EQUAL.
18540000
*
18630000
*
FALL THROUGH IF OK, SO USE RH RANK.
18720000

*
USRHRANK L
5,RHBASE
L
4,RHRANK
L
3,RHXRHO
MVI LTORRT,1
B
RESRANK
USLHRANK L
5,LHBASE
L
4,LHRANK
L
3,LHXRHO
MVI LTORRT,2
*
*
NOW FIGURE OUT HOW MANY WORDS WE NEED FOR RESULT.
*
RESRANK ST
3,RXRHO
STORE RESULT X/RHO.
ST
4,RRANK
AND THE RESULT RANK.
CLI TYPINFO+15,2
BL
BOOLOOR
BE
ADINF
INTEGER - 1 WORD PER ELEMENT.
FLOATOR AR
3,3
FLOAT, MULTIPLY BY 2.
B
ADINF
BOOLOOR LA
3,31(3)
SRL 3,5
DIVIDED BY 32.
*
*
NOW, ADD IN NUMBER OF HEADER WORDS.
*
ADINF
EQU *
SLA 3,2
MULTIPLY BY 4 TO GET BYTES.
AR
3,4
ADD RANK.
LA
1,MRHO-M(3)
ADD IN NUMBER OF HEAD WORDS.
*
*
NOW FIND SPACE FOR RESULT.
*
SEE IF WE CAN USE TEMPORARY STORAGE FIRST.
*
TM
TEMPRGT,1
TRY RUGHT.
BZ
TRYLEFT
BRANCH IF NOT TEMPORARY.
L
3,RHBASE
GET THE BASE.
C
1,MCOUNT(3)
BNE TRYLEFT
BRANCH IF NOT.
L
2,RRANK
GET THE RANK.
CH
2,MRANK(3)
BNE TRYLEFT
SO BRANCH IF THEY'RE NOT.
MVI TEMPRGT,0
OTHERWISE, TURN OFF INDICATOR.
B
GOTEMPR
WE'VE GOT IT.
TRYLEFT L
3,LHBASE
NOW TRY LEFT.
TM
TEMPLFT,1
SEE IF IT'S TEMP.
BZ
GETSP
BRANCH IF NOT.
C
1,MCOUNT(3)
BNE GETSP
BRANCH IF NOT.
L
2,RRANK
TEST RANKS.
CH
2,MRANK(3)
BNE GETSP
BRANCH IF NOT EQUAL.
MVI TEMPLFT,0
OTHERWISE, CLEAR FLAG.
*
*
SET UP HEADER.
*
GOTEMPR L
9,SVI
PICK UP SVI AGAIN.
ST
9,MHEAD(3)
STORE REFLECTING POINTER.
ST
3,M(9)
ST
3,RBASE
STORE RESULT POINTER.
S
9,OP4

18810000
18900000
18990000
19080000
19170000
19260000
19350000
19440000
19530000
19620000
19710000
19800000
19890000
19980000
20070000
20160000
20250000
20340000
20430000
20520000
20610000
20700000
20790000
20880000
20970000
21060000
21150000
21240000
21330000
21420000
21510000
21600000
21690000
21780000
21870000
21960000
22050000
22140000
22230000
22320000
22410000
22500000
22590000
22680000
22770000
22860000
22950000
23040000
23130000
23220000
23310000
23400000
23490000
23580000
23670000
23850000
23940000
24120000
24210000
24300000

ST
LR
B

9,SVI
1,3
HDSETUP

24390000
24480000
24570000
*
24660000
*
CALL GETSPACE, AND REFETCH OPERANDS.
24750000
*
24840000
GETSP
LA
10,OPSPACE
ENTER COMMON GETSPACE ROUTINE.
24930000
BAL LKR,OPSCALL-OPSPACE(0,10)
25020000
ST
1,RBASE
STORE RESULT M-POINTER.
25110000
SPACE
25200000
*
25290000
*
NOW, SET UP HEADER.
25380000
*
25470000
SPACE
25560000
HDSETUP L
2,RHBASE
FIND OUT WHO IS SUPPLYING RANK.
25650000
TM
LTORRT,1
25740000
BNZ *+8
BRANCH IF NOT RIGHT.
25830000
L
2,LHBASE
OTHERWISE, USE LEFT
25920000
L
4,RRANK
PICK UP RESULT RANK.
26010000
ST
4,MTYPE(1)
STORED.
26190000
L
3,RSTYPE
PICK UP RESULT TYPE.
26280000
STC 3,MTYPE(1)
STORED.
26370000
LTR 4,4
SEE IF RESULT IS SCALAR.
26460000
BZ
XSETUP
BRANCH IF SO.
26550000
BCTR 4,0
OTHERWISE, GET AN SS COUNT.
26640000
LA
1,MRHO(1)
AND SOME ABSOLUTE POINTERS.
26730000
LA
2,MRHO(2)
FOR RANK MOVE.
26820000
EX
4,MOVRANK
AND MOVE IN THE RANK.
26910000
EJECT
27000000
*
27090000
*
DYADIC SCALAR OP SET UP AND EXECUTE.
27180000
*
27270000
*
FIRST, SEE IF RESULT IS EMPTY.
27360000
*
THEN, SET UP FETCH CALLS.
27450000
*
27540000
SPACE
27630000
XSETUP L
8,RXRHO
LOOK AT NUMBER OF ELS IN RESULT.
27720000
LTR 8,8
27810000
BC
8,LWCLEAN
BRANCH IF NONE.
27900000
MVI FCHSCLR,0
TURN OFF EXTENSION INDICATOR.
27990000
MVI FCHSCLR,0
TURN OFF PRE-FETCH INDICATOR.
28080000
L
1,LCTYPE
PICK UP LEFT CONVERSION CODE.
28170000
C
1,OP1
SEE IF IT'S BOOLEAN TO BOOLEAN.
28260000
BNE NOLBOOLF
BRANCH IF NOT.
28350000
TM
RHSCALAR,1
OTHERWISE, SEE IF RIGHT IS SCALAR. 28440000
BNZ NOLBOOLF
BRANCH IF SO - 32 AT ONE TIME.
28530000
C
1,RCTYPE
OTHERWISE, SEE IF RIGHT CC IS THE SA 28620000
BE
NOLBOOLF
BRANCH IF SO - 32 AT ONCE
28710000
SR
1,1
OTHERWISE, HAVE TO GO THROUGH FETCH. 28800000
NOLBOOLF SLA 1,4
MAKE CCODE A QUADRUPLE WORD INDEX. 28890000
LA
1,FCHTBL(1)
GET POINTER TO FETCH TABLE.
28980000
LM
2,5,0(1)
AND PICK UP A SET OF FETCH OPERANDS. 29070000
L
4,LHBASE
NOW, BUILD A FETCH ADDRESS.
29160000
A
4,LHRANK
BASE + RANK
29250000
LA
4,MRHO-M(4)
+ HEADER LENGTH.
29340000
TM
LHSCALAR,1
SEE IF LEFT CAN EXTEND.
29430000
BZ
LSETUP
BRANCH IF NOT.
29520000
MVI FCHSCLR,1
OTHERWISE, INDICATE PRE-FETCH.
29610000
BALR LKR,5
AND PRE-FETCH THE OPERAND.
29700000
L
2,COMTYP
PICK UP THE COMPUTE TYPE.
29790000
MOVE RBASE TO R1.
NOW, GO SET UP HEADER.

C
BH
BE
MVI
SRA
LFXT
ST
LA
B
LDXT
C
BE
STM
LA
LSETUP STM
SPACE
L
C
BNE
TM
BNZ
C
BE
SR
NORBOOLF SLA
LA
LM
L
A
LA
TM
BNZ
TM
BZ
MVI
BALR
L
C
BH
BE
MVI
SRA
RFXT
ST
LA
B
RDXT
C
BE
STM
LA
RSETUP STM
SPACE
L
C
BNE
MVC
B
FIXFER MVC
DSTORTN L
OR
O
O
BCT

2,OP2
LDXT
LFXT
LHTYPE+3,1
0,31
0,XTNSHN
5,XTNFIX
LSETUP
2,OP4
LFXT
0,1,XTNSHN
5,XTNFLT
2,5,LHFETCH

COMPARE WITH INTEGER TYPE.

BRANCH IF FLOATING.
OR IF FIXED.
BOOLEAN - SET LH TYPE ACCORDINGLY.
AND EXTEND THE OPERAND TO A FULL WOR
STORE THE EXTENDING OPERAND.
REPLACE THE FETCH RTNE ADDRESS.
SET UP IS COMPLETE.
SEE IF CTYPE IS PERCHANCE CHARACTER.
BRANCH IF SO.
OTHERWISE, STORE FLOATING EXTENSION.
AND REPLACE THE FETCH RTNE ADDRESS.
LEFT IS NOW SET UP.

1,RCTYPE
1,OP1
NORBOOLF
LHSCALAR,1
NORBOOLF
1,LCTYPE
NORBOOLF
1,1
1,4
1,FCHTBL(1)
2,5,0(1)
4,RHBASE
4,RHRANK
4,MRHO-M(4)
FCHSCLR,1
RSETUP
RHSCALAR,1
RSETUP
FCHSCLR,1
LKR,5
2,COMTYP
2,OP2
RDXT
RFXT
RHTYPE+3,1
0,31
0,XTNSHN
5,XTNFIX
RSETUP
2,OP4
RFXT
0,1,XTNSHN
5,XTNFLT
2,5,RHFETCH

NOW RIGHT, PICK UP FETCH CODE.

SEE IF IT'S BOOLEAN.
BRANCH IF NOT.
SEE IF LEFT EXTENDS.
BRANCH IF SO - OI IN ONE BLOW.
SEE IF LEFT IS THE SAME.
BRANCH IF SO - 32 IN ONE BLOW.
OTHERWISE, WE HAVE TO GO THROUGH FTC
FCODE BECOMES A QUADRUPLE WORD INDEX
GET POINTER INTO FETCH TABLE.
PICK UP A SET OF FETCH OPERANDS.
NOW BUILD DATA ADDRESS.
BASE + RANK
+ HEADER LENGTH.
SEE IF RIGHT WAS PRE-FETCHED.
BRANCH IF SO - CAN'T PREFETCH AGAIN.
OTHERWISE, SEE IF RIGHT CAN EXTEND.
BRANCH IF NOT.
OTHERWISE, SET PRE-FETCH INDICATOR.
AND PRE-FETCH.
NOW, LOOK AT CTYPE.
COMPARE TO INTEGER.
BRANCH IF FLOATING,
OR IF INTEGER.
BOOLEAN - SET TYPE TO BOOL.
AND EXTEND OPERAND TO WORD.
STORE EXTENDING WORD.
AND REPLACE FETCH RTNE ADDRESS.
SET UP COMPLETE.
SEE IF CTYPE IS CHARACTER.
BRANCH IF SO.
OTHERWISE, STORE FLOATING EXTENSION.
AND REPLACE FETCH ROUTINE ADDRESS.
RIGHT IS NOW SETUP.

2,COMTYP
2,OP3
FIXFER
STOP(8),DSTL
DSTORTN
STOP(8),GSTL
1,RSTYPE
2,1
2,LHTYPE
2,RHTYPE
2,NOTBOOL

PICK UP COMPUTE TYPE.

SEE IF IT'S FLOATING.
BRANCH IF NOT.
MOVE IN STORE, LOAD INSTRUCTION.
FIXED STORE, LOAD OVER RIGHT FETCH.
NOW, PICK UP RESULT TYPE.
SEE IF WE CAN DO 32 IN ONE BLOW.
CONSIDER OPERAND TYPES AS WELL.
CONSIDER OPERAND TYPES AS WELL.
BRANCH IF NOT.

29880000
29970000
30060000
30150000
30240000
30330000
30420000
30510000
30600000
30690000
30780000
30870000
30960000
31050000
31140000
31230000
31320000
31410000
31500000
31590000
31680000
31770000
31860000
31950000
32040000
32130000
32220000
32310000
32400000
32490000
32580000
32670000
32760000
32850000
32940000
33030000
33120000
33210000
33300000
33390000
33480000
33570000
33660000
33750000
33840000
33930000
34020000
34110000
34200000
34290000
34380000
34470000
34560000
34650000
34740000
34830000
34920000
35010000
35100000
35190000

LA
8,31(8)
OTHERWISE, CHANGE ELEMENT COUNT SRL 8,5
INTO A WORD COUNT.
LA
1,2
AND USE INTEGER STORE ROUTINE.
NOTBOOL SLA 1,2
MAKE RESULT TYPE A WORD INDEX.
L
7,STRTBL(1)
PICK UP ROUTINE ADDRESS.
L
6,RBASE
PICK UP RESULT M-POINTER.
A
6,RRANK
ADD IN RESULT RANK.
LA
6,MRHO-M(6)
NOW POINTS TO WHERE RESULT GOES.
LA
2,32
INITIALIZE BOOLEAN STORE.
ST
2,STRSHIFT
EJECT
*
*
DYADIC EXECUTION LOOP.
*
SPACE
L
9,OPRN
PICK EXECUTION ROUTINE ADDRESS.
ON
XOF,=A(BLOWUP)
DOPLOOP LM
2,5,RHFETCH
FETCH A RIGHT.
BALR LKR,5
ENTER FETCH ROUTINE.
STM 2,5,RHFETCH
ALSO SAVE UPDATED FETCH OPERANDS.
EX
0,STOP
STORE OVER LEFT FETCH.
LM
2,5,LHFETCH
FETCH LEFT OPERAND.
BALR LKR,5
GO GET IT.
STM 2,5,LHFETCH
SAVE UPDATED OPERANDS.
LR
1,0
MOVE LEFT TO R1.
EX
0,LOP
LOAD RIGHT AFTER FETCH.
BALR LKR,9
EXECUTE.
BCR 1,0
NO OP INSERTED TO COMBAT IMPRECISE
*
INTERRUPTS ON THE MODEL 91
BALR LKR,7
STORE ROUTINE.
QUEND
B
DOPLOOP
IF STORE ROUTINE RETURNS, LOOP.
SPACE 3
TITLE 'MONADIC EXECUTION CONTROL.'
*
*
MONADIC EXECUTION CONTROL.
*
*
NOTE PROGRAM BASE REGISTER MANEUVER - NEEDED FOR
*
UNIFORM ADDRESSABILITY.
*
SPACE
DOMOP
PROLOG OPSECT,NDOPSECT
ENTRY.
ENTRY DOMOP
L
PR,=A(DODOP+6)
DOMOP MUST BE GE DODOP.
USING DODOP+6,PR
THIS IS DEPENDENT ON PROLOG MACRO.
*
***********************************
SPACE
MVI BLOWN,0
RESET BLOWUP INDICATOR.
L
9,SVI
LOCATE STACKED EXPRESSION.
AR
9,MR
USE AN ABSOLUTE POINTER.
LM
15,1,4(9)
PICK UP MONADIC EXPRESSION.
STM 15,0,OPERATOR
SAVE OPERATOR AND ITS INDEX
LA
5,12
SET UP SVI INCREMENT.
ST
5,INCR
BAL LKR,LJWSET
SET UP THE GOOD STUFF.
STC 8,TEMPRGT
STORE TEMPORARY INDICATOR.
STC 6,RHSCALAR
STORE SCALAR INDICATOR.
STM 1,4,RHBASE
STORE SOME MORE.
BAL LKR,PICKINDX
SPACE

35280000
35370000
35460000
35550000
35640000
35730000
35820000
35910000
36000000
36090000
36180000
36270000
36360000
36450000
36540000
36630000
36720000
36810000
36900000
36990000
37080000
37170000
37260000
37350000
37440000
37530000
37620000
37710000
37800000
37890000
37980000
38070000
38160000
38250000
38340000
38430000
38520000
38610000
38700000
38790000
38880000
38970000
39060000
39150000
39240000
39330000
39420000
39510000
39600000
39690000
39780000
39870000
39960000
40050000
40140000
40230000
40320000
40410000
40500000
40590000

SR
*
*
*

0,0

BLOWUP MAY RETURN HERE.

ENTRY MBLOWRTN
MBLOWRTN SR
2,2
ST
2,LHTYPE
ST
2,LHBASE
LR
1,0
IC
1,OPERATOR+3
L
3,RHTYPE
CLI OPERATOR+2,0
BE
MC1
LR
2,3
MC1
ICALL ARTHTP
STM 1,5,TYPINFO
L
2,OPERATOR
C
2,=F'256'
BNH MCOT
L
9,=A(REDUCE)
BALR LKR,9
BC
15,LWCLEAN
MCOT
L
5,=A(INDICTR)
LA
5,0(2,5)
TM
0(5),INDEXED
BO
MNXCHK
L
1,OPINDEX
LTR 1,1
BNZ SYNTERR
MNXCHK TM
0(5),1
BNZ MSCOP
L
9,OPRN
BALR LKR,9
BC
15,LWCLEAN
SPACE
*
*
SET UP RESULT.
*
SPACE
MSCOP
TM
0(5),X'80'
BO
MNOXCHK
L
1,OPINDEX
LTR 1,1
BNZ SYNTERR
MNOXCHK L
2,RHRANK
ST
2,RRANK
L
3,RSTYPE
L
1,RHXRHO
TM
TEMPRGT,1
BZ
MGETSP
C
3,RHTYPE
BNE MGETSP
L
9,SVI
L
1,RHBASE
ST
9,MHEAD(1)
ST
1,M(9)
S
9,OP4
ST
9,SVI
ST
1,RBASE
MVI TEMPRGT,0

DON'T FORCE A RESULT TYPE.

40680000
40770000
40860000
40950000
41040000
ZERO LHBASE AND TYPE.
41130000
41220000
41310000
41400000
PICK UP THE OPERATOR
41490000
AND RH TYPE.
41580000
IS THIS REDUCE
41670000
NO
41760000
YES SO REALLY DYADIC
41850000
41940000
SAVE THE RESULTS.
42030000
PICK UP OPERATOR AGAIN.
42120000
42210000
42300000
ISN'T THIS JUST GREAT
42390000
42480000
42570000
42660000
42750000
SEE IF INDEX IS ALLOWED.
42840000
BRANHC IF NOT.
42930000
OTHERWISE, SEE IF THERE WAS ONE.
43020000
43110000
SYNTAX ERROR IF SO.
43200000
SEE IF IT'S A SCALAR OPERATOR.
43290000
BRANCH IF SCALAR.
43380000
OTHERWISE, LINK TO NON-SCALAR ROUTIN 43470000
43560000
GO TO CLEANUP.
43650000
43740000
43830000
43920000
44010000
44100000
SEE IF AN INDEX IS ALLOWED.
44190000
BRANCH IF SO.
44280000
OTHERWISE, CHECK FOR INDEX.
44370000
IT SHOULD BE ZERO.
44460000
SYNTAX ERROR IF NOT.
44550000
PICK UP RESULT RANK.
44640000
SET RESULT RANK TO IT.
44730000
PICK UP TYPE.
44820000
AND NO. OF ELEMENTS.
44910000
SEE IF OPERAND IS TEMP.
45000000
BRANCH IF NOT.
45090000
COMPARE RESULT TO RH TYPE.
45180000
BRANCH IF WE HAVE TO GET SPACE.
45270000
OTHERWISE, PUT RESULT PTR ON STACK. 45360000
ALSO ON TOP OF OPERAND.
45450000
SET UP REFLECTING POINTERS.
45540000
IN STACK AND M-ENTRY.
45630000
MOVE DOWN STACK POINTER.
45720000
AND SAVE IT.
45810000
45900000
45990000

MGETSP

*
*
*

B
SPACE
LA
BALR
ST
L
ST
L
STC
LTR
BZ
L
LA
LA
BCTR
EX
EJECT

MSETUP

NOW, REJOIN.

10,OPSPACE
LKR,10
1,RBASE
3,RHRANK
3,MTYPE(1)
4,RSTYPE
4,MTYPE(1)
3,3
MSETUP
2,RHBASE
1,MRHO(1)
2,MRHO(2)
3,0
3,MOVRANK

ENTER COMMON GETSPACE ROUTINE

AND THE TYPE.

SEE IF THERE'S ANY RANK VECTOR.
BRANCH IF NOT.
GET
FOR
GET
AND

ABSOLUTE POINTERS.
THE RANK MOVE.
SS COUNT FROM RANK.
MOVE IN THE RANK VECTOR.

MONADIC SCALAR SETUP AND EXECUTE.

SPACE
L
8,RHXRHO
LTR 8,8
BC
8,LWCLEAN
MVI FCHSCLR,0
L
1,RCTYPE
SLA 1,4
LA
1,FCHTBL(1)
LM
2,5,0(1)
L
4,RHBASE
A
4,RHRANK
LA
4,MRHO-M(4)
STM 2,5,RHFETCH
L
1,RSTYPE
L
2,COMTYP
O
2,RHTYPE
OR
2,1
BCT 2,MNOBOOL
LA
8,31(8)
SRL 8,5
LA
1,2
MNOBOOL SLA 1,2
L
7,STRTBL(1)
L
6,RBASE
A
6,RHRANK
LA
6,MRHO-M(6)
LA
2,32
ST
2,STRSHIFT
SPACE 5
*
*
MONADIC EXECUTION LOOP.
*
SPACE
L
9,OPRN
ON
XOF,=A(BLOWUP)
MOPLOOP LM
2,5,RHFETCH
BALR LKR,5
STM 2,5,RHFETCH
LR
2,0
LDR 2,0
MSETUP

STORE RESULTING POINTER.

SET UP HEADER.
STORE RANK,

PICK UP NUMBER OF ELEMENTS.

SEE IF THERE ARE ANY.
BRANCH IF NONE.
TURN OFF EXTENSION FLAG.
PICK UP CONVERSION CODE.
CONVERT TO QUADRUPLE WORD INDEX.
GET POINTER INTO FETCH TABLE.
PICK UP A SET OF OPERANDS.
PICK UP OPERAND BASE.
ADD RANK VECTOR LENGTH.
ADD HEAD LENGTH.
STORE OPERANDS.
PICK UP RESULT TYPE.
SEE IF WE CAN DO 32 ELS AT A TIME.
BRANCH IF NOT.
OTHERWISE, CHANGE ELCT TO WDCT.
AND USE INTEGER STORE ROUTINE.
CONVERT RESULT TYPE TO WORD INDEX.
AND PICK UP STORE ROUTINE ADDRESS.
PICK UP RESULT BASE.
ADD RANK.
POINT AT FIRST RESULT ELEMENT.
INITIALIZE BOOLEAN STORE.

PICK UP EXECUTION ROUTINE ADDRESS.

SET FIXED OVERFLOW TRAP.
FETCH AN OPERAND.
THROUGH FETCH ROUTINE.
STORE UPDATED FETCH OPERANDS.
MOVE OPERAND TO RH REGISTER.

46080000
46170000
46260000
46350000
46440000
46530000
46710000
46800000
46890000
46980000
47070000
47160000
47250000
47340000
47430000
47520000
47610000
47700000
47790000
47880000
47970000
48060000
48150000
48240000
48330000
48420000
48510000
48600000
48690000
48780000
48870000
48960000
49050000
49140000
49230000
49320000
49410000
49500000
49590000
49680000
49770000
49860000
49950000
50040000
50130000
50220000
50310000
50400000
50490000
50580000
50670000
50760000
50850000
50940000
51030000
51120000
51210000
51300000
51390000
51480000

BALR LKR,9
BCR 1,0

EXECUTE OPERATOR.
NO OP INSERTED TO COMBAT IMPRECISE
INTERRUPTS ON THE MODEL 91
STORE.

51570000
51660000
*
51750000
BALR LKR,7
51840000
QUEND
51930000
B
MOPLOOP
THAT'S ALL.
52020000
EJECT
52110000
*
52200000
*
PICKINDX COMPUTES OPERATOR INDEX AND TESTS IF VALID INDEX
52290000
***** THIS ROUTINE ASSUMES OPINDEX HAS BEEN SET *****
52380000
*
CALLING SEQUENCE
52470000
*
L
10=A(PICKINDX)
52560000
*
BALR LKR,10
52650000
*
DATA RETURNED.
52740000
*
'INDEX' CONTAINS
52830000
*
0-N
ORIGIN CORRECTED OPERATOR INDEX.
52920000
*
INDBASE = 0 FOR ELIDED INDEX
53010000
*
INDBASE = 1 FOR INDEX (UPPER BYTE.)
53100000
*
53190000
PICKINDX ST
LKR,REGSAV
SAVE LINK REGISTER
53280000
MVI INDBASE,0
INITIALLY SET FOR ELIDED INDEX
53370000
MVI TEMPIND,0
SET INDEX TO TEMPORARY
53460000
L
3,OPINDEX
GET THE OPERATOR INDEX
53550000
LTR 3,3
TEST FOR ELISION
53640000
BCR 8,LKR
RETURN IF INDEX ELIDED
53730000
MVI INDBASE,X'80'
53820000
LH
2,MLSCT(3)
PICK UP COUNT OF LIST ELEMENTS
54000000
BCT 2,RNGEROR
ERROR IF COUNT NE 1
54090000
*
R2 IS ZERO IF THIS ROUTE IS TAKEN
54180000
L
4,MLSORG(3)
OTHERWISE, PICK UP FIRST LIST ELEM. 54270000
LTR 4,4
TEST IF TEMP OR POINTER
54360000
BP
LISTTEMP
BRANCH IF TEMPORARY
54450000
BZ
RNGEROR
ERROR IF NULL
54540000
L
4,M(4)
INDIRECT -- GET M-ENTRY
54720000
MVI TEMPIND,1
MARK INDEX NOT TEMP
54810000
LISTTEMP SR
3,3
54900000
IC
3,MTYPE(4)
GET TYPE
54990000
ST
3,INDTYPE
SAVE FOR FRACTIONAL FE\CH
55080000
LH
1,MRANK(4)
AND RANK
55170000
CL
1,OP4
TEST IF SCALAR
55260000
BL
GETINDEX
BRANCH IF SCALAR
55350000
BNE RANKBAD
MATRIX OR HIGHER = INDEX ERROR
55440000
L
0,MRHO(4)
GET NO. OF ELEMENTS
55530000
BCT 0,RANKBAD
ERROR IF NOT ONE COMPONENT
55620000
GETINDEX LA
4,MRHO-M(4,1)
GET BASE OF DATA
55710000
ON
RNG,FLTINDX
55890000
ICALL FETCHINT
55980000
S
0,IORIGIN
CORRECT FOR ORIGIN
56070000
ST
0,INDEX
INDEX IS RESULT
56160000
GOTIND ON
RNG
DISABLE DOMAIN ERROR TRAP
56250000
L
LKR,REGSAV
RESTORE RETURN REGISTER
56340000
BR
LKR
RETURN TO CALLER
56430000
SPACE 4
56520000
FINDEX EQU INDRANK
MAKE IT EASY TO CHANGE
56610000
*
WE PROBABLY HAVE A FLOATING INDEX
56700000
FLTINDX CLI INDTYPE+3,4
UNLESS THE DUMMY CODED
56790000
BE
RANKBAD
A CHARACTER INDEX
56880000
AR
4,MR
56970000
MVC DBLHOLD,0(4)
GOT IT
57060000
LA
3,8
TO CONVERT ORIGIN TO FLOATING
57150000

SR
LA
ICALL
LD
SDR
STD
MVC
MVI
B
TITLE

2,2
4,IORIGIN-M
FETCH
2,DBLHOLD
2,0
2,DBLHOLD
FINDEX(8),DBLHOLD
INDBASE,X'C0'
GOTIND
'SCALAR OP CONTROL

SHOULD STILL BE ZERO

M-REL ADDRESS OF IORIGIN
CONVERT IT
PICK UP INDEX
SUBTRACT ORIGIN
SAVE IT
STUFF IT
MARK INDEX FRACTIONSL

57240000
57330000
FLT1
57420000
57510000
57600000
57690000
57780000
57870000
57960000
FETCH AND STORE ROUTINES.'
58050000
*
58140000
*
SCALAR OP FETCH ROUTINES.
58230000
*
58320000
SPACE
58410000
*
FIXED - NO CONVERSION.
58500000
*
R2 - NOT USED.
58590000
*
R3 - INCREMENT (0 IF OPERAND EXTENDING.).
58680000
*
R4 - BASE.
58770000
*
58860000
*
R0 - FETCHED OPERAND.
58950000
*
59040000
SPACE
59130000
FCHWORD L
0,M(4)
PICK UP DATA.
59220000
AR
4,3
ADD POINTER INCREMENT.
59310000
BR
LKR
AND RETURN.
59400000
SPACE
59490000
*
FLOATING - NO CONVERSION.
59580000
*
R2 - DESTROYED.
59670000
*
R3,R4 - AS IN FIXED, ABOVE.
59760000
*
59850000
*
D0 - FETCHED OPERAND
59940000
*
R0,R1 - FETCHED OPERAND.
60030000
*
60120000
SPACE
60210000
FCHDBL LA
2,M(4)
R2 DESTROYED.
60300000
LM
0,1,0(2)
PICK UP DOUBLE WORD.
60390000
STM 0,1,DTEMP
THROUGH TEMP STORAGE 60480000
LD
0,DTEMP
TO GET TO A DOUBLE REGISTER.
60570000
AR
4,3
ADD INCREMENT.
60660000
BR
LKR
AND RETURN.
60750000
SPACE
60840000
SPACE
60930000
*
61020000
*
CHARACTER FETCH.
61110000
*
REGISTERS AS IN FIXED.
61200000
*
61290000
SPACE
61380000
FCHCHAR IC
0,M(4)
PICK UP CHARACTER.
61470000
SLL 0,24
LAND IT ON THE LEFT OF THE REGISTER. 61560000
AR
4,3
ADD INCREMENT.
61650000
BR
LKR
AND RETURN.
61740000
SPACE
61830000
*
61920000
*
CALL TO EXTERNAL FETCH ROUTINE.
62010000
*
62100000
SPACE
62190000
EXFETCH ST
LKR,SAVER
SAVE LINK OVER CALL.
62280000
ICALL FETCH
FETCH AN OPERAND.
62370000
L
LKR,SAVER
PICK UP LINK.
62460000
LA
2,1(2)
INCREMENT INDEX.
62550000

BR
LKR
SPACE

AND RETURN.

62640000
62730000
*
62820000
*
OPERAND EXTENSION FETCHES.
62910000
*
63000000
SPACE
63090000
XTNFIX L
0,XTNSHN
FIXED - BOOLEAN, INTEGER , CHARACTER 63180000
BR
LKR
63270000
SPACE
63360000
XTNFLT LD
0,XTNSHN
FLOATING.
63450000
BR
LKR
63540000
SPACE
63630000
*
63720000
*
INTEGER TO BOOLEAN FETCH.
63810000
*
63900000
SPACE
63990000
FCHIBOOL L
0,M(4)
PICK UP INTEGER.
64080000
CL
0,OP1
SEE IF IT'S IN RANGE.
64170000
BH
RNGEROR
QUIT IF NOT.
64260000
SLL 0,31
OTHERWISE, LEFT JUSTIFY IT.
64350000
AR
4,3
INCREMENT THE POINTER.
64440000
BR
LKR
AND RETURN.
64530000
SPACE
64620000
*
64710000
*
INTEGER TO FLOATING FETCH.
64800000
*
64890000
SPACE
64980000
FCHIDBL L
0,M(4)
PICK UP INTEGER.
65070000
AL
0,DUN231+4
65160000
ST
0,DTEMP+4
INTO A WORK AREA.
65250000
LD
0,DTEMP
INTO A FLOATING REGISTER.
65340000
LE
0,DUN231
65430000
SD
0,DUN231
65520000
STD 0,DTEMP
BACK TO GRS.
65610000
LM
0,1,DTEMP
65700000
AR
4,3
INCREMENT POINTER.
65790000
BR
LKR
AND RETURN.
65880000
EJECT
65970000
*
66060000
*
SINCE ARTHTP WILL ONLY ALLOW EQUAL AND NOTEQUAL TO
66150000
*
RETURN FOR EXECUTION, WE ASSUME THAT A FETCH OF A NUMERIC
66240000
*
QUANTITY FOR ONE OF THESE OPERATIONS IS REQUIRED.
66330000
*
SINCE CHARACTERS WILL BE LEFT JUSTIFIED WHEN FETCHED, AND
66420000
*
SINCE THE LAST 24 BITS OF A REGISTER WILL BE ZERO WHEN IT
66510000
*
CONTAINS A CHARACTER, WE LOAD FRACMASK (00FFFFFF) TO ENSURE
66600000
*
A NOT-EQUAL COMPARE.
66690000
*
66780000
SPACE
66870000
ILLCHAR L
0,FRACMASK
66960000
BR
LKR
67050000
EJECT
67140000
*
67230000
*
STORE ROUTINES.
67320000
*
67410000
SPACE
67500000
*
67590000
*
BOOLEAN STORE ROUTINE.
67680000
*
67770000
SPACE
67860000
STRBOOL ST
1,CURRES
STORE CURRENT RESULT.
67950000

LM
0,2,GEARSHFT
GET SHIFT STATE.
SLDL 0,1
CATENATE CURRENT RESULT.
BCT 2,PUTBACK
DECREMENT SHIFT COUNT.
ST
0,M(6)
STORE A WORD IF WE FALL THROUGH.
LA
6,4(6)
INCREMENT RESULT POINTER.
LA
2,32
RE-INITIALIZE SHIFT COUNT.
PUTBACK STM 0,2,GEARSHFT
AND STORE SHIFT STATE.
BCTR 8,LKR
BRANCH IF MORE TO BO.
C
2,OP32
OTHERWISE, SEE IF WE JUST STORED.
BE
NOSHFT
BRANCH IF SO.
SLL 0,0(2)
OTHERWISE, LEFT JUSTIFY.
ST
0,M(6)
AND STORE.
NOSHFT B
LWCLEAN
ALL FINISHED.
SPACE
*
*
INTEGER STORE.
*
SPACE
STRFIX ST
1,M(6)
STORE RESULT ELEMENT.
LA
6,4(6)
BUMP RESULT POINTER.
BCTR 8,LKR
RETURN IF MORE TO GO.
B
LWCLEAN
ALL FINISHED.
SPACE
*
*
FLOATING STORE.
*
SPACE
STRFLT STD 0,DTEMP
MOVE RESULT TO GRS.
LM
0,1,DTEMP
LA
2,M(6)
GET ABSOLUTE RESULT POINTER.
STM 0,1,0(2)
STORE RESULT ELEMENT.
LA
6,8(6)
BUMP POINTER.
BCTR 8,LKR
BRANCH IF NOT FINISHED.
B
LWCLEAN
OTHERWISE QUIT.
EJECT
*
*
FETCH ROUTINE TABLE.
*
SPACE
*TYPE
INDEX,FETCHCODE,DATABASE,ROUTINE ADDR
*
OR
UNUSED,INCR,DATABASE,ROUTINEADDR
SPACE
DC
0F'0'
WORD ALIGNMENT AREA.
ENTRY FCHTBL
FCHTBL EQU *
T0
FETCHES 0,1,0,EXFETCH
T1
FETCHES 0,4,0,FCHWORD
T2
FETCHES 0,4,0,FCHWORD
T3
FETCHES 0,8,0,FCHDBL
T4
FETCHES 0,1,0,FCHCHAR
T5
FETCHES 0,5,0,EXFETCH
T6
FETCHES 0,6,0,EXFETCH
T7
FETCHES 0,4,0,FCHIBOOL
T8
FETCHES 0,4,0,FCHIDBL
T9
FETCHES 0,9,0,EXFETCH
T10
FETCHES 0,10,0,EXFETCH
T11
FETCHES 0,11,0,EXFETCH
T12
FETCHES 0,12,0,EXFETCH
T13
FETCHES 0,0,0,ILLCHAR
SPACE

68040000
68130000
68220000
68310000
68400000
68490000
68580000
68670000
68760000
68850000
68940000
69030000
69120000
69210000
69300000
69390000
69480000
69570000
69660000
69750000
69840000
69930000
70020000
70110000
70200000
70290000
70380000
70470000
70560000
70650000
70740000
70830000
70920000
71010000
71100000
71190000
71280000
71370000
71460000
71550000
71640000
71730000
71820000
71910000
72000000
72090000
72180000
72270000
72360000
72450000
72540000
72630000
72720000
72810000
72900000
72990000
73080000
73170000
73260000
73350000

*
*
*

73440000
73530000
73620000
SPACE
73710000
STRTBL EQU *-4
73800000
DC
A(STRBOOL)
73890000
DC
A(STRFIX)
73980000
DC
A(STRFLT)
74070000
TITLE 'OPERATOR EXECUTION CLEANUP ROUTINE.'
74160000
*
74250000
*
SCALAR OPERATION CLEANUP ROUTINE.
74340000
*
74430000
*
SOME EXECUTION ROUTINES DIDDLE INCR.
74520000
*
BE CAREFUL WHEN MODIFYING CLEANUP.
74610000
*
74700000
LWCLEAN BALR PR,0
ESTABLISH THE BASE REGISTER.
74790000
CLEANUP EQU *
74880000
ENTRY CLEANUP
74970000
DROP PR
75060000
USING CLEANUP,PR
75150000
ON
XOF
RESTORE ON CONDITION.
75240000
L
9,SVI
GET SVI AGAIN.
75330000
*
75420000
*
NOW, MARK GARBAGE.
75510000
*
75600000
GARBIT TM
TEMPLFT,1
SEE IF LEFT TEMP.
75690000
BZ
GARBRT
BRANCH IF NOT.
75780000
L
3,LHBASE
75870000
LTR 3,3
MAKE SURE WE HAD A LEFT.
75960000
BZ
GARBRT
BRANCH IF NOT.
76050000
MKG 3
OTHERWISE, MARK IT.
76140000
GARBRT TM
TEMPRGT,1
NOW TRY RIGHT.
76230000
BZ
SETSVI
BRANCH IF NOT TEMP.
76320000
L
3,RHBASE
76410000
LTR 3,3
MAKE SURE RT IS STILL DEFINED
76500000
BZ
SETSVI
MEANS OPERATOR IS USING RT
76590000
*
AS A RESULT
76680000
MKG 3
OTHERWISE, MARK IT.
76770000
SETSVI L
7,M+4(9)
PICK UP RESULT M-POINTER.
76860000
A
9,INCR
INCREMENT SVI.
76950000
ST
9,SVI
AND STORE IT.
77040000
L
1,M(9)
MARKING THE OPERATOR INDEX GARBAGE. 77130000
ICALL MKGARB
NOTE THE ASSUMPTION ABOUT SVI.
77220000
ST
7,M+4(9)
PUT RESULT ADDR AT PROPER PLACE IN S 77310000
LA
9,4(9)
INCREMENT SVI.
77400000
LTR 7,7
IF RESULT IS INDIRECT POINTER (TO
77490000
BM
OPEND
SYMBOL TABLE), AVOID RELOCATION.
77580000
LA
0,CONST
INSERT CLASS = TEMP IN STACKED
77670000
STC 0,M(9)
M-POINTER.
77760000
ST
9,MHEAD(7)
AND STORE A REFLECTING POINTER.
77940000
OPEND
IRETURN
78030000
TITLE 'COMMON OP CONTROL SUBROUTINES.'
78120000
*
78210000
*
CALCULATE X/RHO
78300000
*
78390000
*
ARGUMENTS..
78480000
*
RANK - R2
78570000
*
BASE - R3
78660000
*
RESULT IN R1.
78750000
*
78840000
STORE ROUTINE TABLE.

*
*

REGISTERS 1 2 3 4 5 DESTROYED.

78930000
79020000
SPACE
79110000
CXRHO
EQU *
79200000
OPCXRHO EQU CXRHO
FOR EXTERNAL USERS.
79290000
ENTRY OPCXRHO
79380000
USING CXRHO,10
79470000
SPACE
79560000
LA
1,1
INITIALIZE RESULT.
79650000
LTR 2,2
SEE IF OPERAND IS SCALAR.
79740000
BCR 8,LKR
QUIT EARLY IF SO
79830000
LA
5,4
SET UP BXH CONSTANTS.
79920000
LCR 4,5
DECREMENT.
80010000
AR
3,MR
GET ABS POINTER TO OPERAND.
80100000
L
1,MRHO-M-4(3,2)
PICK UP LAST RANK ELEMENT.
80190000
BCT 5,CXBXH
SKIP FIRST MULTIPLY.
80280000
M
0,MRHO-M-4(3,2)
MULTIPLY BY NEXT RANK ELEMENT.
80370000
CXBXH
BXH 2,4,*-4
AND LOOP.
80460000
BR
LKR
80550000
EJECT
80640000
*
80730000
*
OPERATOR COMMON GETSPACE.
80820000
*
80910000
*
CALLING
R1 - NUMBER OF ELEMENTS (X/RHO).
81000000
*
R2 - RANK.
81090000
*
R3 - TYPE.
81180000
*
81270000
*
RETURN
R1 - RESULT M-POINTER.
81360000
*
R2 - DESTROYED.
81450000
*
R3 - DESTROYED.
81540000
*
81630000
SPACE
81720000
*********************************************************************** 81810000
*
81900000
*
OP CONTROL MAKES ASSUMPTIONS
81990000
*
ABOUT THIS ROUTINE. CHECK BEFORE MODIFICATION.
82080000
*
82170000
*********************************************************************** 82260000
SPACE
82350000
OPSPACE EQU *
82440000
ENTRY OPSPACE
82530000
ENTRY OPSCALL
82620000
USING OPSPACE,10
82710000
CL
1,OVERSIZE
MAKE SURE REQUEST WITHIN
82800000
BH
NOSPACE
FULLWORD CAPACITY
82890000
BCT 3,OPSF
BRANCH IF TYPE NOT BOOLEAN.
82980000
A
1,OP31
OTHERWISE, CEIL OF
83070000
SRL 1,5
N DIV 32 GIVES WORD COUNT.
83160000
B
OPGET
GET THE SPACE.
83250000
OPSF
BCT 3,OPSD
BRANCH IF NOT INTEGER
83340000
B
OPGET
OTHERWISE, HAVE WORD COUNT.
83430000
OPSD
BCT 3,OPSC
BRANCH IF CHARACTER.
83520000
AR
1,1
OTHERWISE, WE NEED N DOUBLEWORDS.
83610000
B
OPGET
83700000
OPSC
A
1,OP3
CHARACTER - CEIL OF
83790000
SRL 1,2
N DIV 4 GIVES WORD COUNT.
83880000
OPGET
SLA 1,2
X 4 GIVES BYTES.
83970000
LA
2,MRHO-M(2)
COMBINE RANK*4 AND OVERHEAD SPACE
84060000
AR
1,2
GUARANTEED NO OVERFLOW
84150000
OPSCALL SR
2,2
84240000

ST
LKR,SAVER
ICALL GETSPACE
L
LKR,SAVER
SPACE
*
*
*
*

OPRDIR

OPLDIR

NOSPACE
DYADLEN
*
*
*
EXERROR
RANKEROR

RANKBAD
RNGEROR
*
*
*
SYNTERR

*
*

SAVE LINK.
GET THE SPACE.
PICK UP LINK.

84330000
84420000
84510000
84600000
84690000
THE FOLLOWING RELOCATION IS REQUIRED IN CASE GARBAGE WAS COLLE 84780000
CTED.
84870000
84960000
SPACE
85050000
L
3,SVI
PICK UP STACK POINTER.
85140000
A
3,INCR
LOOK AT RIGHT HAND OPERAND.
85230000
L
2,M+4(3)
PICK UP RH OPERAND.
85320000
LTR 2,2
SEE IF IT'S IN SYMBOL TABLE.
85410000
BP
OPRDIR
BRANCH IF NOT.
85500000
L
2,M(2)
OTHERWISE, GO INDIRECT.
85590000
N
2,FRACMASK
CLEAR HI-ORDER GARBAGE.
85680000
ST
2,RHBASE
RIGHT IS RELOCATED.
85770000
CLI LHTYPE+3,0
SEE IF THERE'S A LEFT OPERAND.
85860000
BCR 8,LKR
BRANCH IF NOT.
85950000
S
3,=A(DYADLEN)
SUBTRACT LENGTH OF DYADIC EXP.
86040000
L
2,M+8(3)
OTHERWISE, PICK UP LEFT OPERAND.
86130000
LTR 2,2
SEE IF IT'S IN ST.
86220000
BP
OPLDIR
BRANCH IF NOT.
86310000
L
2,M(2)
OTHERWISE, GO INDIRECT.
86400000
N
2,FRACMASK
CLEAR HI-ORDER BYTE.
86490000
ST
2,LHBASE
LEFT RELOCATED.
86580000
BR
LKR
RETURN.
86670000
SPACE
86760000
LA
1,EMFULL
86850000
ICALL ERROR
PR MAY HAVE BEEN CHANGED
86940000
EQU 16
87030000
TITLE 'OUR ERROR ROUTINE.'
87120000
87210000
IF WE END UP HERE, THINGS ARE ROUGH.
87300000
87390000
DROP 10
87480000
USING DODOP+6,PR
87570000
EQU *
87660000
LA
1,ESYSTEM
BOMB OUT ON SYSTEM ERROR.
87750000
BC 15,ERRCALL
NO NEED TO DUPLICATE THE ICALL.
87840000
EQU *
87930000
L
1,LHRANK
CHECK RANKS.
88020000
C
1,RHRANK
88110000
BNE RANKBAD
IF NOT EQUAL, RANK ERROR.
88200000
LA
1,ELENGTH
OTHERWISE, MUST BE LENGTH ERROR.
88290000
BC 15,ERRCALL
NO NEED TO DUPLICATE THE ICALL.
88380000
LA
1,ERANK
88470000
BC 15,ERRCALL
NO NEED TO DUPLICATE THE ICALL.
88560000
EQU *
88650000
LA
1,ERANGE
OUT OF RANGE.
88740000
BC 15,ERRCALL
NO NEED TO DUPLICATE THE ICALL.
88830000
88920000
SYNTAX ERROR - INDEXED SCALAR OPERATOR.
89010000
89100000
EQU *
89190000
LA
1,ESYNTAX
89280000
BC 15,ERRCALL
NO NEED TO DUPLICATE THE ICALL.
89370000
SPACE
89460000
89550000
VALUE ERROR - WE FOUND A ZERO M-POINTER.
89640000

*
VALERR LA
1,EVALUE
ERRCALL ICALL ERROR
COMMON ERROR ROUTINE CALL.
TITLE 'CONSTANTS.'
*
*
CONSTANTS AND SYMBOLS.
*
SCALAROP EQU 1
ODDOP
EQU 2
INDEXED EQU X'80'
BRANCH EQU 1
CMPLC
CLC 0(0,3),0(4)
CNOP 0,4
LJWSCONS DC
AL1(MLSTBIT)
THESE SIX CONSTANTS ARE LOADED WITH
DC
XL3'000000'
OP1
DC
F'1'
OVERSIZE EQU *
FRACMASK DC
XL4'00FFFFFF'
LOAD MULTIPLE INSTRUCTION, AND MUST
NEGFOUR DC
XL4'FFFFFFFC'
NOT BE SEPARATED.
DC
F'1'
DC
F'0'
OP2
DC
F'2'
OP3
DC
F'3'
OP4
DC
F'4'
OP31
DC
F'31'
OP32
DC
F'32'
ALLONES DC
X'FFFFFFFF'
CLASSC DC
AL1(CONST,0,0,0)
FOUREASY DC
X'4E000000'
DZERO
DC
D'0'
DUN231 DC
X'4E00000080000000'
MOVRANK MVC 0(0,1),0(2)
GSTL
ST
0,DSAVE
STORE AND LOAD OVER LEFT FETCH.
L
2,DSAVE
MUST FOLLOW GSTL *******************
DSTL
STD 0,DSAVE
DOUBLE STORE AND LOAD OVER FETCH.
LD
2,DSAVE
MUST FOLLOW DSTL *******************
LTORG
EXTRN FETCH
EXTRN GETSPACE
EXTRN ARTHTP
EXTRN FETCHINT
EXTRN ERROR
EXTRN BLOWUP
EXTRN EXDZ
EXTRN MKGARB
EXTRN INDICTR
END
./ ADD
NAME=APLSOPEN
OPEN
TITLE 'A P L D A S D O P E N R O U T I N E S 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
OPLIB
CSECT
PRINT OFF
COPY APLDEFN
COPY APLDEFN
TITLE 'A P L D A S D O P E N R O U T I N E S 05/11/70'
PRINT ON
C037
EXTRN OUTWRTL
C037
EXTRN AAPLSDCB
EXTRN ADIRTAB

89730000
89820000
89910000
90000000
90090000
90180000
90270000
90360000
90450000
90540000
90630000
90720000
90810000
90900000
90990000
91080000
91170000
91260000
91350000
91440000
91530000
91620000
91710000
91800000
91890000
91980000
92070000
92160000
92250000
92340000
92430000
92520000
92610000
92700000
92790000
92880000
92970000
93060000
93150000
93240000
93330000
93420000
93510000
93600000
93690000
93780000
93870000
00130000
00260000
00390000
00520000
00910000
01040000
01170000
01300000
01430000
01560000
01820000
01950000

EXTRN
EXTRN
EXTRN
EXTRN
TITLE
*
*
*
*
*
*
*
*
*
OPLIB

AMANHASH
APLINIT
ALIBPARS,ALIBPZ
AWSLEN
'O P E N A P L

L I B R A R Y

P A C K S

05/11/70'

OPLIB OPENS ALL LIBRARY EXTENTS, CALLING NOPEN FOR EACH.

THE EXTENTS ARE CHECKED TO MAKE SURE THEY ARE ALL OF THE SAME
DEVICE, AND THE PROGRAM IS CANCELLED IF THEY ARE NOT.
WHEN ALL LIBRARY EXTENTS ARE OPENED SUCESSFULLY, PRIMARY
AND SECONDARY DIRECTORY ADDRESSES ARE CALCULATED.
IF LIBRARY EXTENT ZERO IS NOT LARGE ENOUGH TO CONTAIN ALL
DIRECTORIES (UNLIKELY), WE CANCEL THE PROGRAM.

CSECT
BALR 2,0
USING *,2
STM 0,15,SAVEALL
DROP 2
BALR 12,0
USING *,12
LM
1,2,=A(ALIBPZ,ALIBPARS)
L
1,0(1)
L
2,0(2)
STM 1,2,CDCBXLE+4
MOTHER COPY OF LIBPARS.
*
CFREDSK IS MAX/FREEDSK
WHERE RHO FREEDSK IS PACKS,MANHAS
LA
9,NOPEN
L
8,ADPAR
USING CDCPARS,8
LOL1
BALR 15,9
OPEN ONE FILE
MVC CFREDSK,EXTLOW
FILE ZERO WILL HAVE THIS OVERWRITTEN
L
2,ADPAR
INITIALIZE EXTENT COMPARE INNER LOOP
LOL4
CR
2,8
BE
LOL5
END OF EXTENT COMPARE
CLC PHYSAD,PHYSAD-CDCPARS(2)
BNE LOL6
DIFFERENT DEVICES
LOL2
A
2,CDCBXLE
B
LOL4
BACK TO TOP OF INNER LOOP
LOL6
CLC TLENF,TLENF-CDCPARS(2)
BE
LOL2
DEVICE TYPES IDENTICAL
LA
1,DTM
LIBRARY DEVICE TYPES DIFFER
MVC BUF1(44),DSLAB
STANDARD LOCATION TO PRINT FROM
MVI BUF1+44,X'FF'
END OF STATEMENT CODE FOR OUTWRTL
ICALL OUTWRTL
DC
AL4(BUF1)
MVC BUF1(44),DSLAB-CDCPARS(2)
ICALL OUTWRTL
DC
AL4(BUF1)
LOGEOJ2 ST
1,LOGEOJ3
CNOP 2,4
FORCE ALIGNMENT OF TEXT ADDRESS
ICALL OUTWRTL
LOGEOJ3 DC
AL4(*-*)
ABEND 1410
K12
EXTOMIN LA
1,ETM
LIB 0 TOO SMALL FOR DIRECTORIES
B
LOGEOJ2
*
*
END OF INNER LOOP
*
LOL5
LM
0,1,CDCBXLE
BXLE 8,0,LOL1
OPEN NEXT FILE

02080000
02210000
02340000
02470000
03640000
03770000
03900000
04030000
04160000
04290000
04420000
04550000
04680000
04810000
04940000
05070000
05200000
05330000
05460000
05590000
05720000
05980000
06110000
06240000
06370000
06630000
06760000
06890000
07020000
07150000
07280000
07410000
07540000
07670000
07800000
07930000
08060000
08190000
08320000
08450000
08580000
08710000
08840000
08970000
09100000
09230000
09360000
09490000
09620000
09750000
09880000
10010000
10530000
10790000
10920000
11050000
11180000
11310000
11440000
11570000

*
*
*
*
*

*
MLOOP

ALTCZ

ALTCP

*
ALTC1
ALTC3
*
*
*
ETM
DTM
*
SAVEALL
ADSW
*
*
*
*
*
*
*
*
*
*

CALCULATE PRIMARY AND SECONDARY DIRECTORY ADDRESSES.

R7 IS DIRTAB ADDRESS. ASSUME DIRTAB DS (2*MANHASH+1)F
R15 IS RETURN
USING
L
L
S
L
L
L
LA
L
L
MVI
B

CDCPARS,8
7,=A(ADIRTAB)
7,0(7)
7,=F'4'
1,=A(AMANHASH)
1,0(1)
1,0(1)
0,1(1,1)
8,ADPAR
1,EXTLOW
ADSW,0
ALTCZ

AH
BAL
XI
BZ
EX
BNE
LA
BAL
CL
BNL
ST
LA
BCT
ST
LM
BR
EX
BCR
A
B

1,TPERWS
15,ALTCP
ADSW,1
ALTCZ
1,ALTC3
ALTCZ
1,1(1)
15,ALTCP
1,EXTUP
EXTOMIN
1,4(7)
7,4(7)
0,MLOOP
1,CFREDSK
0,15,SAVEALL
15
1,ALTC1
2,15
1,CCADJ
ALTCP

CLI
CLI

HMAX+1,0
3(7),0

INDIRECT ADDRESS TO FIND DIRTAB.

AND MANHASH.
COMPUTE 1+2*MANHASH
1 EXTRA FOR CFREDSK
FILE ZERO CONTAINS DIRECTORIES
START WITH PRIMARY DIRECTORY
FIRST DIRECTORY IS AT EXTLOW
5989
PROPAGATE CARRY FROM HEAD TO CYL
FLIP PRIM VS ALT STATE
PRIMARY DIRECTORY
CHECK FOR PRIM & ALT HEADS =
WASTE ONE TRACK
PROPAGATE CARRY
EXTENT CAN'T HOLD DIRS AND ALTS
R7 = DIRTAB ADDR, -4
ADVANCE

PROPAGATE CARRY IN CCHH REPRESENTATN

SAME CYLINDER
2*16 - HEADS PER CYL

PRIMARY HEAD

OPLIB ERROR MESSAGES

DC
DC

C'LIBRARY EXTENT 0 TOO SMALL FOR DIRECTORIES',X'FF'

C'LIBRARY DEVICE TYPES DIFFER',X'FF'

DS
16F
DS
X
TITLE 'A P L

OPLIB REGISTER SAVE AREA

D I R E C T - A C C E S S

O P E N

05/11/70'

NOPEN OPENS ONE DASD EXTENT, FILLING IN THE FIELDS IN CDCPARS

FOR THAT EXTENT. ON ENTRY, CDCPARS CONTAINS LOGAD AND DSLAB.
ON EXIT, ALL FIELDS ARE VALID.
R0-R6 ARE USED
R8 IS BASE REGISTER FOR CDCPARS
R9 = A(NOPEN)
R15 IS RETURN

11700000
11830000
11960000
12090000
12220000
12350000
13000000
13130000
13260000
13390000
13520000
13650000
13780000
13910000
14040000
14170000
14300000
14430000
14560000
14690000
14820000
14950000
15080000
15210000
15340000
15470000
15600000
15730000
15860000
15990000
16120000
16250000
16380000
16510000
16640000
16770000
16900000
17030000
17160000
17290000
17420000
17550000
17680000
17810000
17940000
18070000
18200000
18330000
18460000
18590000
18720000
18850000
18980000
19110000
19240000
19370000
19500000
19630000
19760000
19890000

ENTRY NOPEN
20020000
USING NOPEN,9
SET BY CALLER
20150000
USING CDCPARS,8
REFERS TO SWAPPARS, OR LIBNPARS
20280000
NOPEN
ST
15,SAVA
SAVE RETURN ADDRESS
39390000
L
1,=A(AWSLEN)
ENTRY IN SUPINI OR APLUMAIN.
39520000
L
1,0(1)
DOUBLE INDIRECT ADDRESSING.
39650000
L
1,0(1)
VALUE OF WORKSPACE LENGTH.
39780000
ST
1,WLEN
39910000
L
4,=A(AAPLSDCB)
ENTRY IN SUPINI AND APLUMAIN.
40040000
L
4,0(4)
INDIRECT ADDRESSING.
40170000
LH
1,LOGAD
NUMBER I (CORRESP. TO ITH DCB IN DPARS)
40300000
LTR 1,1
TEST LOGAD. CODE OF 0 NOT ALLOWED.
40430000
BM
ERROR1
40560000
MH
1,=H'72'
MULTIPLY BY LENGTH OF DCB
40690000
AR
4,1
ADDBASE OF DCB TABLE TO INDEX
40820000
USING IHADCB,4
40950000
MVC DDNAME(8),DCBDDNAM
TEMPORARY DDNAME AREA
41080000
OPEN ((4),(OUTPUT))
OPEN DCB FOR INPUT AND OUTPUT
41210000
TM
DCBOFLGS,X'10'
IS OPEN SUCCESSFUL
41340000
BZ
ERROR2
K12 41470000
L
5,DCBIFLGS
GR5=FLAGS,A(DATA EXTENT BLOCK)
41600000
LA
5,0(5)
41730000
* DCBIFLGS OVERLAYS DCBDDNAM+4 DURING OPEN
41860000
* GR5=A(DEB)
41990000
CLI DEBNMEXT(5),1 TEST FOR SINGLE EXTENT DATASET
8021 42120000
BNE ERROR3
GIVE ABEND
8021 42250000
MVC EXTLOW(8),DEBSTRCC(5) MOVE LOWER AND UPPER EXTENTS OF X42380000
FIRST EXTENT
42510000
DEVTYPE DDNAME,TRCYLBYT,DEVTAB
42640000
L
1,ASWAPARS
ADDRESS OF A(SWAPPAR) IN SUPINI 3043 42770000
CL
8,0(1)
SWAP BEING OPENED?
3043 42900000
BNE LIBOPEN
NO
3043 43030000
CLI EXTLOW+3,X'00'
START ON CYL BOUNDARY?
3043 43680000
BNE ERROR4
NO
3043 43810000
LH
1,TRCYLBYT+10
TRKS PER CYL
3043 43940000
BCTR 1,0
MINUS ONE
3043 44070000
CH
1,EXTUP+2
END ON CYL BOUNDARY?
3043 44200000
BNE ERROR4
NO
3043 44330000
LIBOPEN EQU *
3043 44460000
MVC TLENF+2(2),TRCYLBYT+6 TLENF GETS MAX BYTES/RECORD DASD 44590000
NC
TLENF(4),=X'0000FFF8' ROUND DOWN TO DOUBLE WORD.
44720000
TM
TRCYLBYT,DCDEV
CAN THIS DEVICE SUPPORT DATACHAIN5989 44850000
BO
HASDC
YES IT CAN
5989 44980000
OI
CDCFLAGS,CDCNDC
SET NO-DATA-CHAIN FLAG
5989 45110000
HASDC
EQU *
5989 45240000
MVC HMIN(2),=H'0'
ZERO HMIN.
45370000
TM
TRCYLBYT+1,RPSDEV CAN THIS DEVICE REALLY USE RPS DASD 45500000
BNZ HASRPS
YES
DASD 45630000
NI
CDCFLAGS,X'FF'-RPS IF RPS WAS SELECTED, CANCEL IT DASD 45760000
HASRPS EQU *
DASD 45890000
TM
DEBOFLGS(5),X'04' TEST FOR SPLIT CYLINDER.
46020000
BZ
NOTSPLIT
BRANCH ON NOT SPLIT
46150000
MVC HMIN(2),EXTLOW+2
SET HMIN = HH OF LOWER EXTENT
46280000
LA
0,1
46410000
AH
0,EXTUP+2
COMPUTE HMIN=HH OF UPPR EXT+1
46540000
STH 0,HMAX
46670000
B
AFHMAX
46800000
NOTSPLIT MVC HMAX(2),TRCYLBYT+10 HMAX CONTAINS NUMBER OF TRACSK/CYL. 46930000
AFHMAX L
0,=A(X'10000')
47060000
AH
0,HMIN
47190000

ERROR1
ERROR2
ERROR3
ERROR4
ASWAPARS
SAVA
WLEN
DDNAME
TRCYLBYT
CDCBXLE
ADPAR
BUF1
DEBOFLGS
DEBNMEXT
DEBSTRCC
*
*
*
*
*
*
*
*
DISKFMT

SH
ST
SR
L
A
BCTR
D
STH
L
LH
STH
LR
LR
SVCC
L
BR
SPACE
ABEND
ABEND
ABEND
ABEND
EXTRN
DC
DS
DS
DS
DS
DC
EQU
DS
EQU
EQU
EQU
TITLE

0,HMAX
0,CCADJ
(2*16)+HMIN-HMAX
0,0
GR0=0 FOR DIVIDE
1,WLEN
COMPUTE TRACKS PER WORKSPACE.
1,TLENF
ROUND QUOTIENT UP
1,0
0,TLENF
1,TPERWS
IS CEIL WSLENGTH DIV TRMAX
5989
3,32(5)
UCB ADDRESS.
3,4(3)
UNIT ADDRESS.
3,PHYSAD
DEVICE ADDRESS.
1,5
DEB ADDRESS.
0,4
DCB ADDRESS.
INIT
SET FILE MASK TO ZERO.
15,SAVA
RESTORE RETURN ADDRESS
15
3
K12
1420,DUMP
INVALID DCB NUMBER
C055
1430,DUMP
OPEN NOT SUCCESSFUL
C055
1440,DUMP
NOT A SINGLE EXTENT DATA SET
C055
1450
SWAP NOT ON CYL BOUNDARY 3043
ASWAPPAR
3043
A(ASWAPPAR)
3043
1F
RETURN ADDRESS
F
8C
5F
A(CDCL,0,0)
CDCL,LIBPZ,LIBPARS
C037
CDCBXLE+8
C037
44C'*',X'FF'
MESSAGE BUFFER FOR OPLIB
8
FLAG BYTE OF DEB
16
38
'A P L D I S K F O R M A T R O U T I N E 05/11/70'

47320000
47450000
47580000
47710000
47840000
47970000
48100000
48230000
48360000
48490000
48620000
48750000
48880000
49010000
49140000
49270000
49400000
49530000
49660000
49790000
49920000
50050000
50180000
50310000
50440000
50570000
50700000
50830000
50960000
51090000
51220000
51350000
51480000
51740000
51870000
FORMATS A DASD DEVICE ACCORDING TO
DASD 52000000
PARAMETRIC CONTROL BLOCK.
DASD 52130000
ON ENTRY, R1 = ADDRESS OF CONTROL INFORMATION
52260000
(SEE DKFMPAR DSECT FOR LAYOUT)
52390000
R15 = RETURN ADDRESS
52520000
REGISTERS R0 - R9 USED
52650000
REGISTERS R10 - R14 UNTOUCHED
52780000
ENTRY DISKFMT
52910000
BALR 9,0
ESTABLISH ADDRESSABILITY
53040000
USING *,9
53170000
ST
15,SAV15
SAVE RETURN REG TO SUPINI
53300000
LR
8,1
53430000
USING DKFMPAR,8
53560000
L
7,CDCBASE
53690000
USING CDCPARS,7
53820000
XC
WSCT(4),WSCT
53950000
MVC PERD(4),PERDAD
BASE OF TABLE FOR CCHH OF
DASD 54080000
SWAP AREA TRACKS
54210000
L
4,=A(IOB)
55510000
USING IOBECB,4
ESTABLISH ADDRES. FOR IOBECB DSECT
55640000
LH
1,LOGAD
55770000
MH
1,=H'72'
55900000
L
2,=A(AAPLSDCB)
INDIRECT ADDRESS.
56030000
A
1,0(2)
56160000
ST
1,IOBDCB
56290000

NORPS

*
*
BCC0
BCC1
MCTP1

MVI
TM
BZ
MVI
EQU
MVC
LH
SH
ST
MVI
L
STH

CMRPS,NOP
CDCFLAGS,RPS
NORPS
CMRPS,SETSECTR
*
CHREA+2(4),EXTLOW
0,HMAX
0,HMIN
0,TPERCY
NEWWS,0
1,TLENF
1,CKD+6

LA
ST
MVC
*
MVI
EXCP
WAIT
CLI
BE
L
S
MVC
UNPK
TR
MVI
UNPK
TR
MVI
UNPK
UNPK
TR
MVI
ICALL
DC
OI
MOVE
BCT
CLI
BE
MVI
CLI
BNE
L

DASD
DASD
DASD
DASD
DASD

CCHHR OF FIRST TRACK

WE ARE STARTING A NEW WS

MOVE IN TRACK LENGTH AS COUNT
FOR WRITE COUNT, KEY, DATA

BUILD COMMAND CHAIN FOR CYLINDER.

5,TPERCY
BADTRKS,0
IF BAD TRACKS IN PREVIOUS CYLINDER
MCTP1
ARE ENCOMPASSED BY CURRENT WS,
BADTRKS,0
CLEAR BAD TRACKS INDICATOR
6,TPERWS
AND START NEW WS AT HEAD 0
5989
WSCYL(4),CHREA+2
NEWWS
IF THIS TRACK STARTS A NEW WORKSPACE
BCC1
SET UP WORKSPACE COUNT, FLAGS ETC
CKD(4),CHREA+2
SET COUNT AREA TO CCHH
EXECUTE COMMAND CHAIN.
FOR SWAP AREA, SIMPLY BYPASS BAD TRACKS.
FOR NON-SWAP AREA, FORMAT ALTERNATE TRACK.
10,CMCHN
MOVE ADDR. OF CHN PGM INTO IOB
10,IOBSIOCC
IOBSKPT+2(4),CHREA+2 MOVE CCHH INTO IOB FOR STAND DASD
ALONE SEEK
EVNTCB,X'00' RESET ECB TO 0.
IOB
EXECUTE CHN PGM
ECB=EVNTCB
WAIT FOR COMPLETION OF CHN PGM
EVNTCB,X'7F' DID CHAN PROGM END NORMALLY ?
MCTP
IF YES, BRANCH.
2,IOBFLAG3
2,=A(CMSCH+8-CMCHN) LOCATE THE SCHIDE
SENSE(2),IOBSENS0
MOVE IOB SENSE INFO
UCMSGU(5),PHYSAD(3)
CHAN AND UNIT NUMBER
UCMSGU(4),XTR
UCMSGU+4,C','
UCMSGS(9),SENSE(5)
SENSE DATA
UCMSGS(8),XTR
UCMSGS+8,C','
UCMSGC(5),CHREA+2(3) CONVERT CYL ADDRESS
DASD
UCMSGC+4(3),CHREA+5(2) AND HEAD ADDRESS
DASD
UCMSGC(6),XTR
DASD
UCMSGC+6,X'FF'
MARK THE END OF THE MESSAGE
DASD
OUTWRTL
OUTPUT SENSE MESSAGE TO OPERATOR
AL4(UCMSG)
BADTRKS,1
MARK THE WORKSPACE UNUSABLE

L
CLI
BE
MVI
LH
MVC
TS
BZ
MVC

*
*
*

*
*
MCTP

RESET TO A NO OP COMMAND
SHOULD RPS BE USED
NO
MOVE IN SET SECTOR COMMAND

CCHH'S TO PERDISK (IF SWAP AREA)

DASD
6,MCTP4
ISSWAP,0
NO WSS PER SE IF NOT SWAP AREA.
MCTP4
NEWWS,0
STARTING NEW WORKSPACE
BADTRKS,0
ALL TRACKS IN WORKSPACE CHECKED.
MCTP4
SOME BAD TRACKS. BYPASS THIS WS.
1,PERD

56420000
56550000
56680000
56810000
56940000
57070000
57200000
57330000
57460000
57590000
57720000
57850000
57980000
58110000
58240000
58370000
58500000
58630000
58760000
58890000
59020000
59150000
59280000
61100000
61230000
61360000
61490000
61620000
61750000
61880000
62010000
62140000
62270000
62400000
62530000
62660000
62790000
62920000
63310000
63440000
63570000
63700000
63830000
63960000
64090000
64220000
64350000
64480000
64610000
64740000
64870000
65000000
65130000
65260000
65390000
65520000
65650000
65780000
65910000
66040000

*
MCTP4

*
MCTP7

*
*
*
UCMSG
UCMSGU
UCMSGS
UCMSGC
NSAMG
*
*
*
IOB

ECB
*
CMCHN
CMRPS
CMSCH
CMWCKD
*

USING PERDISK,1
MVC PDDA,WSCYL
MVC PDXTENT(1),EXTENT+1
DROP 1
A
1,PERDINC
ST
1,PERD
L
1,WSCT
LA
1,1(1)
ST
1,WSCT
L
15,SAV15
C
1,WSS
BCR 8,15
INCREMENT TO NEXT TRACK
CLC CHREA+2(4),EXTUP
BNL MCTP7
LH
1,CHREA+4
LA
1,1(1)
STH 1,CHREA+4
BCT 5,MCTP1

66170000
MOVE STARTING CCHH INTO PERDISK DASD 66300000
MOVE EXTENT INDEX TO PERDISK
66430000
66560000
STEP TO NEXT PERDISK ENTRY
66690000
66820000
BUMP COUNT OF WORKSPACES IN SWAP
66950000
AREA
67080000
67210000
RESTORE REG 15
67340000
DO WE HAVE ENOUGH FORMATTED -67470000
YES. RETURN.
67600000
67730000
WAS THAT THE LAST TRACK
67860000
YES, QUIT
67990000
INCREMENT HEAD
68120000
68250000
68380000
CONTINUE UNTIL ALL TRACKS IN CYL
68510000
HAVE BEEN LOOKED AT
68640000
LH
1,CHREA+2
WHEN DONE, ADVANCE CYLINDER NO.
68770000
LA
1,1(1)
68900000
STH 1,CHREA+2
69030000
MVC CHREA+4(2),HMIN
RESET HEAD NUMBER
69160000
B
BCC0
START A NEW CYLINDER
69290000
UPPER EXTENT (CCHH) HAS BEEN REACHED
69420000
L
15,SAV15
RESTORE REGISTER 15
69550000
CLI ISSWAP,0
69680000
BCR 8,15 BZR
RETURN IF EXTENT NOT SWAP
69810000
ICALL OUTWRTL
SEND ERROR MESSAGE TO OPERATOR
70980000
DC
AL4(NSAMG)
'INSUFFICIENT SWAP AREA'
71110000
ABEND 1400
INSUFFICIENT SWAP AREA
K12 71630000
71890000
DISKFMT ERROR MESSAGES
72020000
72150000
DC
C'OCUU='
UNIT CHECK ERROR MESSAGE
72280000
DC
C'3XXX,SENSE='
C037 72410000
DC
C'XXXXXXXX,CCH='
DASD 72540000
DC
C'XXXXXX '
DASD 72670000
DC
C'INSUFFICIENT SWAP AREA',X'FF'
72800000
72930000
DISKFMT DASD CHANNEL PROGRAMS
73060000
73190000
DC
0F'0'
74100000
DC
X'42000000'
74230000
DC
X'00'
74360000
DC
AL3(ECB)
74490000
DC
2F'0'
74620000
DC
X'00'
74750000
DC
AL3(0)
74880000
DC
A(0)
75010000
DC
4F'0'
75140000
DC
F'0'
75270000
75530000
CCW SEEK,CHREA,CC,6
75660000
CCW SETSECTR,SECTOR,CC,1 WILL BE A NO-OP IF RPS NOT USEDDASD 75920000
CCW SCHIDE,CHREA+2,CC,5
76180000
CCW TIC,*-8,0,0
76310000
CCW X'1D',CKD,X'20',8 WRITE CKD
76440000
76570000

SETSECTR
NOP
DCDEV
RPSDEV
TIC
SEEK
SCHIDE
CC
*
CHREA
BADTRKS
SECTOR
EXTENT
CKD
SENSE
SAV15
NEWWS
WSCYL
WSCT
PERD
TPERCY
*
*
*
XTR

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

X'23'
3
X'10'
X'10'
X'08'
X'07'
X'31'
X'40'

DC
DC
DC
DC
DC
DS
DS
DS
DS
DS
DS
DS

D'0'
X'0'
X'0'
H'0'
Y(0,0,256,*-*)
6X
F
X
F
F
A
F

SET SECTOR COMMAND FOR RPS

NO OP COMMAND
DC DEVICE (OS DEVTYP)
RPS DEVICE FROM OS OPTION BYTE

EQU *-C'0'
DC
C'0123456789ABCDEF'
TITLE 'D S E C T S

DASD
DASD
5989
DASD

SK/SCH ADDR, BAD TRACK FLAG

SECTOR ZERO FOR FULL TRACK RECS DASD
SWAP EXTENT INDEX
R15 SAVE AREA
CCHH OF FIRST TRACK, THIS WORKSPACE
WSS FORMATTED IN SWAP AREA SO FAR
ADDR TO STUFF CCHH OF NEXT WS DASD
TRACKS PER CYLINDER
NOTE TPERWS AND TPERCY SHOULD BE
MULTIPLES. (NOT A RESTRICTION, JUST
A SUGGESTION)
05/11/70'

*
LTORG
*
*
DKFMPAR
ISSWAP
*
CDCBASE
WSS
*
PERDAD
*
*
PERDINC
*
*
PERDISK
PDDA
PDXTENT
PDTERM

PARAMETRIC CONTROL BLOCK FOR DISKFORMAT

DSECT
DS
X
0 = FORMAT ALTERNATE TRACKS
NON0 = SKIP BAD-TRACK AREAS
DS
A(CDCPARS)
DS
F
WORKSPACES TO BE FORMED IN SWAP AREA
IRRELEVANT IF ISSWAP = 0
DS
A
START ADDR OF TABLE INTO WHICH TO
STUFF CCHH OF EACH WORKSPACE. DASD
IRRELEVANT IF ISSWAP = 0
DS
F
WIDTH OF PERDISK ENTRIES.
IRRELEVANT IF ISSWAP = 0

76700000
76830000
76960000
77090000
77220000
77350000
77480000
77610000
77740000
77870000
78000000
78130000
78260000
78390000
78520000
78650000
78780000
78910000
79040000
79170000
79300000
79430000
79560000
79690000
79820000
79950000
80080000
80210000
80340000
80470000
80600000
80730000
80860000
80990000
81120000
81250000
81380000
81510000
81640000
81770000
81900000
82030000
82160000
82290000
82420000
82550000
82680000
82810000
82940000
83070000
93210000
93340000
93470000
93730000
93860000
93990000
94120000

DSECT ,
ONE PER DISK AREA
DS
F
DASD
EQU *
DASD
DS
X
DS
AL3 (PERTERM)
HIGH ORDER BIT MEANS UNASSIGNED
PERDISKL EQU *-PERDISK
*
OPLIB
CSECT
IOBECBD
DCBD DSORG=(DA)
COPY CDCPARS
*
COPY DIRSECT
END
./ ADD
NAME=APLSPCSB
PCSB
TITLE 'PROGRAM CHECK HANDLER AND FRIENDS
05/11/70' 00180000
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
00360000

*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PCSUB
CSECT
PRINT OFF
COPY APLDEFN PERTERM ZSYMBOLS
COPY APLDEFN
COPY PERTERM
COPY ZSYMBOLS
PRINT ON,NOGEN
APLSUPC
VALCON EQU 1
AVOID ASSEMBLY ERROR
PCSUB
CSECT
TITLE 'PROGRAM CHECK HANDLER AND FRIENDS
05/11/70'
EXTRN DZERR
EXTRN ERROR
EXTRN LOUT
EXTRN LOUTN
2550
EXTRN COPSINK
COPSINK IS IN APLSUP
2550
EXTRN SUPPARS
EXTRN TYPEIN
EXTRN WSLEN
EXTRN DAYSUP
EXTRN SVOLDPSW
EXTRN TCBMERE
*
*
*
PROGRAM CHECK HANDLER -- ENTERED FROM THE SUPERVISOR WHEN
*
AN APL PROGRAM CHECK OCCURS.
*
*
PROGRAM CHECK IN SUPERVISOR STATE TERMINATES APL
*
*
PROGRAM CHECK IN PROBLEM STATE..
*
*
INTERRUPT CODE ACTION
*
*
0
MODEL 91 IMPRECISE INT, REFORMAT AS 8-15
*
1-7 DUMP CONSOLE AND PSW.
*
8-15 ON CONDITION.
*
*
NOTE THAT THE STORAGE KEY WILL BE THAT OF CURRENT M.
*
*
USING PCSUB,15
BASE REGISTER PROVIDED BY OS
SR
0,0
FOR MVT MODEL 91 SUPPORT.
SPM 0
LR
0,1
SAVE PIE POINTER
L
1,=A(SVOLDPSW)
GET ADDR. OF SVC OLD PSW IN APLSUP
SVRAPE , THIS SHOULDN'T BE NEEDED, BUT LETS NOT TAKE CHANCES
NC
0(2,1),=X'000F'
SET PSW TO DISABLE INTERRUPTS
*
AND A PROT.KEY OF 0
LR
1,0
RESTORE PIE PTR. TO R1
USING PIE,1
STM 14,2,OSREGS
SVE OS REGISTERS.
LA
2,PCSAVAR
USING SVEARA,2
STM 3,13,SVER03
SAVE PC REGS
MVC SVER14(2*4),PIESR14 PC REGISTERS 14,15
MVC SVER00(3*4),PIESR0 PC REGS 0-2.
MVC SVEPSW1(8),PIEPSW PC PSW. SAVED
L
1,=A(SUPPARS)
L
MR,CURRENTM-SUPPARD(1) CORRECT MR

00540000
00720000
01080000
01440000
01620000
01800000
01980000
02160000
02340000
02520000
02700000
02880000
03060000
03240000
03420000
03600000
03780000
03960000
04140000
04320000
04680000
04860000
05040000
05400000
05580000
05760000
05940000
06120000
06300000
06480000
06660000
06840000
07020000
07200000
07380000
07560000
07740000
07920000
08100000
08280000
08460000
10080000
10260000
10440000
10620000
10800000
10980000
11160000
11340000
11520000
11700000
11880000
12060000
12240000
12420000
12600000
12780000
12960000
13140000
13320000

ST
L
ST

MR,SVER11
VERY IMPORTANT.
13500000
1,PTBASE-SUPPARD(1) IN CASE LOW END OF WS WAS CLOBERED, 13680000
1,MPTBASE
RESTORE MPTBASE
13860000
*
14040000
*
DETERMINE INTERRUPT TYPE.
14220000
*
14400000
TM
SVEPSW1+1,1
SEE IF WE WERE IN PROB. STATE.
14580000
BO
NOTSUP
BRANCH IF SO.
14760000
ABEND 1290,DUMP,STEP POOF
K12 15660000
*
16020000
*
PROBLEM STATE PROGRAM CHECK.
16200000
*
16380000
NOTSUP TM
SVEPSW2,X'C0'
ZERO INSTRUCTION LENGTH CODE
16560000
BNZ PRECISE
MEANS IMPRECISE INTERRUPT
16740000
*
OR CODE UNDER 8 ON A 65
16920000
LA
1,7
DECODE IMPRECISE INTERRUPT CODE
17100000
LH
0,SVEPSW1+2
SET BY MODEL 91
17280000
N
0,=A(X'0FC0')
ALL PRECISE INTERRUPTS GET REG DUMP 17460000
BZ
DUMPCONS
17640000
SLA 0,19
17820000
PCTSTBIT LA
1,1(1)
COUNT TO FIRST 1 BIT
18000000
AR
0,0
18180000
BNO PCTSTBIT
18360000
CH
1,=H'10'
18540000
BL
STPSW1
18720000
LA
1,2(1)
ADD 2 FOR OMITTED DECIMAL INTS
18900000
STPSW1 STH 1,SVEPSW1+2
19080000
PRECISE CLI SVEPSW1+3,7
CHECK FOR ON CONDITION TYPE
19260000
BNH DUMPCONS
NOT ON CONDITION, GO DUMP REGISTERS 19440000
*
19620000
*
ON-CONDITION INTERRUPT
19800000
*
19980000
ONCOND LH
1,SVEPSW1+2
20160000
SLL 1,3
GET INT CODE TO
20340000
L
0,ONADRS(1)
LOCATE ON-CONDITION ADDRESS
20520000
L
1,ONADRS+4(1)
AND SAVED RELATIVE LOCALS REGISTER 20700000
LTR 0,0
0 MEANS IGNORE
20880000
BNZ PCS2
21060000
CLI SVEPSW1+3,15
EXCEPT ZERO-DIVIDE, FOR WHICH 'IGNO- 21240000
BNE PCS3
RE' ISN'T QUITE ACCURATE.
21420000
LTER 0,0
ASSUME INTERRUPTED FROM SCOPS
21600000
LD
0,QD1
IN WHICH WE WERE DOING F0 = F0/F2
21780000
BZ
PCS3
0/0 GIVES 1.0
21960000
L
0,=A(DZERR)
OTHERWISE DEFAULT IS DOMAIN ERROR
22140000
PCS2
AR
1,MR
22320000
LM
4,7,SVER12
USE 48
22500000
PCS5
CLR 5,1
RUN BACK R13 STACK TO MATCHING R13 22680000
BE
PCS6
22860000
BL
DUMPCONS
23040000
LM
4,7,0(5)
23220000
B
PCS5
23400000
PCS6
IC
1,SVEPSW2
PUT NEW ADDRESS IN OLD PC PSW.
23580000
ST
0,SVEPSW2
DON'T DISTURB PROGRAM MASK.
23760000
STC 1,SVEPSW2
23940000
STM 4,7,SVER12
24120000
PCS3
LM
14,1,OSREGS
RESTORE OS'S REGS.
25380000
MVC PIESR14(2*4),SVER14 NEW REG 14 & 15
25560000
MVC PIEPSW(8),SVEPSW1
25740000
*
PREVIOUSLY WE USED SVRAPE TO GIVE THIS ROUTINE A PROT.
25920000
*
KEY OF ZERO AND DISABLE INTERRUPTS.
26100000

*
*
*
OSEXIT

NOW WE WANT TO RESTORE THE PSW TO THE STATE IT WAS IN

WHEN THE PROG. CHECK OCCURED - THAT IS, ITS ORIGINAL
PROT. KEY AND SYS. MASK
L
5,=A(SVOLDPSW)
LOCATE ADDR OF SVC OLD PSW
L
4,PIEPSW
GET FIRST WD. OF PROG. CHECK
SVRAPE
PSW AND PUT IT IN FIRST WD.
ST
4,0(5)
OF PSW TO RE RESTORED AFTER
THIS SVC INTERRUPT
LM
3,13,SVER03
RESTORE PC'S REGISTERS
L
2,OSREGS+4*4
RESTORE R2 FROM WHERE IT WAS SAVED
BR
14
TO OS.

*
*
CONSOLE DUMP FOLLOWED BY
*
'SYSTEM ERROR'
*
DUMPCONS L
LR,=A(WSLEN)
FIRST, GET SAVED REGISTERS INTO M.
L
LR,0(LR)
RECOMPUTE BASE OF R13 STACK FROM
S
LR,=A(LR13STK)
INFORMATION IN CONFIG
ST
LR,QR13STK
MAKE SURE WORKSPACE COPY IS CORRECT
AR
LR,MR
MVC 16(SVEFP0-SVER00,LR),SVER00 MOVE REGISTERS INTO M.
MVC 80(8,LR),SVEPSW1
PSW.
*
*
ROUTINE TO LOCATE APL'S LOAD POINT IN CORE FOR CONSOLE DUMP
*
L
7,=A(TCBMERE+8)
MOTHER PRB ADDRESS.
L
7,0(7)
MOTHER PRB.
*
MFT
L
1,CVTPTR
MFT
USING CVTD,1
MFT
TM
CVTDCB,MFT
NO CDE FOR MFT SYSTEMS
MFT
BZ
MVTCDE
TEAR THE MVT CDE APART
MFT
DROP 1
MFT
*
MFT
* THE LOAD MODULE IS NORMALLY JUST AFTER THE RB IN MFT
MFT
*
MFT
TM
10(7),X'02'
IS THERE A PROGRAM EXTEND LIST?
MFT
LA
7,32(7)
BUMP PAST BASIC LRP
MFT
BZ
RESTDUMP
IF NONE, 7 POINTS TO LOAD MODULE
MFT
LR
1,7
MFT
L
7,8(1)
H0 ADDRESS
MFT
LTR 7,7
MFT
BNZ RESTDUMP
PRINT OUT H0 ADDRESS
MFT
L
7,12(1)
H1 LOAD ADDRESS
MFT
LTR 7,7
MFT
BNZ RESTDUMP
PRINT H1 ADDRESS
MFT
L
7,16(1)
MFT
B
RESTDUMP
MFT
*
MFT
*
FIND LOAD ADDRESS OF APL360 LOAD MODULE FROM CDE/XL
MFT
*
MFT
MVTCDE L
7,12(7) ADDRESS OF CONTENTS DIRECTORY
MFT
TM
0(7),4
TEST FOR MINOR CDE
BNO MAJCDE
IF MAJOR CDE - BRANCH
L
7,20(7)
IF MINOR - GET ADDR. OF MAJOR CDE
MAJCDE L
7,20(7)
PTR TO XL.
L
7,12(7)
LOAD PT OF APLPORT
RESTDUMP ST
7,88(LR)
STORE LOAD PT. TO BE WRITTEN ON
*
ON USERS CONSOLE
*

26280000
26460000
26640000
26820000
27000000
27180000
27360000
27540000
27720000
27900000
28080000
28440000
28620000
28800000
28980000
29160000
29340000
29520000
29700000
29880000
30060000
30240000
32220000
32400000
32580000
32760000
32940000
33120000
33300000
33480000
33660000
33840000
34020000
34200000
34380000
34560000
34740000
34920000
35100000
35280000
35460000
35640000
35820000
36000000
36180000
36360000
36540000
36720000
36900000
37080000
37260000
37440000
37620000
37800000
37980000
38160000
38340000
38520000
38700000
38880000

*
*
*

THE FOLLOWING MANEUVER IS REQUIRED TO ACHIEVE SOME SORT

OF RE-ENTRANCE FOR THE PROGRAM CHECK ROUTINE.
LM
USING
MVC
L
B
DROP

14,1,OSREGS
RESTORE OS'S REGISTERS
PIE,1
PIEPSW+4(4),=A(PCRETURN) OS WILL BRNCH TO REST OF PCSB
5,=A(SVOLDPSW)
LOCATE ADDR OF SVC OLD PSW
OSEXIT
15

*
*
FORMAT AND OUTPUT CONSOLE DUMP TO USERS TERMINAL
*
PCRETURN BALR 9,0
USING *,9
L
LR,QR13STK
RESTORE LR.
AR
LR,MR
LA
TLR,104(LR)
L
7,MPTBASE
ADDR OF CURRENT PERTERM
2550
TM
IOB1-PERTERM(7),COPYWM ARE WE A COPY SOURCE
2550
BO
SN3
BYPASS LOUT IF COPY SOURCE
2550
CLC OBUFPTR(2),=H'130' FORCE OUT ANY REMAINING TEXT UNLESS
BNL SN3
THE BUFFER POINTER LOOKS RIDICULOUS
ICALL LOUT
PRINT THE GRS AND THE PC OLD PSW
*
ON THE USER'S TYPEWRITER
SN3
MVI (92+4*1)(LR),ZBLANK*16-ZBLANK/16*255
LM
3,5,BXLR
SN0
LA
6,OBUF+2
MVI OBUF,ZBLANK
MVC OBUF+1(80),OBUF
SN1
L
1,16(3,LR)
ST
1,(88+4*1)(LR)
UNPK 0(9,6),(88+4*1)(5,LR)
TR
0(8,6),TOHEX
LA
6,10(6)
BXLE 3,4,SN1
BCTR 6,0
R6 POINTS AT LAST HEX DIGIT + 2 2550
MVC 0(2,6),EXS4
APPEND CR AND EOB
2550
LA
1,OBUF-1
FIND LENGTH OF LINE
2550
SR
6,1
STH 6,OBUFPTR
TM
IOB1-PERTERM(7),COPYWM ARE WE A COPY SOURCE
2550
BZ
SN4
BRANCH IF NOT COPY SOURCE
2550
TCOM LOG,OBUFPTR
SEND REG DUMP TO RECORD TERM
2550
B
SN5
2550
SN4
EQU *
2550
ICALL LOUTN
PRINT REG DUMP ON USER TERM
2550
SN5
EQU *
2550
LA
5,32(5)
C
5,SNET
BL
SN0
LA
5,71+4*1
BE
SN0
MVC 24(23+10,LR),OBUF SAVE PSW, CR, AND EOB
2550
L
2,=A(SUPPARS)
LR
1,7
R1 HAS ADDR OF PERTERM
2550
TM
IOB1-PERTERM(7),COPYWM IS THIS A COPY SOURCE
2550
BZ
*+12
BRANCH IF NOT A COPY SOURCE
2550
L
1,=A(COPSINK)
GET ADDR OF SINK'S
2550
L
1,0(1)
PERTERM.
2550
S
1,PTBXLE+8-SUPPARD(2)

39060000
39240000
39420000
39600000
39780000
39960000
40140000
40320000
40500000
40860000
41040000
41220000
41400000
41580000
41760000
41940000
42120000
42300000
42480000
42660000
42840000
43020000
43200000
43380000
44280000
44640000
44820000
45000000
45180000
45360000
46260000
47340000
47700000
47880000
48060000
48240000
48420000
48600000
48780000
48960000
49140000
49320000
49500000
49680000
49860000
50040000
50220000
50400000
50580000
50760000
51660000
52020000
52920000
53280000
53460000
53640000
53820000
54000000
54180000
54360000

SR
D
CVD
UNPK
TR
MVC
MVC
MVI
TCOM
TM
BZ
MVC
ICALL
TYI
PCSWITCH BC
MVI
MVC
ICALL
LEMP
ENTRY
SN2
LA
MVI
ICALL
DROP
*
*
*
*
ENTRY
BGATTN LA
*
*
*
*
*
*
*
*
*
*
ENTRY
SIGNAL STM
LR
BALR
USING
LR
L
AR
SIG2
CR
BE
BL
*
LM
B
SIGR
L
LM
BR
DUMPCON2 L
AR
MVC

0,0
0,PTBXLE-SUPPARD(2) COMPUTE PORT NUMBER
1,16(LR)
OBUF(5),22(3,LR)
OBUF(3),TOHEX
CONVERT TO ZSYMBOLS
OBUF+3(EXS4-EXS3+1),EXS3-1 ' SYSTEM ERROR'
OBUF+4+EXS4-EXS3(23+10),24(LR) MOVE IN PSW, CR, EOB2550
OBUFPTR+1,26+10+EXS4-EXS3 MOVE IN LENGTH
2550
LOG,OBUFPTR
TELL OPERATOR ABOUT SYSTEM ERROR
IOB1-PERTERM(7),COPYWM ARE WE A COPY SOURCE
2550
PCSWITCH
BRANCH IF NOT A COPY SOURCE
2550
OBUF(3),=AL1(Z0,Z0,Z0) SEND '000 SYSTEM ERROR
2550
LOUTN
PSW' TO SINK
2550
,
THIS ENDS COPY SOURCE
2550
0,SN2
OBUFPTR+1,EXS4-EXS3 LENGTH OF SYSTEM ERROR MESSAGE
OBUF(EXS4-EXS3),EXS3 MOVE IN SYSTEM ERROR MESSAGE
LOUT
OUTPUT MESSAGE
, LOAD EMPTY WORKSPACE.
PCSWITCH
1,ESYSTEM
OBUFPTR+1,0
CLEAR OBUFPTR FOR ERROR ROUTINE 2550
ERROR
9

BGATTN
0,ONATTN
NOTES ...

SIGNAL
0,15,16(TLR)
10,TLR
2,0
*,2
1,0
0,4(1)
0,MR
LR,0
SIGR
DUMPCON2
12,15,0(LR)
SIG2
1,0(1)
2,11,2*4+16(10)
1
LR,QR13STK
LR,MR
16(16*4,LR),16(10)

GUARANTEED RECOGNITION OF ATTENTION

THIS REALLY IS A FAKED 'SIGNAL'
EXPANSION. IF WE GET HERE, ONATTN
IS GUARANTEED NONZERO. APLSUP DOES
THE RECOGNITION OF INHIBITED BGATTN
FOR US BECAUSE WE WOULD HAVE NO WAY
TO GET BACK TO INTERRUPTEE ON
INHIBITED INTERRUPT.

ON-CONDITION SIMULATED INTERRUPT.

PRESERVE CURRENT LR TO FIND REGISTER
***** BYPASSES LINKAGE MACROS *****
GET ON-INFO ADDRESS IN R1
RECALL RELATIVE LR
WEND DOWN THE SAVE AREAS UNTIL
WE FIND A MATCHING LR.
IF PAST, DISASTER. SOMEONE FORGOT
TO DISABLE THE ON-CONDITION.
RECALL NEXT REGISTER-SAVE GROUP
RECALL ADDRESS OF ON BLOCK
RESTORE REGISTERS
AND TAKE ON-CONDITION.
MOVE REGISTERS SO PCRETURN WILL FIND

54540000
54720000
54900000
55080000
55260000
55440000
56340000
57420000
57780000
57960000
58140000
58320000
58500000
58680000
58860000
59040000
59220000
59400000
59580000
59760000
59940000
60120000
60300000
60480000
60660000
63180000
63360000
63540000
63720000
63900000
64080000
64260000
64440000
64620000
64800000
64980000
65160000
65340000
65520000
65700000
65880000
66060000
66240000
66420000
66600000
66780000
66960000
67140000
67320000
67500000
67680000
67860000
68040000
68220000
68400000
68580000
68760000
68940000
69120000
69300000

XC
L
BR

16+16*4(8,LR),16+16*4(LR) ZERO PSW

10,=A(PCRETURN)
GO DUMP CONSOLE
10

69480000
69660000
69840000
*
70020000
*
PRINT MESSAGE AFTER RELOC (APLSUP) FOUND ERROR THAT THE
70200000
*
R13, R14 STACK HAS BEEN LOST
70380000
*
70560000
ENTRY EREXSUP
70740000
EREXSUP BALR 5,0
70920000
USING *,5
71100000
TYO EXS1
PRINT ERROR MESSAGE
71280000
ICALL TYPEIN
WHICH NEVER RETURNS
71460000
EXS1
DC
Y(EXS2-*-3)
71640000
DC
AL1(ZR,Z1,Z3,ZBLANK)
71820000
EXS3
DC
AL1(ZS,ZY,ZS,ZT,ZE,ZM,ZBLANK,ZE,ZR,ZR,ZO,ZR)
72000000
EXS4
DC
AL1(ZCR,ZEOB)
72180000
EXS2
EQU *
72360000
DROP 5
72540000
*
72720000
*
CONVERT DIRECTORY INTO CLEAR WS WITH MESSAGE TO TERMINAL
72900000
*
73080000
ENTRY NEWWS
73260000
NEWWS
BALR 12,0
73440000
USING *,12
73620000
BAL LKR,DIREMP
RESET MX AND SVI
73800000
TYO DTXT
73980000
ICALL TYPEIN
WHICH NEVER RETURNS
74160000
DROP 12
74340000
*
74520000
*
CONVERT DIRECTORY INTO CLEAR WS
74700000
*
74880000
ENTRY DIREMP
75060000
DIREMP PROLOG
75240000
LA
1,FREE-M
SET UP MX,
75420000
ST
1,MX
75600000
ST
1,MING
75780000
L
1,QSYMBOT
SVI,
75960000
S
1,=A(STPARAM+8-STFREG)
76140000
ST
1,SVI
76320000
LA
1,4(1)
AND PARREL.
76500000
ST
1,PARREL
76680000
AR
1,MR
76860000
XC
0(STPARAM+4-STFREG,1),0(1) AND INITIALIZE BOTTOM OF STK 77040000
MVI STFLAGS(1),STIMBIT
77220000
IRETURN
77400000
*
77580000
DTXT
DC
Y(DTXTZ-*-3)
77760000
DC
AL1(ZC,ZL,ZE,ZA,ZR,ZBLANK,ZW,ZS,ZCR,ZEOB)
77940000
DTXTZ
EQU *
78120000
*
78300000
*
GETIME -- GET TIME OF DAY (300 TH SECOND) INTO R1
78480000
*
78660000
ENTRY GETIME
78840000
GETIME PROLOG GETIMEL,GETIMELZ
80820000
STM 14,0,GETIMEL
SAVE 14,15,0.
81000000
TIME TU
OS TIME OF DAY IN R0.
81180000
LR
1,0
MOVE TO R1.
81360000
SRL 1,7
CONVERT TO REASONABLE UNITS.
81540000
L
2,=A(DAYSUP)
GET NUMBER OF DAYS SINCE INITIATION. 81720000
A
1,0(2)
FROM APLSUP, ADD TO T.O.D.
81900000

L
C

2,=A(SUPPARS+(REALTIME-SUPPARD)) LOOK AT APLSUP'S TOD

1,0(2) IF OUT TOD LT REALTIME, ASSUME MIDNIGHT. APLSUP
WILL RESOLVE SHORTLY.
BNL *+8
BRANCH IF NOT.
L
1,0(2)
PROBABLY NOT MIDNIGHT.
LM
14,0,GETIMEL
IRETURN

82080000
82260000
*
82440000
82620000
82800000
82980000
83160000
*
83340000
*
DSECT FOR GETIME.
83520000
*
83700000
GETIMEL DSECT
83880000
DS
3F
84060000
GETIMELZ EQU *
84240000
*
84420000
CVTD
DSECT
MFT 84600000
MFT
EQU X'20'
MFT 84780000
CVT SYS=MFT
MFT 84960000
PCSUB
CSECT
86040000
*
86220000
*
PROGRAM CHECK SAVE AREA
86400000
*
86580000
ENTRY PCSAVAR
86760000
PCSAVAR DC
D'0',16F'0'
SAVE AREA
86940000
*
87120000
*
CONSTANTS
87300000
*
87480000
QD1
DC
D'1'
87660000
OSREGS DS
5F
REG SAVEAREA FOR REGS 14-1
88740000
K24HOURS DC
F'25920000'
88920000
LTORG
89280000
*
89460000
BXLR
DC
F'0,4,31'
89640000
SNET
DC
F'95'
89820000
TOHEX
EQU *-C'0'
90000000
DC
AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,ZA,ZB,ZC,ZD,ZE,ZF)
90180000
*
90360000
*
SAVE AREA DESCRIPTION
90540000
*
90720000
SVEARA DSECT
90900000
SVEPSW1 DS
0CL8
91080000
DS
CL4
91260000
SVEPSW2 DS
CL4
91440000
SVER00 DS
CL4
91620000
SVER01 DS
CL4
91800000
SVER02 DS
CL4
91980000
SVER03 DS
CL4
92160000
SVER04 DS
CL4
92340000
SVER05 DS
CL4
92520000
SVER06 DS
CL4
92700000
SVER07 DS
CL4
92880000
SVER08 DS
CL4
93060000
SVER09 DS
CL4
93240000
SVER10 DS
CL4
93420000
SVER11 DS
CL4
93600000
SVER12 DS
CL4
93780000
SVER13 DS
CL4
93960000
SVER14 DS
CL4
94140000
SVER15 DS
CL4
94320000
SVEFP0 DS
CL8
94500000
SVEFP2 DS
CL8
94680000

SVEFP4
SVEFP6
*
*
*
*
PIE
PICA
PIEPSW
PIESR14
PIESR15
PIESR0
PIESR1
PIESR2

DS
DS

CL8
CL8

DSECT
DS
A
DS
2A
DS
F
DS
F
DS
F
DS
F
DS
F
END
./ ADD
NAME=APLSRAVL
RAVL
TITLE 'R A V E L T O V E C T O R
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, OPSECT
EXRAVEL CSECT
COPY APLDEFN
COPY OPSECT
TITLE 'R A V E L T O V E C T O R
05/11/70'
PRINT ON,NOGEN
EXRAVEL CSECT
USING *,9
USING OPSECT-16,LR
*
*
THIS OPERATOR MAKES A RHXRHO LONG VECTOR OUT OF ANYTHING.
*
SPACE
ST
LKR,CURRES
SAVE THE LINK.
L
1,RHXRHO
FIRST, WE GET SPACE.
SPACE
LA
2,4
MAKE RANK - VECTOR.
L
3,RHTYPE
PICK UP OPERAND TYPE.
L
10,=A(OPSPACE)
PICK UP ENTRY TO COMMON GETSPACE.
BALR LKR,10
AND ENTER IT.
SPACE
*
*
NOW, SET UP HEADING.
*
LA
2,4
THE RANK WILL BE 4.
STH 2,MRANK(1)
STORED.
L
2,RHTYPE
TYPE.
STC 2,MTYPE(1)
STORED.
L
4,RHXRHO
PICK UP RIGHT LENGTH.
ST
4,MRHO(1)
STORE AS RANK OF RESULT.
*
*
NOW, MOVE IN ELEMENTS.
*
SPACE
L
4,MCOUNT(1)
GET BYTE COUNT FOR RESULT ELEMENTS.
S
4,=A(MRHO-M+4)
BY SUBTRACTING HEAD LENGTH FROM COUN
BNP DONE
BRANCH IF OPERAND IS EMPTY VECTOR.
SPACE
LA
8,MRHO+4(1)
USE ABSOLUTE RESULT POINTER.
L
7,RHBASE

94860000
95040000
95220000
95580000
95760000
95940000
96120000
96300000
96480000
96660000
96840000
97020000
97200000
97380000
97560000
01380000
02760000
04140000
05520000
08280000
09660000
11040000
12420000
13800000
15180000
16560000
17940000
19320000
20700000
22080000
23460000
24840000
26220000
27600000
28980000
30360000
31740000
33120000
34500000
35880000
37260000
38640000
40020000
41400000
44160000
45540000
48300000
49680000
51060000
52440000
53820000
55200000
56580000
57960000
59340000
60720000
62100000
63480000
64860000

LA
7,MRHO(7)
A
7,RHRANK
AND RIGHT POINTER.
LA
2,255
MAXIMUM MOVE COUNT.
LA
3,256
MAXIMUM MOVE LENGTH.
BCTR 4,0
DECREMENT RESULT COUNT BY 1.
SPACE
MVCLOOP CR
4,3
SEE IF THERE LESS THAN 256 BYTES.
BL
LASTMOVE
BRANCH IF SO.
EX
2,MOVER
OTHERWISE, MOVE 256 BYTES.
AR
8,3
INCREMENT POINTERS.
AR
7,3
SR
4,3
DECREMENT RH COUNT.
B
MVCLOOP
AND TRY AGAIN.
SPACE
LASTMOVE EX
4,MOVER
REMOVE REMAINING OPERAND.
SPACE
DONE
L
LKR,CURRES
PICK UP LINK.
BR
LKR
AND DEPART.
SPACE
MOVER
MVC 0(0,8),0(7)
DC
0F'0'
EXTRN OPSPACE
LTORG
END
./ ADD
NAME=APLSROTR
ROTR
TITLE 'R O T A T I O N A N D R E V E R S A L
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, ZSYMBOLS, OPSECT
SCNSETUP CSECT
COPY APLDEFN
COPY ZSYMBOLS
COPY OPSECT
PRINT ON,NOGEN
OPSECT DSECT
ORG BINOSAVE
CLOSS
DS
F
DIF
DS
F
DX
DS
F
ELEMS
DS
F
EMU
DS
F
HIPROD DS
2F
LHFINCR DS
F
LOPROD EQU HIPROD+4
ORX
DS
F
RA
DS
2F
REALINDX DS
F
ROORET DS
F
SAVED
DS
2F
SCNRET DS
F
SINCR
DS
2F
SX
DS
F
TRIV
DS
F
ORG
EXTRN ERROR
EXTRN FETCH
EXTRN FETCHINT
EXTRN STORE
EXTRN OPSPACE

66240000
67620000
69000000
70380000
71760000
73140000
74520000
75900000
77280000
78660000
80040000
81420000
82800000
84180000
85560000
86940000
88320000
89700000
91080000
92460000
93840000
95220000
96600000
97980000
00250000
00500000
00750000
01000000
01500000
01750000
02000000
02250000
02500000
02750000
03000000
03250000
03500000
03750000
04000000
04250000
04500000
04750000
05000000
05250000
05500000
05750000
06000000
06250000
06500000
06750000
07000000
07250000
07500000
07750000
08000000
08250000
08500000
08750000
09000000

TITLE
'I N I T A L I Z A T I O N F O R V E C T O R O P S'
SCNSETUP CSECT
*
* CALLED BY ROTATE AND REVERSAL FOR INITALIZATION. GETS SPACE
*
FOR ANSWER OR SETS UP TO DO OPERATION IN PLACE.
*
CALCULATES SUNDRY MAGIC NUMBERS.
*
USING OPSECT-16,LR
USING *,8
ST
LKR,SCNRET
MVI TRIV+3,0
TRIV=0 MEANS TRIVIAL
CLI TEMPRGT,0
IS RH ARG TEMP9
BNE OVWT
YES. WE'LL USE SAME SPACE FOR RESLT
L
1,RHXRHO
OTHERWISE, RESERVE SPACE
L
2,RHRANK
L
3,RHTYPE
L
10,=A(OPSPACE)
BALR LKR,10
L
LKR,SCNRET
MAY EXIT ANY TIME NOW
L
2,RHBASE
ST
1,RHBASE
SAVE RESULT BASE. PREPARE FOR MOVE
AR
1,MR
R1 ABSOLUTE PTR FOR RESULT
L
5,MCOUNT(2)
AR
2,MR
R2 ABSOLUTE PTR FOR RH ARG
LA
4,256
SR
3,3
S
5,=F'8'
DON'T MOVE FIRST 2 WORDS
BCT 5,MV2
EXMV
MVC 8(0,1),8(2)
PICK UP LAST FEW BYTES
MV
MVC 8(256,1),8(2)
AR
1,4
AR
2,4
MV2
BXLE 3,4,MV
EX
5,EXMV
COMPLETING THE MOVE
B
COMP
OVWT
MVI TEMPRGT,0
OVERWRITE RIGHT ARG IN TEMP CASE
L
1,SVI
CALL IT THE RESULT (BY STACKING IT
L
3,INCR
WHERE THE RESULT SHOULD BE)
AR
3,1
L
2,M(3)
RARG STACK ENTRY
ST
2,M(1)
ST
1,M(2)
SR
0,0
ST
0,M(3)
S
1,=F'4'
ST
1,SVI
COMP
L
10,RHBASE
LR
1,10
COMPUTE RHORG
A
1,RHRANK
LA
1,MRHO-M(1)
ST
1,RHORG
MVC RCFTYPE,RHTYPE
& SET UP RCFTYPE
AR
10,MR
R10 ABSOLUTE PTR TO RESULT
LA
7,1
R7 X/HIGH DIMENSIONS
LR
1,7
R1 X/LOW DIMENSIONS
ST
7,SINCR+4
SR
4,4
R4 INDEX THROUGH RHO S
L
3,RHRANK
R3 RHRANK
TM
INDBASE,X'C0'
IS AN INDEX SUPPLIED
BO
INDEXER
YES BUT ITS FRACTIONSL

09250000
09500000
09750000
10000000
10250000
10500000
10750000
11000000
11250000
11500000
11750000
12000000
12250000
12500000
12750000
13000000
13250000
13500000
13750000
14000000
14250000
14500000
14750000
15000000
15250000
15500000
15750000
16000000
16250000
16500000
16750000
17000000
17250000
17500000
17750000
18000000
18250000
18500000
18750000
19000000
19250000
19500000
19750000
20000000
20250000
20500000
20750000
21000000
21250000
21500000
21750000
22000000
22250000
22500000
22750000
23000000
23250000
23500000
23750000
24000000

BM
SR
CLI
BE
LR
S
BNM
BR
LINDXX L
SLA
CHIX
CLR
BCR
STORIX ST
DOHIPROD CR
BNL
M
LA
B
GOTHIPR LTR
BCR
ST
L
LTR
*
BCR
DOLOPROD LA
CR
BNL
M
B
GOTLOPR LTR
BCR
ST
MR
ST
SR
ST
LA
ST
SR
ST
ST
LA
SR
ST
ST
ST
BR
INDEXER LA
ICALL
LTORG
TITLE
NEXTVECT CSECT
USING
LA
TEST
L
LA
ST
C
BL

LINDXX
YES.SO USE IT
5,5
ASSUME COLUMN OPERATION
OPERATOR+3,1+2*ZCOLREV
CHIX
ACT ON LEFTMOST COORDINATE
5,3
IMPLICIT. MAKE EQUAL TO LAST
5,=F'4'
DIMENSION
STORIX
AND SKIP OUT-OF-RANGE TEST
LKR
NULL VECTOR
5,INDEX
5,2
R5 INDEX X 4, 0 ORIGIN
3,5
INDEX GT RANK ISN'T AN ERROR
13,LKR
BUT TRAP IT AS TOO EASY
5,REALINDX
MAY BE USEFUL
4,5
GOTHIPR
6,MRHO-M(4,10)
4,4(4)
DOHIPROD
7,7
8,LKR
0 HIGH DIMENSION TRIVIAL RETURN
7,HIPROD
2,MRHO-M(5,10)
GET MU, THE SPECIFIED DIMENSION
2,2
(HIGH AND LOW DIMENSIONS REFER TO
THOSE TO THE LEFT AND RIGHT OF MU)
8,LKR
0 MU TRIVIAL RETURN
5,4(5)
5,3
GOTLOPR
0,MRHO-M(5,10)
DOLOPROD
10,1
8,LKR
0 LO DIMENSION TRIVIAL RETURN
1,LOPROD
0,2
1,EMU
EMU=X/SPECIFIED&LOWER DIMENSIONS
1,10
1,DIF
1,1(1)
1,SINCR
4,4
4,RA
4,SX
3,1
4,3
4,RA+4
4,ORX
4,TRIV
TRIV NE 0 MEANS NOT TRIVIAL
LKR
1,EINDEX
FRACTIONAL INDEX NOT ALLOWED
ERROR

24250000
24500000
24750000
25000000
25250000
25500000
25750000
26000000
26250000
26500000
26750000
27000000
27250000
27500000
27750000
28000000
28250000
28500000
28750000
29000000
29250000
29500000
29750000
30000000
30250000
30500000
30750000
31000000
31250000
31500000
31750000
32000000
32250000
32500000
32750000
33000000
33250000
33500000
33750000
34000000
34250000
34500000
34750000
35000000
35250000
35500000
35750000
36000000
36250000
36500000
36750000
'N E X T V E C T O R'
37000000
37250000
*,8
37500000
1,4
R1 K
37750000
2,RA(1)
INCREMENT RA(K)
38000000
2,1(2)
38250000
2,RA(1)
38500000
2,HIPROD(1)
HIPROD OR LOPROD
38750000
GOAHEAD
MEANING S(RA,,RA(1)) IS THE DESIRED 39000000

LTR 1,1
VECTOR
BCR 8,LKR
RETURN CC = IF NO MORE VECTORS
SR
1,1
ST
1,RA+4
B
TEST
GOAHEAD L
2,SINCR(1)
A
2,ORX
R2 INDEX OF NEXT VECTOR
ST
2,ORX
CR
1,LKR
BR
LKR
WITH CC SET NE BECAUSE THERE IS
*
A VECTOR
LTORG
TITLE 'R O T A T E -- A L L C A S E S'
EXDCIRSL CSECT
USING *,9
ST
LKR,ROORET
* SAVE A LITTLE TIME IN A SPECIAL CASE
CLI RHTYPE+3,1
WE'RE LOOKING
BE
BOOLORNV
FOR A
L
3,RHTYPE
L
2,RHRANK
NON-BOOLEAN
C
2,=F'4'
BNE BOOLORNV
VECTOR
L
1,RHXRHO
GOT ONE. GET SPACE FOR RESULT
LR
7,1
R7 X/RHO
LR
5,2
R5 RANK (ONE)
LR
6,3
R6 TYPE (GTR 1)
L
10,=A(OPSPACE)
BALR LKR,10
STH 5,MRANK(1)
STC 6,MTYPE(1)
ST
7,MRHO(1)
LA
5,MRHO+4(1)
R5 ABSOLUTE RESORG
CLI LHSCALAR,0
OTHERWISE, CHECK FOR SCALAR
BE
RANKERR
LEFT OP
L
4,LHBASE
AND GET ITS VALUE
A
4,LHRANK
LA
4,MRHO-M(4)
L
3,LHTYPE
SR
2,2
ICALL FETCHINT
L
1,=F'-1'
MR
0,0
R1 RIGHT ROTATE
L
10,RHXRHO
LTR 10,10
BE
ROTEND
NULL ARGUMENT
DR
0,10
LR
1,10
LTR 0,0
BNL *+6
AR
0,1
R0 AMOUNT OF RIGHT SHIFT
IC
6,SHFCT-2(6)
CONVERT TO CHARACTERS
SLDL 0,0(6)
SR
1,0
R1 AMT OF LEFT SHIFT
LR
10,0
R10 TEMP STORE
LA
0,256
R0 MVC INCREMENT
SR
2,2
R2 COUNT OF CHARS MOVED
L
3,RHBASE
LA
3,MRHO+4(3)
R3 ABS PTR FOR RH ORG
LA
6,0(3,1)
R6 ABS PTR FOR SOURCE OF 2ND MOVE

39250000
39500000
39750000
40000000
40250000
40500000
40750000
41000000
41250000
41500000
41750000
42000000
42250000
42500000
42750000
43000000
43250000
43500000
43750000
44000000
44250000
44500000
44750000
45000000
45250000
45500000
45750000
46000000
46250000
46500000
46750000
47000000
47250000
47500000
47750000
48000000
48250000
48500000
48750000
49000000
49250000
49500000
49750000
50000000
50250000
50500000
50750000
51000000
51250000
51500000
51750000
52000000
52250000
52500000
52750000
53000000
53250000
53500000
53750000
54000000

LA
4,0(5,10)
R4 ABS PTR FOR DEST OF FIRST MOVE
BCT 1,MVLEFT
B
EXLFMV
LEFT SHIFT BY 1 OF CHARACTER VECTOR
MAUVEL MVC 0(256,4),0(3)
FIRST MOVE IS INIT SEG OF RH ARG
AR
3,0
AR
4,0
MVLEFT BXLE 2,0,MAUVEL
EXLFMV EX
1,MEVL
SR
2,2
FIRST MOVE COMPLETED.
LTR 1,10
NOW DO OTHER MOVE
BE
ROTEND
UNLESS SHIFT WAS NULL
BCT 1,MVRGT
B
EXRGMV
SINGLE CHARACTER RIGHT SHIFT
MAUVER MVC 0(256,5),0(6)
AR
5,0
AR
6,0
MVRGT
BXLE 2,0,MAUVER
EXRGMV EX
1,MEVR
B
ROTEND
DONE, SO QUIT
MEVL
MVC 0(0,4),0(3)
MEVR
MVC 0(0,5),0(6)
* ORDINARY OLD CASE
BOOLORNV L
8,=A(SCNSETUP)
BALR LKR,8
L
4,LHBASE
LR
5,4
R5 LHBASE
L
8,LHRANK
SET UP LH FETCHINT ARGS
LA
4,MRHO-M(4,8)
R8 LHRANK
ST
4,LHORG
L
3,LHTYPE
ST
3,LCFTYPE
LA
2,1
ST
2,LHFINCR
XC
LHFINCR+3(1),LHSCALAR
BE
TRIVCHEK
AR
5,MR
CHECK THAT (RHO RHO L)=
L
6,RHBASE
(-EPSI(I))/RHO RHO S.
AR
6,MR
R5, R6 ABS PTRS TO LH AND RH ARGS
L
3,RHRANK
R3, R8 RH, LH DIM INDEX
L
4,REALINDX
R4 INDEX OF DIM TO SKIP COMPARE
LA
7,4
R7 DECREMENT
SR
1,1
R1 LENGTH ERR SWITCH
COMPDIMS SR
3,7
BM
DIMSCHKD
CR
3,4
BE
COMPDIMS
SR
8,7
BM
RANKERR
L
0,MRHO-M(8,5)
C
0,MRHO-M(3,6)
BE
COMPDIMS
LA
1,ELENGTH
B
COMPDIMS
RANKERR LA
1,ERANK
ICALL ERROR
DIMSCHKD LTR 8,8
BNE RANKERR
LTR 1,1
BE
TRIVCHEK
ICALL ERROR

54250000
54500000
54750000
55000000
55250000
55500000
55750000
56000000
56250000
56500000
56750000
57000000
57250000
57500000
57750000
58000000
58250000
58500000
58750000
59000000
59250000
59500000
59750000
60000000
60250000
60500000
60750000
61000000
61250000
61500000
61750000
62000000
62250000
62500000
62750000
63000000
63250000
63500000
63750000
64000000
64250000
64500000
64750000
65000000
65250000
65500000
65750000
66000000
66250000
66500000
66750000
67000000
67250000
67500000
67750000
68000000
68250000
68500000
68750000
69000000

TRIVCHEK CLI TRIV+3,0

BE
ROTEND
*PRELIMINARIES NOW DISPENSED WITH.
* AND ROTATE THEM IN PLACE.
NEXTONE L
8,=A(NEXTVECT)
BALR LKR,8
BE
ROTEND
LM
3,4,LCFTYPE
L
2,SX
ICALL FETCHINT
A
2,LHFINCR
ST
2,SX
SRDA 0,32
M
0,LOPROD
L
7,EMU
LR
5,7
DR
0,7
LTR 1,0
BP
NEGATE
BM
POSATE
QUEND
B
NEXTONE
POSATE AR
1,7
NEGATE LNR 1,1
ST
1,DX
GCDLP
SR
6,6
DR
6,1
LPR 7,1
LTR 1,6
BNE GCDLP
GCDFUND ST
7,CLOSS
SR
4,4
DR
4,7
BCT 5,STELEMS
STELEMS ST
5,ELEMS
LM
3,4,RCFTYPE
L
5,ORX
L
10,CLOSS
CLASSLP S
10,LOPROD
BM
NEXTONE
ST
10,CLOSS
LR
2,5
AR
2,10
ICALL FETCH
STM 0,1,SAVED
LDR 2,0
L
8,ELEMS
MOVELP L
2,DX
AR
2,10
BNL POSRES
A
2,EMU
POSRES LR
10,2
AR
2,5
ICALL FETCH
LR
6,0
LDR 4,0
LDR 0,2
LDR 2,4
LR
7,1
LM
0,1,SAVED

GET VECTORS ONE AT A TIME

NO MORE VECTORS

R1 DISTANCE TO MOVE LEFT

COMPUTE DX GCD EMU
R5 SAVE EMU FOR ELEMS CALC
REDUCE DX MOD EMU
PUT IT IN THE RIGHT REG FOR GCD
CALCULATION.
CHANGE TO RIGHT ROTATION
NULL ROTATE. DON'T DO IT, BUT
SOMEONE HAS TO QUEND
MAKING A POSITIVE LEFT ROTATION
A NEGATIVE RIGHT ROTATION

IF NEXT DIVIDE WOULD BE BY 0,

THEN THE REQUIRED GCD
IS NOW IN R7
ELEMS=(EMU./.CLOSS)-1. -1 BECAUSE
LAST ITEM OF CYCLE IS HANDLED
SPECIALLY
R5 ORX
R10 RX

R2 RX+ORX

R8 T--INNER LOOP COUNTER

NEXT RX IS THIS FORD RX

R6, R7 TEMPFORWD

69250000
69500000
69750000
70000000
70250000
70500000
70750000
71000000
71250000
71500000
71750000
72000000
72250000
72500000
72750000
73000000
73250000
73500000
73750000
74000000
74250000
74500000
74750000
75000000
75250000
75500000
75750000
76000000
76250000
76500000
76750000
77000000
77250000
77500000
77750000
78000000
78250000
78500000
78750000
79000000
79250000
79500000
79750000
80000000
80250000
80500000
80750000
81000000
81250000
81500000
81750000
82000000
82250000
82500000
82750000
83000000
83250000
83500000
83750000
84000000

STM 6,7,SAVED
ICALL STORE
QUEND
BCT 8,MOVELP
LR
0,6
DEPOSIT LAST ITEM
LR
1,7
BACK WHERE FIRST ONE WAS.
LDR 0,2
L
2,CLOSS
LR
10,2
TOP OF LOOP NEEDS IT
AR
2,5
ICALL STORE
B
CLASSLP
ROTEND L
LKR,ROORET
BR
LKR
LTORG
SHFCT
DC
FL1'2,3,0'
TITLE 'R E V E R S E'
EXMREV CSECT
USING *,9
ST
LKR,ROORET
L
8,=A(SCNSETUP)
BALR LKR,8
CLI TRIV+3,0
BE
REVEND
L
10,LOPROD
R10 PROD/LOW DIMENSIONS
NEXT
L
8,=A(NEXTVECT)
BALR LKR,8
BE
REVEND
LM
3,4,RCFTYPE
L
5,ORX
R5 RX
L
6,DIF
AR
6,5
R6 RHX
XCH
CR
5,6
BNL NEXT
LR
2,5
ICALL FETCH
LR
7,0
LR
8,1
R7, R8 TEMP
LDR 2,0
LR
2,6
ICALL FETCH
LR
2,5
ICALL STORE
LR
0,7
LR
1,8
LDR 0,2
LR
2,6
ICALL STORE
AR
5,10
SR
6,10
QUEND
B
XCH
REVEND L
LKR,ROORET
BR
LKR
LTORG
END
./ ADD
NAME=APLSSCOP
SCOP
TITLE 'SCALAR EXECUTION ROUTINES
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970

84250000
84500000
84750000
85000000
85250000
85500000
85750000
86000000
86250000
86500000
86750000
87000000
87250000
87500000
87750000
88000000
88250000
88500000
88750000
89000000
89250000
89500000
89750000
90000000
90250000
90500000
90750000
91000000
91250000
91500000
91750000
92000000
92250000
92500000
92750000
93000000
93250000
93500000
93750000
94000000
94250000
94500000
94750000
95000000
95250000
95500000
95750000
96000000
96250000
96500000
96750000
97000000
97250000
97500000
97750000
98000000
00150000
00300000
00450000

*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
SCOPS
CSECT
PRINT OFF
APLDEFN
COPY APLDEFN
PRINT ON,NOGEN
COPY OPSECT
TITLE 'SCALAR EXECUTION ROUTINES
05/11/70'
EXTRN ERROR
SCOPS
CSECT
*
*
SCALAR OPERATOR EXECUTION ROUTINES.
*
USING OPSECT-16,LR
*
*
ADD, SUBTRACT, MULTIPLY, DIVIDE.
*
EXADD
EQU *
INTEGER ADD.
ENTRY EXADD
AR
1,2
BR
LKR
*
EXFAD
EQU *
FLOATING ADD
ENTRY EXFAD
ADR 0,2
BR
LKR
*
EXSUB
EQU *
INTEGER SUBTRACT
ENTRY EXSUB
SR
1,2
BR
LKR
*
EXFSB
EQU *
FLOATING SUBTRACT.
ENTRY EXFSB
SDR 0,2
BR
LKR
*
EXMPY
EQU *
INTEGER MULTIPLY.
ENTRY EXMPY
MR
0,2
SLDA 0,32
OVERFLOW TEST **********************
LR
1,0
BR
LKR
*
EXFMP
EQU *
FLOATING MULTIPLY.
ENTRY EXFMP
MDR 0,2
BR
LKR
*
EXFDP
EQU *
DIVIDE.
ENTRY EXFDP
DDR 0,2
BR
LKR
*
EJECT
*
*
MAX, MIN.
*
EXMAX
EQU *
INTEGER MAXIMUM.
ENTRY EXMAX
CR
1,2

00600000
00750000
01050000
01200000
01350000
01500000
01650000
01800000
01950000
02100000
02250000
02400000
02550000
02700000
02850000
03000000
03150000
03300000
03450000
03600000
03750000
03900000
04050000
04200000
04350000
04500000
04650000
04800000
04950000
05100000
05250000
05400000
05550000
05700000
05850000
06000000
06150000
06300000
06450000
06600000
06750000
06900000
07050000
07200000
07350000
07500000
07650000
07800000
07950000
08100000
08250000
08400000
08550000
08700000
08850000
09000000
09150000
09300000
09450000
09600000

*
EXDMAX

*
EXMIN

*
EXDMIN

*
*
*
EXRES

RES4
RES1

BCR
LR
BR

10,LKR
1,2
LKR

EQU
ENTRY
CDR
BCR
LDR
BR

*
EXDMAX
0,2
10,LKR
0,2
LKR

EQU *
ENTRY EXMIN
CR
1,2
BCR 12,LKR
LR
1,2
BR LKR
EQU
ENTRY
CDR
BCR
LDR
BR
EJECT

*
EXDMIN
0,2
12,LKR
0,2
LKR

RESIDUE
EQU
ENTRY
USING
LPER
BZ
STD
STE
XI
LPER
CDR
BH
STD
DDR
LD

*
EXRES
EXRES,9
0,0
RES3
0,A
2,BSIGN
BSIGN,X'80'
2,2
0,2
RES2
2,B
2,0
4,DMKFLOOR

LDR
ADR
LER
LER
SDR
MER
MDR

6,4
2,4
4,2
6,0
0,6
6,4
0,4

LD
SDR
SDR
LD
BNM

2,B
2,6
2,0
0,A
RES1

RES4

*
*

*
*

09750000
09900000
10050000
10200000
FLOATING MAXIMUM.
10350000
10500000
10650000
10800000
10950000
11100000
11250000
INTEGER MINIMUM.
11400000
11550000
11700000
11850000
12000000
12150000
12300000
FLOATING MINIMUM.
12450000
12600000
12750000
12900000
13050000
13200000
13350000
13500000
13650000
13800000
13950000
14100000
14250000
TAKE ABSOLUTE A
14400000
0 RES B IS B (IF B POSITIVE)
14550000
14700000
SAVE TRUE SIGN OF B FOR POSSIBLE
14850000
15000000
DECOMPLEMENTATION AT RES2
15150000
END TEST IS A GTR REDUCED B
15300000
15450000
15600000
THE FOLLOWING TAKES A SIX-OR-LESS- 15750000
DIGIT QUOTIENT B/A, MULTIPLIES
15900000
(ACCURATELY) BY A, AND SUBTRACTS
16050000
THIS (ALSO ACCURATELY) FROM B.
16200000
USED TO SPLIT F0
16350000
LOSE FRACTIONAL PART OF B/A, IF ANY 16500000
HIGH 6 DIGITS OF FLOOR B/A
16650000
HIGH 6 DIGITS OF A
16800000
LOW 8 DIGITS OF A
16950000
HIGH 12 DIGITS OF A * FLOOR B/A
17100000
LOW 14 DIGITS OF A * FLOOR B/A
17250000
(OVERLAPPING BY 8 DIGITS)
17400000
14 DIGITS OF B
17550000
CANCEL 5 OR 6 DIGITS OF B
17700000
R2 HOLDS TRUE B - A * FLOOR B/A
17850000
RECALL MODULUS
18000000
AND ITERATE IF NOT ENOUGH SIGNIFI- 18150000
CANCE HAS BEEN REMOVED FROM B.
18300000
POSSIBILITY EXISTS ON MOD 91 OF F2 18450000
GOING NEGATIVE. EXAMPLE IN 4-DIGIT 18600000

*
*
*
*
*
*
RES2

RES3

*
*
*
EXFRES

FRES0

*
*
*
*
*
*
EXLSTH

CLI
BNL
LTER
BZ
SDR
BR
LTDR
BCR
B
DROP
EJECT

BSIGN,X'80'
RES3
2,2
RES3
0,2
LKR
0,2
11,LKR
RNGEROR
9

DECIMAL IS 3 RES 5999 . SINCE F2

IS CONGRUENT MOD A TO THE CORRECT
RESULT WE RECYCLE AS IF IT WERE THE
ORIGINAL ARGUMENT (EXCEPT FOR DECOMPLEMENTATION)
SIGNIFICANCE HAS BEEN REMOVED FROM B
RESIDUE MAY NEED DECOMPLEMENTATION
NO, B WAS POSITIVE
YES, B WAS NEGATIVE.
QUIT NOW IF A RES -B IS 0
F0 IS ACCURATE A - A RES -B
PUT RESIDUE IN F0
RETURN UNLESS A = 0 AND B LESS 0

INTEGER RESIDUE.
EQU
ENTRY
USING
LR
LPR
BZ
SRDA
DR
LTR
BCR
AR
BR
LTR
BCR
B
DROP
EJECT

*
EXFRES
EXFRES,9
0,2
2,1
FRES0
0,32
0,2
1,0
11,LKR
1,2
LKR
1,0
11,LKR
RNGEROR
9

SET UP FOR DR 0,2

ABSOLUTE A
QUICK EXIT FOR 0 RESIDUE
EXTEND SIGN OF B
REMAINDER TO R1
EXIT IF NON-NEGATIVE
OTHERWISE DECOMPLEMENT
0 RESIDUE REQUIRES NON-NEGATIVE B

RELATIONAL OPERATORS.
RESULT RETURNED IN R1.
= TRUE.
+ = FALSE.
EQU
ENTRY
CR
LA
BCR
BCTR

*
EXDLSTH EQU
ENTRY
SR
SWR
BCR
STD
CLC
BCR
BCTR
*

*
EXLSTH
1,2
1,0
11,LKR
1,LKR

INTEGER LESS THAN.

*
EXDLSTH
1,1
0,2
2,LKR
0,DTEMP
DTEMP+1(7),FUZZ+1
13,LKR
1,LKR

FLOATING LESS THAN.

INITIALIZE RESULT

18750000
18900000
19050000
19200000
19350000
19500000
19650000
19800000
19950000
20100000
20250000
20400000
20550000
20700000
20850000
21000000
21150000
21300000
21450000
21600000
21750000
21900000
22050000
22200000
22350000
22500000
22650000
22800000
22950000
23100000
23250000
23400000
23550000
23700000
23850000
24000000
24150000
24300000
24450000
24600000
24750000
24900000
25050000
25200000
25350000
25500000
25650000
25800000
25950000
26100000
26250000
26400000
26550000
26700000
26850000
27000000
27150000
27300000
27450000
27600000

EXLSTHEQ EQU
ENTRY
CR
LA
BCR
BCTR
*
EXDLSTHE EQU
ENTRY
USING
SR
SWR
BNP
STD
CLC
BCR
TDLSTH BCTR
DROP
*
EXEQUAL EQU
ENTRY
CR
LA
BCR
BCTR
*
EXDEQUAL EQU
ENTRY
SR
SWR
STD
CLC
BCR
BCTR
*
EXNOTEQU EQU
ENTRY
CR
LA
BCR
BCTR
*
EXDNOTEQ EQU
ENTRY
LA
SWR
STD
CLC
BCR
BCTR
*
EXGRTHEQ EQU
ENTRY
CR
LA
BCR
BCTR
*
EXDGRTHE EQU
ENTRY

*
EXLSTHEQ
1,2
1,0
3,LKR
1,LKR

INTEGER LESS THAN OR EQUAL.

*
EXDLSTHE
EXDLSTHE,9
1,1
0,2
TDLSTH
0,DTEMP
DTEMP+1(7),FUZZ+1
2,LKR
1,LKR
9

FLOATING LESSTHAN OR EQUAL.

*
EXEQUAL
1,2
1,0
7,LKR
1,LKR

INTEGER EQUAL.

*
EXDEQUAL
1,1
0,2
0,DTEMP
DTEMP+1(7),FUZZ+1
2,LKR
1,LKR

FLOATING EQUAL.

*
EXNOTEQU
1,2
1,0
8,LKR
1,LKR

INTEGER NOT EQUAL.

*
EXDNOTEQ
1,0
0,2
0,DTEMP
DTEMP+1(7),FUZZ+1
13,LKR
1,LKR

FLOATING NOT EQUAL.

*
EXGRTHEQ
1,2
1,0
5,LKR
1,LKR

INTEGER GREATER THAN OR EQUAL.

*
EXDGRTHE

FLOATING GREATER THAN OR EQUAL.

INITIALIZE RESULT FALSE.

SET RESULT FALSE.

27750000
27900000
28050000
28200000
28350000
28500000
28650000
28800000
28950000
29100000
29250000
29400000
29550000
29700000
29850000
30000000
30150000
30300000
30450000
30600000
30750000
30900000
31050000
31200000
31350000
31500000
31650000
31800000
31950000
32100000
32250000
32400000
32550000
32700000
32850000
33000000
33150000
33300000
33450000
33600000
33750000
33900000
34050000
34200000
34350000
34500000
34650000
34800000
34950000
35100000
35250000
35400000
35550000
35700000
35850000
36000000
36150000
36300000
36450000
36600000

USING
SR
SWR
BNM
STD
CLC
BCR
BCTR
DROP

EXDGRTHE,9
1,1
0,2
TDGE
0,DTEMP
DTEMP+1(7),FUZZ+1
2,LKR
1,LKR
9

36750000
36900000
37050000
37200000
37350000
37500000
37650000
TDGE
37800000
37950000
*
38100000
EXGRTH EQU *
INTEGER GREATER THAN.
38250000
ENTRY EXGRTH
38400000
CR
1,2
38550000
LA
1,0
38700000
BCR 13,LKR
38850000
BCTR 1,LKR
39000000
*
39150000
EXDGRTH EQU *
FLOATING GREATER THAN.
39300000
ENTRY EXDGRTH
39450000
SR
1,1
39600000
SWR 0,2
39750000
BCR 4,LKR
39900000
STD 0,DTEMP
40050000
CLC DTEMP+1(7),FUZZ+1
40200000
BCR 13,LKR
40350000
BCTR 1,LKR
40500000
EJECT
40650000
*
40800000
*
MONADIC SCALAR OPS.
40950000
*
ARG IN HIGH REGISTER, RESULT IN LOW.
41100000
*
41250000
*
FLOATING FLOOR AND CEILING
41400000
*
41550000
*
FLOOR AND CEILING ARE FUZZED AS FOLLOW,
41700000
*
RESULT IS ZERO IF CPUTFUZZ GE ABS ARG.
41850000
*
FOR FLOOR, THE RESULT IS THE TRUE FLOOR UNLESS
42000000
*
THE ARG IS GREATER THAN THE TRUE FLOOR AND EQUAL TO
42150000
*
THE TRUE CEILING (WHERE BOTH COMPARISONS ARE FUZZED).
42300000
*
FOR CEILING, THE RESULT IS THE TRUE CEILING UNLESS
42450000
*
THE ARG IS LT THE TRUE CEILING AND EQUAL TO THE
42600000
*
TRUE FLOOR (WHERE BOTH COMPARISONS ARE FUZZED).
42750000
*
42900000
SPACE
43050000
EXDCEIL EQU *
FLOATING CEILING.
43200000
ENTRY EXDCEIL
43350000
USING EXDCEIL,9
43500000
LA
1,1
SET CEILING FLAG
43650000
BAL 2,INIT
GO TO COMMON ROUTINE WITH FLOOR
43800000
*
* * * * * * * USING FOR FLOOR MUST FOLLOW IMMEDIATELY * 43950000
DROP 9
44100000
*
44250000
EXDFLOOR EQU *
FLOATING FLOOR.
44400000
ENTRY EXDFLOOR
44550000
USING EXDFLOOR,2
44700000
LR
2,9
44850000
SR
1,1
SET FLOOR FLAG
45000000
INIT
LPDR 0,2
WANT EXPONENT BYTE WITH + SIGN
45150000
STE 0,DTEMP
45300000
CD
0,DBLHALF
45450000
BH
RELF
IF ABS ARG GT .5 THEN USE REL FUZZ 45600000

MVI DTEMP,X'40'
SET EXP BYTE FOR ABS FUZZ
CLC CPUTFUZZ+1(7),DUNZERO+1
BNE RELF
IF FUZZ NONZERO MERGE WITH REL F
LDR 0,2
SPECIAL CASE OF ZERO FUZZ AND
SDR 2,2
ARG IS SMALL
BXH 1,1,CLNRZ
LTER 0,0
BNM TRUNCATE
SD
2,DBLONE
B
TRUNCATE
CLNRZ
LTER 0,0
BNP TRUNCATE
LD
2,DBLONE
B
TRUNCATE
RELF
MVC DTEMP+1(7),CPUTFUZZ+1 MOVE FUZZ BITS INTO PLACE
LD
4,DTEMP
F4 CONTAINS RELATIVE FUZZ
CD
4,DBLHALF
BL
*+6
SDR 4,4
SET FUZZ TO ZERO
CASE
BXH 1,1,SETUPCL
GO BACK TO DOING CEILING
ADR 2,4
INCREASE ARG BY FUZZ
BP
TRUNCATE
JUST TRUNCATE IF POSITIVE ARG
SD
2,DBLONEM
DECREASE BY ALMOST 1
TRUNCATE AW
2,DUNZERO
TRUNCATE TO INTEGER
CLI BLOWN,0
RETURN NOW IF FLOATING RESULT
BNE CEFL2
REQUESTED
STD 2,DBLHOLD
L
1,DBLHOLD+4
ELSE TRANSFER TO FIXED REG
AWR 2,2
TEST SIGN, SET UP FOR MAGNITUDE TEST
BNM *+6
LCR 1,1
LTER 2,2
NONZERO IF F2 WAS GEQ 2*31
BCR 8,LKR
L
1,=V(BLOWUP)
BR
1
SETUPCL SDR 2,4
DECREASE ARG BY FUZZ
BM
TRUNCATE
JUST TRUNCATE IF NEG ARG
AD
2,DBLONEM
INCREASE BY ALMOST 1
B
TRUNCATE
NOW TRUNCATE
DROP 2
*
EXMADD EQU *
MONADIC ADD
ENTRY EXMADD
LR
1,2
BR
LKR
*
EXMCIRC EQU *
DIAMETER FUNCTION
ENTRY EXMCIRC
USING EXMCIRC,9
DD
2,IPI
IS PI TIMES ARG
*
DIVIDE IS ANCIENT NON-GUARD-DIGIT HISTORY BUT HELPS MOD 91 TOO
DROP 9
*
EXMFAD EQU *
CEFL2
EQU EXMFAD
ENTRY EXMFAD
SDR 0,0
ADR 0,2
NORMALIZE JUST IN CASE
BR
LKR
*

45750000
45900000
46050000
46200000
46350000
46500000
46650000
46800000
46950000
47100000
47250000
47400000
47550000
47700000
47850000
48000000
48150000
48300000
48450000
48600000
48750000
48900000
49050000
49200000
49350000
49500000
49650000
49800000
49950000
50100000
50250000
50400000
50550000
50700000
50850000
51000000
51150000
51300000
51450000
51600000
51750000
51900000
52050000
52200000
52350000
52500000
52650000
52800000
52950000
53100000
53250000
53400000
53550000
53700000
53850000
54000000
54150000
54300000
54450000
54600000

EXMSUBT EQU *
ENTRY EXMSUBT
LCR 1,2
BR
LKR
*
EXMFSB EQU *
ENTRY EXMFSB
LCDR 0,2
BCR 7,LKR
LPER 0,0
BR
LKR
*
ENTRY EXMMPY
EXMMPY EQU *
SIGN -- (X GTR 0) - (X LSS 0)
LTR 1,2
BCR 8,LKR
LA
1,1
BCR 2,LKR
LCR 1,1
BR
LKR
*
EXMFMP EQU *
SIGN FUNCTION, FLOATING ARG
ENTRY EXMFMP
USING *,9
LTDR 0,2
BCR 8,LKR
LD
0,DBLONE
BCR 2,LKR
LCER 0,0
BR
LKR
DROP 9
*
EXABS
EQU *
INTEGER ABSOLUTE VALUE.
ENTRY EXABS
LPR 1,2
BR
LKR
*
EXDABS EQU *
FLOATING ABSOLUTE VALUE.
ENTRY EXDABS
LPDR 0,2
BR
LKR
*
EXCEIL EQU EXMADD
INTEGER CEILING
ENTRY EXCEIL
*
EXFLOOR EQU EXMADD
INTEGER FLOOR
ENTRY EXFLOOR
EJECT
*
FRANDOM EQU *
INTEGER MONADIC QUERY
ENTRY FRANDOM
USING *,9
*
WE ARE TAKING ADVANTAGE IN THESE ROUTINES OF THE FACT THAT THE
*
NUMBER GENERATED BY RANDOM IS BETWEEN 0 AND 2*31-1 AND THAT
*
WE MAY CONSIDER THIS A FRACTION UNIFORMLY DISTRIBUTED BETWEEN
*
0 AND 1.
ST
LKR,RSAVE
LTR 2,2
SEE IF OPERAND IS POSITIVE
BNH RNGERR
DOMAIN ERROR IF NOT
LA
10,RANDOM
BASE REGISTER FOR RANDOM.

54750000
54900000
55050000
55200000
55350000
55500000
55650000
55800000
55950000
56100000
56250000
56400000
56550000
56700000
56850000
57000000
57150000
57300000
57450000
57600000
57750000
57900000
58050000
58200000
58350000
58500000
58650000
58800000
58950000
59100000
59250000
59400000
59550000
59700000
59850000
60000000
60150000
60300000
60450000
60600000
60750000
60900000
61050000
61200000
61350000
61500000
61650000
61800000
61950000
62100000
62250000
62400000
62550000
62700000
62850000
63000000
63150000
63300000
63450000
63600000

BALR
MR
SLDL
A
LR
L
BR
DROP

LKR,10
0,2
0,1
0,IORIGIN
1,0
LKR,RSAVE
LKR
9

GET A RANDOM NUMBER.

MULTIPLY BY ARG
ADD IN INDEX ORIGIN
R1 IS RESULT REGISTER

*
DRANDOM EQU *
FLOATING MONADIC QUERY
ENTRY DRANDOM
USING *,9
ST
LKR,RSAVE
LTDR 0,2
OPERAND MUST BE POSITIVE INTEGER.
BNP RNGERR
ERROR IF NOT.
*
CHECK FOR FRACTIONAL PART LESS THAN FUZZ WITHOUT
*
REQUIRING MAGNITUDE TO BE LSS 2*31
AD
2,DMKFLOOR
INTEGERIZE
SWR 2,0
SUBTRACT OPERAND.
STD 2,DSAVE
SAVE RESULT OF SUBTRACTION.
CLC DSAVE+1(7),CNVTFUZZ+1
BH
RNGERR
REALLY HAS A FRACTIONAL PART
CD
0,=D'2147483647'
TO DRAND3 IF ARG LTEQ 2*31-1
3592
BNH DRAND3
3592
LA
10,RANDOM
BASE RESISTER FOR RANDOM.
BALR LKR,10
GET A RANDOM NUMBER.
LR
2,1
SAVE IT IN R2
BALR LKR,10
GET A RANDOM NUMBER.
LR
0,2
RECALL FIRST RANDOM
ALR 1,1
DO A COUPLE OF SHIFTS TO FORM 62-BIT
SLDL 0,1
RANDOM INTEGER
ST
1,DSAVE+4
GET RANDOMS INTO FLOATING REGISTERS
LD
4,DSAVE
ST
0,DSAVE+4
LD
2,DSAVE
LE
2,QU40HEX
PUT IN SIGNS AND EXPONENTS.
LE
4,QU38HEX
MDR 4,0
MULTIPLY MIDDLE PIECE BY OPERAND.
CLI DSAVE+4,2
SEE IF THERE WERE 6 OR MORE L ZEROS.
BNL DRAND2
BRANCH IF NOT - WON'T LOSE SIGNIFANC
BALR LKR,10
OTHERWISE, GET ANOTHER RANDOM NO.
ALR 1,1
ST
1,DSAVE+4
LD
6,DSAVE
GET IT INTO F6.
LE
6,QU30HEX
WITH AN EXPONENT.
MDR 6,0
MULTIPLY BY OPERAND.
ADR 4,6
ADD INTO RESULT SO FAR.
DRAND2 MDR 0,2
MULTIPLY HIGH ORDER BITS BY OPERAND.
ADR 0,4
ADD IN REST - NOW HAVE 56 RANDOM BTS
MVC DSAVE+4(4),IORIGIN
LD
2,DSAVE
LE
2,DUNZERO
ADR 0,2
ADD IORIGIN AND INTEGERIZE.
AD
0,DMKFLOOR
L
LKR,RSAVE
BR
LKR
SPACE 2
3592
*
FLOATING ARGUMENT IS 2*31-1 OR LESS. CONVERT FLOATING
3592
*
ARG TO FIXED POINT AND USE FRANDOM. THIS AVOIDS
3592
*
INCONSISTENT RESULTS WHICH DEPEND ON WHETHER ARGUMENT
3592

63750000
63900000
64050000
64200000
64350000
64500000
64650000
64800000
64950000
65100000
65250000
65400000
65550000
65700000
65850000
66000000
66150000
66300000
66450000
66600000
66750000
66900000
67050000
67200000
67350000
67500000
67650000
67800000
67950000
68100000
68250000
68400000
68550000
68700000
68850000
69000000
69150000
69300000
69450000
69600000
69750000
69900000
70050000
70200000
70350000
70500000
70650000
70800000
70950000
71100000
71250000
71400000
71550000
71700000
71850000
72000000
72150000
72300000
72450000
72600000

*
DRAND3

*
*
*
*
*
*
*
*
*
RANDOM

*
*
*
EXNOT

*
EXAND

*
EXOR

IS INTERNALLY STORED AS FIXED OR FLOATING.

AW
0,DUNZERO
THIS SHUFFLE CONVERTS FLOATING
STD 0,DSAVE
ARG TO FIXED POINT IN
L
2,DSAVE+4
GENERAL REG 2.
ST
LKR,RSAVE+4
FRANDOM USES RSAVE
L
9,=A(FRANDOM)
SET FRANDOM BASE REG
BALR LKR,9
OFF TO FRANDOM, RESULT IN GR1
BALR 9,0
REESTABLISH ADDRESSABILITY
USING *,9
ST
1,DSAVE+4
THIS SHUFFLE CONVERTS
LD
0,DSAVE
POS FRANDOM RESULT FROM
LE
0,DUNZERO
INTEGER TO NORMALIZED
SD
0,DUNZERO
FLOATING POINT.
L
9,=A(DRANDOM)
RESET DRANDOM BASE REG.
L
LKR,RSAVE+4
RECALL DRANDOM'S RETURN REG.
BR
LKR
SPACE 2
DROP 9
RANDOM NUMBER GENERATOR.
LEHMER'S METHOD, CACM JUNE '66, P 432.
N(I+1) = P RES Q X N(I)
P = (2**31)-1
Q = 7**5
ENTRY
EQU
USING
L
LTR
BP
L
M
D
ST
LR
BR
DROP
EJECT

RANDOM
*
*,10
1,RNUMBER
1,1
*+8
1,QU7T5
0,QU7T5
0,QU2T31
0,RNUMBER
1,0
LKR
10

PICK UP LAST RANDOM NO.

SEE IF IT'S ZERO.
BRANCH IF POSITIVE.
OTHERWISE, PICK UP STARTER.
X 7**5
DIV (2**31)-1
STORE RESULT.

LOGICAL OPERATORS.
EQU
ENTRY
USING
X
LR
BR
DROP

*
EXNOT
EXNOT,9
2,ALLONE
1,2
LKR
9

NOT.

EQU
ENTRY
NR
BR

*
EXAND
1,2
LKR

AND.

EQU *
ENTRY EXOR
OR
1,2

OR.

3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592
3592

72750000
72900000
73050000
73200000
73350000
73500000
73650000
73800000
73950000
74100000
74250000
74400000
74550000
74700000
74850000
75000000
75150000
75300000
75450000
75600000
75750000
75900000
76050000
76200000
76350000
76500000
76650000
76800000
76950000
77100000
77250000
77400000
77550000
77700000
77850000
78000000
78150000
78300000
78450000
78600000
78750000
78900000
79050000
79200000
79350000
79500000
79650000
79800000
79950000
80100000
80250000
80400000
80550000
80700000
80850000
81000000
81150000
81300000
81450000
81600000

BR

81750000
81900000
EQU *
NAND
82050000
ENTRY EXNAND
82200000
USING EXNAND,9
82350000
NR
1,2
82500000
X
1,ALLONE
82650000
BR
LKR
82800000
DROP 9
82950000
*
83100000
EXNOR
EQU *
NOR
83250000
ENTRY EXNOR
83400000
USING EXNOR,9
83550000
OR
1,2
83700000
X
1,ALLONE
83850000
BR
LKR
84000000
DROP 9
84150000
EJECT
84300000
*
84450000
*
RECIPROCAL (MONADIC DIVIDE)
84600000
*
84750000
SPACE
84900000
EXMFDP EQU *
85050000
ENTRY EXMFDP
85200000
USING *,9
85350000
LD
0,DBLONE
85500000
DDR 0,2
85650000
BR
LKR
85800000
DROP 9
85950000
EJECT
86100000
*
86250000
*
ARTHTP ERROR ROUTINE.
86400000
*
86550000
*
THIS ROUTINE IS ENTERED IF AN INVALID OPERATION IS REQUESTED. 86700000
*
FOR EXAMPLE, IF AN OPERATOR WHICH MAY BE DYADIC ONLY
86850000
*
IS PRESENTED TO ARTHTP WITH ONLY ONE OPERAND, THE ADDRESS
87000000
*
OF THIS ROUTINE IS RETURNED AS THE OPERATOR EXECUTION ROUTINE. 87150000
*
IF THE ERROR GOES UNDETECTED UNTIL EXECUTION TIME, THEN THE
87300000
*
EXECUTE WILL CAUSE A TRANSFER HERE, AND EXECUTION WILL BE
87450000
*
ABANDONED.
87600000
*
87750000
*
NOTE...
87900000
*
****
88050000
*
88200000
*
AN ERROR IN ARTHTP MAY RESULT IN THIS ERROR BEING GENERATED. 88350000
*
88500000
EXERROR EQU *
88650000
ENTRY EXERROR
88800000
BALR 9,0
88950000
USING *,9
89100000
LA
1,ESYNTAX
89250000
ICALL ERROR
89400000
DROP 9
89550000
EJECT
89700000
*
89850000
*
WE END UP HERE WITH A RANGE ERROR.
90000000
*
90150000
RNGERR EQU *
90300000
RNGEROR EQU RNGERR
90450000
BALR 9,0
90600000
*
EXNAND

LKR

USING *,9
SO WE NEED TO SET A BASE REGISTER.
LA
1,ERANGE
ICALL ERROR
DROP 9
TITLE 'CONSTANTS.'
FUZZ
EQU RFUZZ
CPUTFUZZ EQU RFUZZ
DBLONE DC
D'1'
DBLHALF DC
D'.5'
CNVTFUZZ DC
X'40000000000003FF'
DUNZERO DC
X'4E00000000000000'
DMKFLOOR DC
X'4F00000000000000'
DBLONEM DC
X'40FFFFFFFFFFFFFF'
ALLONE EQU *-4
IPI
DC
D'.31830988618379067153' INVERSE PI
F1
DC
F'1'
QU30HEX DC
X'36000000'
QU38HEX DC
X'3E000000'
QU40HEX DC
X'46000000'
QU7T5
DC
F'16807'
7**5
QU2T31 DC
X'7FFFFFFF'
(2**31)-1
LTORG
END
./ ADD
NAME=APLSSINI
SINI
TITLE 'APLSUP LOAD AND INITIALIZE ROUTINE
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&L
COMRG
MNOTE 7,'ENVIRONMENT CONFUSION.'
MEND
GBLA &SLOP
TYBUFG CSECT
&SLOP
SETA 2048
PRINT OFF
COPY PERTERM DIRSECT
COPY PERTERM
TO GET PERBUF
COPY DIRSECT
PRINT ON
EMPTYM EQU X'80'
TYBUFG CSECT
*
TYBUFG CONTAINS INITIALIZATION CODE WHICH IS THEN OVERLAID BY
*
TYPEWRITER BUFFERS AT THE END OF INITIALIZATION. ALL OTHER
*
INITIALIZATION CODE IS CLOBBERED BY BUFFERS AT THIS TIME SO
*
THIS MUST BE THE LAST INITIALIZATION FUNCTION.
*
ORDER OF STORAGE AT LINK TIME IS ASSUMED TO BE..
*
*
LOW ADDR OF PARTITION
*
APLSUP, TABLES, INTERPRETER, ETC.
*
TYBUFG CSECT
*
OTHER INITIALIZATION SUBROUTINES
*
UNUSED
*
HIGH ADDRESS OF PARTITION
*
*
AFTER SUPINI FINISHES AND DOES QUANTUM END..
*
*
APLSUP, TABLES, INTERPRETER, ETC.
*
TYBUFG CSECT
*
TYPEWRITER BUFFERS
*
WORKSPACES

90750000
90900000
91050000
91200000
91350000
91500000
91650000
91800000
91950000
92100000
92250000
92400000
92550000
92700000
92850000
93000000
93150000
93300000
93450000
93600000
93750000
93900000
94050000
00080000
00160000
00240000
00320000
00400000
00480000
01040000
01120000
01280000
01440000
01520000
01680000
01760000
01840000
01920000
02000000
02080000
02160000
02240000
02320000
02400000
02480000
02560000
02640000
02720000
02800000
02880000
02960000
03040000
03120000
03200000
03280000
03360000
03440000
03520000
03600000

*
*
*
*
*
*
*
TB1

HIGH ADDRESS OF PARTITION

03680000
03760000
FOLLOWING CODE ASSUMES L'PBSTAR IS AT LEAST TWELVE AND THAT
03840000
ITB1 DOES NOT TOUCH FIRST WORD OF PBCCW. NOTE THAT IT LIVES 03920000
IN PBSTAR AND POSSIBLY HALF OF PBCCW. IT IS EXECUTED IN
04000000
SUPVR STATE WITH INTERRUPTS DISABLED. SVINIT IN APLSUP IS
04080000
CALLER.
04160000
DC
D'0'
FIRST PBCCW
04240000
DC
F'0'
FIRST PBTIC
04320000
*
04400000
*
REGISTERS HAVE BEEN INITIALIZED FOR BXLE, ETC. FROM ITBREGS. 04480000
*
R0 = TBL
04560000
*
R1 = UPPER LIMMIT OF BXLE
04640000
*
R2 = A(TB1)
04720000
USING ITB1,4
04800000
USING PERBUF,2
04880000
ITB1
MVI PBFLAG,FREEBIT
MARK FREE
04960000
LA
3,PBLAST+1
CHAIN TO NEXT
05040000
ST
3,PBTIC
05120000
B
ITB2
ASSUME SHORT BUFFER
05200000
ORG ITB1+TBL
AVOID PBFLAG AND PBTIC
05280000
ITB2
BXLE 2,0,ITB1
LOOP BACK
05360000
SR
2,0
POINT TO LAST BUFFER
05440000
MVI PBTIC+1,EMPTYM
MARK AS LAST
05520000
BR
LINK
RETURN TO SVINIT IN APLSUP
05600000
DROP 2,4
05680000
IM
CSECT
NOMINAL START OF WORKSPACE AREA
05760000
DS
XL14000
MUST BE LONGER THAN 1 TRACK ON DASD 05840000
*
DIRECT-ACCESS DEVICE
05920000
SUPINI CSECT
06000000
PRINT OFF
COPY APLDEFN
06080000
COPY APLDEFN
06160000
DROP MR
06240000
TITLE 'LOAD AND INITIALIZE APLSUP'
06320000
PRINT ON,GEN
C021 06400000
*
SUPINI FUNCTIONS
06480000
*
06560000
*
A) VERSION CHECK, ESTABLISH CONFINIT ADDRESSABILITY, TIMER
07040000
*
POSSESSION CHECK, TIMER RECORD TO TEST IF RUNNING.
07200000
*
B) ZSYMDATE
07280000
*
C) OPEN LIBRARY PACKS
07360000
*
D) OPEN SWAP AREA
07440000
*
E) MAX/CFREDSK
07520000
*
F) TIMER CHECK AND DATE-TOD VALIDATION
07600000
*
G) FORMAT SWAP DISK
07680000
*
H) COMPUTE WORKSPACE AND TYPEWRITER BUFFER PARAMETERS
07760000
*
J) SETIME TWO SECONDS, UPDATE REALTIME, MOVE SUPCONF TO APLSUP 08080000
*
K) LOAD REGISTERS FOR TYPEWRITER BUFFER SETUP AND ENTER
08480000
*
APLSUP SVINIT VIA SVC YYQZ
08560000
*
L) APLSUP CALLS ITB1 SUBROUTINE WHICH OVERWRITES SUPINI ETC
08640000
*
WITH TYPEWRITER BUFFERS
08720000
*
M) RETURN TO SVINIT CODE TO ENTER WAIT STATE AND AWAIT TIMER 08800000
*
INTERRUPT FROM SETIME TWO SECONDS IN STEP J).
08880000
*
ONE COPY PER CORE SLOT
10160000
PERCORE DSECT
10240000
PCQUONT DS
1H
QUONT COUNTER
10320000
PCADDR DS
AL3
STARTING ADDRESS OF THIS SLOT
10400000
PCTERM EQU *-1
PERTERM BASE REGISTER
10480000
DS
AL3
HIGH ORDER BIT ON MEANS UNASSIGNED
10560000
DS
0D
10640000

PERCOREL EQU *-PERCORE

SUPINI CSECT
SO SUPCONF WILL KNOW
PRINT GEN
SUPPARD APLSUPC
*
VALCON EQU ALEN+3
*
SUPINI CSECT
CUB2702 EQU X'70'
BUSY 270X CONTROL UNIT
CSW
EQU 64
Q1052
EQU X'54'
TITLE 'LIST OF EXTERNAL ADDRESSES'
EXTRN APLINIT
EXTRN OPLIB
OPEN ALL LIBRARY PACKS
EXTRN NOPEN
EXTRN DISKFMT
TITLE 'INITIALIZE APL PROGRAM'
*
THIS ROUTINE IS START OF APL EXECUTION
LINK
EQU 15
STAREX BALR 13,0
USING STAREX+2,13
*
ST
1,MPARM
SAVE R1 FOR LATER
*
LA
3,TOLIST
PASS LIST CONTAINING SUPINI'S
ST
3,4(1)
ECB TO MOTHER TASK
L
1,0(1)
MVC LIST(LISTLENG),0(1) PASS ADDRESSES TO SUPINI
L
5,SUPLOC
RELOCATION FACTOR OF APLSUP
*
BASE REGISTERS IN SUPINI
*
R13 SUPINI ADDRESSABILITY
*
R12 SUPPARS AREA IN CONFINIT
L
12,ASUPPARS
POINT TO APLSUP
LA
0,VALCON
FOR VERSION VALIDATION
USING SUPPARD,12
C
0,LSUPC(5)
COMPARE WITH APLSUP COPY
LA
2,CURRENTM
SET UP ADDRESSES FOR SVCINIT
BNE WRONGV
APLSUP, WRONG VERSION
L
12,ACONFINI
POINT TO CONFINIT
C
0,LSUPC
BNE WRONGV
CONFIG, WRONG VERSION
*
SPACE 3
*
ALTHOUGH MFT-ATTACH IS SUPPOSED TO PROVIDE ESSENTIALLY
*
THE SAME FUNCTIONS AS MVT, THERE ARE SUBSTANTIAL
*
DIFFERENCES IN THEIR MODUS OPERANDI.
*
*
WE WILL CHECK FOR THE TYPE OF SYSTEM BEING USED, AND IF
*
THERE IS HIERARCHY SUPPORT
*
* OSFLG
HAS FOLLOWING FORMAT
*
* .... XX.. R E S E R V E D
* X... .... 1 - PARM=DEBUG
* .X.. .... 1 - UNRECOGNIZED PARM
* ..X. .... 1 - MFT-ATTACH
* ...X .... 1 - MVT
* .... ..X. 1 - HIARCHY 1 ONLY
* .... ...X 1 - SPLIT CORE, SINI AND WSS IN LCS
*

MFT
MFT
MFT
MFT
MFT
MFT
LCS
MFT
MFT
MFT
P062
P062
P062
MFT
MFT
LCS
LCS
LCS

10720000
10800000
10880000
10960000
11040000
11680000
11840000
11920000
12000000
12080000
12160000
12240000
12400000
14320000
14400000
14480000
14560000
14640000
14720000
14800000
14880000
16480000
16560000
16640000
16720000
16800000
16880000
16960000
17120000
17200000
17280000
17360000
17440000
17520000
17600000
17680000
17760000
17840000
17920000
18000000
18080000
21120000
21200000
21280000
21360000
21440000
21520000
21600000
21680000
21760000
21840000
21920000
22000000
22080000
22160000
22240000
22320000
22400000
22480000
22560000

MFT
MVT
LCS
*
*
*
*
*
*

EQU
EQU
EQU

X'20'
X'10'
X'01'

MFT SYSTEM
MVT SYSTEM
SINI AND WSS IN LCS

MFT
MFT
LCS
MFT
SINCE MVT AND MFT ASSIGN PROTECT KEYS IN THE OPPOSITE ORD MFT
ER, WE HAVE TO DO DIFFERENT STUFF TO ASSIGN ACTKEY
MFT
MFT
WE'LL SET THE KEY WHILE WE'RE TESTING THE SYSTEM TYPES
MFT
MFT
L
3,CVTPTR
MFT
USING CVTD,3
MFT
L
4,CVTTCBP
DISPATCHERS POINTER WORDS
LCS
L
4,4(4)
CURRENT TCB ADDRESS
LCS
USING TCB,4
LCS
LA
13,0(13)
CLEAR HI BYTE FOR LATER COMPARES
MVC OSFLG,CVTDCB GET THE ONE BYTE TYPE FLAGS
MFT
CLI OSFLG,MVT
MFT
BE
MVTSYS
MFT
CLI OSFLG,MFT
MFT
BE
MFTSYS
MFT
*
MFT
*
AN ATTEMPT TO RUN APL ON AN OS SYSTEM OTHER THAN
MFT
*
MVT OR MFT-ATTACH
MFT
*
MFT
NONSS
ICALL OUTWRTL,*
TSK,TSK
MFT
DC
AL4(NPCP)
MFT
LA
15,20
UNSUPPORTED OS SYSTEM
MFT
B
OSEXIT
MFT
*
MFT
NPCP
DC
C'APL/360-OS ONLY SUPPORTS MVT AND MFT-ATTACH'
MFT
DC
X'FF'
MFT
SPACE 3
MFT
* VALIDITY CHECK AND INITIALIZE M F T
MFT
*
MFT
MFTSYS TM
CVTOPTA,X'08' SUBTASKING SUPPORT IN THIS MFT?
MFT
*
MFT
BZ
NONSS
NOPE.
MFT
*
MFT
*
WE ARE RUNNING UNDER MFT-ATTACH
MFT
MVI KEY2,X'F0'
ACTKEY FOR MFT
MFT
*
MFT
*
TEST FOR HIARCHY SUPPORT IN MFT
LCS
*
LCS
L
5,TCBOTC
ORIGINATING TCB IS TCBMERE
3058
L
5,TCBMSS-TCB(5)
BOUNDARY BOX FOR PARTITION
3058
TM
0(5),X'01'
HIERARCHY SUPPORT?
LCS
BZ
NOH1
NO
C032
CLC 1(11,5),ZERO
ANY PROCESSOR CORE
3058
BE
NOH0
SET H1 ONLY FLAG
3058
CLC 13(11,5),ZERO
ANY LCS?
3058
BE
NOH1
B IF NOT
3058
*
LCS
*
NOTE THAT ANY SINGLE HIERARCHY PARTITION IS TREATED
LCS
*
AS 'NO HIARCHY SUPPORT'
LCS
*
LCS
*
THIS IS A SPLIT PARTITION, CHECK IF SINI IS IN LCS
LCS
*
LCS
CL
13,16(5)
COMPARE SINI BASE WITH LOW
LC>
*
END OF THE H1 PARTITION
LCS
BL
NOH1
SINI MUST BE IN H0
LCS

22640000
22720000
22800000
22880000
22960000
23040000
23120000
23200000
23280000
23360000
23440000
23520000
23600000
23680000
23760000
23840000
23920000
24000000
24080000
24160000
24240000
24320000
24400000
24480000
24560000
24640000
24720000
24800000
24880000
24960000
25040000
25120000
25200000
25280000
25360000
25440000
25520000
25600000
25680000
25760000
25840000
25920000
26000000
26080000
26160000
26240000
26320000
26400000
26480000
26560000
26640000
26720000
26800000
26880000
26960000
27040000
27120000
27200000
27280000
27360000

* IF ABOVE BRANCH IS TAKEN, IT MEANS THAT ALL OF THE H1

*
PARTITION WILL BE UNUSED.
*
OI
OSFLG,LCS
SET THE SPLIT PARTITION FLAG
B
NOH1
SPACE 3
*
WE ARE RUNNING UNDER MVT
*
MVTSYS MVI KEY2,X'10'
ACTKEY FOR MVT
*
*
MAKE SURE THAT SINI WAS BLOCK LOADED.
*
L
5,0(4)
RB ADDRESS INTO R5
L
6,12(5)
ADDRESS OF CDE
L
6,20(6)
EXTEND LIST
CLC 4(4,6),=F'1' SINI MUST BE BLOCK LOADED.
BNE ABEND
OTHERWISE WE'D ABEND SOMEPLACE ELSE
*
*
TEST FOR HIARCHY SUPPORT IN MVT
*
L
6,TCBPQE
ADDRESS OF DPQE-8
CLC 9(3,6),13(6) MORE THAN ONE PQE?
BNE LOOP
SPLIT REGION
*
*
ANY SINGLE HIERARCHY REGION IS TREATED AS
*
'NO HIARCHY SUPPORT'.
*
L
6,8(6)
GET PQE ADDRESS
TM
29(6),X'01'
ALL IN LCS?
BZ
NOH1
ALL PROCESSOR CORE
NOH0
OI
OSFLG,LCS+LCS ALL IN LCS
B
NOH1
SPACE 3
LOOP
L
6,8(6)
GET NEXT PQE ADDRESS
LTR 6,6
END OF PQE CHAIN?
BZ
ABEND
SHOULD NEVER HAPPEN
L
8,24(6)
START OF REGION
L
9,20(6)
LENGTH OF REGION
AR
9,8
END ADDRESS
CR
13,8
BEFORE START OF THIS SECTION
BNH LOOP
ALSO SHOULDN'T HAPPEN
CR
13,9
AFTER END OF THIE REGION?
BH
LOOP
LOOK AT NEXT PQE
*
*
THIS IS IT
*
TM
29(6),X'01'
H1?
BZ
NOH1
IF THIS IS 0 AFTER ALL THIS,
*
IT MEANS ALL OF THE H1 CORE IS LYING FALLOW.
OI
OSFLG,LCS
SET THE SPLIT REGION FLAG.
*
DROP 3,4
NOH1
EQU *
OSFLG IS NOW INITIALIZED.
SPACE 3
LA
3,WLEN
OPLIB,NOPEN, ETC
LA
4,KMHASH
FROM POINTERS IN MOTHER LIST
STM 2,4,ACURRENT
DCBLGTH EQU 72
L
MR,=A(IM)
ST
MR,0(2)
SAVE IM ADDRESS

LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
MFT
K21
K21
K21
K21
K21
K21
K21
K21
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS
LCS

27440000
27520000
27600000
27680000
27760000
27840000
27920000
28000000
28080000
28160000
28240000
28320000
28400000
28480000
28560000
28640000
28720000
28800000
28880000
28960000
29040000
29120000
29200000
29280000
29360000
29440000
29520000
29600000
29680000
29760000
29840000
29920000
30000000
30080000
30160000
30240000
30320000
30400000
30480000
30560000
30640000
30720000
30800000
30880000
30960000
31040000
31120000
31200000
31280000
31360000
31440000
31520000
31600000
31680000
31760000
31840000
31920000
32000000
32080000
32160000

ST
LM
STM
*

2,LISTLENG(1)
2,3,ALIBPZ
2,3,CDCBXLE+4

PEACOCK CURRENTM.
PARAMETERS FOR MAX CFREDSK

THIS MUST BE ADDR OF SVOLDPS IN

1,ASVOLDPS-LIST(1) MOTHER. NOTE ASSUMPTIONS THAT
*
R1 HAS NOT BEEN MISUSED
SR
0,0
SVCC INIT
*
HALT ALL 270X LINES.
SVRAPE
BAL 5,HIOL
B
TIME
*
FOLLOWING CODE IS SIMILAR TO APLCNCL IN ASUP.
EXTRN MPXCH
5991
MPXCHANL DC
AL3(MPXCH-APLSVC)
5991
ORG *-1
5991
HIOL
LM
0,2,PTBXLE
LENGTH,LAST,FIRST
LH
3,MPXCHANL
CHANNEL ADDRESS
5991
USING PERTERM,2
HIO
CLI PTTYPE,0
IGNORE DUMMY ENTRIES.
BE
HIO2
CLI PTTYPE,Q1052
IGNORE NON-270X DEVICES.
BNL HIO2
IC
3,PTUNAD
PICK UP UNIT ADDRESS.
HIO1
MVI CSW+4,0
CLEAR DEVICE STATUS.
HIO 0(3)
TM
CSW+4,CUB2702
BO
HIO1
TRY AGAIN.
HIO2
BXLE 2,0,HIO
NEXT PERTERM.
BR
5
DROP 2
TIME
EQU *
SPACE 2
*
*
CONVERT CURRENT DATE TO APL FORM AVOIDING THE USE OF
*
PACKED DECIMAL ARITHMETIC FOR THE SAKE OF THE MODEL 91
*
THIS PIECE OF CODE IS REUSABLE SO THAT IT MAY BE USED IN
*
APLSUP AT SOME LATER DATE
*
TIME DEC
GET PACKED DATE
ST
1,DATE
AND
STH 1,DAY+6
SAVE IT
CVB 1,DAY
FORM BINARY DAY OF YEAR
LM
2,5,INDEX
INDICES FOR CALCULATING MONTH
TM
DATE+1,X'01'
CHECK FOR LEAP YEAR
BO
CMP
THIS IS AN ODD YEAR
TM
DATE+1,X'12'
FIND EVEN NON LEAP YEARS. THIS
BM
CMP
CODE IS VALID UNTIL THE YEAR 2100
CH
1,NUMTH+2(4)
A LEAP YEAR. IS THIS BEFORE FEB 29TH
BL
CMP
YES
BZ
PRT
NO, BUT IT IS FEB 29TH
BCTR 1,0
DATE AFTER 29TH FEB IS 1 DAY TOO HI
CMP
CH
1,NUMTH(4)
IS DAY IN THIS MONTH
BL
DEC
EXIT FROM SEARCH IF YES
BXLE 4,2,CMP
GO TEST NEXT MONTH IN LIST TO DEC.
DEC
SR
4,2
ADJUST MONTH
PRT
SH
1,NUMTH(4)
FORM DAY OF MONTH
AH
1,NUMTH
AR
2,4
FORM BINARY DATE
MR
4,2
(100*MONTH)+DAY
LA

32240000
32320000
32400000
32480000
32560000
32640000
32720000
32800000
32880000
32960000
33040000
33120000
33200000
33280000
33360000
33440000
33520000
33600000
33680000
33760000
33840000
33920000
34000000
34080000
34160000
34240000
34320000
34400000
34480000
34560000
34640000
34720000
34800000
34880000
34960000
35040000
35120000
35200000
35280000
35360000
35440000
35520000
35600000
35680000
35760000
35840000
35920000
36000000
36080000
36160000
36240000
36320000
36400000
36480000
36560000
36640000
36720000
36800000
36880000
36960000

INPCA

AR
CVD
OI
MVC
L
UNPK
MVC
TR
L
TR
TIME
ST
TITLE

1,5
1,DECDT
PACKED DECIMAL DATE IN FORM
DECDT+7,X'0F'
DECDT+4(1),DATE+1 YY0MMDDS
2,AZSYMDAT
CONVERT DATE TO EBCDIC
DATE(7),DECDT+4(4) WITH INTERSPERSED SLASHES
0(8,2),=AL1(3,4,7,5,6,7,0,1)
0(8,2),DATE
1,ATYI1052
0(8,2),0(1)
TRANSLATE FROM EBCDIC
TU
TOD NOW
5986
0,INITIM
FOR TIMER CHECK
'PERFORM STORAGE ALLOCATION OF BUFFERS AND WORKSPACES'

*
*
PERFORM STORAGE ALLOCATION FOR TYPEWRITER BUFFERS AND WORKSP'S
*
* INPCA0.. R4 IS R3 IS (F1LOWADDR+F1SIZE)-SLOTS*WSLENR
*
PCADDR(IOTA SLOTS) IS R3+WSLENR*IOTA SLOTS
*
FREEBC IS FLOOR (R4-A(TYBUFG) ) DIV TBL
*
GOTO (FREEBC LSS MINBUF)/INPCA2
*
SETUP FOR TYPEWRITER BUFFER CREATION
*
R0 IS TBL
*
R1 IS R4-TBL
*
* INPCA2.. GOTO (2 GEQ SLOTS IS SLOTS-1)/INPCA0
*
QUAD IS 'TOO FEW CORE SLOTS'
*
L
1,CVTPTR
GET TCB ADDRESS
USING CVTD,1
L
1,CVTTCBP
FROM CVT POINTER
DROP 1
L
1,4(1)
MVC INACTKEY,TCBPKE-TCB(1) SAVE STORAGE PROTECT KEYS
MVC ACTKEY,KEY2
MFT
NC
GETMLCSF(1),OSFLG LEAVE H1 FLAG ON ONLY IF WE'RE
*
IN A SPLIT REGION
*
GETMAIN MF=(E,GETMLIST) GET ALL AVAILABLE CORE
K13
LA
1,GETMLIST
LOAD PARAMETER REGISTER 1
K13
SVC 4
GETMAIN
K13
LTR 15,15
SEE IF
BNE OVFLOW
CORE WAS OBTAINED
LM
0,1,SPACES
GET AMOUNT OF STOARGE AND ADDRESS
AR
1,0
CALCULATE HIGH ADDRESS
LR
0,1
&SLOP
SETA (&SLOP+2047)/2048*2048
S
1,=A(&SLOP)
*
L
2,MPARM
OC
OSFLG(1),8(2)
COPY FLAG AS PASSED FROM MOTHER P062
TM
OSFLG,X'01'
SPLIT?
P062
BO
DEBUGX
YES
P062
TM
OSFLG,X'80'
DEBUG?
P062
BZ
DEBUGX
NO.
P062
S
1,=A(4*2048)
FREE 8K MORE FOR DEBUG.
P062
DEBUGX EQU *
P062
*
N
1,=F'-2048'
ROUND DOWN TO 2K BOUNDARY
SR
0,1
FREE THAT NOT REQD
ST
1,SPACES+8
*
FREEMAIN R,LV=(0),A=(1),
K13

37040000
37120000
37200000
37280000
37360000
37440000
37520000
37600000
37760000
37840000
38240000
38400000
38480000
38560000
38640000
38720000
38800000
38880000
38960000
39040000
39120000
39200000
39280000
39360000
39440000
39520000
39600000
45280000
45360000
45440000
45520000
45600000
45680000
45760000
45840000
45920000
46000000
46080000
46160000
46240000
46320000
46400000
46480000
46560000
46640000
46720000
46800000
46880000
46960000
47040000
47120000
47200000
47280000
47360000
47440000
47520000
47600000
47680000
47760000
47840000

INPCA0

*
INPCA1

*
*
INPCA2

LA
1,0(1)
LOAD PARAMETER REGISTER 1 AND CLEAR K13
SVC 10
REGISTER FORM GETMAIN
K13
SPACE 2
P062
L
3,SPACES+8
HI ADDRESS OF WORKSPACES AND BUFFERS
L
0,SLOTS
RHO PERCORE
LH
5,INPCA
L
1,AWSLENR
2048*CEIL WSLENGTH DIV 2048
SR
3,1
COMPUTE WS ORG
BCT 0,*-2
LOOP FOR ALL SLOTS
LR
4,3
R4 POINTS TO FIRST WORKSPACE
SLR 1,5
LR
5,1
ITERATE THROUGH PERCORE, SETTING PCADDR
LM
0,2,PCBXLE
USING PERCORE,2
ST
3,BUCK3-1
MVC PCADDR,BUCK3
A
3,AWSLENR
BXLE 2,0,INPCA1
DROP 2
ST
4,CURRENTM
FIRST SLOT IS THROWAWAY AREA FOR
ST
4,PTBASE
SUPINI'S QUANTUM END
ST
4,FINALMR
LR
1,4
S
1,=A(TYBUFG)
R1 IS SPACE FOR TYPEWRITER BUFFERS
BNP INPCA2
NO SPACE FOR TYBUFS
SR
0,0
D
0,=A(TBL)
ST
1,FREEBC
FREE BUFFER COUNT
C
1,KMINBUF
MINIMUM BUFFER REQUIREMENT FROM CONF
BL
INPCA2
NOT ENOUGH SPACE FOR BUFFERS
MH
1,KOVERBOK+2
MULTIPLY BY OVERBOOK FACTOR FOR
ST
1,KOVERBOK
POSOM USE IN APLSUP
SETUP R0,R1,R2,R4 FOR ITB1 USAGE
SRA 5,28
LA
0,TBL
LR
1,4
SR
1,0
FOR BXLE STOPPER
L
2,=A(TYBUFG)
ST
2,FREEBA
FOR GETBUF IN APLSUP
LA
4,ITB1-TYBUFG(2)
BASE REG FOR ITB1
STM 0,5,ITBREGS
FOR LATER RELOADING
FORMAT TYPEWRITER MESSAGE
L
0,SLOTS
DISPLAY ACTUAL PARAMETERS
CVD 0,CVDTEM
UNPK DSLOTS(2),CVDTEM+6(2)
CLI DSLOTS,C'0'
BNE *+8
MVI DSLOTS,C' '
LEADING ZERO SUPPRESSION
OI
DSLOTS+1,C'0'
L
0,FREEBC
FREE BUFFER COUNT
CVD 0,CVDTEM
UNPK DFBC(4),CVDTEM+5(3)
OI
DFBC+3,C'0'
B
COREOK
ENOUGH CORE TO RUN
TOO MANY WORKSPACES, NOT ENOUGH TYPEWRITER BUFFERS.
DECREMENT SLOTS AND TRY AGAIN.
LM
0,3,PCBXLE
BCTR 3,0
SR
1,0
BXLE STOPPER

47920000
48000000
48080000
48160000
48560000
48640000
48720000
48800000
48880000
48960000
49040000
49120000
49200000
49280000
49360000
49440000
49520000
49600000
49680000
49760000
49840000
49920000
50000000
50080000
50160000
50240000
50320000
50400000
50480000
50560000
50640000
50720000
50800000
50880000
50960000
51040000
51120000
51200000
51280000
51360000
51440000
51520000
51600000
51680000
51760000
51840000
51920000
52000000
52080000
52160000
52240000
52320000
52400000
52480000
52560000
52640000
52720000
52800000
52880000
52960000

STM 0,3,PCBXLE
53040000
BCT 3,INPCA0
BR WHILE SLOTS GE 2
C045 53200000
*
SLOTS HAS BECOME ONE, EVIL
53520000
*
INSUFFICIENT CORE STORAGE ASSIGNED.
53600000
B
OVFLOW
53680000
TITLE 'OPEN LIBRARY FILES AND CHECK TIMER'
53760000
COREOK EQU *
53840000
USING CDCPARS,7
54000000
L
7,ASWAPPAR
54080000
LH
7,LOGAD
54160000
USING IHADCB,7
54240000
LA
6,DCBLGTH
54320000
MR
6,6
54400000
A
7,AAPLSDCB
54480000
OI
DCBMACRF+8,X'20'
SET END APP FLAG ON IN SWAPDCB
54560000
STM 0,2,TEM4
54640000
*
54720000
* THE APL PSEUDO APPENDAGES MUST NOW BE IDENTIFIED TO OS
54800000
*
54880000
*
SINCE APPENDAGES ARE LOADED BY OPEN, AND LOAD RECOGNIZES
54960000
*
THE PREVIOUS EXISTENCE OF A MODULE, WE WILL LOAD THE
55040000
*
APL PSEUDO APPENDAGE, MODIFY AN INTERNAL ADDRESS CONSTANT
55120000
*
SO THEY CAN TRANSFER CONTROL TO THE REAL APL APPENDAGES.
55200000
*
55280000
*
THE ABOVE DESCRIBED MESS IS NECESSARY BECAUSE MFT DOES
55360000
*
NOT RECOGNIZE AN IDENTIFY'D ENTRY POINT WHEN PROCESSING
55440000
*
A LOAD.
55520000
*
55600000
* BEFORE DOING BLDL, MOVE IN CORRECT APPENDAGE NAMES FROM SWAPDCB
55680000
*
55760000
MVC PCI+6(2),DCBPCIA
55840000
MVC
CE+6(2),DCBCENDA
55920000
MVC
XE+6(2),DCBXENDA
56000000
*
56080000
BLDL 0,BLDLIST
SEARCH THE JOBLIB DIRECTORY FOR THE
56160000
*
APPENDAGE ENTRY POINTS. THIS IS
56240000
*
DONE SO WE CAN DIE GRACEFULLY IF
56320000
*
MODULES ARE NOT FOUND.
56400000
*
56480000
LTR 15,15
56560000
BNZ BLDLFAIL
B. IF AT LEAST 1 UNSUCCESSFUL
56640000
*
56720000
* SINCE THE BLDL WAS SUCCESSFUL,WE OUGHT TO BE ABLE TO LOAD
56800000
*
56880000
LOAD DE=PCI
56960000
ST
0,DAPAD
SAVE APP ADD
2212 57040000
LOAD DE=CE
57120000
ST
0,DAPAD+4
2212 57200000
LOAD DE=XE
57280000
ST
0,DAPAD+8
2212 57360000
*
57440000
* THE PSEUDO APPENDAGES HAVE BEEN LOADED, BUT NOT INITIALIZED
2212 57520000
*
57600000
LM
0,2,CDCBXLE
57680000
USING CDCPARS,2
57760000
FLAGON LH
7,LOGAD
57840000
LA
6,DCBLGTH
57920000
MR
6,6
58000000
A
7,AAPLSDCB
58080000
OI
DCBMACRF+8,X'20'
TURN ON END APPENDAGE FLAG
58160000

BXLE
DROP
LM
ICALL
L
USING
L
STH

2,0,FLAGON
2,7
0,2,TEM4
OPLIB
8,ADPAR
CDCPARS,8
0,TLENF
0,RDCCW+6

L
LH
LA
MR
A
ST
DROP
L
MVC
STM
MVC

0,KMHASH
7,LOGAD
6,DCBLGTH
6,6
7,AAPLSDCB
7,DCBN
8
3,ADIRTAB
CCHH,0(3)
0,3,TEM4
IOB+35(4),CCHH

USING
MVC
MVI
EXCP
WAIT
CLI
BNE
L

IHADCB,7
DCBIOBAD(4),=A(IOB)
MOVE IOB ADDR. INTO DCB
ECB,0
IOB
ECB=ECB
ECB,X'7F'
NORMAL COMPLETION ?
IOABEND
3,CDCBXLE+12
DIRECTORY BASE

OPEN ALL LIBRARY PACKS

DIRLP1
*

NUMBER OF DIRECTORIES
PERFORM ALGORITHM ON LOGAD TO FIND
STORE DCB ADDR. INTO IOB

INITIALIZE BBCCHHR IN IOB FOR STAND

ALONE SEEK

2212
2212
C037
*
C037
* DO SOME TRIVIAL VALIDITY CHECKING TO VERIFY THAT WE ARE
C037
* ACTUALLY READING APL DIRECTORIES
C037
SR
2,2
ERR CODE FOR NON-DIRECTORY
C037
CLC APLDIR(20),WFLLIB-M(3) IS THIS THE RIGHT DIRECTORY C037
BNE DIRERR
IF NOT, GIVE ERROR MESSAGE
C037
L
4,APLDIR
GET THE DIRECTORY NUMBER
C037
LA
4,1(4)
INCREMENT IT BY ONE
C037
ST
4,APLDIR
AND STORE BACK FOR NEXT PASS
C037
ST
4,APLDIR+16
WE CHECK BOTH SIDES
C037
LA
2,4
ERR CODE IF DIR FORMAT WRONG
C059
CLC VVMM-M(4,3),=C'V1M1' DIRS WRITTEN WITH V1M1 UTIL? C059
BNE DIRERR
NO. INCOMPATIBLE DIR FORMATS C059
LA
2,8
ERR CODE IF COUNTS WRONG
C059
L
4,KMHASH
NO. DIRS FROM CONFIG
C059
LA
5,1000
C059
A
5,QR13STK-M(3)
ACTUAL WS LENGTH
C059
C
4,NUMDIRS-M(3)
ACTUAL DIRS VS. CONFIG DIRS
C059
BNE DIRERR
MISMATCH. LET'S QUIT
C059
C
5,WLEN
ACTUAL WSLEN VS. CONFIG WSLEN C059
BNE DIRERR
MISMATCH. LET'S QUIT
C059
LM
0,2,CDCBXLE
C059
USING CDCPARS,2
LA
3,FREEDSK-M(3)
DIRLP3 CLC CFREDSK,0(3)
BH
DIRLP4
MVC CFREDSK,0(3)
DIRLP4 LA
3,4(3)
BXLE 2,0,DIRLP3
DROP 2
LM
0,3,TEM4

58240000
58320000
58400000
58560000
58640000
58720000
59120000
59200000
59280000
59360000
59760000
59840000
59920000
60000000
60080000
60240000
60320000
60400000
60480000
60960000
61040000
61120000
61200000
61280000
61360000
61440000
61520000
61600000
61760000
61840000
61920000
62000000
62080000
62160000
62240000
62320000
62400000
62480000
62560000
62640000
62720000
62800000
62880000
62960000
63040000
63120000
63200000
63280000
63360000
63440000
63520000
63600000
63680000
63760000
63840000
63920000
64000000
64080000
64160000
64240000

DIRLP2
*
*
*
*
*

LA
3,8(3)
BCT 0,DIRLP1
CFREDSK IS INITIALIZED

READ NEXT DIRECTORY

IF HTAB =0 THEN HISTOGRAM CSECT HAS NOT BEEN LOADED.

FOLLOWING CODE WILL KILL HISTOGRAMS BY CHANGING A BCR 0,0
AT THE BEGINNING OF HISTCOMP IN APLSUP TO A BCR 15,15
L
1,AHISTKIL
A
1,SUPLOC
TRUE LOCATION OF APLSUP DURING INIT
L
0,AHTAB
SEE IF WE WERE LINKEDITED WITHOUT
LTR 0,0
HISTOGRAM STORAGE SPACE
BNZ *+8
MVI 1(1),X'FF'
KILL HISTOGRAMS
TIME TU
TOD NOW SHOULD NOT BE SAME NOW 5986
C
0,INITIM
AS IT WAS EARLIER.
5986
BNE TIMEROK
TITLE 'ERROR CONDITIONS'
ICALL OUTWRTL,*
TIMER NOT RUNNING
K04
DC
AL4(TIM1)
K04
LA
15,12
K03
B
OSEXIT
K03
*
K03
OVFLOW ICALL OUTWRTL,*
INSUFFICIENT CORE STORAGE
K04
DC
AL4(OVFMSG)
K04
LA
15,4
K03
B
OSEXIT
K03
*
K03
WRONGV ICALL OUTWRTL,*
MISMATCH OF APL MODULES
K04
DC
AL4(WRVT)
K04
LA
15,8
K03
*
K03
* SUPINI HAS DETECTED AN UNTENABLE ENVIRONMENT.
K03
*
IT WILL TERMINATE WITH A NON-ZERO COMPLETION CODE
K03
*
K03
OSEXIT SVC EXIT
K03
SPACE 3
K03
EXIT
EQU 3
K03
*
*
THE BLDL OPERATION FAILED, WE WILL BE UNABLE TO BRING UP APL
*
BLDLFAIL STC 15,BLDLFC+1
SAVE RC
UNPK BLDLFC(3),BLDLFC+1(2)
TR
BLDLFC(2),HEXTAB
MVI BLDLFC+2,X'FF'
ICALL OUTWRTL,*
DC
AL4(BLDLF)
LA
15,16
B
OSEXIT
SPACE 3
IOABEND ABEND 1099,DUMP
QUICK AND DIRTY ERROR HANDLING 2212
DIRERRAB ABEND 1098,DUMP
BAD DIRECTORIES
2212
*
*
WE GOT CONFUSED WHEN LOOKING AT THE CORE LAYOUT.
*
ABEND
ICALL OUTWRTL,*
PRINT ERROR MESSAGE.
DC
AL4(HELP)
ABEND 1090,DUMP
*
HELP
DC
C'CORE FRAGMENTATION WITHIN APL REGION/PARTITION'
DC
X'FF'

64320000
64400000
64480000
64560000
64640000
64720000
64800000
64880000
64960000
65040000
65120000
65200000
65280000
65760000
65840000
66000000
66080000
67840000
67920000
68000000
68080000
68160000
68240000
68320000
68400000
68480000
68560000
68640000
68720000
68800000
68880000
68960000
69040000
69120000
69200000
69280000
69360000
69440000
69520000
69600000
69680000
69760000
69840000
69920000
70000000
70080000
70160000
70240000
70320000
70400000
70480000
70560000
70640000
70720000
70800000
70880000
70960000
71040000
71120000
71200000

DC
0H'0'
FOR ALIGNMENT
*
C037
* AN INVALID NUMBER OF DIRECTORIES
C037
*
C037
DIRERR ST
2,DERRTEMP
OUTWRTL CLOBBERS R2
C059
ICALL OUTWRTL,*
'INCOMPATIBLE LIB FMT'
C059
DC
AL4(DIRERRM)
C037
L
2,DERRTEMP
R2 HAS OUR ERROR CODE
C059
L
6,WLEN
WSSIZE FROM CONFIG
C059
L
3,NUMDIRS-M(3)
ACTUAL DIRS
C059
B
DIRERRAB
GO GIVE DUMP
C037
TITLE 'COMPLETE THE INITIALISATION'
TIMEROK EQU *
*
PREFORMAT SWAP AREA
*
L
8,ASWAPPAR
L
9,=A(NOPEN)
BALR 15,9
L
1,ACONFSWA
FORMAT SWAP DISK
L
15,=A(DISKFMT)
BALR 15,15
SR
0,0
ZERO GR0
SPM 0
SET PROGRAM MASK TO ZERO
TIME TU
R4:
SRDL 0,39
R4:
ST
1,REALTIME
MVC SYSPARS+1(1),OSFLG SAVE IT FOR THE DUMP
C037
*
MOVE SUPCONF FROM CONFIG TO APLSUP
L
1,ASUPPARS
A
1,SUPLOC
FOR STAND ALONE
MVC 4(ALEN,1),PTBXLE
CONFINIT PARAMETERS TO APLSUP
L
1,ACONFINI
CONFINIT IS NO LONGER NEEDED
K10
L
2,APCSUB
APL'S PROGRAM CHECK HANDLER
K10
SPIE (2),((1,15)),MF=(E,(1))
K10
*
2212
*
ESTABLISH LINK TO APPENDAGES IN ASUP
2212
*
2212
L
5,MPARM
POINTER TO TRUE APP. ADDRESSES
2212
L
1,DAPAD
FIRST DUMMY APP
2212
MVC 8(4,1),12(5)
2212
L
1,DAPAD+4
2212
MVC 8(4,1),16(5)
2212
L
1,DAPAD+8
2212
MVC 8(4,1),20(5)
2212
ICALL OUTWRTL,*
K04
DC
AL4(RMSG)
K04
L
1,MOTHER
GET THE ADDRESS OF ECBMERE
K03
POST (1)
TELL APLM THAT SINI HAS FINISHED
K03
WAIT ECB=ECBSUP
*
ENTER APLSUP VIA QUEND.
L
MR,FINALMR
LM
0,5,ITBREGS
SVCC YYQZ
TITLE 'OUTWRTL - OUTPUT MESSAGE TO SYSTEM OPERATOR 05/11/70'
*
*
THIS OUTWRTL IS A SIMPLE-MINDED VERSION OF THE OUTWRTL
*
IN URSECT OF THE APL UTILITY. THE MESSAGE IS SENT ONLY TO THE
*
SYSTEM OPERATOR WITH NO REPLY REQUIRED.
*
*
CODES X'FA' TO X'FF' ARE USED FOR END OF MESSAGE. ALL OTHER

71280000
71440000
71520000
71600000
71680000
71760000
71840000
71920000
72000000
72080000
72160000
72240000
72320000
72400000
72480000
72560000
72640000
72720000
72800000
72880000
72960000
73840000
73920000
74000000
74080000
74160000
74240000
74400000
74480000
74560000
74640000
77600000
77680000
77760000
78000000
78080000
78160000
78240000
78320000
78400000
78480000
78560000
78640000
78720000
78800000
78880000
78960000
79040000
79120000
79280000
79360000
79440000
79520000
79600000
79680000
79760000
79840000
79920000
80000000
80080000

*
*
*
*

CHARACTERS ARE TREATED AS TEXT.

R0, R1, & R2 ARE USED. RETURN IS TO 4 + R15.
CALLED BY ICALL OUTWRTL FOLLOWED BY DC AL4(TEXTADDR)

ENTRY OUTWRTL
OUTWRTL BALR 2,0
SHORTENED FORM OF PROLOG
USING *,2
MVC OUTWTEMP(4),0(15) TEXT ADDRESS MIGHT NOT BE ALIGNED
L
1,OUTWTEMP
PICK UP ADDRESS OF TEXT
MVC OUTWMSG(130),0(1) MOVE MESSAGE INTO BUFFER
OUTWRTA LR
0,1
POINT TO LAST NON-BLANK CHARACTER
OUTWRTB CLI 0(1),X'FA'
BNL OUTWRTC
WE HAVE FOUND THE END OF TEXT
CLI 0(1),X'40'
AVOID PRINTING TRAILING BLANKS
LA
1,1(0,1)
LOOK AT NEXT CHARACTER NEXT TIME
BNE OUTWRTA
B
OUTWRTB
OUTWRTC S
0,OUTWTEMP
CALCULATE EFFECTIVE LENGTH OF TEXT
AH
0,=H'12'
OS WANTS COUNT 4 GREATER THAN IT IS, K04
*
AND THERE IS AN 8 DIGIT MESSAGE HEADER.
K04
ST
15,OUTWTEMP
AND IT WANTS TO USE REG. 15
K04
STH 0,OUTWMSGG
PUT COUNT INTO MESSAGE HEADER
LA
1,OUTWMSGG
AR
1,0
ADDRESS OF END OF TEXT
K04
MVC 0(4,1),=X'00008020' MCS FLAGS FOR ROUTCDE=(1,11)
K04
LA
1,OUTWMSGG
WTO PARAMETER LIST
K04
SVC 35
WTO MACRO EXPANSION
L
15,OUTWTEMP
RESTORE REG. 15 BEFORE BRANCHING K04
B
4(0,15)
RETURN TO CALLER
DROP 2
*
OUTWMSGG DC
0F'0',AL2(*-*),XL2'8000' MSG LENGTH, MCS FLAG
K04
OUTWMSH DC
CL8'APL'
MESSAGE HEADER FOR CONSOLE MESSAGES
OUTWMSG DC
130C'*',X'FF'
MESSAGE TEXT BUFFER
OUTWTEMP DC
A(*-*)
TEMP STORAGE AREA FOR ALIGNMENT
DERRTEMP DS
F
SAVE R2 BEFORE OUTWRTL
C059
*
TITLE 'IO CONTROL BLOCKS AND OTHER CONSTANTS'
TIM1
DC
C'INTERVAL TIMER NOT STEPPING. '
K04
DC
C'PLEASE ENABLE AND SET CLOCK.',X'FF'
K04
OVFMSG DC
C'INSUFFICIENT CORE STORAGE.',X'FF'
K04
WRVT
DC
C'MISMATCH OF APL MODULES',X'FF'
K04
DIRERRM DC
C'INCOMPATIBLE APL LIBRARY FORMAT',X'FF'
C037
APLDIR DC
F'0',C'APLDIRECTORY',F'0'
C037
PRINT NOGEN
DCBD DSORG=(DA,XA)
CVTD
DSECT
CVT SYS=MVT
SPACE 2
MFT
TCB
DSECT
TCBPKE EQU TCB+28
TCBOTC EQU TCB+X'84'
3058
TCBPQE EQU TCB+X'98'
TCBMSS EQU TCB+X'18'
SUPINI CSECT
PRINT ON,GEN
* TOLIST TO TOLISTZ IS MOVED TO APLM BY APLM
TOLIST DC
A(ECBSUP)
OSFLG
DC
X'00'
OS TYPE AND LCS FLAGS
KEY2
DC
X'FF'
ACTKEY

80160000
80240000
80320000
80400000
80480000
80560000
80640000
80720000
81040000
81120000
81200000
81280000
81360000
81440000
81520000
81600000
81680000
81760000
82720000
82800000
82880000
82960000
83040000
83120000
83200000
83280000
83360000
83440000
83520000
83600000
83680000
83760000
83920000
84000000
84080000
84160000
84240000
84320000
84400000
84480000
84560000
84640000
84720000
84800000
86640000
86720000
86800000
86880000
86960000
87040000
87120000
87200000
87280000
87360000
87440000
87520000
87600000
87680000
87760000
87840000

TOLISTZ EQU *
ECBSUP DC
F'0'
LENGTH DC
A((2*20480)-22000) MINIMUM EXTRA CORE FOR 2 WS SYS
*
MINIMUM WSS IS 20480, APP SIZE OF APLSINIT IS 22000
DC
X'00FFFF00'
MAXIMUM AMOUNT
SPACES DC
3A(EMPT3)
ZERO
DC
XL11'00'
TEST FOR LCS IN MFT
SPACE 3
GETMLIST GETMAIN VC,LA=LENGTH,A=SPACES,HIARCHY=1,MF=L,SP=0
GETMLCSF EQU GETMLIST+4
HIAR BYTE
SPACE 3
GETMAIN DSECT
SPACE 3
GETMAIN VC,LA=LENGTH,A=SPACES,HIARCHY=0,MF=L
SPACE 3
GETMAIN VC,LA=LENGTH,A=SPACES,HIARCHY=1,MF=L
SPACE 3
SUPINI CSECT
SPACE 3
*
* CONSTANTS AND LISTS FOR PSEUDO IDENTIFY.
*
SPACE 3
BLDLF
DC
C'BLDL FOR PSEUDO APPENDAGES FAILED, RC='
BLDLFC DC
C'XX'
DC
X'FF'
BLDLIST DC
H'3,58'
# OF ENTRIES,LENGTH OF EACH
PCI
DC
C'IGG019$$'
PCI
DC
XL50'00'
CE
DC
C'IGG019$$'
CE
DC
XL50'00'
XE
DC
C'IGG019$$'
ABNORMAL END
DC
XL50'00'
*
SPACE 3
HEXTAB EQU *-C'0'
DC
CL16'0123456789ABCDEF'
SPACE 3
MPARM
DC
A(EMPT3)
DAPAD
DC
3A(EMPT3)
DUMMY APPENDAGE ARE
EMPT3
EQU X'800000'
IOB
DC
X'42000000'
DC
X'00'
DC
AL3(ECB)
DC
2F'0'
DC
X'00'
DC
AL3(RD1TKW)
DCBN
DS
F
DC
4F'0'
ECB
DS
F
INDEX
DC
A(2,22,2,50)
NUMTH
DC
H'1,32,60,91,121,152,182,213,244,274,305,335'
DAY
DC
D'0'
DECDT
DS
D
DATE
DS
CL7
DC
C'/'
SUPLOC DC
F'0'
CVDTEM DS
D
FINALMR DS
A
MR FOR SVC YYQZ USE
ITBREGS DS
7A
INITIAL REGS FOR ITB1

DASD
DASD
3058
C069

KHG

2212

87920000
88000000
88080000
88160000
88240000
88320000
88400000
88480000
88560000
88640000
88720000
88800000
88880000
88960000
89040000
89120000
89200000
89280000
89360000
89440000
89520000
89600000
89680000
89760000
89840000
89920000
90000000
90080000
90160000
90240000
90320000
90400000
90480000
90560000
90640000
90720000
90800000
90880000
90960000
91040000
91120000
91200000
91280000
91360000
91440000
91520000
91600000
91680000
91760000
91840000
91920000
92000000
92080000
92160000
92240000
92320000
92720000
92880000
92960000
93040000

BUCK3
CDCBXLE
ADPAR
CYLTEMP
RD1TKW
RDCCW
CCHH
INITIM
TEM4
RMSG
DSLOTS
DFBC
ALLOFF
*
*
*
*
*
LIST
ASUPPARS
ACONFINI
ATYI1052
AHISTKIL
ASWAPPAR
ACONFSWA
AHTAB
ADIRTAB
*
*
ALIBPZ
ALIBPARS
AAPLSDCB
AZSYMDAT
APCSUB
MOTHER
ASVOLDPS
ASVINT
LISTLENG
*
*
ACURRENT
AWSLEN
AMANHASH
*
*
*
*
SUPPARS
CONFINIT
TYI1052
HISTKILL

DS
X
DS
AL3
DC
A(CDCL,LIBPZ,LIBPARS,IM)
EQU CDCBXLE+8
DC
F'0'
CCW X'07',CCHH-2,X'40',6
CCW X'31',CCHH,X'40',5
CCW X'08',*-8,0,0
CCW X'06',IM,0,0
DC
F'0'
DC
F'0'
DC
X'01'
RECORD NUMBER
DC
F'0'
DC
4F'0'
DC
C'APL HAS'
DC
CL2' '
DC
C' SLOTS, '
DC
CL4'
'
DC C' BUFFERS',X'FF'
DC
X'00'
EXTERNAL ADDRESS LIST FOR SUPINI
THESE ADDRESSES ARE PASSED FROM THE MOTHER TASK

93120000
93200000
93280000
93360000
93440000
93520000
93600000
93680000
93760000
93840000
93920000
94000000
94400000
94480000
94560000
94640000
94720000
94800000
K04 94880000
94960000
95040000
95440000
95600000
95680000
95760000
DS
0A
START OF LIST
95840000
DC
A(SUPPARS)
95920000
DC
A(CONFINIT)
96000000
DC
A(TYI1052)
96080000
DC
A(HISTKILL)
96160000
DC
A(SWAPPARS)
96240000
DC
A(CONFSWAP)
96320000
DC
A(HTAB)
96400000
DC
A(DIRTAB)
96480000
96560000
96640000
ENTRY ASWAPPAR
3043 96800000
DS
A
96880000
DS
A
96960000
DS
A
97040000
DS
A
97120000
DS
A
97200000
DS
A
97280000
DS
A
97360000
DS
A
97440000
EQU *-LIST
END OF LIST
97520000
97600000
ADDRESSES FILLED IN BY SUPINI FROM SUPPARS
97680000
DS
A
97760000
DS
A
97840000
DS
A
97920000
98000000
ENTRY POINTS FOR OPLIB,NOPEN,DSKFMT ETC.
98080000
ENTRY AAPLSDCB,ALIBPARS,ALIBPZ,ADIRTAB,AWSLEN,AMANHASH
98160000
98240000
THE SYMBOLS ARE DEFINED TO ENSURE NO ASSEMBLY ERRORS UNDER OS 98320000
EQU 0
98400000
EQU 0
98480000
EQU 0
98560000
EQU 0
98640000

SWAPPARS
CONFSWAP
HTAB
DIRTAB
APLSUP
LIBPZ
LIBPARS

EQU 0
EQU 0
EQU 0
EQU 0
EQU 0
EQU 0
EQU 0
LTORG
COPY CDCPARS
END STAREX
./ ADD
NAME=APLSSLCT
SLCT
TITLE 'C O M P R E S S I O N , E X P A N S I O N 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, ZSYMBOLS
SELECT CSECT
COPY APLDEFN
COPY ZSYMBOLS
PRINT ON,NOGEN
COPY OPSECT
TITLE 'C O M P R E S S I O N , E X P A N S I O N 05/11/70'
SELECT CSECT
*
*
SELECT EQUATES.
*
SPACE
BLNKRZ EQU DBISAVE
EXPANSION FILL CHARACTER
DEXTN
EQU RSAVE
FLOATING EXTENSION
ELIDED EQU BLOWN
INDEX ELIDED INDICATOR
EXPZERO EQU LOP
INSERTING ZEROS FLAG
EXTN
EQU XTNSHN
FIXED EXTENSION
INNERDF EQU HOLDRITE
INNER LOOP DIFFERENCE
LHINDEX EQU LINDX
LEFT FETCH INDEX
LINCR
EQU BINOSAVE
LINKRES EQU SAVER
SAVE LINKREG OVER CALLS
LHONES EQU FACTSAVE
+/LEFT OPERAND
LOPRND EQU SAVEMALL
LEFT OPERAND FROM STACK
OUTERDF EQU FTEMP
OUTER LOOP INCREMENT
PRODLEFT EQU DBINSAVE
X/(DROP -1)/RHO RIGHT
PRODRITE EQU FBINSAVE
X/(OMEGA (RHO RHO RH)-I+1)/RHO RH
RESBASE EQU RESORG
RESULT DATA ORIGIN
RESINDEX EQU RESINDX
RESULT STORE INDEX
RESRHOS EQU BSIGN
(RHO RESULT) SUB INDEX
RESXRHO EQU RXRHO
X/RHO RESULT
RFROUT EQU STOP
RIGHT FETCH ROUTINE ADDRESS
RHINDEX EQU RINDX
RIGHT FETCH INDEX
RHOSUBX EQU BINSAVE
(RHO RIGHT) SUB INDEX
RINNERDF EQU RESSIGN
RESULT INNER DIFFERENCE
ROPRND EQU SAVEMALL+12
RIGHT OPERAND FROM STACK
ROUTERDF EQU REGSAV
RESULT OUTER DIFFERENCE
TRIPLET EQU SAVEMALL
EXPRESSION FROM STACK
WHICH
EQU FCHSCLR
0 - COMPRESSION, 1 - EXPANSION
EJECT
EXTRN ERROR
EXTRN FETCH
EXTRN FETCHINT
EXTRN MKGARB
EXTRN OPCXRHO
EXTRN OPSPACE

98720000
98800000
98880000
98960000
99040000
99120000
99200000
99360000
99440000
99520000
00150000
00300000
00450000
00600000
00900000
01050000
01200000
01350000
01500000
01650000
01800000
01950000
02100000
02250000
02400000
02550000
02700000
02850000
03000000
03150000
03300000
03450000
03600000
03750000
03900000
04050000
04200000
04350000
04500000
04650000
04800000
04950000
05100000
05250000
05400000
05550000
05700000
05850000
06000000
06150000
06300000
06450000
06600000
06750000
06900000
07050000
07200000
07350000
07500000

ISCOM
*
*
*

EXTRN STORE
SPACE
PROLOG OPSECT,NDOPSECT
SPACE
MVC INCR(4),=F'16'
SET INCR FOR REFETCH IN OPSPACE
L
SVIR,SVI
FIRST, FIND STACK POINTER
LA
SVIR,M(SVIR)
MAKE IT ABSOLUTE
LM
1,4,4(SVIR)
PICK UP TRIPLET
L
SVIR,SVI
GET RELATIVE SVI AGAIN
STM 1,4,TRIPLET
SAVE THE TRIPLET
MVI WHICH,0
SET INDICATOR TO COMPRESSION
CLI TRIPLET+7,1+2*ZSLASH
BE
ISCOM
DETERMINE COMPRESSION VS EXPANSION
CLI TRIPLET+7,1+2*ZCOLSLSH
BE
ISCOM
POSSIBLY COLUMN COMPRESSION
MVI WHICH,1
OTHERWISE, SET INDICATOR TO EXPANSIO
EQU *
SPACE
NOW, GET THE INDEX.

MVI ELIDED,0
LTR 3,3
BZ
ELISION
LH
2,MLSCT(3)
L
3,MLSORG(3)
BCT 2,SYNTER
SPACE
LTR 3,3
BNM LSPTR
L
3,M(3)
LSPTR
N
3,FRACMASK
BZ
VALERR
ST
3,INDBASE
LH
2,MRANK(3)
ST
2,INDRANK
LTR 2,2
BZ
GETINDEX
L
10,=A(OPCXRHO)
BALR LKR,10
ST
1,INDXRHO
C
1,COM1
BNE SYNTER
L
3,INDBASE
GETINDEX LR
4,3
SR
3,3
IC
3,MTYPE(4)
SR
2,2
A
4,INDRANK
LA
4,MRHO-M(4)
ICALL FETCHINT
S
0,IORIGIN
ELBACK ST
0,INDEX
*
*
NOW, CHECK OUT LEFT
*
SPACE
L
3,LOPRND
LTR 3,3
BNM GOTLEFT

INITIALIZE INDICATOR TO INDEX

SEE IF THERE REALLY IS ONE
BRANCH IF NOT
PICK UP COUNT OF ELEMENTS
OTHERWISE, PICK UP FIRST LIST EL
ERROR IF MORE THAN ONE ELEMENT
SEE IF IT'S TEMPORARY
BRANCH IF NOT
GET M-ENTRY POINTER
REMOVE HI-ORDER GARBAGE
MIGHT BE UNDEFINED
AND SAVE THE INDEX
PICK UP RANK
OTHERWISE SAVE IT
SEE IF IT'S ZERO
BRANCH IF SO
ENTER COMMON CXRHO SUBROUTINE
STORE THE RESULT
SEE IF THERE IS ONE ELEMENT
BRANCH IF YES
PICK UP BASE AGAIN
MOVE IT TO R4
CLEAR R3
PICK UP TYPE
SET FOR FIRST ELEMENT
ADD IN RANK
AND HEADER SPACE
AND GET THE INDEX
FOLLOW INDEX ORIGIN
AND SAVE IT
OPERAND
PICK UP STACK ENTRY
SEE IF IT IS

07650000
07800000
07950000
08100000
08250000
08400000
08550000
08700000
08850000
09000000
09150000
09300000
09450000
09600000
09750000
09900000
10050000
10200000
10350000
10500000
10650000
10800000
10950000
11100000
11400000
11550000
G01 11700000
11850000
12000000
12150000
12300000
12450000
12600000
12750000
12900000
13050000
13200000
13350000
13500000
13650000
13800000
13950000
G01 14100000
G01 14250000
14400000
14550000
14700000
14850000
15000000
15150000
15300000
15450000
15600000
15750000
15900000
16050000
16200000
16350000
16500000
16650000

L
GOTLEFT N
BZ
LA
TM
BNZ
ST
LH
ST
SR
IC
ST
SPACE
L
BALR
ST
L
C
BNH
C
BE
RANKEROR LA
ICALL
SPACE
LHRANKOK L
A
LA
L
IC
ST
SR
SR
L
SPACE
LTR
BNZ
ST
B
SPACE
PREDUCE ICALL
LA
CL
BH
AR
QUEND
BCT
ST
SPACE
GETRIGHT L
MVI
LTR
BNM
L
GOTRIGHT N
BZ
LA
TM
BNZ
NORLBT ST
LH

3,M(3)
3,FRACMASK
VALERR
4,MLIST(3)
0(4),MLSTBIT
SYNTER
3,LHBASE
2,MRANK(3)
2,LHRANK
4,4
4,MTYPE(3)
4,LHTYPE
10,=A(OPCXRHO)
LKR,10
1,LHXRHO
2,LHRANK
2,COM4
LHRANKOK
1,COM1
LHRANKOK
1,ERANK
ERROR
4,LHBASE
4,LHRANK
4,MRHO-M(4)
3,LHTYPE
3,CTOI-1(3)
3,LCFTYPE
2,2
5,5
8,LHXRHO
8,8
PREDUCE
8,LHONES
GETRIGHT
FETCH
2,1(2)
0,COM1
RANGEROR
5,0
8,PREDUCE
5,LHONES
3,ROPRND
RHSCALAR,0
3,3
GOTRIGHT
3,M(3)
3,FRACMASK
VALERR
4,MLIST(3)
0(4),MLSTBIT
SYNTER
3,RHBASE
2,MRANK(3)

OTHERWISE, GO INDIRECT
REMOVE HI-ORDER BYTE
MIGHT BE UNDEFINED
CHECK THE LISTBIT
SHOULD NOT BE ON
BRANCH IF SO
SAVE THE BASE
PICK UP THE RANK
SAVE IT

16800000
16950000
17100000
17250000
17400000
G01 17550000
17700000
17850000
18000000
18150000
PICK UP THE TYPE
18300000
AND SAVE IT
18450000
18600000
GET ENTRY TO COMMON X/RHO ROUTINE
18750000
18900000
AND SAVE THE RESULT
19050000
NOW, DO SOME CHECKING
19200000
LH SIDE MUST BE A VECTOR
19350000
LET SCALARS SNEAK THROUGH
19500000
OTHERWISE, CHECK X/RHO
19650000
BRANCH IF ONE
19800000
OTHERWISE,
19950000
RANK ERROR
20100000
20250000
CALCULATE +/LEFT OPERAND
20400000
20550000
20700000
20850000
GET FETCH CONVERSION TYPE
21000000
STORE THE TYPE
21150000
SET UP FOR FETCH
21300000
INITIALIZE SUM
21450000
LOOP COUNTER
21600000
21750000
SEE IF LH IS EMPTY
21900000
BRANCH IF NOT
22050000
OTHERWISE, SET +/LEFT TO 0
22200000
GO GET RH OPERAND
22350000
22500000
FETCH A LEFT
22650000
BUMP INDEX
22800000
CHECK AGAINST 1
22950000
BRANCH OUT IF GREATER
23100000
OTHERWISE, ADD IT IN
23250000
23400000
AND LOOP
23550000
SAVE RESULT
23700000
23850000
NOW, GET SOME RH STUFF
24000000
SET RH TO NOT SCALAR
24150000
SEE IF IT REALLY IS
24300000
24450000
OTHERWISE, GO INDIRECT
24600000
GET RID OF HI-ORDER BYTE
24750000
MIGHT BE UNDEFINED
24900000
SEE IF IT'S A LIST
25050000
IT SHOULDN'T BE
25200000
BRANCH IF SO
G01 25350000
OTHERWISE, SAVE BASE
25500000
PICK UP THE RANK
25650000

ST
2,RHRANK
AND SAVE IT
SR
4,4
IC
4,MTYPE(3)
PICK UP THE TYPE
ST
4,RCFTYPE
SAVE IT
L
10,=A(OPCXRHO)
GET EMTRY TO COMMON X/RHO ROUTINE
BALR LKR,10
AND CALL IT
ST
1,RHXRHO
SAVE RESULT
L
4,RHBASE
PICK UP RH BASE AGAIN
L
3,RHRANK
SEE IF RH IS SCALAR
CL
1,COM1
BNE CHEKINDX
BRANCH IF NOT ONE COMPONENT
MVI RHSCALAR,1
OTHERWISE, SET INDICATOR
LTR 3,3
BNZ CHEKINDX
B
SCLRIN
JUMP INTO INDEX ROUTINE
SPACE
CHEKINDX L
2,INDEX
PICK UP THE INDEX
SLA 2,2
MULTIPLY IT BY 4
BC
5,ELIDCHEK
BRANCH ON OVERFLOW OR NEGATIVE
CR
2,3
COMPARE IT TO RANK
BNL ELIDCHEK
TWAS
AR
2,4
OTHERWISE,
L
2,MRHO(2)
PICK UP APPROPIATE EL OF RANK VECTOR
ST
2,RHOSUBX
AND SAVE IT
TM
RHSCALAR,1
BZ
CONFORM
SCLRIN TM
WHICH,1
TEST OPERATOR
BZ
ITSCOMP
BRANCH IF COMPRESSION
MVC RHOSUBX(4),LHONES
MVC RESRHOS(4),LHXRHO
B
CONFORM
ITSCOMP MVC RHOSUBX(4),LHXRHO
MVC RESRHOS(4),LHONES
B
CONFORM
SPACE
*
*
END UP HERE ON ELIDED INDEX.
*
SPACE
ELISION L
0,ABLES
ABLES IS X'2AAAAAAA'
MVI ELIDED,1
B
ELBACK
SPACE
ELIDCHEK TM
ELIDED,1
SEE IF INDEX WAS ELIDED
BZ
INDEXER
BRANCH IF NOT
SR
2,2
ASSUME COLUMN OPERATION
CLI TRIPLET+7,1+2*ZBSLASH
BH
ELCH2
IT IS. TAKE FIRST COORDINATE.
LR
2,3
OTHERWISE, SET INDEX TO RHO RHO RH
S
2,COM4
ELCH2
LR
1,2
SRL 1,2
ST
1,INDEX
B
TWAS
SPACE
EJECT
*
*
CONFORMABILITY CHECK.
*
SPACE

25800000
25950000
26100000
26250000
26400000
26550000
26700000
26850000
27000000
27150000
27300000
27450000
27600000
27750000
27900000
28050000
28200000
28350000
28500000
28650000
28800000
28950000
29100000
29250000
29400000
29550000
29700000
29850000
30000000
30150000
30300000
30450000
30600000
30750000
30900000
31050000
31200000
31350000
31500000
31650000
31800000
31950000
32100000
32250000
32400000
32550000
32700000
32850000
33000000
33150000
33300000
33450000
33600000
33750000
33900000
34050000
34200000
34350000
34500000
34650000

CONFORM LA
3,1
INITIALIZE FETCH INCREMENT
ST
3,LINCR
FOR USE DURING COMPRESSION LOOPS
TM
WHICH,1
SEE IF THIS IS EXPANSION
BO
EXPCNFM
BRANCH IF SO
L
1,LHXRHO
SEE IF LEFT IS ONE-COMPONENT
LR
2,1
BCT 2,COMPCNFM
BRANCH IF NOT
SPACE
*
LH OPERAND ONE COMPONENT.
*
LEFT OPERAND SCALAR EXTENSION IN COMPRESSION ONLY
SPACE
MVI LINCR+3,0
RESET LEFT FETCH INCREMENT
L
1,RHOSUBX
PICK UP SELECTEE DIMENSION
ST
1,LHXRHO
EXTENDED LEFT LENGTH
ST
1,RESRHOS
SAVE AS RESULT DIMENSION
L
2,LHONES
GET +/LEFT OPERAND
LTR 2,2
ZERO OR ONE
BNZ XTCOMP
BRANCH IF ONE
ST
2,RESRHOS
OTHERWISE, RESULT WILL BE EMPTY
B
CALCSPAC
XTCOMP ST
1,LHONES
STORE EXTENDED +/LEFT OPERAND
B
CALCSPAC
SPACE
*
LH OPERAND IS A VECTOR.
SPACE
COMPCNFM L
2,RHOSUBX
GET SELECTEE DIMENSION
CR
1,2
COMPARE TO LEFT LENGTH
BNE LENGTHER
LENGTH ERROR IF UNEQUAL
B
CALCSPAC
OTHERWISE, GO CALCULATE SPACE
SPACE
EXPCNFM L
1,RHOSUBX
PICK UP SELECTEE DIMENSION
C
1,LHONES
COMPARE TO +/LEFT
BNE LENGTHER
LENGTH ERROR IF UNEQUAL
FILCHAR SR
1,1
FIX UP INSERT CHARACTER
ST
1,BLNKRZ
L
3,RCFTYPE
NOW, LOOK AT RH TYPE
C
3,COM4
SEE IF IT'S CHARACTER
BL
CALCSPAC
BRANCH IF NOT
LA
1,ZBLANK
CHANGE INSERT TO BLANK
STC 1,BLNKRZ
EJECT
*
*
CALCULATE, AND GET, SPACE.
*
SPACE
CALCSPAC ON
XDZ,ZERODEV
SET UP ZERO DIVIDE INTERUPT
TM
RHSCALAR,1
SEE IF RH IS SCALAR
BZ
NXTSPAC
BRANCH IF NOT
L
1,LHONES
X/RHO RESULT IS +/LEFT
TM
WHICH,1
IF WE'RE COMPRESSING
BZ
RBYVIN
BRANCH IF SO
L
1,LHXRHO
OTHERWISE, IT'S X/RHO LEFT
B
RBYVIN
SPACE
NXTSPAC L
1,RHXRHO
PICK UP X/RHO RHS
L
2,LHONES
PICK UP +/LEFT
TM
WHICH,1
SEE IF WE'RE COMPRESSING
BZ
COMSPAC
BRANCH IF SO
L
2,LHXRHO
OTHERWISE, PICK UP LEFT LENGTH
COMSPAC ST
2,RESRHOS
MULTIPLY BY THIS

34800000
34950000
35100000
35250000
35400000
35550000
35700000
35850000
36000000
36150000
36300000
36450000
36600000
36750000
36900000
37050000
37200000
37350000
37500000
37650000
37800000
37950000
38100000
38250000
38400000
38550000
38700000
38850000
39000000
39150000
39300000
39450000
39600000
39750000
39900000
40050000
40200000
40350000
40500000
40650000
40800000
40950000
41100000
41250000
41400000
41550000
41700000
41850000
42000000
42150000
42300000
42450000
42600000
42750000
42900000
43050000
43200000
43350000
43500000
43650000

MR
0,2
D
0,RHOSUBX
DIVIDE BY SELECTEE DIMENSION
B
RBYVIN
ZERODEV SR 1,1
WE GET HERE ON A ZERO DIVIDE
TM WHICH,1
SEE IF WE'RE COMPRESSING
BZ
RBYVIN
BRANCH IF SO
*
EXPANSION OF AN EMPTY ARRAY, STORE NEW RANK VECTOR ELEMENT,
*
RECOMPUTE X/RHO RHS, THEN RETURN RHS RANK ELEMENT TO ZERO
L
1,LHXRHO
OTHERWISE, PICK UP LEFT LENGTH
L
9,INDEX
FIND THE RANK ELEMENT
SLL 9,2
L
8,RHBASE
PICK ADDRESS OF RH M ENTRY
LA
8,MRHO(8)
DISPLACED TO RANK VECTOR
ST
1,0(8,9)
STORE NEW ELEMENT
L
3,RHBASE
NOW, COMPUTE NEW X/RHO
L
2,RHRANK
L
10,=A(OPCXRHO)
TAKE OFF TO XRHO ROUTINE
BALR LKR,10
SR
2,2
RETURN RANK VECTOR OF RHS TO
ST
2,0(8,9)
ORIGINAL FORM
SPACE
*
NOW HAVE X/RHO RESULT IN R1.
SPACE
RBYVIN ST
1,RESXRHO
SAVE IT
L
2,RHRANK
PICK UP THE RANK
LTR 2,2
SEE IF IT'S SCALAR
BNZ *+8
BRANCH IF NOT
LA
2,4
OTHERWISE, MAKE IT VECTOR
L
3,RCFTYPE
AND THE TYPE
L
10,=A(OPSPACE)
GET ENTRY TO COMMON GETSPACE ROUTINE
BALR LKR,10
AND CALL IT
ST
1,RESBASE
AND SAVE RESULT M-POINTER
ON
XDZ
REVERT ZERO-DIVIDE CONDITION
*
*
*
SET UP RESULT HEADING.
*
LA
1,FECHRITE
SET UP RIGHT FETCH ROUTINE
TM
RHSCALAR,1
SEE IF RIGHT EXTENDS
BZ
*+8
BRANCH IF NOT
LA
1,RHXTND
OTHERWISE, SET UP EXTENSION
ST
1,RFROUT
AND SAVE ADDRESS
SPACE
L
1,RESBASE
L
2,RHRANK
RNAK
ST
2,MTYPE(1)
IC
2,RCFTYPE+3
TYPE
STC 2,MTYPE(1)
LA
1,MRHO(1)
RANK VECTOR
L
2,RHBASE
LA
2,MRHO(2)
L
3,RHRANK
LTR 3,3
SEE IF RIGHT IS SCALAR
BZ
SCLSETUP
BRANCH IF SO
BCTR 3,0
EX
3,MOVRANK
MOVED IN
L
3,INDEX
PICK UP INDEX
L
4,RESRHOS
AND NEW DIMENSION
SLL 3,2
X 4
ST
4,0(1,3)
STORED

43800000
43950000
44100000
44250000
44400000
44550000
44700000
44850000
45000000
45150000
45300000
45450000
45600000
45750000
45900000
46050000
46200000
46350000
46500000
46650000
46800000
46950000
47100000
47250000
47400000
47550000
47700000
47850000
48000000
48150000
48300000
48450000
48600000
48750000
48900000
49050000
49200000
49350000
49500000
49650000
49800000
49950000
50100000
50250000
50400000
50700000
50850000
51000000
51150000
51300000
51450000
51600000
51750000
51900000
52050000
52200000
52350000
52500000
52650000
52800000

B
VSETUP
SPACE
SCLSETUP LA
3,4
SR
1,3
STH 3,2(1)
L
3,RESXRHO
ST
3,4(1)
LA
5,1
ST
5,PRODLEFT
B
RITEDONE
SPACE
EJECT
*
*
NOW, SET UP AND COMPUTE.
*
SPACE
VSETUP EQU *
L
8,RHBASE
LA
8,MRHO-M(8)
L
7,INDEX
SLL 7,2
AR
7,8
L
6,RHRANK
AR
6,8
LA
5,1
LEFTLOOP CR
8,7
BNL LEFTDONE
M
4,M(8)
LTR 4,4
BNZ WSFULL
LA
8,4(8)
B
LEFTLOOP
LEFTDONE ST
5,PRODLEFT
LA
8,4(8)
LA
5,1
RITELOOP CR
8,6
BNL RITEDONE
M
4,M(8)
LTR 4,4
BNZ WSFULL
LA
8,4(8)
B
RITELOOP
RITEDONE ST
5,PRODRITE
S
5,RHXRHO
ST
5,OUTERDF
L
3,RHOSUBX
BCTR 3,0
M
2,PRODRITE
LTR 2,2
BC
0,WSFULL
ST
3,INNERDF
L
3,PRODRITE
S
3,RESXRHO
ST
3,ROUTERDF
L
3,RESRHOS
BCTR 3,0
M
2,PRODRITE
ST
3,RINNERDF
L
2,PRODLEFT
LTR 2,2

DECREMENT RESULT POINTER BY 4

SET RANK OF RESULT TO VECTOR
PICK UP LENGTH
AND STORE IT IN RANK VECTOR
AND DO SOME OF THEM
AND JUMP INTO THEM

PICK UP RH POINTER
POINT AT FIRST RANK ELEMENT
PICK UP THE INDEX
X 4
+ BASE OF RANK VECTOR
PICK UP RANK
FOR STOPPING
PRODUCT
SEE IF WE'RE DONE
BRANCH IF SO
OTHERWISE, MULTIPLY
A01
A01
BUMP POINTER
AND LOOP
SKIP INDEXED ELEMENT
RE-INITIALIZE PRODUCT
SEE IF WE'RE DONE
OTHERWISE, MULTIPLY
A01
A01
BUMP POINTER
ASN LOOP
SUBTRACT RIGHT LENGTH
FROM RIGHT PRODUCT
PICK UP SELECTEE DIMENSION
SUBTRACT 1
MULTIPLY BY RIGHT PRODUCT
TEMPORARY BYPASS
RIGHT LENGTH
- RESULT LENGTH

A01
A01

52950000
53100000
53250000
53400000
53700000
53850000
54000000
54150000
54300000
54450000
54600000
54750000
54900000
55050000
55200000
55350000
55500000
55650000
55800000
55950000
56100000
56250000
56400000
56550000
56700000
56850000
57000000
57150000
57300000
57450000
57600000
57750000
57900000
58050000
58200000
58350000
58500000
58650000
58800000
58950000
59100000
59250000
59400000
59550000
59700000
59850000
60000000
60150000
60300000
60450000
60600000
60750000
60900000
61050000
61200000
61350000
61500000
61650000
61800000
61950000

BNZ
MVI
L
LTR
BNZ
MVI
L
SPACE
SR
ST
ST
ST
L
ST
L
LTR
BNZ
LA
A
LA
ST
SPACE
*
*
*

2,2
2,LHINDEX
2,RHINDEX
2,RESINDEX
2,RCFTYPE
2,RESTYPE
2,RHRANK
2,2
*+8
2,4
2,RESBASE
2,MRHO-M(2)
2,RESBASE

PICK UP INNER LENGTH

INITIALIZE FETCH INDICES

RESULT STORE TYPE

RESULT BASE

GARBAGE IS MARKED HERE.

SPACE
L
L
ICALL
L
ICALL
L
A
LA
ST
L
ICALL
L
A
LA
ST
SPACE

*
*
*

*+8
PRODLEFT+3,1
2,PRODRITE
2,2
*+8
PRODRITE+3,1
8,LHXRHO

SVIR,SVI
1,M+16(SVIR)
MKGARB
1,M+20(SVIR)
MKGARB
1,RHBASE
1,RHRANK
1,MRHO-M(1)
1,RHORG
1,M+8(SVIR)
MKGARB
1,LHBASE
1,LHRANK
1,MRHO-M(1)
1,LHORG

PICK
PICK
MARK
PICK
MARK

UP SVI AGAIN
UP INDEX
LIST GARBAGE
UP RH POINTER
GARBAGE IF TEMP

SET BASE ADDRESS

TO FIRST ELEMENT
POINT AT DATA
SAME PROCEDURE FOR LEFT ARG

POINT AT DATA

WE'RE ALL SET.

EJECT

*
*
*

COMPRESSION, EXPANSION, SOOPER LOOP

SPACE
LTR
BZ
L
LTR
BZ
L
LTR
BNZ
TM
BZ

8,8
CLEANUP
5,RESXRHO
5,5
CLEANUP
7,RHXRHO
7,7
OUTER
WHICH,1
CLEANUP

BRANCH IF SO
X / RESULT
SEE IF RESULT IS EMPTY
BRANCH IF SO
SEE IF RIGHT WAS EMPTY

62100000
62250000
62400000
62550000
62700000
62850000
63000000
63150000
63300000
63450000
63600000
63750000
63900000
64050000
64200000
64350000
64500000
64650000
64800000
64950000
65100000
65250000
65400000
65550000
65700000
65850000
66000000
66150000
66300000
66450000
66600000
66750000
66900000
67050000
67200000
67350000
67500000
67650000
67800000
67950000
68100000
68250000
68400000
68550000
68700000
68850000
69000000
69150000
69300000
69450000
69600000
69750000
69900000
70050000
70200000
70350000
70500000
70650000
70800000
70950000

*
OUTER

GOTAONE
GOTAZERO

*
SECOND
MIDDLE
*
INNER

SKIPRITE
STORIT

MIDEND

NOINCR

DNTOUCH

EXPANSION OF EMPTY ARRAY.

LA
6,1
MIDDLE LOOP COUNT
LA
8,1
OUTER LOOP COUNT
LA
7,SKIPRITE
BRANCH ADDRESS AT 'INNER'
B
SKIPRITE
ENTER INNER LOOP
SPACE
OUTER LOOP.
SPACE
LM
2,4,LHFETCH
PICK UP LEFT
ICALL FETCH
A
2,LINCR
ST
2,LHINDEX
MVI EXPZERO,0
BCT 0,GOTAZERO
BRANCH IF IT'S A ZERO
L
7,RFROUT
ADDRESS OF RIGHT FETCH
B
SECOND
BRANCH TO START OF SECOND LOOP
SPACE
TM
WHICH,1
SEE IF WE'RE COMPRESSING
BZ
SKIP
BRANCH IF SO
LA
7,SKIPRITE
ADDRESS TO SKIP FETCH
MVI EXPZERO,1
SPACE
MIDDLE LOOP.
SPACE
L
6,PRODLEFT
COUNT FOR MIDDLE LOOP
L
5,PRODRITE
COUNT FOR INNER LOOP
SPACE
INNER LOOP.
SPACE
BALR LKR,7
LA
2,1(2)
BUMP INDEX BY ONE
ST
2,RHINDEX
B
STORIT
GO AND STORE IT
SR
1,1
SET UP EXPANSION STORE
L
0,BLNKRZ
PICK UP ZERO OR BLANK
SDR 0,0
LM
2,4,RESTORE
STORE A RESULT ELEMENT
ICALL STORE
LA
2,1(2)
INCR STORE INDEX BY 1
ST
2,RESINDEX
QUEND
BCT 5,INNER
END OF INNER LOOP
SPACE
A
2,RINNERDF
ADD IN LOOP INCR
ST
2,RESINDEX
TM
EXPZERO,1
BO
NOINCR
L
2,RHINDEX
A
2,INNERDF
ST
2,RHINDEX
QUEND
BCT 6,MIDDLE
END OF MIDDLE LOOP
SPACE
TM
EXPZERO,1
BO
DNTOUCH
A
2,OUTERDF
ADD OUTER LOOP INCRS
ST
2,RHINDEX
L
2,RESINDEX
A
2,ROUTERDF
ST
2,RESINDEX

71100000
71250000
71400000
71550000
71700000
71850000
72000000
72150000
72300000
72450000
72600000
72750000
72900000
73050000
73200000
73350000
73500000
73650000
73800000
73950000
74100000
74250000
74400000
74550000
74700000
74850000
75000000
75150000
75300000
75450000
75600000
75750000
75900000
76050000
76200000
76350000
76500000
76650000
76800000
76950000
77100000
77250000
77400000
77550000
77700000
77850000
78000000
78150000
78300000
78450000
78600000
78750000
78900000
79050000
79200000
79350000
79500000
79650000
79800000
79950000

OUTEREND QUEND
BCT 8,OUTER
B
CLEANUP
SPACE
SKIP
L
2,RHINDEX
A
2,PRODRITE
ST
2,RHINDEX
B
OUTEREND
SPACE
*
*
CLEAN UP.
*
SPACE
CLEANUP EQU *
L
SVIR,SVI
L
7,M+4(SVIR)
O
7,CLASSC
LA
SVIR,16(SVIR)
ST
SVIR,SVI
LA
SVIR,4(SVIR)
ST
SVIR,MHEAD(7)
ST
7,M(SVIR)
IRETURN
EJECT
*
*
SET UP TO SPECIFY RESULT
*
SPACE
*
*
FETCH ROUTINES.
*
SPACE
SPACE
RHXTND ST
LKR,LINKRES
LM
3,4,RHFETCH+4
SR
2,2
ICALL FETCH
ST
0,EXTN
STD 0,DEXTN
LA
7,PKUPXT
ST
7,RFROUT
L
LKR,LINKRES
BR
LKR
SPACE
PKUPXT L
0,EXTN
LD
0,DEXTN
BR
LKR
SPACE
FECHRITE ST
LKR,LINKRES
LM
2,4,RHFETCH
ICALL FETCH
L
LKR,LINKRES
BR
LKR
SPACE
*
*
ERRORS.
*
SPACE
RANGEROR LA
1,ERANGE
B
ERXIT

END OF OUTER LOOP

GO CLEAN UP

PICK UP STACK POINTER

PICK UP RESULT STACK EL
PUT IN CLASS = TEMP
BUMP UP STACK POINTER
STORE IT
BUMP IT AGAIN
PUT INTO RESULT HEAD
ENTRY IN STACK

BY RHX

SAVE LINK
WANT FIRST ELEMENT

80100000
80250000
80400000
80550000
80700000
80850000
81000000
81150000
81300000
81450000
81600000
81750000
81900000
82050000
82200000
82350000
82500000
82650000
82800000
82950000
83100000
83250000
83400000
83550000
83700000
83850000
84000000
84150000
84300000
84450000
84600000
84750000
84900000
85050000
85200000
85350000
85500000
85650000
85800000
85950000
86100000
86250000
86400000
86550000
86700000
86850000
87000000
87150000
87300000
87450000
87600000
87750000
87900000
88050000
88200000
88350000
88500000
88650000
88800000
A01 88950000

SPACE 1
A01
LA
1,EMFULL
A01
ICALL ERROR
A01
SPACE
LENGTHER LA
1,ELENGTH
ICALL ERROR
SPACE
INDEXER LA
1,EINDEX
ICALL ERROR
SPACE
VALERR LA
1,EVALUE
VALUE ERROR DETECTED
ICALL ERROR
SOMEONE DELETED A LOCAL IN SUSPENDED
SPACE 1
G01
SYNTER LA
1,ESYNTAX
G01
ICALL ERROR
G01
TITLE 'CONSTANTS.'
*
*
CONSTANTS.
*
SPACE
SVIR
EQU 9
SPACE
MOVRANK MVC 0(0,1),0(2)
COM1
DC
F'1'
COM4
DC
F'4'
CLASSC DC
AL1(CONST,0,0,0)
ABLES
DC
X'2AAAAAAA'
FRACMASK DC
X'00FFFFFF'
CTOI
DC
FL1'5,2,10,11'
SPACE
LTORG
END
./ ADD
NAME=APLSSYNT
SYNT
TITLE 'A P L S Y N T A X A N A L Y S I S
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&L
PATH &GRPH,&NG
AIF (T'&L EQ 'O').NL
&L
EQU *-DIAG
.NL
ANOP
DC
AL1(&GRPH(1),&GRPH(2))
ORG *+DIIR-DIAG-2
DC
Y(&GRPH(3)-SYNST1)
ORG *+DIAG-DIIR
AIF (T'&NG EQ 'O').AUS
DC
X'FFFF'
.AUS
MEND
MACRO
&ZQ
SYLC &Q
ORG SYLCLASS+Z&ZQ*2+1
DC
AL1(&Q)
MEND
PRINT NOGEN
SYNTXX CSECT
COPY APLDEFN
COPY ZSYMBOLS
COPY PERTERM
TITLE 'SYNTAX ANALYSIS AND TRANSITION DIAGRAMS
05/11/70'
WSFULL
ERXIT

89100000
89250000
89400000
89550000
89700000
89850000
90000000
90150000
90300000
90450000
90600000
90750000
90900000
91050000
91200000
91350000
91500000
91650000
91800000
91950000
92100000
92250000
92400000
92550000
92700000
92850000
93000000
93150000
93300000
93450000
93600000
93750000
00050000
00100000
00150000
00200000
00250000
00300000
00350000
00400000
00450000
00500000
00550000
00600000
00650000
00700000
00750000
00800000
00850000
00900000
00950000
01000000
01050000
01150000
01200000
01250000
01300000
01350000
01400000

ENTRY
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
EXTRN
*
SYNTXX

NONSTMTD
DODOP
DOMOP
ERAST
ERROR
FETCHINT
GCOL
GETSPACE
GOUT
INDEX
LOUT
LOUTI
MKGARB
PLINF
SELECT
XRHO

CSECT
LA
TLR,16(LR)

*
*
*
*
PROLOG LOCALS,LEND
MVI BRVAL,X'C0'
TM
RUNCTL,RCOLBIT
BO
IRS2L
*
*
SYNST1

*
*
*
*
*
*
*
*
*
*
*
*
*
*
SYNTX

LA
ST
MVI
MVI
NI

1,STMTSTMT
1,PATH
BAKTOG,0
NEXTOG,1
RUNCTL,RCQEBIT

PRETEND THAT TYPEIN HAS NO LOCALS

SO IT AND SYNT CAN USE OVERLAPPING
AREAS. THE FIRST 4 WORDS CONTAIN
THE END OF THE LINKED REGISTER-SAVE
LIST, AND MUST NOT BE DISTURBED.
REALLY OUT-OF-RANGE BRANCH ADDR
IF ENTERED BECAUSE WE'RE EXITING
FROM A LOCKED FN, REJOIN END-OF-STMT
CODE WITH ADDRESSABILITY REESTABLISHED.
START SYNTAX ANALYZER OFF AT STMT
DIAGRAM
INDICATE NOT BRANCH STATEMENT

THIS CODE ANALYZES A STATEMENT AND EXECUTES INTERPRETATION

RULES BY COMPARING SUCCESSIVE SYMBOLS IN THE STATEMENT TO
PATHS IN TRANSITION DIAGRAMS STORED AT 'DIAG'. R3 CONTAINS
A POINTER TO THE RELEVANT PATH IN DIAG. POINTERS TO PATHS
IN OUTER DIAGRAMS ARE REMEMBERED WHILE TRAVERSING AN INNER
DIAGRAM BY BEING STACKED IN A BYTE-WIDE STACK 'DIAST', INDEXED
BY 'DIASTPTR'.
WHEN AN INTERPRETATION RULE IS EXECUTED, DIASTPTR POINTS TO
THE FIRST BYTE PAST TOP OF DIAGRAM STACK.
REENTRY AFTER EXECUTING INTERPRETATION RULE
QUEND
L
LA
CLI
BNE
L
BCTR
ST
AR
OC
NI
NI

3,PATH
1,DIAG(3)
1(1),0
SYNT07
1,DIASTPTR
1,0
1,DIASTPTR
1,MR
BAKTOG,DIAST-M(1)
BAKTOG,1
DIAST-M(1),X'FE'

, ALLOW QUANTUM END

RECALL CURRENT PATH
WHERE DOES THIS PATH LEAD -TO NEXT NODE IN DIAGRAM.
OUT OF DIAGRAM. PICK UP TOP OF DIAG
STACK AND DROP STACK POINTER.
OR SAVED AND CURRENT BAKTOGS.
MASK OUT GARBAGE.
NOW PICK UP OLD PATH, WHICH WE HAVE

01450000
01500000
01550000
01600000
01650000
01700000
01750000
01800000
01850000
01900000
01950000
02000000
02050000
02100000
02150000
02200000
02250000
02300000
02350000
02400000
02450000
02500000
02550000
02600000
02650000
02700000
02750000
02800000
02850000
02900000
02950000
03000000
03050000
03100000
03150000
03200000
03250000
03300000
03350000
03400000
03450000
03500000
03550000
03600000
03650000
03700000
03750000
03800000
03850000
03900000
03950000
04000000
04050000
04100000
04150000
04200000
04250000
04300000
04350000
04400000

IC
B
*
*
*
*
*
*
*
SYNT07

SYNT01
SYNT03
SYNT05
*
*
*
*
SYNT11

3,DIAST-M(1)
SYNT09

NEXT OBTAINS NEXT CODE SYLLABLE FROM CODESTRING (LOCATED

THROUGH STACKED ADDRESSES OF CODESTRING AND POINTER
WITHIN CODESTRING), CLASSIFIES IT AS LONG OR SHORT
(AND EST OR BST IF LONG), AND PLACES SYMBOL CLASS IN
'CLASS' AND (FOR LONG SYLLABLES) SPTR IN 'SPTR'.
CLI
BZ
MVI
L
L
LH
AR
ST
AR
MVC
LH
BCTR
TM
BO
SLA
BNM
A
ST
IC
N
BCT
LA
TRT
STC
STH
IC

NEXTOG,0
SYNT05
NEXTOG,0
6,PARREL
2,STCODE(6,MR)
4,STCPTR(6,MR)
2,4
2,IRCPTR
2,MR
SYL,MCSORG-M-2(2)
5,SYL
4,0
SYL+1,1
SYNT01
5,2
SYNT12
5,QR13STK
5,SPTR
2,0(5,MR)
2,QF127
4,SYNT03
LKR,SYLCLASS-1000
SYL+1(1),1000(LKR)
2,CLASS+1
4,STCPTR(6,MR)
3,DIAG+1(3)

*
*
*
SYNT08

HAS CURRENT SYMBOL BEEN USED YET -NO. TRY MATCHING IT TO THIS PATH.
YES. GET NEXT SYL FROM CODESTRING.
LOCATE POINTERS IN STACK
PICK UP BASE ADDRESS OF CODESTRING
AND BYTE ADDRESS WITHIN CODESTRING.
MVC NEEDS 1 BASE REGISTER
SAVE CODE POINTER -- CONST INTERP
RULE MAY WANT IT.
MOVE NEXT 2 BYTES OF CODESTRING INTO
SYL AND INTO R5
DROP CODE POINTER BY 1
IS THIS SHORT OR LONG SYLLABLE -SHORT
LONG. R5 IS DOUBLEWORD ADDRESS.
LONG SYLLABLE MUST BE NEGATIVE.
COMBINE BST POINTER AND RELATIVIZER
SAVE SYMBOL ADDRESS IN SPTR
FIRST BYTE OF SYMBOL ENTRY IS CLASS.
MAY HAVE FLAG INDICATING NOT M-PTR
SAFE BECAUSE SHORT IS ALWAYS 1ST SYL
ESTABLISH ADDRESSABILITY OF SYLCLASS
FIND CLASS FROM CLASS TABLE
SAVE CLASS FOR SYNTAX ANALYSIS.
SAVE CODE POINTER
ON TO THE NEXT PATH --

NOW WE HAVE SYMBOL CLASS IN 'CLASS' AND CURRENT PATH ADDR

IN R3. PREPARE TO EXAMINE PATH AGAINST CLASS.
LA
CLI
BL
BE

1,DIAG(3)
0(1),TERMSYM
SYNT08
SYNT09

IC
MVI
OR
L
STC
LA
ST
BCTR
C
BL
LA
B

2,BAKTOG
BAKTOG,0
2,3
1,DIASTPTR
2,DIAST(1)
1,1(1)
1,DIASTPTR
3,0
1,DIASTOP
SYNT05
1,EDEPTH
GENER

SYNTDE

SUCCESSFULLY TRAVERSED.
GO EXECUTE OLD PATH'S INTERP RULE.

IS THIS PATH A TERMINAL SYMBOL -YES. GO COMPARE CLASSES.

NO. IF PATH REPRESENTS EMPTY,
AUTOMATIC MATCH.
PUSH PATH POSITION AND BAKTOG
ONTO DIAGRAM STACK.
BUMP STACK POINTER
AND SAVE IT.
SYNT05 PICKS UP FROM PATH, NOT CLASS
HAVE WE RUN OUT OF DIAGRAM STACK -NO. ANALYZE INNER DIAGRAM.
COMMON CALL OF ERROR

THE PATH REPRESENTS A TERMINAL SYMBOL

CLC

CLASS+1(1),0(1)

DO CLASSES MATCH --

04450000
04500000
04550000
04600000
04650000
04700000
04750000
04800000
04850000
04900000
04950000
05000000
05050000
05100000
05200000
05250000
05300000
05350000
05400000
05450000
05500000
05550000
05600000
05650000
05700000
05750000
05800000
05850000
05900000
05950000
06000000
06050000
06100000
06150000
06200000
06250000
06300000
06350000
06400000
06450000
06500000
06550000
06600000
06650000
06700000
06750000
06800000
06850000
06900000
06950000
07000000
07050000
07100000
07150000
07200000
07250000
07300000
07350000
07400000
07450000

BNE
MVI
MVI
*
*
*
SYNT09

*
*
*
SYNT10

*
*
*
SYNT12
*
DIASTOP
DIASPEN
*
*
NONSTMTD
QATMPCLS
QAVARB
QAVMT
QASHADOW
QF1
QF3
QF4
QF8
QF127
QFE
QF261
QF15BITS
QF24BITS
QFBIT0
*
*
*
IRS1

SYNT10
NEXTOG,1
BAKTOG,1

NO.
YES. WE WILL TRAVERSE THIS PATH.
WE CAN'T BACK OUT OF THIS DIAGRAM

07500000
07550000
07600000
07650000
REENTRY FROM SYNTX AFTER TRAVERSING INNER DIAGRAM
07700000
07750000
ST
3,PATH
SAVE PATH ADDRESS
07800000
LA
LKR,DIIR-1000
ESTABLISH ADDRESSABILITY TO DIIR
07850000
LH
3,1000(3,LKR)
BRANCH TO INTERPRETATION RULE
07900000
B
SYNST1(3)
07950000
08000000
CLASSES DIDN'T MATCH.
08050000
08100000
LA
3,2(3)
PREPARE TO LOOK AT NEXT PATH
08150000
TM
2(1),255
FROM THIS NODE.
08200000
BC
14,SYNT11
IS THERE ANOTHER PATH -08250000
TM
BAKTOG,1
NO. HAVE WE GOBBLED ANY SYMBOLS
08300000
BO
SYNT12
WITHIN THIS DIAGRAM -08350000
YES. SYNTAX ERROR.
08400000
C
3,NONSTMTD
NO. IS THIS 'STMT' DIAGRAM -08450000
BL
SYNT12
YES. NO OUTER DIAGRAM TO RETURN TO. 08500000
L
1,DIASTPTR
POP THE DIAGRAM STACK.
08550000
BCTR 1,0
DROP POINTER
08600000
ST
1,DIASTPTR
AND SAVE IT.
08650000
IC
3,DIAST(1)
PICK UP PATH AND BAKTOG
08700000
STC 3,BAKTOG
STORE AND ISOLATE BAKTOG
08750000
NI
BAKTOG,1
08800000
N
3,QFE
THEN REMOVE BAKTOG FROM PATH.
08850000
LA
1,DIAG(3)
08900000
B
SYNT10
08950000
09000000
SYNTAX ERROR
09050000
09100000
LA
1,ESYNTAX
09150000
B
GENER
COMMON CALL OF ERROR
09200000
09250000
DC
F'498'
LIMIT FOR DIAGRAM STACK SIZE
09300000
DC
F'494'
ALMOST LIMIT FOR DIAST, BUT WITH
09350000
ENOUGH SLOP TO ALLOW EXECUTION OF
09400000
SIMPLE STATEMENTS.
09450000
DC
A(NONSTMT)
09500000
DC
AL1(CONST,0,0,0)
09550000
DC
AL1(VARB,0,0,0)
09600000
DC
AL1(VARB-CONST,0,0,0)
09650000
DC
AL1(SHADOW+X'80',0,0,0)
09700000
DC
F'1'
09750000
DC
F'3'
09800000
DC
F'4'
09850000
DC
F'8'
09900000
DC
F'127'
09950000
DC
X'000000FE'
10000000
DC
F'261'
10050000
DC
X'00007FFF'
10100000
DC
X'00FFFFFF'
10150000
DC
X'80000000'
10200000
TITLE 'I N T E R P R E T A T I O N R U L E S
05/11/70' 10250000
10300000
10350000
STMT -- EXPRESSION TRAVERSED
10400000
EQU SYNTX
10450000

*
*
IRS2
*
*
IRS4
*

IRS2E

IRS2A

IRS2B
*
*
*
*
*
*
IRS2F

*
*
IRS2C
*
*

STMT -- END-OF-STATEMENT PRECEDING EXPRESSION TRAVERSED

EQU *
STMT
EQU
L
AR

-- END-OF-STATEMENT PRECEDING RIGHT ARROW TRAVERSED

*
2,PARREL
2,MR
R2 HOLDS ABSOLUTE ADDRESS OF STACKED
FUNCTION INFORMATION
CLI SYL+1,1+2*ZEOS
A MISPLACED COLON COULD GET US HERE
BE
IRS2E
SO GENERATE A SYNTAX ERROR IF NEITHCLC STCPTR(2,2),QH3
ER EOS NOR LEOS LABEL COLON
BNE SYNT12
LEOS, LABEL MUST BE REMAINING SYLS
TM
SYL,1
SYL LEFT OF COLON MUST BE 16 BITS
BO
SYNT12
L
4,SVI
TM
STTRACE(2),STTRBIT IS THIS STATEMENT BEING TRACED -BZ
IRS2A
NO.
ICALL LOUTI
YES. FORCE OUT ANY BUFFERRED TEXT,
ICALL PLINF
PRINT FUNCTION NAME AND LINE NUMBER,
B
IRS2B
THEN PRINT VALUE OF PRINCIPAL EXPN.
TM
STFLAGS(2),STQBIT+STQPBIT DUCK OUT NOW IF THIS EXPRESSIN
BNZ IRS2D
IS INPUT VALUE FOR QUAD OR QUAD-PRIM
L
1,4(4,MR)
GET ENTRY ON TOP OF STACK
N
1,QF24BITS
IS VALUE 'UNDEFINED' -BZ
IRS2F
YES. PRINT NOTHING.
TM
STFLAGS(2),STSTBIT OR, IF EXPRESSION IS NOT A COMPLETE
BO
IRS2F
STATEMENT, PRINT JUST PRINCIPAL EXPN
L
1,4(4,MR)
LOAD WORD AT TOP OF STACK
NOW WE HAVE M-ENTRY POINTER
OF PRINTEE. PRINT THE VALUE OF THE
ICALL GOUT
M-ENTRY IN NORMAL OUTPUT FORMAT.
DO END-OF-STATEMENT PROCESSING -- FREE ANY REMAINING
TEMPS, BUMP LINE NUMBER IF STATEMENT WASN'T A BRANCH,
RESTORE CODESTRING TO FUNCTION DIRECTORY, AND
RETURN TO TYPEIN IF WE'RE IN IMMEDIATE EXECUTION.
L
3,PARREL
RESTORE ADDRESS OF FUNCTION INFO
LR
2,3
TO R2
S
3,QF4
ALSO RESTORE SVI TO POINT JUST BELOW
ST
3,SVI
FUNCTION INFO IN STACK.
L
1,0(3,MR)
PICK UP RESULT OF STATEMENT EXECUTN
LTR 1,1
BNP IRS2C
IF IT'S AN EXPRESSION,
ICALL MKGARB
IT MUST BE MARKED AS GARBAGE.
BAL
B

*
*
*
*
*
*
IRS2L
*

REENTRY FROM IRS2U TO SKIP EXECUTION OF COMMENT LINE

LKR,IREOSB
PUT CODESTRING BACK IN FUNCTION
DIRECTORY UNLESS IT'S IMM-EX.
RETURN FOR IMM-EX
IRS2G
RETURN FOR FUN-EX
EXECUTED STATEMENT WAS PART OF A DEFINED
FUNCTION. ADJUST LINE COUNTER AND POSSIBLY EXIT
FROM THIS FUNCTION.

REENTRY FROM FUNCTION CALL SETUP AT IRB5D

OI
RUNCTL,RCFNBIT
INDICATE STMT IN FUNCTION FOR IRS2FR
TM
RUNCTL,RCOUTBIT+RCQEBIT+RCTRABIT WAS THIS STMT A BRANCH
BZ
IRS2J
NO.

10500000
10550000
10600000
10650000
10700000
10750000
10800000
10850000
10900000
10950000
11000000
11050000
11100000
11150000
11200000
11250000
11300000
11350000
11400000
11450000
11500000
11550000
11600000
11650000
11700000
11750000
11800000
11850000
11900000
11950000
12000000
12050000
12100000
12150000
12200000
12250000
12300000
12350000
12400000
12450000
12500000
12550000
12600000
12650000
12700000
12750000
12800000
12850000
12900000
12950000
13000000
13050000
13100000
13150000
13200000
13250000
13300000
13350000
13400000
13450000

*
IRS2H
IRS2J

*
*
*
*
*
*
*
IRS2K
IRS2V
IRS2T

IRS2TA
*

*
*
*
IRS2S
*
IRS2M
*

*
*
*

REENTRY FROM IRS2G IMM-EX BRANCH TO RESUME FN EXECUTION

L
4,BRVAL
STATEMENT WAS A BRANCH.
L
2,PARREL
LA
3,M(2)
RESET 'COMPLETE STATEMENT' AND
MVI STFLAGS(3),0
OTHER FLAGS
STH 4,STLINE(3)
GET NEW LINE NUMBER, AND PUT IT IN
STACKED LINE COUNTER.
LTR 4,4
NOW, IS LINE COUNTER OUT OF RANGE -BNP IRS2K
YES, IT'S NEGATIVE.
SH
4,MFLINES(5)
IT'S POSITIVE. IS IT MORE THAN THE
LAST LINE OF THE FUNCTION -BM
IRS2Q
NO. LINE NO. IS IN RANGE.
LINE NUMBER OUT OF RANGE. RETURN FROM FUNCTION.
REENTRY FROM IMMEDIATE-EXECUTION CLEANUP AT IRS2G
NOW R2 = PARREL (M-RELATIVE)
R3 = PARREL (ABSOLUTE)
WE MUST RESTORE SHADOWED VARIABLES TO THE BST AND MARK
GARBAGE ALL PARAMETERS AND LOCALS EXCEPT THE RESULT.
SR
1,1
ASSUME FN RESULT NONEXISTENT
LR
6,1
SAVE ADDR OF RESULT M-ENTRY
LA
3,8(3)
ADVANCE TO NEXT SAVED SHADOW
CLI STSHADOW(3),SHADOW+X'80' HAVE WE REACHED END OF LIST
BNE IRS2M
-- YES. ALL DONE.
LM
4,5,STSHADOW(3) ,STPARAM LOAD BST POINTER AND MPTR
N
4,QF24BITS
IF NONEXISTENT PARAMETER,
AVOID THE POINTER-FLIPPING GAMES.
L
1,M(4)
ALLOW UNNAMED, NON-SHADOWING LOCALS
BNZ IRS2TA
TO RESIDE IN STACK WHERE GLOBAL
LTR 1,5
IS NORMALLY STORED. CONDITION INDIBNP IRS2T
CATED BY ZERO ADDR FIELD OF SHADOW.
ST
5,M(4)
RESTORE GLOBAL VALUE TO SYMBOL TABLE
(OR TO M(0) IF UNNAMED LOCAL)
LTR 5,5
BM
IRS2S
IF S.T. ENTRY IS M-POINTER,
IC
7,MHEAD(5)
POINT GLOBAL'S M-ENTRY AT BST
ST
4,MHEAD(5)
*** NOTE THAT IF OUTER VALUE WAS
UNDEFINED, WE ARE STORING IN WORD 0
OF THE WORKSPACE. THIS IS HARMLESS
AND PROBABLY NOT WORTH CHECKING FOR.
STC 7,MHEAD(5)
CLI STSHADOW-8(3),SHADOW+X'80' IF FIRST PARAM, NO SHADOW
BNE IRS2V
PRECEDES. SKIP GARBAGE MARKING AND
RETAIN ADDRESS OF RESULT M-ENTRY.
ICALL MKGARB
OTHERWISE ERASE LOCAL VALUE.
B
IRS2T
NI
RUNCTL,255-RCFNBIT-RCTRABIT CLEAR FLAG INDICATING
POSSIBILITY OF PROGRAMMED STOP.
LA
3,STSHADOW-8(3)
SET SVI TO ALLOW ROOM FOR FN VALUE
SR
3,MR
ST
3,SVI
PARAM NO. 1 (IN R6) IS RESULT.
LA
3,4(3)
PUT IT JUST ABOVE NEW SVI.
LTR 6,6
IS IT INDIRECT PTR (POSSIBLE ONLY
BM
IRS2P
FOR QUAD) -N
6,QF24BITS
IS IT UNDEFINED (FUNCTION HAS
NO VALUE) -BZ
IRS2P
YES.
CODE AT IRS2D MAKES IT NECESSARY THAT THIS ADJUSTMENT BE DONE
BY REPLACING MHEAD ADDRESS RATHER THAN BY INCREMENTING IT.
IC
0,MHEAD(6)
SAVE FLAG BYTE
A03

13500000
13550000
13600000
13650000
13700000
13750000
13800000
13850000
13900000
13950000
14000000
14050000
14100000
14150000
14200000
14250000
14300000
14350000
14400000
14450000
14500000
14550000
14600000
14650000
14700000
14750000
14800000
14850000
14900000
14950000
15000000
15050000
15100000
15150000
15250000
15300000
15350000
15400000
15450000
15500000
15550000
15600000
15650000
15700000
15750000
15800000
15850000
15900000
15950000
16000000
16050000
16100000
16150000
16200000
16250000
16300000
16350000
16400000
16450000
16550000

ST

3,MHEAD(6)

STC
O
ST

0,MHEAD(6)
6,QATMPCLS
6,0(3,MR)

L
ST
MVI
L
BCTR
ST
SR
IC
ST
MVI
BAL

2,STFREG(2,MR)
2,PARREL
NEXTOG,1
1,DIASTPTR
1,0
1,DIASTPTR
0,0
0,DIAST(1)
0,PATH
BAKTOG,1
LKR,IRS2FR

*
IRS2P
*

*
*
*
*
IRS2I
*
IRS2N

*
*
IRS2D

*
*
*
*
IRS2G

NO. SET M-ENTRY HEADER TO NEW

STACK LOCATION.
RESTORE FLAG BYTE
A03
MAKE RESULT A TEMP, NOT A VARB.
NOW PUT RESULT EST ENTRY IN NEW
STACK POSITION.
PARREL NOW POINTS TO OUTER FUNCTION
STACK INFO.
RE-ESTABLISH SYNTAX ANALYSIS FOR FN.
DROP DIAGRAM STACK POINTER.

AND PICK UP ADDRESS OF PATH WE WERE

WORKING ON
BAKTOG IS ON, SINCE FN WAS SCANNED.
RE-ESTABLISH CODESTRING POINTER FOR
OUTER FUNCTION.
TM
RUNCTL,RCOLBIT
IF IN THE PROCESS OF EXITING FROM
BO
SYNT12
LOCKED FNS, LET ERROR CONTINUE.
TM
RUNCTL,RCOUTBIT+RCQEBIT IF FN EXIT IS BEING FORCED,
BZ
IRS2N
(IT'S NOT)
ICALL ERAST
TREAT ALMOST LIKE ERROR IN OUTER FN
L
2,PARREL
(RESTORE AFTER ERAST)
B
IRS2C
AND THEN LEAVE OUTER FN AS WELL.
NOTE THAT BRVAL IS STILL OUT OF RANGE FROM SETTING
AT IRS5
REENTRY FROM IRS2FR IF PENDENT FUNCTION HAS BEEN ERASED
ICALL ERAST
SIMPLY RETURN FROM THE EX-FUNCTION
BAL 4,IRS2J
ILC BECOMES OUT-OF-RANGE BRANCH ADDR
LTR
BNZ
BAL
B
B
THIS
LA
ST
MVI
OI
MVI

L
N
MKG
L
LTR
BZ
TM
BO
TM
BZ
TM
BZ

6,6
SYNTX
LKR,CSTSUB
SVALER
SYNTX

IF FUNCTION RETURNED NO VALUE,

(IT DID)
MAKE SURE IT STANDS AS A COMPLETE
STATEMENT (IT DOESN'T)
RESUME EXECUTION OF OUTER FUNCTION.

STATEMENT IS INPUT VALUE FOR QUAD OR QUAD-PRIME.

1,4(4)
(TRICKY) MAKE SHADOW PTR FOR PARAM 1
1,STSHADOW+8(2)
POINT TO STACKED RESULT OF QUAD EXCN
STSHADOW+8(2),SHADOW+X'80' WHICH IRS2M WILL RELOCATE.
RUNCTL,RCTRABIT
FAKE A BRANCH TO GET US OUT OF 'DFN'
BRVAL,X'C0'
ENSURE BRANCH OUT OF RANGE IN CASE
OF QUAD-PRIME 'OUT' OPERATION
WHICH DIDN'T GO THROUGH IRS5
THIS IS IMMEDIATE-EXECUTION STATEMENT.
1,STCODE(2)
FIND BASE ADDR OF CODESTRING
1,QF24BITS
1
AND MARK IT GARBAGE.
1,STFREG(2)
IF EX STACK LIST POINTER IS ZERO
1,1
WE'RE ON THE OUTERMOST LEVEL.
IRS2Z
IGNORE POSSIBLE BRANCH AND RETURN.
RUNCTL,RCTRABIT
WAS THE STATEMENT A BRANCH -IRS2R
YES. CONTINUE EXECUTION.
RUNCTL,RCOUTBIT+RCQEBIT IF THIS IS FORCED BRANCH OUT
IRS2Z
STFLAGS(2),STQBIT AND THIS LEVEL IS QUAD 'FN',
IRS2Z

16600000
16650000
16700000
16750000
16800000
16850000
16900000
16950000
17000000
17050000
17100000
17150000
17200000
17250000
17300000
17350000
17400000
17450000
17500000
17550000
17600000
17650000
17700000
17750000
17800000
17850000
17900000
17950000
18000000
18050000
18100000
18150000
18200000
18250000
18300000
18350000
18400000
18450000
18500000
18550000
18600000
18650000
18700000
18750000
18800000
18850000
18900000
18950000
19000000
19050000
19100000
19150000
19200000
19250000
19300000
19350000
19400000
19450000
19500000
19550000

*
IRS2R

*
*
IRS2Z
*
IRS2ZA
*
*
IRS2Q

*
IRS2Y

L
LR
SR
LTR
BZ

1,STFNSPTR(2)
3,2
2,MR
1,1
IRS2K

LEAVE IT TOO
IF FUNCTION BST POINTER IS ZERO,
(ABSOLUTE PARREL)

THE USER HAS DELETED THE FUNCTION

HE WANTS US TO EXECUTE (OR 'FN' IS
A QUAD OR QUAD-PRIME.)
NI
RUNCTL,255-RCFNBIT OTHERWISE, AVOID POSSIBILITY OF
B
IRS2H
PROGRAMMED STOP AND RESUME FN EXECN.
PRINT GEN
REENTRY FROM IRB5D TO EXECUTE QUAD (QUAD-PRIME) INPUT REQUEST
NI
RUNCTL,255-RCQEBIT WE'VE ESCAPED FROM QUAD-PRIME TRAP
ATT ON=IRS2W,OFF=IRS2X,RESET=YES IF ATTENTION IS SET,
PRINT CR TO GET CARRIAGE AT LEFT MGN
TCOM RECEIVE
RECEIVE A PA OR MSG, RETEST ATTN A01
LINE
EQU
L
TM
BO
ATT
ATT
PRINT
ICALL
TYO

NUMBER IS IN RANGE OF THIS FUNCTION.

*
1,MPTBASE
THE ATTENTION MACRO CAN'T HANDLE A
IOB2-PERTERM(1),BOUNCM TEST ON BOUNCM.
IRS2Y
OFF=IRS2U,PAON=IRS2ZA,RESET=NO,MPTBASE=(1)
RESET=YES
NOGEN
LOUT
IRS2IDL

MAKE SURE CARRIAGE IS AT MARGIN

AN ATTENTION SIGNAL WOULD HAVE SUP*
PRESSED TRAILING IDLES OF PREVIOUS
*
OUTPUT LINE. PRINT SOME IDLES TO
*
HELP CARRIER GET TO LEFT MARGIN.
AR
5,MR
LOCKED FUNCTIONS REFUSE TO GIVE UP
TM
MHEAD-M(5),MFLKBIT WE MAY BE LOOKING AT BYTE 0 OF MX
LA
1,EINT
GIVE HIM 'INTERRUPT' MESSAGE
BO
GENER
ICALL PLINF
PRINT FUNCTION NAME AND
IRS2W
ICALL LOUT
LINE NUMBER.
IRS2X
IRETURN
RETURN TO TYPEWRITER.
*
IDLE CHARACTERS FOR 2741
IRS2IDL DC
AL1(0,7,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB)
*
*
EXECUTE NEXT LINE OF FUNCTION.
IRS2U
BAL LKR,IRS2FR
PUT CODESTRING ADDRESS IN STACK
NI
RUNCTL,255-RCTRABIT ERASE BRANCH-STMT BIT
AR
5,MR
CLI MCSORG-M(5),1+2*ZREM IF THIS IS A COMMENT LINE,
BE
IRS2C
IGNORE IT UTTERLY.
LH
1,MCSCNT-M(5)
SET CODE-POINTER TO RIGHTMOST
STH 1,STCPTR(2,MR)
SYLLABLE OF STATEMENT
B
SYNST1
AND EXECUTE IT.
*
*
SET UP CODESTRING BASE ADDRESS OF OUTER FUNCTION.
*
ADDRESS IS OBTAINED FROM FUNCTION DIRECTORY IN M, THEN REMOVED
*
FROM DIRECTORY AND LINKED TO CODE ADDRESS IN STACK.
*
CPTR WORD IN STACK IS NOT ALTERED.
*
IF CURRENT STATEMENT IN OUTER FUNCTION IS IMMEDIATE-EXECUTION
*
STATEMENT, RETURNS IMMEDIATELY SINCE CODESTRING IS STILL
*
ESTABLISHED.
*
ON ENTRY, R2 = EX STACK SETTING FOR OUTER FUNCTION (PARREL)
*
R0, R1, R3, R5 USED AS TEMPS

19600000
19650000
19700000
19750000
19800000
19850000
19900000
19950000
20000000
20050000
20100000
20150000
20200000
20250000
20300000
20350000
20400000
20450000
20500000
20550000
20600000
20650000
20700000
20750000
20800000
20850000
20900000
20950000
21000000
21050000
21100000
21150000
21200000
21250000
21300000
21350000
21400000
21450000
21500000
21550000
21600000
21650000
21700000
21750000
21800000
21850000
21900000
21950000
22000000
22050000
22100000
22150000
22200000
22250000
22300000
22350000
22400000
22450000
22500000
22550000

*
*
IRS2FR

ON EXIT, R2 UNCHANGED
R5 MPTR OF CODESTRING
LA
3,0(2,MR)
TM
STFLAGS(3),STIMBIT IF STATEMENT BEING EXECUTED IS
BCR 7,LKR
IMMEDIATE-EXECUTION, RETURN.
L
1,STFNSPTR(3)
GET ADDRESS OF FUNCTION BST ENTRY
LTR 1,1
TEST FOR UNUSUAL CASE OF PENDENT
BZ
IRS2I
FUNCTION ERASED FROM STACK.
L
1,M(1)
THEN MPTR OF FUNCTION DIRECTORY
LH
0,STLINE(2,MR)
LOAD LINE NUMBER
SLA 0,2
MAKE IT A WORD INDEX
AR
1,0
R1 IS RELATIVE POINTER TO LINE
AR
1,MR
NOW ABSOLUTE
TM
MFCODE-M(1),STPSBIT IS A STOP REQUESTED FOR THIS LINE -BZ
IRS2FR2
NO.
LA
5,MX-M
SNEAKY 0 FOR LOCKED FN TEST
TM
RUNCTL,RCFNBIT
YES. DID WE GET HERE VIA IMM-EX
*
BRANCH OR A FUNCTION RETURN -BNZ IRS2Y
NO. STOP EXECUTION.
IRS2FR2 L
5,MFCODE-M(1)
PICK UP MPTR OF CODESTRING
LA
3,STCODE(2)
R3 = CODESTRING ADDRESS IN FN-INFO
ST
5,M(3)
STORE CODESTRING MPTR, CODESTRING
*
CLASS, AND TRACE BIT
ST
3,MHEAD(5)
INSTEAD OF TO FUNCTION DIRECTORY
SR
3,3
CLEAR CODESTRING MPTR IN DIRECTORY
ST
3,MFCODE-M(1)
BR
LKR
RETURN
*
*
SUBROUTINE TO REPLACE STACKED CODESTRING ADDRESS IN FUNCTION
*
DIRECTORY. IF STATEMENT IS IMMEDIATE-EXECUTION, RETURNS TO
*
0(LKR) WITHOUT AFFECTING STACK. OTHERWISE REPLACES STCODE,
*
CLEARS STACK POSITION, POINTS CODESTRING M-ENTRY TO FUNCTION
*
DIRECTORY, AND RETURNS TO 4(LKR) .
*
ON ENTRY,
*
R2 = PARREL (M-RELATIVE)
*
ON EXIT,
*
R2 = PARREL (ABSOLUTE)
*
R4 = 1 + CURRENT LINE OF FUNCTION (IF NOT IMM-EXC)
*
R5 = ADDRESS OF DIRECTORY (M-RELATIVE)
*
IREOSB AR
2,MR
GET ABSOLUTE PARREL
L
1,STFNSPTR(2)
FIND ADDRESS OF FUNCTION DIRECTORY
L
5,0(1,MR)
R5 POINTS TO DIRECTORY
TM
STFLAGS(2),STIMBIT WAS THIS AN IMMEDIATE-EXECUTION
BCR 7,LKR
STATEMENT -LH
3,STLINE(2)
FIRST RESTORE CODESTRING ADDRESS TO
*
FUNCTION DIRECTORY.
LA
4,1(3)
R4 IS NO. OF NEXT SEQUENTIAL STMT
SLA 3,2
LOCATE POSITION IN DIRECTORY FROM
LA
1,MFCODE-M(5,3)
DIRECTORY ADDRESS AND LINE COUNTER.
L
3,STCODE(2)
PICK UP BASE ADDRESS OF CODESTRING
ST
3,M(1)
STORE IT IN DIRECTORY
XC
STCODE(4,2),STCODE(2) CLEAR STACK POSITION OF POINTER
ST
1,M(3)
AND STORE LINK TO DIRECTORY IN
B
4(LKR)
CODESTRING.
*
*
STMT -- RIGHT ARROW TRAVERSED
IRS3
EQU *
L
1,SVI
FIND BRANCH VALUE
L
1,M+4(1)
ON TOP OF STACK.

22600000
22650000
22700000
22750000
22800000
22850000
22900000
22950000
23050000
23150000
23200000
23250000
23300000
23350000
23400000
23450000
23500000
23550000
23600000
23650000
23700000
23750000
23800000
23900000
23950000
24000000
24050000
24100000
24150000
24200000
24250000
24300000
24350000
24400000
24450000
24500000
24550000
24600000
24650000
24700000
24750000
24800000
24900000
25000000
25050000
25100000
25150000
25200000
25250000
25300000
25350000
25400000
25550000
25600000
25650000
25700000
25750000
25800000
25850000
25900000

IRS3E

*
IRS3A

*
*
IRS3C
IRS3D
*

IRS3B
*
*
IRS5

*
*
*
IRS6

*
*
IRL1
*
*
IRL2
*

LTR 1,1
BP
IRS3E
GET M-POINTER IF IT'S AN
L
1,M(1)
DS
0H
LR
4,1
AR
1,MR
CHECK FOR LIST
TM
MLIST-M(1),MLSTBIT (ILLEGAL)
BO
SYNT12
OI
RUNCTL,RCTRABIT
INDICATE BRANCH STMT FOR IRS2 LOGIC
LH
0,MRANK-M(1)
LOOK AT RANK
C
0,QF4
BL
IRS3A
SCALAR. UNCONDITIONAL BRANCH.
BH
IRS3B
MATRIX OR HIGHER. RANK ERROR.
L
0,MRHO-M(1)
VECTOR. LOOK AT ITS LENGTH.
LTR 0,0
BZ
IRS3C
LENGTH ZERO MEANS FALL THROUGH.
BRANCH EXPRESSION IS NONEMPTY. BRANCH TO 1ST COMPONENT.
AH
4,MRANK-M(1)
LOCATE FIRST ELEMENT
LA
4,MRHO-M(4)
PUT ADDRESS IN R4
SR
2,2
INDEX (ZERO) IN R2
LR
3,2
TYPE IN R3
IC
3,MTYPE-M(1)
ICALL FETCHINT
AND GET INTEGER VALUE.
B
IRS3D
BRANCH TO EMPTY VECTOR FALLS THROUGH TO FOLLOWING STATEMENT.
L
1,PARREL
FIND LINE NUMBER IN STACKED FUNCTION
LH
1,STLINE(1,MR)
INFORMATION.
LA
0,1(1)
ADD 1 TO IT AND FAKE A BRANCH.
ST
0,BRVAL
SAVE NEW LINE NUMBER FOR END-OF-STMT
LOGIC.
L
1,PARREL
AR
1,MR
INDICATE A COMPLETE STATEMENT
OI
STFLAGS(1),STSTBIT TO BYPASS EXPRESSION DISPLAY.
B
SYNTX
LA
1,ERANK
BRANCH TO MATRIX IS A RANK ERROR
B
GENER
COMMON CALL OF ERROR
STMT
EQU
OI
SR
BAL
BAL

-- ISOLATED RIGHT ARROW TRAVERSED

*
RUNCTL,RCOUTBIT+RCTRABIT INDICATE WHOLESALE EXIT
1,1
FOR IRS2
8,PUSH
STACK MUST HOLD S O M E VALUE
0,IRS3D
GENERATE THOROUGHLY OUT-OF-RANGE
LINE NUMBER AND JOIN BRANCH CODE.

STMT
EQU
L
AR
TM
BZ
B

-- SEMICOLON ON PAREN LEVEL ZERO TRAVERSED

*
2,PARREL
2,MR
STFLAGS(2),STQBIT WAS LIST INPUTTED VIA QUAD?
SYNTX
BRANCH IF NO
SYNT12
BRANCH IF YES, SYNTAX ERROR.

LIST -- SEMICOLON AS RIGHTMOST SYMBOL TRAVERSED

EQU *
LIST -- EXPRESSION TRAVERSED
EQU SYNTX

A04
A04
A04
A04
A04
A04

25950000
26000000
26100000
26150000
26200000
26250000
26300000
26350000
26400000
26450000
26500000
26550000
26600000
26650000
26700000
26750000
26800000
26850000
26900000
26950000
27000000
27050000
27100000
27150000
27200000
27250000
27300000
27350000
27400000
27450000
27500000
27550000
27600000
27650000
27700000
27750000
27800000
27850000
27900000
27950000
28000000
28050000
28100000
28150000
28200000
28250000
28300000
28350000
28400000
28450000
28500000
28550000
28600000
28650000
28700000
28750000
28800000
28850000
28900000
28950000

*
IRL3

*
*
IRL4
*
*
IRL5
*
*
IRB1
*
*
IRB10
*
*
IRE4
*
*
IRE31
IRB2F

SVALER
GENER
*
IRB1A
*
*
IRB2
*
*
IRB16
*
*
IRE43

IRB2W

LIST
EQU
SR
BAL
B

-- 'EMPTY' PRECEDING SEMICOLON OR AS ENTIRE LIST TRAVERSD

*
1,1
PUT AN 'EMPTY' FLAG ON THE STACK
8,PUSH
SYNTX

29000000
29050000
29100000
29150000
29200000
29250000
LIST -- SEMICOLON PRECEDING EXPRESSION TRAVERSED
29300000
EQU SYNTX
29350000
29400000
LIST -- 'EMPTY' PRECEDING EXPRESSION TRAVERSED
29450000
EQU SYNTX
29500000
29550000
BASIC -- UNSUBSCRIPTED VARIABLE TRAVERSED
29600000
EQU *
29650000
29700000
BASIC -- SUBSCRIPTED VARIABLE TRAVERSED
29750000
EQU *
29800000
29850000
EXP -- DEFINED FUNCTION WITH PARAMETERS TRAVERSED
29900000
EQU *
29950000
30000000
EXP -- SUBSCRIPTED VARIABLE LEFT OF OPERATOR TRAVERSED
30050000
EQU *
30100000
TM
SYL+1,1
SHORT SYLLABLE IS QUAD OR QUAD-PRIME 30150000
BO
IRB5I
ON RIGHT. FAKE A DFN CALL.
30200000
L
1,SPTR
30250000
L
0,M(1)
PICK UP BST ENTRY
30300000
N
0,QF24BITS
IS IT DEFINED -30350000
BNZ IRB1A
YES.
30400000
EQU *
30450000
LA
1,EVALUE
NO. VALUE ERROR.
30500000
ICALL ERROR
30550000
STACK SIGN-BIT-FLAGGED POINTER
30600000
O
1,QFBIT0
TO SYMBOL TABLE (BST OR EST) ENTRY 30650000
BAL 8,PUSH
ON STACK.
30700000
B
SYNTX
30750000
30800000
BASIC -- UNSUBSCRIPTED CONSTANT TRAVERSED
30850000
EQU *
30900000
30950000
BASIC -- SUBSCRIPTED CONSTANT TRAVERSED
31000000
EQU *
31050000
31100000
EXP -- SUBSCRIPTED CONSTANT LEFT OF OPERATOR TRAVERSED
31150000
EQU *
31200000
TM
SYL+1,1
LONG SYLLABLE IS A LOCAL LABEL
31250000
BZ
IRB2F
OR OTHER RELATIVE CONSTANT
31300000
SR
2,2
31350000
TRT SYL+1(1),IRB2TB
GET CONSTANT TYPE FROM SYLLABLE
31400000
LA
1,ERANGE
DOMAIN ERROR IF THIS IS AN ERROR
31450000
BZ
GENER
CONSTANT. (FOR FNS BEFORE APRIL 69) 31500000
ST
2,FTEMP1
SAVE TYPE FOR INSERTION IN M-ENTRY 31550000
L
1,IRCPTR
RECALL M-RELATIVE CODE POINTER
31600000
AR
1,MR
MOVE 16-BIT CONSTANT COUNT FROM
31650000
MVC HTEMP(2),MCSORG-M-3(1) CODESTRING TO HTEMP
31700000
LH
1,HTEMP
31750000
LR
4,1
CONSTANT COUNT NOW IN R1 AND R4
31800000
IC
2,IRB2S-1(2)
PICK UP APPROPRIATE SHIFT FOR THIS 31850000
SLL 1,0(2)
TYPE.
31900000
LA
1,7(1)
FOR BOOLEAN TYPE, ROUND BITS UP TO 31950000

QH3

*
IRB2A

IRB2C

IRB2E

IRB2D
IRB2S
IRB2TB
IRB2M
*
*
IRB3
*
*
IRB4
*
*
IRB11
*
*
IRE6
*
*
IRE12
*

SRL
EQU
ST
LA
BCT
S

1,3
*-2
1,FTEMP2
1,MRHO-M+4(1)
4,IRB2A
1,QF4

NEXT BYTE, THEN DISCARD BIT COUNT.

32000000
32050000
FINALLY SAVE COUNT FOR MVC OPERATION 32100000
COMPUTE STORAGE REQUIREMENT FOR
32150000
M-ENTRY HEADER, INCLUDING 4 BYTES
32200000
FOR DIMENSION IF CONSTANT COUNT
32250000
ISN'T 1.
32300000
SR
2,2
TELL GETSPACE TO PUT EST ENTRY
32350000
ICALL GETSPACE
ON STACK .
32400000
LA
5,MRHO(1)
32450000
LH
3,HTEMP
SET UP RANK VECTOR
32500000
SR
4,4
RANK 0 IF CONSTANT COUNT IS 1
32550000
C
3,QF1
IS IT -32600000
BE
IRB2C
YES.
32650000
LA
4,4
NO. RANK IS 1
32700000
AR
5,4
BUMP DATA ADDRESS
32750000
ST
3,MRHO(1)
STORE RANK VECTOR.
32800000
ST
4,MRANK-2(1)
STORE RANK (CLEARING TYPE ETC)
32900000
L
0,FTEMP1
INSERT CONSTANT TYPE INTO HEADER
32950000
STC 0,MTYPE(1)
33000000
L
2,PARREL
RECALL CODESTRING POINTER
33050000
LH
3,STCPTR(2,MR)
FROM STACK.
33100000
BCTR 3,0
33150000
BCTR 3,0
DECREASE IT BY 2 BYTES OF COUNT SYL 33200000
L
4,FTEMP2
AND BY BYTE COUNT OF CONSTANT.
33250000
SR
3,4
33300000
STH 3,STCPTR(2,MR)
RETURN IT TO STACK.
33350000
A
3,STCODE(2,MR)
ADD IN BASE ADDRESS OF CODESTRING
33400000
AR
3,MR
AND WORKSPACE ADDRESS
33500000
S
4,QF1
DROP BYTE COUNT FOR MVC
33550000
BM
SYNTX
NO MOVE FOR '' CONSTANT
33600000
LA
1,256
SET UP FOR MOVE LOOP.
33650000
SR
4,1
IS BYTE COUNT GTR 256 -33700000
BM
IRB2D
NO. DO A SHORT MOVE.
33750000
MVC 0(256,5),MCSORG-M(3) YES. MOVE 256 BYTES FROM CODESTRING 33800000
AR
5,1
TO M-ENTRY DATA AREA, THEN UPDATE
33850000
AR
3,1
SOURCE AND SINK ADDRESSES BY 256.
33900000
B
IRB2E
BACK FOR NEXT MOVE.
33950000
EX
4,IRB2M
SHORT MOVE. EXECUTE MVC.
34000000
B
SYNTX
BACK TO SYNTAX ANALYSIS
34050000
DC
FL1'0,5,6,3'
TABLE OF LEFT SHIFTS ON TYPE
34100000
EQU *-(ZECONST*2+1)
34150000
DC
FL1'0,0,1,0,2,0,3,0,4' TYPE-FROM-SYL TABLE
34200000
MVC 0(0,5),MCSORG-M(3) EXECUTED MOVE INSTRUCTION
34250000
34300000
BASIC -- UNSUBSCRIPTED RIGHT PARENTHESIS TRAVERSED
34350000
EQU *
34400000
34450000
BASIC -- RIGHT BRACKET TRAVERSED
34500000
EQU *
34550000
34600000
BASIC -- SUBSCRIPTED RIGHT PARENTHESIS TRAVERSED
34650000
EQU *
34700000
34750000
EXP -- RIGHT BRACKET OF OPERATOR SUBSCRIPT TRAVERSED
34800000
EQU *
34850000
34900000
EXP -- RIGHT BRACKET TRAVERSED
34950000
EQU *
35000000
35050000

*
IRE19
*
*
*
IRE32

*
*
IRE13A
*
*

*
*
*
*
IRE8A

*
IRB5Q

*
*
IRB5I

IRB5F
IRB5J
*
*
IRB5SC

*
*

EXP -- RIGHT BRACKET OF LHS TRAVERSED

EQU *

35100000
35150000
35200000
EXP -- RIGHT PARENTHESIS OF SUBSCRIPTED EXPRESSION LEFT OF
35250000
OPERATOR TRAVERSED
35300000
EQU *
35350000
LA
1,1
PUT A ONE ON STACK TO MARK END OF
35400000
BAL 8,PUSH
LIST IN CASE THIS IS PARENTHESIZED 35450000
B
SYNTX
LIST.
35500000
EJECT
35550000
35600000
MONADIC DEFINED FUNCTION TO BE EXECUTED
35650000
EQU *
35700000
ON ENTRY, R1 = FUNCTION SPTR
35750000
R5 = SVI
35800000
LA
2,1
SET R2 = MONADIC DFN
35850000
SR
8,8
INITIALIZE ARGUMENT SPACE
35900000
B
IRB5Q
35950000
36000000
DYADIC DEFINED FUNCTION TO BE EXECUTED
36050000
ON ENTRY, R1 = FUNCTION SPTR
36100000
R5 = SVI
36150000
EQU *
36200000
LA
2,2
SET R2 = DYADIC DFN
36250000
SR
8,8
INITIALIZE ARGUMENT SPACE
36300000
BAL LKR,IRB5SC
ADD IN SPACE FOR LEFT ARG
36350000
LA
5,4(5)
ADVANCE TOWARD RIGHT ARG
36400000
COMMON POINT FOR MONADIC AND DYADIC DFNS
36450000
LA
5,4(5)
R5 = RARG ADDR - 4
36500000
BAL LKR,IRB5SC
ADD IN SPACE FOR RIGHT ARG
36550000
ST
1,SPTR
SAVE FUNCTION S.T. POINTER
36600000
L
6,M(1)
PICK UP FUNCTION DIRECTORY ADDRESS 36700000
LA
0,X'F'
EXTRACT NUMBER OF PARAMS
36800000
N
0,MFLCLS(6)
36900000
CR
2,0
DOES NO. OF ARGS MATCH NO. OF
36950000
LA
2,1(2)
37000000
BE
IRB5C
PARAMS -37050000
B
SYNT12
NO. SYNTAX ERROR.
37100000
37150000
QUAD OR QUAD-PRIME ON RIGHT TRAVERSED
37200000
SR
8,8
INITIALIZE ARGUMENT SPACE
37250000
LA
2,(STIMBIT+STQBIT+STQPBIT)*256
37300000
CLI SYL+1,ZQUAD*2+1
WHICH IS IT -37350000
BNE IRB5J
QUAD-PRIME
37400000
LA
2,(STIMBIT+STQBIT)*256 QUAD
37450000
B
IRB5J
37500000
LA
2,0(6)
S.T. IS IMM DATA FOR KEYWORD 'DFN' 37550000
SR
6,6
37650000
ST
6,SPTR
CLEAR SPTR TO AVOID LATER CONFUSION 37700000
WITH GENUINE DFN
37750000
B
IRB5C
37800000
37850000
L
3,M+4(5)
ADD SPACE NEEDED FOR ARGUMENT TO R8 37900000
LTR 3,3
ON ENTRY, R5 = ARG STACK ADDR - 4
37950000
BCR 11,LKR
NO EXTRA SPACE NEEDED IF ARG IS EXPN 38000000
L
3,M(3)
FOR VARB, GO INDIRECT THROUGH S.T. 38050000
A
8,MCOUNT(3)
ADD IN SPACE CURRENTLY USED
38150000
BR
LKR
38200000
38250000
BASIC -- DFN0 TRAVERSED
38300000

IRB5
*
*
IRB12
*
*
IRE35

IRB5C

IRB5H

IRB5G
*

IRB5A
IRB5B

*
*

EQU

BASIC -- SUBSCRIPTED DFN0 TRAVERSED

EQU *
EXP -- SUBSCRIPTED DFN0 LEFT OF OPERATOR TRAVERSED
EQU *
SR
8,8
NO SPACE NEEDED FOR ARGUMENTS
L
6,SPTR
PICK UP POINTER TO FN BST ENTRY
L
6,M(6)
THEN POINTER TO FUNCTION DIRECTORY
SR
2,2
SET R2 = DFN0
CLI NEXTOG,0
IF WE HAVE ADVANCED PAST LEFT ARG
BNE IRB5H
(OR FUNCTION NAME, IF NO LEFT ARG),
L
3,PARREL
CODESTRING POINTER MUST BE BACKED
LH
1,STCPTR(3,MR)
OFF BY ONE SYLLABLE.
TM
SYL+1,1
BO
*+8
LA
1,1(1)
LONG SYLLABLE
LA
1,1(1)
SHORT SYLLABLE
STH 1,STCPTR(3,MR)
LTR 1,6
IMITATION DFNS AVOID FOLLOWING
BZ
IRB5G
DIRECTORY REFERENCES
LH
4,MFPARS(6)
FETCH NO. OF LABELS AND PARAMS
N
4,QF15BITS
THIS IS A LOAD LOGICAL HALFWORD
SRL 4,4
REMOVE PARAMETER-COUNT FIELD
LH
1,MFLCLS(6)
NUMBER OF NON-LABEL LOCALS
LR
6,4
NEEDED LATER FOR LABEL DEFINITION
MH
4,MSKEL+2
SPACE REQUIRED FOR LABEL M-ENTRIES
AR
1,6
NON-LABEL LOCALS PLUS LOCAL LABELS
NUMBER OF STACK BYTES NEEDED FOR
N
1,QF15BITS
FUNCTION CALL IS LOCALS X 8
AR
1,1
SR
1,2
LESS SPACE ALREADY STACKED
SLA 1,2
LA
3,STSHADOW+32(1)
PLUS FIXED AMOUNT OF FUNCTION-CALL
ST
2,FTEMP3
INFO (INCLUDING SPACE FOR PARAMS
0 THROUGH 3)
LA
0,80(3,4)
COMBINE STACK AND M SPACE, ADD SLOP,
AR
0,8
ADD SPACE NEEDED FOR ARG M-ENTRIES,
BAL 8,GNOSP2
AND CHECK FOR MX, PARREL OVERLAP.
L
1,SVI
SAVE OLD VALUE OF SVI
LR
5,1
SR
1,3
GET NEW VALUE OF SVI AS OLD VALUE
ST
1,SVI
LESS SPACE FOR FUNCTION CALL.
LA
4,4
A USEFUL CONSTANT
SR
0,0
CLEAR STACK BETWEEN NEW AND OLD SVI.
AR
1,4
LR
2,1
LA
3,STSHADOW/4+2
FIXED AREA IS SET TO ZEROES
ST
0,M(1)
BCT 3,IRB5B
L
0,QAVARB
WHILE PARAMS/LOCALS ARE SET TO VARBS
BXLE 1,4,IRB5A
L
3,PATH
SAVE LOCATION IN TRANSITION DIAGRAMS
L
7,DIASTPTR
BY STACKING PATH ON DIAGRAM STACK.
STC 3,DIAST(7)
C
7,DIASPEN
IF WE'VE ALMOST OVERFLOWN DIAST,
BNL SYNTDE
SIGNAL A DEPTH ERROR.
NOTE WELL -- THIS TEST FOR DEPTH ERROR IS PLACED SO THAT
THE STACK IS CLEAN, PARREL HAS NOT BEEN CHANGED YET,

38350000
38400000
38450000
38500000
38550000
38600000
38650000
38700000
38750000
38800000
38900000
38950000
39000000
39050000
39100000
39150000
39200000
39250000
39300000
39350000
39400000
39450000
39500000
39550000
39600000
39650000
39700000
39750000
39800000
39850000
39900000
39950000
40000000
40050000
40100000
40150000
40200000
40250000
40300000
40350000
40400000
40450000
40500000
40550000
40600000
40650000
40700000
40750000
40800000
40850000
40900000
40950000
41000000
41050000
41100000
41150000
41200000
41250000
41300000
41350000

*
*
*
*
*
*
*
*

*
*
*
*
*
*
*
*
*
*
*
IRB5E

IRB5D
*
*
*

*
*
*
*
*

IRBL3

IRBL1

AND THE DIAGRAM STACK HAS NOT BEEN PUSHED (THAT IS, AN
ERROR RECOVERY NOW WILL IGNORE WHAT WE JUST STORED.)
ERROR RECOVERY IS IMPOSSIBLE UNLESS THESE CONDITIONS
ARE SATISFIED.
STACK SPACE HAS BEEN RESERVED AND CLEARED. LOAD IT WITH
FUNCTION-CALL INFORMATION.
CLI FTEMP3+3,2
HOW MANY ARGUMENTS DO WE HAVE -BL
IRB5D
NONE.
LA
3,STPARAM+16(2)
NOW RELOCATE ARGUMENTS AND REPLACE VARIABLES FOR ARGUMENTS BY EXPRESSIONS FOR ARGUMENTS.
R0 = CANONICAL UNDEFINED VARIABLE
R1 = OLD SVI + 4
R2 = NEW SVI + 4 ( = NEW PARREL)
R3 = NEW ADDR OF LEFT ARGUMENT
R4 = 4
R6 = NUMBER OF LABELLED LINES
FTEMP3 IS USED TO HOLD QUAD-ON-RIGHT FLAGS AND
ARGUMENT COUNT.
BE
IRB5E
ONE ARGUMENT.
BAL 7,IRB5S
FIX LEFT ARGUMENT.
ST
0,M(1)
CLEAR SPOT OCCUPIED BY FN SPTR
AR
1,4
BUMP SOURCE AND SINK TO HANDLE
LA
3,8(3)
RIGHT ARGUMENT.
BAL 7,IRB5S
SR
1,4
NOW PLACE BST ENTRIES FOR SHADOWED
GLOBAL NAMES INTO THE STSHADOWSTPARAM AREA, AND PUT LOCALS IN BST.
SR
1,4
DFN0 DID NOT HAVE FN SPTR STACKED,
SO DROP R1 AN EXTRA WORD.
STM 1,2,FTEMPN
PUT CODESTRING OF CURRENT LINE BACK
L
2,PARREL
INTO DIRECTORY OF OUTER FUNCTION
BAL LKR,IREOSB
NOP 0
MUST BE DONE NOW SINCE FN NAME IS
L
1,FTEMPN
NOT ACCESSIBLE IF SAME AS A PARAM
LA
7,IRB5QH+10-(MCSORG-M)
L
8,SPTR
N
8,QF24BITS
CIRCUMVENT THIS MACHINERY FOR QUAD
BZ
IRB5X
AND OTHERS WHICH HAVE NO HEADER
L
7,M(8)
OTHERWISE LOCATE FN DIRECTORY
PREPARE TO PUT ALL STATEMENT LABELS INTO THE STACK AS LOCALS.
WE FIND ALL CODESTRINGS FLAGGED WITH A ZLEOS SYL, RUN THE
FOLLOWING (LONG) SYLLABLE THROUGH THE NORMAL SHADOWING MECHANISM, AND ADDITIONALLY CREATE AN M-ENTRY FOR THE LOCAL HOLDING
THE LINE NUMBER AS AN INTEGER.
LTR 6,6
SKIP ALL THIS LABEL STUFF IF
BZ
IRB5N
NO LABELS
LH
2,MFLINES(7)
POINT R2 TO THE DIRECTORY ENTRY
BCTR 2,0
LR
10,2
SLA 2,2
OF THE LAST LINE
AR
2,7
L
7,MFCODE(2)
ADDR OF CODESTRING FOR THIS LINE
LA
7,M+3(7)
ABSOLUTE AND CLEVERLY OFFSET
CLI MCSORG-M-3(7),1+2*ZLEOS WE DEPEND ON TYPEIN TO USE LEOS
BE
IRBL2
ONLY IF A VALID LABEL EXISTS
S
2,QF4
DROP TO NEXT LOWER LINE NUMBER

41400000
41450000
41500000
41550000
41600000
41650000
41700000
41750000
41800000
41850000
41900000
41950000
42000000
42050000
42100000
42150000
42200000
42250000
42300000
42350000
42400000
42450000
42500000
42550000
42600000
42650000
42700000
42750000
42800000
42850000
42900000
42950000
43000000
43050000
43100000
43150000
43200000
43250000
43300000
43350000
43400000
43450000
43500000
43600000
43650000
43700000
43750000
43800000
43850000
43900000
43950000
44000000
44050000
44100000
44150000
44200000
44250000
44300000
44350000
44400000

MSKEL
IRBL2

BCT
DC
L
LA
MVC
ST
O
ST
LA
ST
BAL
BCT

*
L
*
IRB5N
IRB5X
*
*
*
*
*
*
*
*
*
*
*
*
*
*
IRB5Y

*
IRB5M
IRB5W

IRB5Z

L
AR
AH
LA

MVC
LH
SLA
BZ
A
LA
CR
BNE
LR
L
L
ST
ST
LTR
BNP
IC
ST
STC
DS
ST
O
ST
S
BR
S
CLI

10,IRBL3
ALWAYS BRANCHES
AL4(MRHO+4-M),FL1'2,0',H'0'
5,MX
WE KNOW SPACE EXISTS
4,M(5)
CREATE A SCALAR INTEGER M-ENTRY
MCOUNT-M(MRHO-MCOUNT,4),MSKEL COUNT, TYPE, RANK
10,MRHO(5)
LINE NUMBER IS VALUE
5,QATMPCLS
NOTE THAT LABELS ARE LOCAL CONSTANTS
5,STPARAM-STSHADOW(1,MR) LET IRB5Y POINT M-ENTRY AT STK
5,MRHO+4-M(5)
ADVANCE MX OVER NEW M-ENTRY
5,MX
LKR,IRB5Y
NOW TAKE CARE OF THE SHADOWING
6,IRBL1
DUCK OUT AS SOON AS ALL LABELS ARE
PROCESSED
7,M(8)
RECALL FN DIRECTORY (NOTE R8 MAY
NOW POINT INTO THE STACK BY MAGIC)
7,MFCODE(7)
THEN CODESTRING FOR LINE 0
7,MR
7,MCSCNT-M(7)
THEN RIGHT END OF LINE 0 (OFFSET)
LKR,IRB5Z
THERE IS CONSIDERABLE DEPENDENCE HERE ON A SYNTACTICALLY
CORRECT FN HEADER -- IT MUST CONSIST OF ALTERNATING
'NOISE' (NON-LOCAL) SYLLABLES AND LOCAL SYLLABLES.
IN THE FOLLOWING,
R1 = STACK ADDR OF SHADOW POINTER
R2 = DIRECTORY POINTER (LABEL LOCALIZATION ONLY)
R3 = SYMBOL TABLE ADDR OF NAME
R4 = SYMBOL TABLE ENTRY
R5 = STACK ENTRY (PARAM MPTR OR UNDEFINED VARB)
R6 = NUMBER OF LABELLED LINES (LABEL LOCALIZATION)
R7 = ABS POINTER (OFFSET) TO CODESTRING
R8 = STACK OR S.T. ADDR OF DFN ENTRY
R9 = STACK ADDR OF GLOBAL MPTR ( = R1 + 4)
R10= REMAINING LINES IN FUNCTION
FTEMP3(2),MCSORG-M-2(7)
3,FTEMP3
PICK UP A LOCAL SYLLABLE
3,2
GET DOUBLEWORD INDEX
IRB5W
IGNORE PLACE-HOLDERS
3,QR13STK
MAKE IT M-RELATIVE
9,STPARAM-STSHADOW(1)
3,8
IF WE'RE ABOUT TO SHADOW THE FN NAME
*+6
8,9
THEN MAKE FN SPTR POINT TO THE STACK
4,M(3)
LOAD SHADOWED M-ENTRY POINTER
5,STPARAM-STSHADOW(1,MR) AND LOCAL VALUE'S MPTR
5,M(3)
PUT LOCAL IN SYMBOL TABLE
4,STPARAM-STSHADOW(1,MR) AND GLOBAL MPTR INTO STACK
4,4
IRB5M
IF SYMBOL TABLE ENTRY IS AN M-PTR,
0,M(4)
RELOCATE GLOBAL M-ENTRY TO POINT
9,M(4)
TO STACKED SHADOWED EST ENTRY
0,M(4)
POINT SHADOW PTR AT BST ENTRY
0H
3,MHEAD(5)
POINT LOCAL M-ENTRY AT BST
3,QASHADOW
MARK SHADOW WITH SHADOW FLAG
3,STSHADOW-STSHADOW(1,MR)
1,QF8
ADVANCE TO NEXT STACK LOCATION
LKR
BACK TO LABEL OR HEADER LOGIC
7,QF3
ADVANCE TO NEXT LOCAL SYL IN HEADER
MCSORG-M(7),1+2*ZEOS QUIT WHEN WE REACH END-OF-STATEMENT

44450000
44500000
44550000
44600000
44700000
44750000
44800000
44850000
44900000
44950000
45000000
45050000
45100000
45150000
45200000
45300000
45350000
45400000
45450000
45500000
45550000
45600000
45650000
45700000
45750000
45800000
45850000
45900000
45950000
46000000
46050000
46100000
46150000
46200000
46250000
46300000
46350000
46400000
46450000
46500000
46550000
46600000
46650000
46700000
46750000
46800000
46850000
46900000
47000000
47050000
47100000
47150000
47200000
47250000
47300000
47350000
47400000
47450000
47500000
47550000

*
IRB5K

IRB5QH
*
*
*
*
*
*
*
*
*
*
*
*
IRB5S

IRB5T

BE
TM
BO
BCT

IRB5K
MCSORG-M(7),1
IRB5Y
7,IRB5Y

SYLLABLE
IF NOISE SYLLABLE WAS SHORT,
CONTINUE
OTHERWISE ADVANCE 1 MORE BYTE FIRST

L
LA
MVC
ST
MVC
ST
L
LA
ST
LTR
BZ
MVI
L
LA
B
DC

2,FTEMPN+4
RECALL NEW VALUE OF PARREL
1,0(2,MR)
STFREG(4,1),PARREL LOAD OLD COPY OF PARREL,
8,STFNSPTR(1)
FUNCTION BST ENTRY POINTER,
STFLAGS(1,1),FTEMP3+2 FLAGS FOR QUAD-ON-RIGHT,
2,PARREL
AND NEW VALUE OF PARREL.
LKR,DIASTPTR
LKR,1(LKR)
BUMP DIAGRAM STACK POINTER
LKR,DIASTPTR
5,8
RE-LOCATE FUNCTION DIRECTORY
IRS2Z
OR GO TO TYPEIN IF 'FN' IS QUAD (')
STFNSPTR(1),X'80' MARK FNSPTR INDIRECT
5,M(5)
4,1
SET NEW LINE NUMBER = 1 AND
IRS2L
JOIN END-OF-STATEMENT ANALYSIS.
AL1(1+2*ZEOS,0,0,1+2*ZLARROW,0,0,0,2,0,0) IMITATION
HEADER FOR QUAD
MOVE STACKED ARGUMENT TO PROPER POSITION IN FUNCTION
INFO. CLEAR THE SPOT IT OCCUPIED IN THE STACK. IF THE
ARGUMENT IS A VARIABLE, COPY ITS VALUE AND USE COPY AS
FUNCTION ARGUMENT.
ON ENTRY, R0 = CANONICAL UNDEFINED VARIABLE
R1 = ADDRESS OF STACKED ARG
R3 = TARGET ADDRESS FOR ARG
R7 = RETURN ADDRESS
R8 = FN SYMBOL TABLE PTR OR 0

L
ST
AR
LTR
BM
AL
ST
AR
TM
BO
L
SLR
ALR
ST
BR
DS
STM
L
L
L

*
*
ST
AR
ST
ST
O

5,M(1)
0,M(1)
1,4
5,5
IRB5T
5,QAVMT
5,M(3)
5,MR
MLIST-M(5),MLSTBIT
SYNT12
LKR,MHEAD-M(5)
LKR,1
LKR,3
LKR,MHEAD-M(5)
7
0H
0,7,FTEMPN
5,M(5)
0,MCOUNT(5)
1,MX
NOTE THAT CHECK FOR
AT IRB5G, SO WE CAN
0,MCOUNT(1)
0,1
0,MX
3,MHEAD(1)
1,QAVARB

PICK UP STACKED ARGUMENT

ALL CALLERS NEED THIS, SO WHY NOT
IS THIS ARGUMENT AN SPTR OR MPTR -AN SPTR. WE'LL HAVE TO COPY VALUE.
AN MPTR. MAKE IT A VARIABLE AND
PUT EST ENTRY IN PARAMETER LIST
ABSOLUTE HEADER ADDRESS
ARG MUST NOT BE A LIST
PICK UP HEADER
RELOCATE IT
TO NEW STACK POSITION.

FIND LENGTH OF VALUE

SPACE NEEDED FOR COPY OF ARGUMENT
BUILD M-ENTRY FOR IT.
SPACE AVAILABILITY HAS BEEN DONE
BYPASS GETSPACE CALL.
OLD MX PLUS COUNT
IS NEW MX
POINT M-ENTRY AT STACK
BUILD E.S.T. ENTRY FOR STACK

47600000
47650000
47700000
47750000
47800000
47850000
47900000
47950000
48000000
48050000
48100000
48150000
48200000
48250000
48300000
48350000
48400000
48450000
48550000
48600000
48650000
48700000
48750000
48800000
48850000
48900000
48950000
49000000
49050000
49100000
49150000
49200000
49250000
49300000
49350000
49400000
49450000
49500000
49550000
49600000
49700000
49750000
49800000
49850000
49900000
49950000
50000000
50050000
50100000
50150000
50200000
50300000
50350000
50400000
50450000
50500000
50550000
50600000
50700000
50750000

IRB5V
IRB5U
IRB5MV
*
*
IRB6
*
*
IRB7
*
*
IRB14
*
*
*
IRE38

*
*

*
*
IRS7
*
*
IRB8
*
*
IRB7A
*
*
IRB9
*

ST
LA
LA
LA
L
S
BM
LA
MVC
AR
BXLE
EX
LM
BR
MVC
EJECT

1,M(3)
2,256
6,M(1)
7,M(5)
5,MCOUNT-M(7)
5,QF261
IRB5U
3,0(7,5)
4(256,6),4(7)
6,2
7,2,IRB5V
5,IRB5MV
0,7,FTEMPN
7
4(0,6),4(7)

POINT STACK AT NEW M-ENTRY

PREPARE TO MOVE VALUE.
R6 IS ABSOLUTE SINK
R7 IS ABSOLUTE SOURCE
R5 IS COUNT
DROP IT FOR MOVE LOOP
LOOP NOT NEEDED -- JUST 1 MVC.
SET LIMIT FOR SOURCE POINTER
MOVE 256 BYTES
UP SINK POINTER
AND SOURCE POINTER
DO TAIL END OF MOVE.
RESTORE SAVED REGISTERS

50800000
50900000
50950000
51050000
51100000
51150000
51200000
51250000
51300000
51350000
51400000
51450000
51500000
51550000
51600000
51650000
51700000
BASIC -- LIST TRAVERSED
51750000
EQU SYNTX
51800000
51850000
BASIC -- LEFT PARENTHESIS OF LIST TRAVERSED
51900000
EQU *
51950000
52000000
BASIC -- LEFT PARENTHESIS TRAVERSED
52050000
EQU *
52100000
52150000
EXP -- LEFT PARENTHESIS OF SUBSCRIPTED EXPRESSION LEFT OF
52200000
OPERATOR TRAVERSED
52250000
EQU *
52300000
L
1,SVI
LOCATE TOP OF STACK
52350000
LA
3,0(1,MR)
ABSOLUTE
52400000
TM
11(3),1
WERE ANY SEMICOLONS PRESENT
52450000
BZ
IRB7A
(I.E. WAS IT REALLY A LIST) -52500000
CLI 4(3),0
NO. WAS THERE AN EXPRESSION OR
52550000
BE
SYNT12
VARIABLE BETWEEN THE PARENS -52600000
NO. JUST (). SYNTAX ERROR.
52650000
YES. RELOCATE EST ENTRY FOR PARENTHESIZED EXPRESSION. 52700000
LA
2,4
52750000
AR
1,2
BUMP STACK POINTER
52800000
ST
1,SVI
TO REFLECT SHORTENED STACK.
52850000
L
4,0(1,MR)
PICK UP EST ENTRY
52900000
ST
4,4(1,MR)
STORE IT IN END-OF-LIST '1' WORD
52950000
LTR 4,4
IF R4 IS AN EST ENTRY,
53000000
BM
SYNTX
53050000
AL
2,0(4,MR)
FIX 1ST WORD OF M-ENTRY TO POINT AT 53150000
ST
2,0(4,MR)
NEW LOCATION OF EST ENTRY.
53200000
B
SYNTX
53250000
53300000
STMT -- UNPARENTHESISED LIST (MIXED OUTPUT) TRAVERSED
53350000
EQU *
53400000
53450000
BASIC -- LIST TRAVERSED
53500000
EQU SYNTX
53550000
53600000
REENTRY FROM LEFT-PAREN INTERPRETATION RULE
53650000
EQU *
53700000
53750000
BASIC -- LEFT BRACKET OF SUBSCRIPT LIST TRAVERSED
53800000
EQU *
53850000
53900000

*
IRE25
*
*
IRE27
*
*
IRE28
*
*
*
*

IRB9A

*
*
IRB9C
IRB9B
*

*
IRB9Q
*
*
IRB13
*
*
IRB15

EXP -- LEFT BRACKET OF OPERATOR SUBSCRIPT TRAVERSED

EQU *
EXP -- LEFT BRACKET TRAVERSED
EQU *
EXP -- LEFT BRACKET OF LHS TRAVERSED
EQU *
FORM A LIST M-ENTRY FROM CONTENTS OF STACK IN SVI+4
UP TO FLAG WORD (=1).
SHORT-CUT MOVE DEPENDS ON MX AND SVI BEING AT LEAST
12 APART.
L
1,MX
LOAD SINK ADDRESS
L
2,SVI
LOAD SOURCE ADDRESS
LA
0,4
COMMONLY USED CONSTANT
LA
1,MLSORG-M-4(1)
OFFSET SINK PAST HEADER INFORMATION
AR
1,0
BUMP SINK AND SOURCE
AR
2,0
TO NEXT ITEM.
C
2,PARREL
SPECIAL EXIT FOR UNPARENTHESISED
BE
IRB9C
LIST (ALWAYS ON PAREN LEVEL 0)
L
3,M(2)
MOVE NEXT ITEM FROM STACK
ST
3,M(1)
TO FREE STORAGE.
C
3,QF1
IS THE ITEM A FLAG WORD -BE
IRB9B
YES. END OF MOVE OPERATION.
BNH IRB9A
NO. IS IT AN EST ENTRY -IC
4,M(3)
HEADER RELOCATED TO POSITION IN
ST
1,M(3)
LIST M-ENTRY.
STC 4,M(3)
B
IRB9A
BACK FOR NEXT ITEM.
ADJUST MX AND SVI
FORM M-ENTRY HEADER FOR LIST
SR
2,0
SET R2 TO PARREL-4
L
3,MX
PICK UP OLD MX, WHICH IS ADDRESS OF
M-ENTRY.
ST
1,MX
SET MX TO FIRST WORD PAST M-ENTRY.
AL
3,QATMPCLS
STACK EST ENTRY POINTING TO M-ENTRY
ST
3,M(2)
N
3,QF24BITS
SR
2,0
SET SVI TO ADDRESS PRECEDING FLAG WD
ST
2,SVI
AL
2,IRB9Q
FLAG WORD POSITION IS EST ENTRY FOR
LIST.
ST
2,MHEAD(3)
POINT M-HEADER AT STACK.
SR
1,3
NEW MX - OLD MX
ST
1,MCOUNT(3)
IS BYTE COUNT OF M-ENTRY.
LA
2,MLSORG-M
SET LIST OFFSET.
STH 2,MLSOS(3)
SR
1,2
SET COUNT OF LIST ELEMENTS.
SRL 1,2
STH 1,MLSCT(3)
BAL 8,GNOSPACE
ASSURE ADEQUATE SPACE BETWEEN NEW
MX AND SVI.
B
SYNTX
DC
A(MLSTBIT*(X'FFFFFF'+1)+4)
BASIC -- SUBSCRIPTED EXPRESSION TRAVERSED
EQU SYNTX
BASIC -- SUBSCRIPTED QUANTITY TRAVERSED
EQU *

53950000
54000000
54050000
54100000
54150000
54200000
54250000
54300000
54350000
54400000
54450000
54500000
54550000
54600000
54650000
54700000
54750000
54800000
54850000
54900000
54950000
55000000
55050000
55100000
55150000
55250000
55300000
55350000
55400000
55450000
55500000
55550000
55600000
55650000
55700000
55800000
55850000
55900000
55950000
56000000
56100000
56150000
56200000
56250000
56300000
56350000
56400000
56450000
56500000
56550000
56600000
56650000
56700000
56750000
56800000
56850000
56900000
56950000
57000000
57050000

LA
1,1
ICALL INDEX
B
SYNTX
*
*
IRE1
*
*
IRE2
*
*
IRE3
*
*
IRE29
*
*
IRE30
IRE45A
*
*
*
IRE40
*
*
IRE42

*
*
IRE5
*
*
IRE7
*
*
IRE8

*
*
IRE41
*
*
*
IRE13
IRE33A
*
*

SET UP FOR INDEX FETCH

57100000
57150000
57200000
57250000
EXP -- RIGHTMOST BASIC TRAVERSED
57300000
EQU SYNTX
57350000
57400000
EXP -- UNSUBSCRIPTED OPERATOR TRAVERSED
57450000
EQU *
57500000
57550000
EXP -- UNSUBSCRIPTED SLASH/BACKSLASH TRAVERSED
57600000
EQU *
57650000
SR
1,1
57700000
BAL 8,PUSH
FIRST STACK A 'NO SUBSCRIPT' FLAG
57750000
57800000
EXP -- SUBSCRIPTED OPERATOR TRAVERSED
57850000
EQU *
57900000
57950000
EXP -- SUBSCRIPTED SLASH/BACKSLASH TRAVERSED
58000000
EQU *
58050000
EQU *
REENTRY AFTER RELOCATING SUBSCRIPT 58100000
AT IRE44 OR IRE45
58150000
BAL 8,PSHOP
STACK OPERATOR NUMBER
58200000
B
SYNTX
58250000
58300000
EXP -- LEFT OPERATOR OF MATRIX PRODUCT TRAVERSED
58350000
EQU *
58400000
58450000
EXP -- NULL OF MATRIX PRODUCT TRAVERSED
58500000
EQU *
58550000
SR
1,1
58600000
IC
1,SYL+1
PICK UP THE OPERATOR
58650000
L
2,SVI
58700000
STC 1,6(2,MR)
PUT IT IN STACK NEXT TO RT OPERATOR 58750000
B
SYNTX
58800000
58850000
EXP -- LEFT ARROW TRAVERSED
58900000
EQU SYNTX
58950000
59000000
EXP -- ENTIRE EXPRESSION TRAVERSED
59050000
EQU SYNTX
59100000
59150000
EXP -- BASIC LEFT OF OPERATOR OR DEFINED FUNCTION TRAVERSED
59200000
EQU *
59250000
L
5,SVI
59300000
L
1,M+8(5)
LOOK AT OPERATOR
59350000
LTR 1,1
IS IT OP OR FUNCTION -59400000
BM
IRE8A
DEFINED FUNCTION.
59450000
59500000
EXP -- BASIC PRECEDING MATRIX PRODUCT TRAVERSED
59550000
EQU *
59600000
ICALL DODOP
OP. EXECUTE DYADIC OPERATOR.
59650000
B
SYNTX
59700000
59750000
EXP -- 'EMPTY' IMPLYING MONADIC OPERATOR OR DEFINED FUNCTION 59800000
TRAVERSED
59850000
EQU *
59900000
EQU *
REENTRY FOR MONADIC OP OR DFN
59950000
'DISCOVERED' FOLLOWING SUBSCRIPTED 60000000
OP, SLASH, OR BACKSLASH
60050000

IDOMOP
*
*
IRE14

*
*
IRE15

PSHOP

*
*
IRE18
*
*
*

L
L
LTR
BM
ICALL
B

5,SVI
1,M+4(5)
1,1
IRE13A
DOMOP
SYNTX

IS THIS OPERATOR OR DEFINED FUN -DEFINED FUNCTION.

OP. EXECUTE MONADIC OPERATOR

EXP -- OPERATOR OF REDUCTION TRAVERSED

EQU *
SR
1,1
L
2,SVI
IC
1,7(2,MR)
MOVE SLASH TO LEFT
STC 1,6(2,MR)
IC
1,SYL+1
PICK UP THE OPERATOR
STC 1,7(2,MR)
PUT IT WHERE SLASH WAS
B
IDOMOP
EXP -- BASIC LEFT OF SLASH/BACKSLASH TRAVERSED
EQU *
ICALL SELECT
B
SYNTX
SPACE 3
SR
1,1
IC
1,SYL+1
ASSUME SHORT SYLLABLE
TM
SYL+1,1
BO
PUSH
L
2,SPTR
NO, LONG SYL. GET OP NO FROM SYMBOL
LH
1,2(2,MR)
TABLE ENTRY.
B
PUSH
EJECT
EXP -- SPECIFICATION OF UNSUBSCRIPTED VARIABLE TRAVERSED
EQU *
BAL LKR,CSTSUB
SET 'COMPLETE STATEMENT' BIT
NOP 0
ON RETURN FROM CSTSUB,
R4 = SVI
R6 = PARREL (ABSOLUTE)
L
1,M+4(4)
R1 IS RHS STACK ENTRY
TM
SYL+1,1
WAS SYLLABLE SHORT OR LONG -BO
IRE18Q
SHORT. THIS IS A DISPLAY.

*
*
POSSIBLE CASES IN UNSUBSCRIPTED SPECIFICATION
*
AND ACTIONS TAKEN. IF RHS IS EXPRESSION AND THIS IS COMPLETE
*
STATEMENT, TOP OF STACK AFTER SPECIFICATION IS POINTER TO LHS.
*
OTHERWISE, IT IS POINTER TO RHS.
*
*
LHS UNDEFINED
LHS - RHS
LHS - RHS
*
LENGTHS EQUAL
LENGTHS UNEQUAL
*
........................................................
*RHS IS VARB .
.
* OR, NESTED .
GETSPACE DIF (>0).
* SPECIFICATION. GETSPACE
COPY RHS VALUE
MARK LHS GARBAGE .
*
. COPY RHS VALUE
GETSPACE RHS LGTH.
*
.
COPY RHS VALUE .
*
.
.
*RHS IS EXPN, . CHECK FOR LIST CHECK FOR LIST
CHECK FOR LIST .
* NOT NESTED SP. LINK LHS TO
MARK OLD LHS GAR MARK OLD LHS GAR .
*
.
RHS VALUE
BAGE
BAGE
.
*
.
LINK LHS TO RHS LINK LHS TO RHS .

60100000
60150000
60200000
60250000
60300000
60350000
60400000
60450000
60500000
60550000
60600000
60650000
60700000
60750000
60800000
60850000
60900000
60950000
61000000
61050000
61100000
61150000
61200000
61250000
61300000
61350000
61400000
61450000
61500000
61550000
61600000
61650000
61700000
61750000
61800000
61850000
61900000
61950000
62000000
62050000
62100000
62150000
62200000
62250000
62300000
62350000
62400000
62450000
62500000
62550000
62600000
62650000
62700000
62750000
62800000
62850000
62900000
62950000
63000000
63050000

*
*
*

*
IRE18C

*
*
*

IRE18L
IRE18D

*
*
*
*
*
IRE18B

*
*
IRE18E
IRE18P
IRE18M
*
*
IRE18A

.
VALUE
VALUE
. 63100000
........................................................ 63150000
63200000
L
2,SPTR
R2 IS LEFT-HAND-SIDE
63250000
LTR 3,1
IS RHS AN EXPRESSION OR A VARIABLE - 63300000
L
1,M(2)
R1 IS SYMBOL TABLE ENTRY OF LHS
63350000
BP
IRE18A
EXPRESSION.
63400000
REENTRY FOR NESTED SPECIFICATION OF VARB BY EXPN
63500000
L
4,M(3)
GET MPTR OF RHS
63550000
N
1,QF24BITS
MASK OFF CLASS ETC OF LHS
63650000
BZ
IRE18D
IS LHS PRESENTLY UNDEFINED -63700000
L
7,MCOUNT(4)
NO.
63750000
S
7,MCOUNT(1)
ARE LHS AND RHS OF THE SAME LENGTH, 63800000
SO THAT WE CAN COPY RHS VALUE INTO 63850000
SPACE CURRENTLY OCCUPIED BY LHS -- 63900000
BE
IRE18B
YES.
63950000
BM
IRE18L
WE NEED NEW SPACE FOR LHS
64000000
NO PROBLEM IF NEW LENGTH SMALLER
64050000
LA
0,40(7)
IF LARGER, ASSURE THAT THE DIFFERENC 64100000
BAL 8,GNOSP2
EXISTS BEFORE MARKING OLD LHS GARBAG 64150000
L
4,M(3)
WE MAY HAVE GARBAGE-COLLECTED.
64200000
L
1,M(2)
RECALL LHS AND RHS M-POINTERS
64250000
LA
1,0(1)
NO HIGH-ORDER GARBAGE FOR MKG
64300000
MKG 1
MARK SHORTER OR LONGER LHS GARBAGE 64400000
L
1,MCOUNT(4)
ASK FOR LENGTH OF RHS
64450000
ICALL GETSPACE
NOTE THAT WE ASSUME R2 NE 0
64500000
IC
0,M(2)
CONNECT LHS SYMBOL TABLE ENTRY TO
64550000
ST
1,M(2)
ITS NEW M-ENTRY.
64600000
STC 0,M(2)
64650000
ST
2,MHEAD(1)
POINT M-ENTRY BACK TO LHS.
64750000
L
4,M(3)
RECALL THE RHS MPTR
64800000
COPY VALUE OF RHS INTO M-ENTRY OF LHS
64850000
R1 IS LHS MPTR
64900000
R4 IS RHS MPTR
64950000
65000000
65050000
LA
4,0(4,MR)
R4 IS ABSOLUTE SOURCE ADDRESS
65100000
AR
1,MR
R1 IS ABSOLUTE SINK ADDRESS
65200000
LA
2,256
R2 IS INCREMENT FOR BXLE
65250000
L
5,MCOUNT-M(4)
R5 IS FULL COUNT OF SOURCE
65300000
S
5,QF261
DROP IT BY 256 FOR MOVE LOOP AD65400000
JUSTMENT, 1 FOR MVC ADJUSTMENT,
65450000
AND 4 TO AVOID COPYING M-HEADER.
65500000
BM
IRE18P
DO WE AVOID THE LONG MOVE ALTOGETHER 65550000
LA
3,0(4,5)
NO. R3 IS LIMIT FOR BXLE.
65600000
MVC 4(256,1),4(4)
THE MOVE LOOP.
65650000
AR
1,2
MOVE 256 BYTES, UPDATE SOURCE AND
65700000
BXLE 4,2,IRE18E
SINK, AND REPEAT UNTIL SHORT MVC.
65750000
EX
5,IRE18M
FINISH OFF THE MOVE.
65800000
B
IRE18T
DONE EXCEPT TO CHECK FOR DFN TRACE 65850000
MVC 4(0,1),4(4)
65900000
65950000
66000000
DS
0H
66050000
LA
5,0(3,MR)
66100000
TM
MLIST-M(5),MLSTBIT IS EXPRESSION A LIST -66150000
BNZ SYNT12
YES. NO SPECIFICATION BY LISTS. G01 66200000
TM
STFLAGS(6),STSTBIT IF NOT COMPLETE STATEMENT,
66250000
BNZ IRE18K
(IT IS)
66300000
LA
3,4(4)
MUST COPY VALUE AND LEAVE TOS=EXPN. 66350000

IRE18K

IRE18F

IRE18T
IRE51M

IRE20D

B
O
ST
N
BZ
MKG
IC
ST
STC
IC
ST
STC
EQU
B
EQU
L
LA
TM
BO
LH
ST
EX
LA

IRE18C
2,QFBIT0
2,M+4(4)
1,QF24BITS
IRE18F
1
1,M(2)
3,M(2)
1,M(2)
1,MHEAD(3)
2,MHEAD(3)
1,MHEAD(3)
*
SYNTX
*
7,M(3)
3,0(7,MR)
MHEAD-M(3),MFLKBIT
SYNTX
1,MLSCT-M(3)
1,FTEMP1
2,IRE20N
3,4(3)

BCT
LCR
BCTR
L
L
LTR
BP
L
DS
LR
AH
LA
ST
SR
IC
ST
ICALL
LR
LM
BCTR
LTR
BM
ICALL
LR
C
BNL
SLA
BNH
AR
AR
EX
B
ICALL
B

1,IRE20D
5,2
5,0
3,SVI
3,M+4(3)
1,3
IRE20B
1,M(1)
0H
3,1
3,MRANK(1)
3,MRHO-M(3)
3,FTEMPN+4
2,2
2,MTYPE(1)
2,FTEMPN
XRHO
6,1
3,4,FTEMPN
6,0
2,6
SYNTX
FETCHINT
1,0
1,FTEMP1
IRE20A
1,2
IRE20A
1,MR
1,7
5,IRE20R
IRE20A
GOUT
SYNTX

*
*
*

IRE20B

IRE20A

IRE18Q

66400000
66450000
66500000
66600000
66650000
66700000
66750000
66800000
66850000
AND VICE VERSA.
66900000
66950000
67000000
67050000
67100000
67150000
THEN POINTER TO FUNCTION DIRECTORY 67200000
PREPARE TO ERASE ANY TRACE, STOP BIT 67300000
TRACE OR STOP OF PROTECTED FUNCTION 67350000
NOT ALLOWED
67400000
SAVE STATEMENT COUNT
67450000
67500000
WHICH MAY CURRENTLY BE ON.
67550000
LOOP STARTS ERASING ON STATEMENT
67600000
0. A DFN IS GUARANTEED TO HAVE AT 67650000
LEAST ONE LINE, SO LEADING TEST
67700000
ISN'T NEEDED.
67750000
67800000
DECOMPLEMENT TR/PS BIT
67850000
67900000
67950000
68000000
NOW LOOK AT RHS.
68050000
68100000
68200000
68250000
COMPUTE BASE ADDRESS OF RHS DATA
68300000
AS MPTR PLUS 4*RANK
68350000
PLUS OFFSET OF RANK VECTOR, PLUS M 68400000
68450000
68500000
SAVE RHS TYPE
68550000
68600000
FIND NUMBER OF COMPONENTS IN RHS
68650000
AND LEAVE THAT IN R6.
68700000
RELOAD BASE ADDRESS, TYPE,
68750000
68800000
AND INDEX OF RHS
68850000
HAVE ALL COMPONENTS BEEN USED -68900000
NO. FETCH THE NEXT.
68950000
69000000
IS IT WITHIN RANGE OF LINE NUMBERS - 69050000
NO. TOO BIG.
69100000
MAKE IT A WORD INDEX
69150000
AND TEST FOR NEGATIVE OR ZERO
69200000
IN RANGE. MAKE IT ABSOLUTE
69250000
POINTER TO CODESTRING ENTRY
69300000
AND TURN ON TRACE OR STOP.
69350000
BACK FOR THE NEXT COMPONENT.
69400000
QUAD SPECIFIED BY RHS
69450000
69500000
MAKE TOS AN INDIRECT ENTRY
FOR LHS.
IS LHS DEFINED -NO.
YES. MARK PREVIOUS VALUE GARBAGE.
LINK LHS SYMBOL TABLE ENTRY TO
VALUE OF EXPRESSION

IRE20N
IRE20R
*
*
IRE50
*
*

NI
OI

MFCODE-M(3),0
MFCODE-M(1),0

EXECUTED TRACE- OR STOP-BIT CLEARER 69550000

EXECUTED TRACE OR STOP BIT SETTER
69600000
69650000
EXP -- DFN OR DFN0 LEFT OF SPECIFICATION TRAVERSED
69700000
EQU *
69750000
TRACE (OR STOP) IS DETECTED BY THE OTHERWISE ILLEGAL
69800000
SPECIFICATION OF A DFN OR DFN0.
69850000
MVC FTEMP1,SPTR
JUST SAVE SYMBOL TABLE ADDR OF DFN 69900000
B
SYNTX
69950000
*
70000000
*
EXP -- TRACE OR PROGRAMMED STOP LEFT OF DFN OR DFN0 TRAVERSED 70050000
IRE51
EQU *
70100000
BAL LKR,CSTSUB
70150000
NOP 0
70200000
L
3,FTEMP1
RECALL SPTR OF FUNCTION
70250000
TRT SYL+1(1),IRE51TB
PICK UP 8-BIT MASK FOR TRACE OR STOP 70300000
B
IRE51M
70350000
IRE51TB EQU *-2*ZTDELTA-1
70400000
DC
AL1(255-STTRBIT,0,255-STPSBIT)
70450000
DC
0H'0'
GET LOCATION CTR ALIGNED FOR EQU
70500000
*
70550000
*
EXP -- LIST AS OPERATOR SUBSCRIPT TRAVERSED
70600000
IRE21
EQU SYNTX
70650000
*
70700000
*
EXP -- SUBSCRIPTED OPERAND LEFT OF OPERATOR OR DFN TRAVERSED 70750000
IRE22
EQU *
70800000
LA
1,1
70850000
ICALL INDEX
PERFORM THE INDEXING
70900000
B
IRE8
AND JOIN OPND OP OPND CODE
70950000
*
71000000
*
EXP -- LIST AS SUBSCRIPT OF OPERAND LEFT OF OPERATOR TRAVERSED 71050000
IRE23
EQU SYNTX
71100000
*
71150000
*
EXP -- LIST AS SUBSCRIPT OF LHS TRAVERSED
71200000
IRE24
EQU SYNTX
71250000
*
71300000
*
EXP -- SUBSCRIPTED OPERATOR PRECEDING MONADIC OPERATOR OR
71350000
*
DEFINED FUNCTION TRAVERSED
71400000
IRE33
EQU *
71450000
*
71500000
*
EXP -- SUBSCRIPTED SLASH/BACKSLASH PRECEDING MONADIC OPERATOR 71550000
*
OR DEFINED FUNCTION TRAVERSED
71600000
IRE34
EQU *
71650000
LM
2,3,SVI ,PARREL
WE MUST BACKTRACK ENOUGH TO EXECUTE 71700000
L
1,4(2,MR)
THE MONADIC OP. TOWARD THIS END,
71750000
ST
1,STPARAM(3,MR)
MOVE STACK ENTRY FOR SUBSCRIPT TO
71800000
LA
4,STPARAM-4(3)
RELOCATE M-ENTRY TO POINT TO THIS
71900000
SR
4,2
71950000
A
4,MHEAD(1)
NEW STACK LOCATION.
72000000
ST
4,MHEAD(1)
72050000
LA
2,4(2)
BUMP SVI .
72100000
ST
2,SVI
72150000
B
IRE33A
NOW EXECUTE THE WHATEVER-IT-WAS.
72200000
*
72250000
*
EXP -- SUBSCRIPTED VARIABLE LEFT OF LEFT ARROW TRAVERSED
72300000
IRE36
EQU *
72350000
TM
SYL+1,1
SPECIFICATION OF SUBSCRIPTED QUAD
72400000
BO
SYNT12
OR QUAD PRIME IS MEANINGLESS
72450000
L
1,SPTR
STACK INDEX-SPECIFYEE
72500000
O
1,QFBIT0
INDIRECT POINTER
72550000

BAL
SR
ICALL
BAL
B
B
*
*
*
IRE37
*
*
IRE39

*
*
*
IRE44
*
*
*
IRE45

*
*
*
*
CSTSUB

CSTSB2
*

8,PUSH
1,1
INDEX
LKR,CSTSUB
SYNTX
SYNTX

JUST SET UP FOR AN INDEX STORE

CHECK FOR COMPLETE STATEMENT

EXP -- SUBSCRIPTED PARENTHESIZED EXPRESSION LEFT OF OPERATOR

TRAVERSED
EQU SYNTX
EXP -- PERIOD OF MATRIX PRODUCT TRAVERSED
EQU *
L
2,SVI
L
1,M+4(2)
GIVE SYNTAX ERROR IF PREVIOUS OP G01
LTR 1,1
BP
SYNTX
WAS REALLY A DEFINED FUNCTION.
B
SYNT12
SYNTAX ERROR
G01
EXP -- SUBSCRIPTED OPERATOR PRECEDING MONADIC OP OR MONADIC
DEFINED FUNCTION TRAVERSED
EQU *
EXP -- SUBSCRIPTED SLASH/BACKSLASH PRECEDING MONADIC OPERATOR
OR MONADIC DEFINED FUNCTION TRAVERSED
EQU *
LM
2,3,SVI ,PARREL
UNDO WORK AT IRE34
L
1,STPARAM(3,MR)
BY MOVING 'PARAM 0' BACK WHERE IT
ST
1,0(2,MR)
BELONGS.
L
4,MHEAD(1)
AR
4,2
LA
0,STPARAM(3)
RELOCATE SUBSCRIPT LIST M-ENTRY
SR
4,0
BY SUBTRACTING (STPARAM+PARREL)-SVI
ST
4,MHEAD(1)
SR
0,0
ST
0,STPARAM(3,MR)
ERASE M-POINTER FROM 'PARAM 0' WORD
S
2,QF4
DROP SVI PAST SUBSCRIPT ON STACK
ST
2,SVI
B
IRE45A
JOIN OP AND SLASH/BACKSLASH CODE

LM
LR
LA
LA
CR
BNE
OI
L
AH
AR
CLI
BE
CLI
BE
NI
BR

1,2,SVI ,PARREL
MUCH OF THIS IS FOR IRE18'S
4,1
CONVENIENCE
6,0(2,MR)
ABSOLUTE PARREL
5,8(1)
CLEARLY NOT COMPLETE STATEMENT
5,2
IF MORE THAN A SINGLE VALUE
CSTSB2
IS STACKED
STFLAGS(6),STSTBIT SET 'COMPLETE STMT' BIT
5,STCODE(6)
BASE ADDR OF CODESTRING
5,STCPTR(6)
PLUS CURRENT BYTE COUNT
5,MR
ABSOLUTE
MCSORG-M-1(5),ZEOS*2+1 MAY BE A REAL EOS SYLLABLE
4(LKR)
MCSORG-M-1(5),ZFCOLON*2+1 OR FAKE COLON AFTER LABEL
4(LKR)
STFLAGS(6),255-STSTBIT
LKR
RESET COMPLETE STATEMENT BIT

72600000
72650000
72700000
72750000
72800000
72850000
72900000
72950000
73000000
73050000
73100000
73150000
73200000
73250000
73300000
73350000
73400000
73450000
73500000
73550000
73600000
73650000
73700000
73750000
73800000
73850000
73900000
73950000
74000000
74100000
74150000
74200000
74250000
74300000
74350000
74400000
74450000
74500000
74550000
74600000
74650000
74700000
74750000
74800000
74850000
74900000
74950000
75000000
75050000
75100000
75150000
75200000
75300000
75350000
75400000
75450000
75500000
75550000
75600000
75650000

*
*
*
PUSH

PUSH THE CONTENTS OF R1 ONTO STACK, POSSIBLY CAUSING A GARBAGE COLLECTION. SVI POINTS TO FIRST FREE LOCATION, SO
PUSH CAN STACK R1, DECREMENT SVI, AND THEN TEST.
L
2,SVI
LOAD STACK INDEX
ST
1,0(2,MR)
STORE R1 ON TOP OF STACK
S
2,QF4
DROP SVI BY 1 WORD
ST
2,SVI
*
GET NO SPACE, BUT MAKE SURE THAT ADEQUATE SPACING EXISTS
*
BETWEEN MX AND SVI.
GNOSPACE LA
0,40
LEAVE 40 BYTES SLOP, LIKE GETSPACE
GNOSP2 ST
0,FTEMP2
SAVE SLOP
GNOSP1 S
0,SVI
A
0,MX
BCR 4,8
DO WE HAVE THAT MUCH SLOP -ICALL GCOL
AH, NO. DO A GARBAGE COLLECTION.
L
0,FTEMP2
RECALL SLOP
B
GNOSP1
THIS TIME WE'D BETTER HAVE SLOP.
LTORG
PATCH
DS
32H
PATCH AREA
DIAG
DS
128H
DIIR
DS
128Y
ORG DIAG+TERMSYM+2
DS
0H
STMTSTMT EQU *-DIAG
DC
AL1(0,STMT)
STMT
PATH (EXP,STM1,IRS1)
PATH (RARROW,STM2,IRS5),0
STM1
PATH (EOS,0,IRS2)
PATH (RARROW,STM2,IRS3)
PATH (SEMIC,STM3,IRS6),0 GLITCH FOR MIXED OUTPUT W/O PARENS
STM3
PATH (LIST,STM2,IRS7),0
STM2
PATH (EOS,0,IRS4),0
NONSTMT EQU *-DIAG
LIST
PATH (SEMIC,LIST,IRL1)
PATH (EXP,LIS1,IRL2)
PATH (TERMSYM,0,IRL3)
LIS1
PATH (SEMIC,LIST,IRL4)
PATH (TERMSYM,0,IRL5)
BASIC
PATH (VARB,0,IRB1)
PATH (CONST,0,IRB2)
PATH (RPAR,BAS1,IRB3)
PATH (RBR,BAS2,IRB4)
PATH (DFN0,0,IRB5),0
BAS1
PATH (LIST,BAS3,IRB6),0
BAS3
PATH (LPAR,0,IRB7),0
BAS2
PATH (LIST,BAS4,IRB8),0
BAS4
PATH (LBR,BAS5,IRB9),0
BAS5
PATH (VARB,BAS8,IRB10)
PATH (RPAR,BAS6,IRB11)
PATH (CONST,BAS8,IRB16)
PATH (DFN0,BAS8,IRB12),0
BAS6
PATH (EXP,BAS7,IRB13),0
BAS7
PATH (LPAR,BAS8,IRB14),0
BAS8
PATH (TERMSYM,0,IRB15)
EXP
PATH (BASIC,EXP1,IRE1),0
EXP1
PATH (OP,EXP2,IRE2)
PATH (SLSH,EXP3,IRE3)
PATH (DFN,EXP2,IRE4)
PATH (LARROW,EXP5,IRE5)
PATH (RBR,EXP6,IRE6)

75700000
75750000
75800000
75850000
75900000
75950000
76000000
76050000
76100000
76150000
76200000
76250000
76300000
76350000
76400000
76450000
76500000
76550000
76600000
76650000
76700000
76750000
76800000
76850000
76900000
76950000
77000000
77050000
77100000
77150000
77200000
77250000
77300000
77350000
77400000
77450000
77500000
77550000
77600000
77650000
77700000
77750000
77800000
77850000
77900000
77950000
78000000
78050000
78100000
78150000
78200000
78250000
78300000
78350000
78400000
78450000
78500000
78550000
78600000
78650000

EXP2

EXP3
EXP5
*
EXP21
*
EXP6
EXP7
EXP8
EXP9
EXP10
EXP12
EXP13
EXP14
EXP15

EXP16
EXP17
EXP18
EXP19
EXP20
EXP22

PATH (TERMSYM,0,IRE7)
PATH (RBR,EXP8,IRE12)
PATH (BASIC,EXP1,IRE8)
PATH (PER,EXP19,IRE39)
PATH (TERMSYM,EXP1,IRE13)
PATH (OP,EXP1,IRE14)
PATH (BASIC,EXP1,IRE15),0
PATH (VARB,EXP1,IRE18)
PATH (RBR,EXP9,IRE19)
GLITCH TO ALLOW TRACE AND STOP VECTORS
PATH (DFN,EXP21,IRE50)
PATH (DFN0,EXP21,IRE50),0
PATH (DFNT,EXP1,IRE51),0
END OF GLITCH
PATH (LIST,EXP10,IRE21),0
PATH (TERMSYM,EXP1,IRE22)
PATH (LIST,EXP12,IRE23),0
PATH (LIST,EXP13,IRE24),0
PATH (LBR,EXP14,IRE25),0
PATH (LBR,EXP15,IRE27),0
PATH (LBR,EXP16,IRE28),0
PATH (OP,EXP2,IRE29)
PATH (SLSH,EXP3,IRE30),0
PATH (VARB,EXP7,IRE31)
PATH (RPAR,EXP17,IRE32)
PATH (CONST,EXP7,IRE43)
PATH (DFN0,EXP7,IRE35)
PATH (TERMSYM,EXP22,IRE33),0
PATH (VARB,EXP1,IRE36),0
PATH (EXP,EXP18,IRE37),0
PATH (LPAR,EXP7,IRE38),0
PATH (OP,EXP20,IRE40)
PATH (NULL,EXP20,IRE42),0
PATH (BASIC,EXP1,IRE41),0
PATH (OP,EXP2,IRE44)
PATH (SLSH,EXP3,IRE45),0

*
ORG
SYLCLASS EQU
DC
LARROW SYLC
FPER
SYLC
*
FCOLON SYLC
RARROW SYLC
LPAR
SYLC
RPAR
SYLC
LBR
SYLC
RBR
SYLC
QUAD
SYLC
QUADP
SYLC
EOS
SYLC
SEMIC
SYLC
PLUS
SYLC
MINUS
SYLC
TIMES
SYLC
DIV
SYLC
STAR
SYLC
MAX
SYLC
MIN
SYLC

DIIR+256
*
256X'FF'
LARROW
PER
EOS
RARROW
LPAR
RPAR
LBR
RBR
QUAD
QUAD
EOS
SEMIC
OP
OP
OP
OP
OP
OP
OP

78700000
78750000
78800000
78850000
78900000
78950000
79000000
79050000
79100000
79150000
79200000
79250000
79300000
79350000
79400000
79450000
79500000
79550000
79600000
79650000
79700000
79750000
79800000
79850000
79900000
79950000
80000000
80050000
80100000
80150000
80200000
80250000
80300000
80350000
80400000
80450000
80500000
80550000
80600000
(256 MIN 2 TIMES ZLENGTH)X'FF' 2538 80650000
80700000
IMITATION PERIOD, NECESSARY BECAUSE 80750000
VALUE OF REAL PERIOD IS GTR 127.
80800000
SAME COMMENT
80850000
80900000
80950000
81000000
81050000
81100000
81150000
81200000
81250000
81300000
81350000
81400000
81450000
81500000
81550000
81600000
81650000

MOD
AND
OR
NOT
LT
LE
EQ
GE
GT
NE
QUERY
SHRIEK
CIRCLE
EPS
IOTA
RHO
UARROW
DARROW
REV
COLREV
BASE
REP
COMMA
UPGRADE
DNGRADE
DOMINO
TDELTA
SDELTA
NULL
TRAN
HIST
LOG
NAND
NOR
SLASH
BSLASH
COLSLSH
COLBSLH
ECONST
BCONST
ICONST
FCONST
CCONST
LOCALS
IRCPTR
FTEMP1
FTEMP2
FTEMP3
FTEMPN
BRVAL
*
HTEMP
LEND

SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
SYLC
ORG
DSECT
DS
DS
DS
DS
DS
DS

OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
OP
DFNT
DFNT
NULL
OP
OP
OP
OP
OP
SLSH
SLSH
SLSH
SLSH
CONST
CONST
CONST
CONST
CONST
F
F
F
F
8F
F

81700000
81750000
81800000
81850000
81900000
81950000
82000000
82050000
82100000
82150000
82200000
82250000
82300000
82350000
82400000
82450000
82500000
82550000
82600000
82650000
82700000
82750000
82800000
82850000
82900000
82950000
83000000
83050000
83100000
83150000
83200000
83250000
83300000
83350000
83400000
83450000
83500000
83550000
83600000
83650000
83700000
83750000
83800000
83850000
83900000
M-RELATIVE CODE POINTER FOR CONST IR 83950000
84000000
84050000
84100000
84150000
VALUE OF BRANCH EXPRESSION IF LAST 84200000
STATEMENT WAS A BRANCH
84250000
84300000
84350000
84400000

DS
H
EQU *
END
./ ADD
NAME=APLSTAKE
TAKE
TITLE 'A R R O W S -- T A K E A N D D R O P
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083

00200000
00400000
00600000
00800000

ARROWS

CSECT
PRINT
COPY
COPY
COPY
TITLE
ARROWS CSECT
PRINT
EXTRN
EXTRN
EXTRN
ENTRY
ENTRY
ENTRY
R1
EQU
R2
EQU
I
EQU
R3
EQU
ABS
EQU
BLS
EQU
R4
EQU
RXI
EQU
Q0
EQU
Q1
EQU
W0
EQU
W1
EQU
UPDOWN EQU
I4
EQU
USING
USING
EXTAKE LA
USING
EXLEAVE LA
ST
ST
L
LA
AR
L
BALR
USING
LA
LA
L
CH
BCR
LA
BC
CH
BCR
SETLM0 LTR
BC
CR
BCR
SETLM
CH
LA
BCR
CR
BC
LR

OFF
APLDEFN, ZSYMBOLS, OPSECT
APLDEFN
ZSYMBOLS
OPSECT
'A R R O W S -- T A K E A N D D R O P

05/11/70'

ON,NOGEN
ERROR
FETCHINT
OPSPACE
EXTAKE
LJWMOVE
EXLEAVE
1
HOLDS RESULT OF FETCH.
2
R2
INDEX FOR LEFT SIDE.
3
3
ABSOLUTE VALUE OF FETCHED ELEMENT.
4
BASE OF LEFT SIDE.
4
5
HOLDS RX(I).
6
LEFT HALF OF MULTIPLICAND.
7
RIGHT HALF OF MULTIPLICAND.
8
LEFT HALF OF MULTIPLICAND.
9
RIGHT HALF OF MULTIPLICAMD.
10
HOLDS CORRECT BRANCH ADDRESS.
LKR
HOLDS FOUR TIMES I.
OPSECT-16,LR
*,9
9,LWUP-LWDOWN+EXLEAVE-EXTAKE(9) GET SET FOR UP ARROW.
*,9
THIS PROVED TO BE NECESSARY.
UPDOWN,LWDOWN
ADDRESS OF CORRECT BRANCH PLACE.
PR,KEEPPR
SAVE THE PROGRAM REGISTER.
LKR,KEEPLKR
SAVE THE RETURN ADDRESS.
I,LHXRHO
NUMBER OF ELEMENTS IN LEFT SIDE.
ABS,0(I,I)
USE ABS FOR A WORK ARE.
ABS,ABS
MULTIPLY I BY FOUR IN ABS.
R0,LHRANK
FOUR TIMES THE NUMB. OF DIMS.
PR,0
*,PR
Q1,CALLERR
R1,ERANK
Q0,RHRANK
R0,HALF4
2,Q1
R1,ELENGTH
8,SETLM0
Q0,HALF4
2,Q1
Q0,Q0
8,SETLM
ABS,Q0
7,Q1
I,HALFA
A01
R1,ERANGE
11,Q1
A01
ABS,Q0
A01
10,SETLM1
ABS,Q0

01000000
01400000
01600000
01800000
02000000
02200000
02400000
02600000
02800000
03000000
03200000
03400000
03600000
03800000
04000000
04200000
04400000
04600000
04800000
05000000
05200000
05400000
05600000
05800000
06000000
06200000
06400000
06600000
06800000
07000000
07200000
07400000
07600000
07800000
08000000
08200000
08400000
08600000
08800000
09000000
09200000
09400000
09600000
09800000
10000000
10200000
10400000
10600000
10800000
11000000
11200000
11400000
11600000
11800000
12000000
12200000
12400000
12600000
12800000
13000000

LR
I,ABS
SRL I,2
SETLM1 EQU *
ST
ABS,ANSRANK
SH
ABS,HALF8
SUBTRACT 8 FOR THE LIMIT.
ST
ABS,LIM
STASH AWAY THE LIMIT.
L
BLS,LHBASE
SET UP BLS TO CONTAIN THE M-RELATIVE
A
BLS,LHRANK
ADDRESS OF ELEMENT ZERO OF THE LEFT
LA
BLS,MRHO-M(BLS)
ARGUMENT.
LR
R1,I
SET UP THE INITIAL INDEX FOR LHS.
BCTR I,0
XX
BXLE R1,R1,LEFTMT
EMPTY VECTOR OF NUMBERS. NOW WHAT?
LA
R0,1
ST
R0,LSP
SET THE SPACE TO ONE.
LA
Q0,SEE
SET UP RETURN ADDRESS FROM FETCH.
* FETCH AN ELEMENT FROM THE LEFT SIDE, SET UP ABS TO CONTAIN THE
*
* ABSOLUTE VALUE OF THE NUMBER FETCHED, CHECK THE ABSOLUTE VALUE FOR *
* A POSSIBLE DOMAIN ERROR, AND MAKE I4 CONTAIN FOUR TIMES I.
*
BEGET
ST
I,RAT
C
I,LHXRHO
BC
4,BEGET1
SR
I,I
BEGET1 L
3,LHTYPE
GET READY FOR FETCHINT.
ICALL FETCHINT
FETCH THAT INTEGER.
L
I,RAT
LA
I4,0(I,I)
GET I+I IN I4.
AR
I4,I4
THEN GET I+I+I+I IN I4.
L
RXI,RHBASE
NOW I GET (RHO X)(I) IN RXI.
LA
RXI,MRHO(RXI)
XX
L
RXI,0(RXI,I4)
XX
CLI RHRANK+3,X'00'
BC
7,BEGAT
LA
RXI,1
BEGAT
LPR ABS,R0
BCR 15,UPDOWN
LWDOWN CR
RXI,ABS
BC
10,LWDN1
LR
R0,RXI
LWDN1
LR
R1,RXI
LTR R0,R0
BC
4,LWDN2
LCR R1,R1
LWDN2
AR
R0,R1
LPR ABS,R0
LWUP
MVC FEEL,ZORROS
ST
ABS,K(I4)
CR
ABS,RXI
BC
12,LWUP1
ST
RXI,K(I4)
SR
ABS,RXI
LTR R0,R0
BC
10,LWUP0
LCR ABS,ABS
LWUP0
ST
ABS,FEEL
LPR ABS,ABS
AR
ABS,RXI
LWUP1
ST
ABS,RHOS(I4)
LR
R1,R0
BCR 15,Q0
*

13200000
13400000
13600000
13800000
14000000
14200000
14400000
14600000
14800000
15000000
15200000
15400000
15600000
15800000
16000000
16200000
16400000
16600000
16800000
17000000
17200000
17400000
17600000
17800000
18000000
18200000
18400000
18600000
18800000
19000000
19200000
19400000
19600000
19800000
20000000
20200000
20400000
20600000
20800000
21000000
21200000
21400000
21600000
21800000
22000000
22200000
22400000
22600000
22800000
23000000
23200000
23400000
23600000
23800000
24000000
24200000
24400000
24600000
24800000
25000000

WSFULL LA
1,EMFULL
MUCH TOO BIG MATRIX REQUIRED
CALLERR ICALL ERROR
I CALL THE ERROR ROUTINE. GOODBYE.
LEFTMT MVI TEMPRGT,X'00'
L
R1,SVI
A
R1,NEG4
ST
R1,SVI
L
R0,M+20(R1)
ST
R0,M+4(R1)
BC
15,THEEND
SEE
ST
ABS,CNTSAVE
STORE THE COUNT FOR THE MOVES.
CR
ABS,RXI
BC
12,SEE1
ST
RXI,CNTSAVE
SEE1
EQU *
SR
RXI,ABS
CALCULATE THE RESIDUE.
ST
RXI,RES
XX
AR
RXI,ABS
ADD BACK WHAT WAS SUBTRACTED.
SR
W0,W0
ZERO OUT THE SUM.
ST
W0,SUMS
XX
C
W0,FEEL
BC
8,SEE3
BC
2,SEE2
S
W0,FEEL
SEE2
ST
W0,RES
SR
W0,W0
SEE3
S
W0,FEEL
BC
10,SEE4
SR
W0,W0
SEE4
ST
W0,FRONT
SR
W0,W0
LA
W1,1
START WITH A WEIGHT OF ONE.
LR
Q1,W1
ASLO START WITH AN INCREMENT OF ONE.
**********************************************************************
* BEGIN THE FIRST LOOP, CALCULATING THINGS FOR THE NEXT LOOP.
*
**********************************************************************
IT
ST
Q1,INC(I4)
STORE THE CURRENT INCREMENT.
L
Q1,LSP
M
Q0,FEEL
ST
Q1,FILL(I4)
SR
Q0,Q0
L
Q1,LSP
MR
Q0,ABS
ST
Q1,LSP
LTR Q0,Q0
REJECT MUCH TOO BIG RESULT
BNZ WSFULL
LR
Q1,RXI
CALCULATE THE NEXT INCREMENT.
SR
Q1,ABS
XX
BC
10,IT1
SR
Q1,Q1
IT1
EQU *
MR
Q0,W1
XX
LTR R1,R1
SEE IF THE SELECTED POSITIONS ARE
BC
10,RUN
AT THE BEGINNING OR END OF THE ROW.
LR
Q0,Q1
THEY ARE AT THE END.
A
Q0,SUMS
ECHE SUMS ACCORDINGLY.
ST
Q0,SUMS
XX
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
RUN
MR
W0,RXI
CALCULATE THE NEXT WEIGHT.
SH
I,HALF1
DECREASE THE INDEX BY ONE, AND TEST
LA
Q0,IT
FOR THE END OF LOOP ONE.

25200000
25400000
25600000
25800000
26000000
26200000
26400000
26600000
26800000
27000000
27200000
27400000
27600000
27800000
28000000
28200000
28400000
28600000
28800000
29000000
29200000
29400000
29600000
29800000
30000000
30200000
30400000
30600000
30800000
31000000
31200000
31400000
31600000
31800000
32000000
32200000
32400000
32600000
32800000
33000000
33200000
33400000
33600000
33800000
34000000
34200000
34400000
34600000
34800000
35000000
35200000
35400000
35600000
35800000
36000000
36200000
36400000
36600000
36800000
37000000

BC
10,BEGET
XX
**********************************************************************
* NOW DO SOME PRELIMINARY SETTING UP FOR THE NEXT LOOP, LIKE GETTING *
* SPACE FOR THE RESULT, SETTING UP REGISTERS, ETC..
*
**********************************************************************
COUNT
EQU 3
THESE ARFE THE REGISTER USES IN THIS
FROM
EQU 4
THIS LOOP.
TO
EQU 5
THIS IS THE SINK ADDRESS.
V
EQU 6
THIS IS THE INDEX FOR THE SINK.
SUM
EQU 7
INDEX OF SOUCE ELEMENT.
Y
EQU 8
HOLDS THE CURRENT COUNTER FOR MOVES.
NEG4R
EQU 9
HOLDS A NEGATIVE FOUR.
MOVER
EQU 10
ADDRESS OF MOVE ROUTINE.
L
R1,LSP
L
R2,ANSRANK
L
FROM,RHBASE
SR
R3,R3
IC
R3,MTYPE(FROM)
ST
R3,RHTYPE
L
10,=A(OPSPACE)
USE ALREADY EXISTING TECHNIQUES.
BALR LKR,10
XX
LR
TO,R1
GET THE ADDRESS OF THE NEW SPACE.
AR
R1,MR
MAKE AN ABSOLUTE ADDRESS OF IT.
L
FROM,RHBASE
GET THE SOURCE ADDRESS.
L
R2,MTYPE(FROM)
PUT THE TYPE AND NUMBER OF
HALF8
EQU *+2
HERE IS A CONVENIENT ADDRESS.
ST
R2,MTYPE-M(R1)
DIMENSIONS IN THE NEW SPACE.
L
R2,ANSRANK
HALFA
EQU *+2
STH R2,MRANK-M(R1)
BCTR R2,0
THIS IS FOR THE MVC COUNT.
EX
R2,ARRWMVC
THERE GOES THE RANK VECTOR.
L
R2,ANSRANK
LA
TO,MRHO-M(R2,TO)
ADDRESS OF ELEMENT ZERO OF THE SINK.
L
R2,RHRANK
NOW I MAKE TO CONTAIN THE M-RELATIVE
LA
FROM,MRHO-M(R2,FROM) LIKEWISE, I SET THE RECIEVING END.
SR
V,V
LET IT BEGIN WITH NOTHING.
C
V,LSP
SEE IF THERE ARE ANY ELEMENTS IN
BC
10,THEEND
THE RESULT, IF NOT SKIP IT.
L
SUM,SUMS
GET THAT SUM.
LA
MOVER,LJWMOVE
SET UP THE BASE REGISTER FOR MOVES.
L
NEG4R,NEG4
SET UP THAT CONSTANT.
LR
I,NEG4R
BEGIN WITH A MINUS NUMBER.
HALF1
EQU *+2
ANOTHER CONVENIENT ADDRESS.
LA
Y,1
THIS ADDRESS IS USED AS A CONSTANT.
C
V,RHXRHO
BC
7,THEN
L
COUNT,LSP
LA
LKR,THEEND
BC
15,FILLUP
**********************************************************************
* THIS IS THE REAL LOOP, IN WHICH THE APPROPRIATE MOVE ROUTINE GETS *
* CALLED THE CORRECT NUMBER OF TIMES WITH THE RIGHT SETUP EACH TIME. *
**********************************************************************
TRY
SR
I,NEG4R
ADD PLUS FOUR.
SR
COUNT,COUNT
S
COUNT,FILL(I)
BC
12,LOAD
BAL LKR,FILLUP
LOAD
L
Y,K(I)
LOAD THE COUNT FOR THIS DIMENSION.

37200000
37400000
37600000
37800000
38000000
38200000
38400000
38600000
38800000
39000000
39200000
39400000
39600000
39800000
40000000
40200000
40400000
40600000
40800000
41000000
41200000
41400000
41600000
41800000
42000000
42200000
42400000
42600000
42800000
43000000
43200000
43400000
43600000
43800000
44000000
44200000
44400000
44600000
44800000
45000000
45200000
45400000
45600000
45800000
46000000
46200000
46400000
46600000
46800000
47000000
47200000
47400000
47600000
47800000
48000000
48200000
48400000
48600000
48800000
49000000

STORE
THEN

ST
C
BC
DOTHE
L
LTR
BC
BAL
MOVE
L
L
BALR
SR
S
BC
LA
BC
SURELY A
MOVING QUEND
BCT
CR
BC
ON
SR
A
BC
BAL
WARD
BXLE
TOO
A
L
BCT
CR
BC
THEEND L
L
BCR
ARRWMVC MVC
FILLUP L
AR
BCT
FLIB1
SH
BC
HALF4
EQU
LA
BC
FLIB2
L
LCR
SRL
SLL
ST
CR
BC
LCR
LA
SR
BCR
FLIB4
SR
LA
LR
LA
SRL
BCTR
EX

Y,J(I)
I,LIM
4,TRY
COUNT,FRONT
COUNT,COUNT
8,MOVE
LKR,FILLUP
COUNT,CNTSAVE
R1,RHTYPE
LKR,MOVER
COUNT,COUNT
COUNT,RES
12,SURELY
LKR,MOVING
15,FILLUP
SUM,RES
Y,DOTHE
I,NEG4R
8,THEEND
COUNT,COUNT
COUNT,FILL(I)
12,WARD
LKR,FILLUP
I,NEG4R,THEEND
SUM,INC(I)
Y,J(I)
Y,STORE
NEG4R,I
4,ON
LKR,KEEPLKR
PR,KEEPPR
15,LKR
MRHO-M(0,R1),RHOS
R1,RHTYPE
R5,MR
R1,FILLINT
R6,K32
4,FLIB2
*+2
R5,4(R5)
15,FLIB1
R0,0(R5)
R6,R6
R0,0(R6)
R0,0(R6)
R0,0(R5)
R6,COUNT
4,FLIB4
R6,R6
R6,32(R6,COUNT)
R5,MR
15,LKR
COUNT,R6
R5,4(R5)
R6,COUNT
COUNT,7(COUNT)
COUNT,3
COUNT,0
COUNT,FLIBXC

INITIALIZE THE COUNTER.

INITIALIZE ALL COUNTERS FROM HERE
DOWN TO THE LAST DIMENSION.

49200000
49400000
49600000
49800000
50000000
50200000
50400000
SET UP THE COUNT OF ELEMENTS TO
50600000
TYPE FOR THE MOVE ROUTINES.
50800000
BE MOVED, AND THEN MOVE THEM.
51000000
51200000
51400000
51600000
51800000
52000000
ADD IN THE PART LEFT OVER, IF ANY. 52200000
52400000
52600000
52800000
53000000
53200000
53400000
53600000
53800000
54000000
54200000
54400000
54600000
54800000
55000000
RESTORE THE LKR AND THE PR.
55200000
THEN EXIT.
55400000
XX
55600000
MVC FOR FILLING IN THE RANK OF NEW. 55800000
56000000
56200000
56400000
56600000
56800000
57000000
57200000
57400000
57600000
57800000
58000000
58200000
58400000
58600000
58800000
59000000
59200000
59400000
59600000
59800000
60000000
60200000
60400000
60600000
60800000
61000000

LA
R1,255
SR
R5,MR
CR
COUNT,R1
BCR 12,LKR
NR
R1,COUNT
AR
R1,MR
LA
R1,1(R1,R5)
SRL COUNT,8
FLIB5
XC
0(256,R1),0(R1)
LA
R1,256(R1)
BCT COUNT,FLIB5
BCR 15,LKR
FILLINT SR
R0,R0
IC
R1,PIKTYPE(R1)
LTR R1,R1
BC
8,FLARC
FLINT1 SLL COUNT,0(R1)
SLL R6,0(R1)
AR
R5,R6
LR
R6,COUNT
AR
COUNT,NEG4R
FLINTINT ST
R0,0(R5,COUNT)
BXH COUNT,NEG4R,FLINTINT
AR
R5,R6
SR
R6,R6
SR
R5,MR
BCR 15,LKR
FLARC
LA
R0,ZBLANK
AR
R5,R6
LR
R6,COUNT
BCTR R5,0
FLARC1 STC R0,0(R5,COUNT)
BCT COUNT,FLARC1
SR
R5,MR
LA
R5,1(R5,R6)
LR
R6,COUNT
BCR 15,LKR
FLIBXC XC
0(0,R5),0(R5)
****************************************
* MISCELLANEOUS CONSTANTS.
*
****************************************
CNOP 0,4
ALIGN ON A FULL WORD BOUNDARY.
NEG4
DC
XL4'FFFFFFFC'
A NEGATIVE FOUR.
ZORROS DC
XL4'00000000'
LTORG *
AND HERE ARE THE LITERALS.
***********************************************************************
*** THESE ARE THE MOVE ROUTINES. ***********************************
** CONVENTIONS.......
*
** R1 = ARRAY TYPE, 1=BITS, 2=INTEGERS, 3=FLOATING, 4=CHARACTERS. *****
** R2 IS PRESERVED.
*
** R3 = COUNT OF ELEMENTS TO MOVE. *
** R4 = SOURCE ADDRESS, M-RELATIVE.
** R5 = SINK ADDRESS, M-RELATIVE.
** R6 = DESTINATION INDEX.
*
** R7 = SOURCE INDEX
*
***********************************************************************
LJWMOVE EQU *
THIS IS THE GENERAL PURPOSE MOVE RTN
USING *,MOVER
IT EVEN HAS ITS OWN BASE REGISTER.
BCT R1,MOVEINT
BRANCH IF IT IS NOT A BIT MOVE.
MVBIT1 SH
R6,K32
ADJUST THE BIT INDICES SO THAT

61200000
61400000
61600000
61800000
62000000
62200000
62400000
62600000
62800000
63000000
63200000
63400000
63600000
63800000
64000000
64200000
64400000
64600000
64800000
65000000
65200000
65400000
65600000
65800000
66000000
66200000
66400000
66600000
66800000
67000000
67200000
67400000
67600000
67800000
68000000
68200000
68400000
68600000
68800000
69000000
69200000
69400000
69600000
69800000
70000000
70200000
70400000
70600000
70800000
71000000
71200000
71400000
71600000
71800000
72000000
72200000
72400000
72600000
72800000
73000000

BC
LA
BC
SH
BC
LA
BC
AR
AR
LM
LCR
SRDL
L
LCR
SRL
SLDL
ST
CR
BC

4,MVBIT2
R5,4(R5)
15,MVBIT1
R7,K32
4,MVBIT3
R4,4(R4)
15,MVBIT2
R4,MR
R5,MR
R0,R1,0(R4)
R7,R7
R0,0(R7)
R0,0(R5)
R6,R6
R0,0(R6)
R0,0(R6)
R0,0(R5)
R6,COUNT
4,MVBIT4

THEY ARE LESS THAN 32.

XX
XX
THE BASIC APPROACH IN THIS ROUTINE
IS TO MOVE ENOUGH BITS INITIALLY TO
MAKE THE DESTINATION FIELD START ON
A FULL WORD BOUNDARY.
THEN THE NUMBER OF BITS MOVED IS
COMPARED AGAINST THE COUNT.
IF THE NUMBER OF BITS MOVED TO
FILL OUT THE WORD IN THE DESTINATION
FIELD IS AT LEAST AS LARGE AS THE
COUNT, THEN I AM ALL FINISHED MOVING
THE BITS, AND MERELY HAVE TO ADJUST
THE BIT INDICES IN R6 AND R7 FOR THE
NEXT ENTRY INTO THIS ROUTINE.

73200000
73400000
73600000
MVBIT2
73800000
74000000
74200000
74400000
MVBIT3
74600000
74800000
75000000
75200000
75400000
75600000
75800000
76000000
76200000
76400000
IF THERE ARE STILL MORE BITS TO BE 76600000
MOVED, THEN I GO INTO A LOOP TO
76800000
*
MOVE THE REMAINDER.
77000000
*---------------------------------------------------------------------- 77200000
LCR R6,R6
HERE THE COUNT IS NOT GREATER THAN 77400000
LA
R6,32(R6,COUNT)
THE NUMBER OF BITS ALREADY MOVED.
77600000
LCR R7,R7
FIX UP R7.
77800000
LA
R7,32(R7,COUNT)
XX
78000000
SR
R5,MR
MAKE THESE M-RELATIVE AGAIN.
78200000
SR
R4,MR
XX
78400000
BCR 15,LKR
RETURN TO FROM WHENCE IT CAME.
78600000
MVBIT4 LCR R7,R7
HERE IS THE LOOP TO MOVE THE REST
78800000
LA
R7,32(R6,R7)
OF THE BITS.
79000000
SR
COUNT,R6
NOTE THE INTERESTING SEQUENCE WITH 79200000
LA
R6,32
THE LM, SLDL, AND ST.
79400000
K32
EQU *-2
MIGHT AS WELL USE THIS.
79600000
CR
R7,R6
79800000
BC
4,MVBIT6
80000000
SH
R7,K32
80200000
MVBIT5 LA
R4,4(R4)
80400000
MVBIT6 LA
R5,4(R5)
80600000
LM
R0,R1,0(R4)
80800000
SLDL R0,0(R7)
81000000
ST
R0,0(R5)
81200000
SR
COUNT,R6
81400000
BC
2,MVBIT5
81600000
AR
R6,COUNT
81800000
AR
R7,R6
82000000
SR
R4,MR
82200000
SR
R5,MR
82400000
BCR 15,LKR
82600000
* TYPE 2, 3, OR 4 TAKEN CARE OF HERE.
82800000
MOVEINT EQU *
MOVE INTEGER.
83000000
MOVECHR EQU *
CHARACTER MOVES PROCESSED HERE.
83200000
MOVEFLP EQU *
FLOATING POINT MOVES HERE.
83400000
IC
R1,PIKTYPE(R1)
GET THE SHIFT AMOUNT.
83600000
SLL COUNT,0(R1)
MULTIPLY THE COUNT BY THE ELEMENT
83800000
SLL R6,0(R1)
SIZE, AS WELL AS THE INDICES FOR THE 84000000
SLL R7,0(R1)
SOURCE AND SINK.
84200000
R7
EQU 7
84400000
R6
EQU 6
84600000
R5
EQU 5
84800000
AR
R4,MR
85000000

AR
R4,R7
ADD THE INDEX TO THE SOURCE ADDRESS.
AR
R5,MR
AR
R5,R6
ADD THE INDEX TO THE SINK ADDRESS.
AH
COUNT,NEG257
LA
R0,256
PREPARE FOR THE BXLE.
BC
4,LAST1
BRANCH IF ONLY ONE MVC. A524
R0
EQU 0
LA
R1,0(TO,COUNT)
MOVEIT MVC 0(256,TO),0(FROM)
AR
FROM,R0
BXLE TO,R0,MOVEIT
LAST1
EX
COUNT,MVCMINE
LA
R6,255
PREPARE TO ADD INTO THE TO, FROM TH
NR
R6,COUNT
AMOUNT OF THE LAST (SHORT) MOVE.
SR
R6,MR
SIMULTANEOULSY RELATIVIZE THE PTRS.
LA
TO,1(TO,R6)
LA
FROM,1(FROM,R6)
SR
R6,R6
MAKE THE RELATIVE ELEMENT INDICES
LR
R7,R6
ZERO AGAIN.
BCR 15,LKR
MVCMINE MVC 0(0,TO),0(FROM)
NEG257 DC
XL2'FEFF'
PIKTYPE DC
XL1'FF'
TYPE
DC
XL1'02'
TYPE TWO, INTEGER.
DC
XL1'03'
TYPE 3, FLOATING POINT.
DC
XL1'00'
TYPE 4, CHARACTERS.
**********************************************************************
***** THIS IS MY DSECT, WHICH I HOPE FITS IN WITH OPSECT. ***********
**********************************************************************
OPSECT DSECT
ORG FACTSAVE
THIS SHOULD WORK.
KEEPPR DC
XL4'00000000'
HOLDS THE BASE REGISTER FOR OTHER .
KEEPLKR DC
XL4'00000000'
SPACE TO SAVE THE LINK REGISTER.
CNTSAVE DC
XL4'00000000'
SAVE THE COUNT FOR MOVE ROUTINES.
SUMS
DC
XL4'00000000'
SAVE THE SUM.
LIM
DC
XL4'00000000'
LIMIT FOR A IN SECOND LOOP.
RES
DC
XL4'00000000'
THE RESIDUE.
K
DC
XL4'00000000'
THE COUNTERS FOR VARIOUS DIMENSIONS.
DC
10XL4'00000000'
XX
ORG
TESTAREA
I MUST NOT USE THAT OTHER WORD, BAD.
LSP
DC
XL4'FFFFFFFF'
INC
DC
XL4'00000000'
THE INCREMENTS FOR DIMENSIONS.
DC
10XL4'00000000'
XX
FRONT
DC
XL4'00000000'
ANSRANK DC
XL4'00000000'
FILL
DC
XL4'00000000'
DC
10XL4'00000000'
J
DC
XL4'00000000'
THE CURRENT COUNTERS.
RHOS
EQU J
DC
10XL4'00000000'
XX
RAT
DC
XL4'00000000'
FEEL
DC
XL4'00000000'
END
./ ADD
NAME=APLSTBCD
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, ZSYMBOLS
TBCD
TITLE 'O U T P U T C O N V E R S I O N
05/11/70'
TOBCD
CSECT

85200000
85400000
85600000
85800000
86000000
86200000
86400000
86600000
86800000
87000000
87200000
87400000
87600000
87800000
88000000
88200000
88400000
88600000
88800000
89000000
89200000
89400000
89600000
89800000
90000000
90200000
90400000
90600000
90800000
91000000
91200000
91400000
91600000
91800000
92000000
92200000
92400000
92600000
92800000
93000000
93200000
93400000
93600000
93800000
94000000
94200000
94400000
94600000
94800000
95000000
95200000
95400000
95600000
00330000
00660000
00990000
01320000
01980000
02310000

TOBCD

*
*
*
*
*
*
*
*
*
*
* IT IS
TBCDBITE

TBCDINT
TBCDINT2

*
TBCDINT3
*
TBFLT

*
*

COPY APLDEFN
COPY ZSYMBOLS
TITLE 'O U T P U T C O N V E R S I O N
CSECT
PRINT ON
EXTRN DPDIV
EXTRN DPMUL
EXTRN SQUIRT
EXTRN TOPRINT
PROLOG TOBCDWK,TOBEND
TOBCD

05/11/70'

OUTPUT CONVERSION AND FORMATTING ROUTINE

CALL .. ICALL TOBCD
R0,R1 = VALUE, LEFT-JUSTIFIED
R2
= TYPE = 1, 2, 3, 4
R3
= CONTROL INFORMATION -BYTES 0, 1
PLACES LEFT OF DECIMAL POINT
(FLOATING CONVERSION ONLY)
BYTES 2, 3
FIELD WIDTH (ZERO IF FREE-FIELD)

STM 3,6,WIDTH
SAVE CONTROL INFORMATION AND R4-R6
BCT 2,TBCDINT
FALL THROUGH IF LOGICAL CONVERSION
A LOGICAL VARIABLE, PLACE A ZERO OR A ONE IN THE OUTPUT BYTE.*
SRL 0,31
B
TBCDINT2
TREAT IT AS AN INTEGER 1 OR 0 .
SRL 0,24
LR
1,0
ICALL TOPRINT
IRETURN
BCT 2,TBFLT
FALL THROUGH IF INTEGER CONVERSION
CVD 0,TBFLTW1
CONVERT TO DECIMAL
MVI TBSTRING,X'FC'
AND EDIT INTO A 12-CHARACTER FIELD
MVI TBSTRING+1,X'20'
WITH LEADING BLANKS.
MVC TBSTRING+2(10),TBSTRING+1
MVI TBSTRING+10,X'21' ZERO EDITED TO SINGLE DIGIT
LA
1,TBSTRING+11
ANTICIPATE ZERO VALUE
LR
4,1
R4 IS END-OF-SIGNIFICANCE ADDRESS
EDMK TBSTRING(12),TBFLTW1+2
BNL TBCDINT3
RESULT IS POSITIVE OR ZERO
BCTR 1,0
PREFACE NEGATIVE VALUE BY HIGH
MVI 0(1),X'FA'
MINUS SIGN.
FOR PROCESSING AT TBX, SET UP ...
LR
6,4
R4 = ADDR OF RIGHTMOST SIGNIFICANT
SH
6,WIDTH+2
R6 = ADDR OF LEFT END - 1, FOR MATRX
BCT 1,TBX
R1 = ADDR OF LEFT END - 1, FOR VECTR
(BRANCH ALWAYS GOES)
SPACE 2
BCT 2,TBCDBITE
FALL THROUGH IF FLOATING CONVERSION
STM 0,1,TBFLTW0
LD
0,TBFLTW0
LA
3,85
R3 WILL CONTAIN THE DECIMAL EXPONENT
OFFSET BY 100 TO KEEP IT POSITIVE.
85 IS A GLITCH FOR CONSTANT 0.0
SDR 2,2
ADR 0,2
MAKE SURE CONVERTEE IS NORMALIZED
STE 0,TBFLTW0
REMOVE NEG SIGN IF NEG 0
LPER 0,0
REMOVE SIGN OF CONVERTEE
BZ
TBFLTZRO
QUIT SCALING IF ZERO
LA
3,100
LA
4,D106
PREPARE FOR LARGE SCALEDOWN

02640000
02970000
03300000
03630000
03960000
04290000
04620000
04950000
05280000
05610000
05940000
06270000
06600000
06930000
07260000
07590000
07920000
08250000
08580000
08910000
09240000
09570000
09900000
10230000
10560000
10890000
11220000
11550000
11880000
12210000
12540000
12870000
13200000
13530000
13860000
14190000
14520000
14850000
15180000
15510000
15840000
16170000
16500000
16830000
17160000
17490000
17820000
18150000
18480000
18810000
19140000
19470000
19800000
20130000
20460000
20790000
21120000
21450000
21780000
22110000

LA
CLI
* NON CRITICAL
BL
L
BALR
CE
BL
LA
BR
TBFLT2 LA
BALR
CE
BL
LA
BR
TBFLT2A CH
BNZ
*
LA
CLI
BL
L
LD
BALR
SH
CE
BCR
LD
BALR
BCTR
CE
BCR
LA
TBRND
L
CD
BL
BCTR
TBRND1 SLA
SDR
LE
ADR
ADR
*
TBFLTZRO STD
MVI
LM
D
CVD
CVD
*
*
*
*
*
*
*
*
*
*

5,TBDIV
EITHER SINGLE PRECISION
OSIGDIG+3,14
FOR 13 DIGITS OR LESS,
-- CHANGE 14 TO 16 WHEN GUARD DIGIT EC INSTALLED
*+8
5,=A(DPDIV)
OR DOUBLE PRECISION.
2,0
0,QBSD
DO WE NEED A BIG SCALEDOWN -TBFLT2
NO.
3,6(3)
BUMP EXPONENT BY 6.
5
SCALE DOWN BY 1E6.
4,D10
PREPARE FOR SMALL SCALEDOWN
2,0
0,QSSD
DO WE NEED A SMALL SCALEDOWN -TBFLT2A
NO.
3,1(3)
YES. BUMP EXPONENT BY 1.
5
SCALE DOWN BY 10.0
3,QH100
CHECK FOR ZERO (100) EXPONENT
TBRND
IF NONZERO, FRACTION WAS SCALED UP
AND NEEDN'T BE SCALED DOWN AGAIN.
5,TBMUL
PREPARE FOR SINGLE PRECISION
OSIGDIG+3,14
OR DOUBLE PRECISION MULTIPLY.
*+8
5,=A(DPMUL)
6,D106
2,0
3,QH6
DROP DECIMAL EXPONENT
0,QBSU
DO WE NEED A BIG SCALEUP -4,5
YES.
6,D10
2,0
3,0
DROP DECIMAL EXPONENT
0,QSSU
DO WE NEED A SMALL SCALEUP -4,5
YES.
3,7(3)
CORRECT EXPONENT AGAIN.
1,OSIGDIG
PREPARE TO ROUND FRACTION BY 5 IN
0,D1016
FIRST NONPRINTING POSITION
TBRND1
1,0
1,2
4,4
CLEAR LONG REGISTER
4,DRND-4(1)
AND LOAD SHORT CONSTANT.
2,4
ADD ROUNDING CONSTANT INTO SMALL
0,2
PART OF FRACTION, THEN COMBINE FRACS
REENTRY FOR ZERO VALUE. EXPONENT IS 1.
0,TBFLTW1
NOW 1.6E16 GTR D0 GEQ 1E15
TBFLTW1,X'00'
GET RID OF THE EXPONENT BITS.
0,1,TBFLTW1
GET R AND Q IN R0 AND R1 SO THAT
0,QF1E8
((Q X 1E8)+R) = N .
0,TBFLTW2
CONVERT R TO DECIMAL
1,TBFLTW1
CONVERT Q TO DECIMAL
01234567
-------W1 IS NOW 000XXXXX
000XXXXS
01234567
-------W2 IS NOW 0000XXXX
000XXXXS

22440000
22770000
23100000
23430000
23760000
24090000
24420000
24750000
25080000
25410000
25740000
26070000
26400000
26730000
27060000
27390000
27720000
28050000
28380000
28710000
29040000
29370000
29700000
30030000
30360000
30690000
31020000
31350000
31680000
32010000
32340000
32670000
33000000
33330000
33660000
33990000
34320000
34650000
34980000
35310000
35640000
35970000
36300000
36630000
36960000
37290000
37620000
37950000
38280000
38610000
38940000
39270000
39600000
39930000
40260000
40590000
40920000
41250000
41580000
41910000

42240000
TBFLTW2+3(1),TBFLTW1+7 CATENATE THE QUOTIENT AND
42570000
TBFLTW1+7(4),TBFLTW1+3 DIVISOR, IGNORING THE SIGN OF
42900000
*
THE QUOTIENT.
43230000
* NOW THERE ARE 17 DECIMAL DIGITS PLUS THE SIGN IN THE NUMBER,
* 43560000
* BEGINNING AT TBFLTW1+7 AND ENDING WITH TBFLTW2+7.
43890000
MVI TBFILL,X'FC'
44220000
MVC TBFILL+1(18),TBFILL CREATE EDIT PATTERN OF BLANKS AND
44550000
MVI TBSTRING+7,X'21'
44880000
MVC TBSTRING+8(16),TBSTRING+7 SIGNIFICANCE STARTERS.
45210000
EDMK TBSTRING+6(18),TBFLTW1+7
45540000
*
45870000
*
IN THE FOLLOWING,
46200000
*
R2 = ADDRESS OF LEFTMOST SIGNIFICANT CHARACTER
46530000
*
R3 = DECIMAL EXPONENT
46860000
*
R4 = ADDRESS OF RIGHTMOST SIGNIFICANT CHARACTER
47190000
*
R5 = ADDRESS AT WHICH TO INSERT DECIMAL POINT
47520000
*
(POSSIBLY DISPLACED 1 TO THE LEFT)
47850000
*
R6 = ADDRESS OF LEFT END OF FIELD TO BE PRINTED
48180000
*
(ALSO POSSIBLY DISPLACED 1 TO THE LEFT)
48510000
*
48840000
LA
2,TBSTRING+7
FIND LEFTMOST SIGNIFICANT DIGIT
49170000
CLI TBSTRING+7,X'FC'
(EXCEPT FOR 0.0, ALL VALUES ARE
49500000
*
AT LEAST 16 DIGITS)
49830000
BNE TBFLT4
POSITION 7
50160000
LA
2,1(2)
POSITION 8
50490000
BCTR 3,0
EXPONENT IS DOWN 1, TOO.
50820000
TBFLT4 SH
3,QH84
REMOVE EXCESS 100 ADJUSTED FOR SCALE 51150000
LR
4,2
RIGHTMOST SIGNIFICANT DIGIT IS
51480000
A
4,OSIGDIG
51810000
BCTR 4,0
(OSIGDIG-1) FROM LEFTMOST
52140000
LR
5,2
ASSUME DECIMAL POINT FOLLOWS LEFT- 52470000
CLI WIDTH+1,X'FF'
MOST DIGIT (E-FORMAT)
52800000
*
SEPARATE CASES OF FORMATTING
53130000
BE
TBFLT10
E-FORMAT MATRIX
53460000
*
F-FORMAT MATRIX OR FREE-FORMAT VECTOR
53790000
MVI IR,0
ASSUME VECTOR NOT IN RANGE
54120000
*
(CALLER GUARANTEES MATRIX IN RANGE) 54450000
CLI WIDTH+3,0
PREPARE TO LOCATE THE DECIMAL POINT 54780000
BNE TBFLT6
MATRIX OUTPUT. POINT IS AT LSIG+EXP 55110000
CH
3,QHM4
VECTOR OUTPUT. POINT IS AT LSIG+EXP 55440000
BL
TBFLT7
ONLY IF EXP IS IN RANGE.
55770000
C
3,OSIGDIG
56100000
BNL TBFLT7
EXPONENT GREATER THAN NO. OF SIG DIG 56430000
TBFLT6 AR
5,3
EXPONENT IN RANGE.
56760000
MVI IR,X'FF'
INHIBIT EXPLICIT EXPONENT
57090000
TBFLT7 CR
4,5
DELETE TRAILING ZEROS
57420000
BNH TBFLT8
RIGHT OF THE DECIMAL POINT.
57750000
CLI 0(4),X'F0'
IS RIGHTMOST A ZERO -58080000
BNE TBFLT8
NO. QUIT NOW.
58410000
BCT 4,TBFLT7
DROP RSIG AND CHECK NEXT DIGIT
58740000
TBFLT8 MVI 1(4),X'FC'
BLANK ALL DIGITS TO RIGHT OF RSIG
59070000
MVC 2(20,4),1(4)
PLUS SOME EXTRA TO SAVE CALCULATING 59400000
*
AN MVC COUNT
59730000
CR
5,2
NEGATIVE IN-RANGE EXPONENT REQUIRES 60060000
BNL TBFLT9
LEADING ZEROS.
60390000
LR
2,5
FROM POSITION LSIG (NOW = TO DECPT) 60720000
LCR 1,3
MOVE IN (-EXP) LEADING ZEROS (MAX 4) 61050000
BCTR 1,0
61380000
EX
1,TBMVZR
61710000
MVZ
MVC

TBFLT9

*
TBFLT10
*
*
*
TBFLT11
*

TBFLT12
TBFLT13
*

TBFLT14

TBFLT16

*
TBFLT17
*
TBX

TBFLT18

TSTUFTR
TSTUFTT

LA
SH
B
SPACE

6,1(5)
COMPUTE LEFT END OF F-FORMAT FIELD
6,WIDTH
AS DECIMAL POINT POSITION + 1
TBFLT11
MINUS DEC PT OFFSET FROM LEFT END
2
E - FORMAT MATRIX.
LR
6,2
LEFT END OF FIELD IS LSIG-2
SH
6,QH3
CARRIED AS TRUE VALUE - 1
DECIMAL POINT POSITION IS POSITION
OF LEFTMOST SIGNIFICANT DIGIT.
ATTACH MINUS SIGN AND DECIMAL POINT
BCTR 2,0
CARRY LSIG AS TRUE VALUE - 1
MVI 0(2),X'FC'
ASSUME VALUE IS POSITIVE
LR
1,2
R1 CALCULATES LEFT END OF FIELD
FOR VECTORS
TM
TBFLTW0,X'80'
IS VALUE NEGATIVE -BZ
TBFLT12
NO.
MVI 0(2),X'FA'
YES. ATTACH SIGN.
BCTR 1,0
MOVE POTENTIAL LEFT END OVER.
CLI WIDTH+3,0
IS THIS VECTOR OUTPUT -BNZ TBFLT13
LR
6,1
YES. ESTABLISH LEFT END.
CLR 5,4
ATTACH DECIMAL POINT.
BNL TBFLT14
NO DECIMAL POINT IF BEYOND LAST
SIGNIFICANT DIGIT.
LR
1,5
CALCULATE NO. OF CHARS LEFT OF
LA
0,TBSTRING
DECIMAL POINT, WHICH MUST BE MOVED.
SR
1,0
EX
1,TBMVLFT
OVERLAPPED MOVE LEFT
MVI 0(5),X'FB'
INSERT POINT IN VACATED POSITION
BCTR 6,0
ADJUST LEFT END OF DECIMAL POINT
CLC WIDTH+1(1),IR
ATTACH AN 'E' IF REQUESTED BY CALLER
BL
TBFLT17
OR IF EXPONENT IS NOT IN F-FMT RANGE
CVD 3,TBFLTW1
CONVERT EXPONENT
LA
1,TBFLTW1+2
ANTICIPATE ZERO EXPONENT
MVC TBFLTW1-1(7),EXPAT EDIT IT TO LEADING E'S, 2 OR 1
EDMK TBFLTW1-1(4),TBFLTW1+6 DIGITS, AND 3 TRAILING BLANKS.
BCTR 1,0
ADDRESS THE TRAILING E
BNM TBFLT16
IS EXPONENT NEGATIVE -MVI 0(1),X'FA'
YES. MOVE IN HIGH MINUS SIGN,
BCTR 1,0
ADDRESS NEW TRAILING E.
MVC 1(5,4),0(1)
INSERT EXPONENT AND BLANKS IN FIELD.
SR
4,1
MOVE RIGHTMOST SIGNIFICANT ADDRESS
LA
1,TBFLTW1+3
OVER BY LENGTH OF EXPONENT,
AR
4,1
IGNORING TRAILING BLANKS.
PREPARE TO SEND CONVERTED STRING TO OUTPUT BUFFER
LR
1,6
FINAL ADDRESS OF LEFT END OF FIELD
REENTRY FROM INTEGER CONVERSION ROUTINE
SR
4,1
LENGTH IS RIGHTMOST SIGNIFICANT
CLI WIDTH+3,0
MINUS (LEFT END - 1)
BE
TBFLT18
FOR VECTORS,
LH
4,WIDTH+2
CALLER'S FIELD WIDTH FOR MATRICES.
LR
1,6
SUPERFLUOUS FOR MATRIX OUTPUT
EX
4,TSTUFTR
TRANSLATE OUTPUT TO Z-SYMBOLS
STC 4,0(1)
INSERT TRUE COUNT
ICALL SQUIRT
AND SQUIRT FIELD INTO BUFFER.
LM
4,6,TBCDRSV
IRETURN
TR
0(0,1),TSTUFTT
EQU *-C'0'
DC
AL1(Z0)

62040000
62370000
62700000
63030000
63360000
63690000
64020000
64350000
64680000
65010000
65340000
65670000
66000000
66330000
66660000
66990000
67320000
67650000
67980000
68310000
68640000
68970000
69300000
69630000
69960000
70290000
70620000
70950000
71280000
71610000
71940000
72270000
72600000
72930000
73260000
73590000
73920000
74250000
74580000
74910000
75240000
75570000
75900000
76230000
76560000
76890000
77220000
77550000
77880000
78210000
78540000
78870000
79200000
79530000
79860000
80190000
80520000
80850000
81180000
81510000

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
TBDIV
DD
BR
TBMUL
MDR
BR
TBMVLFT MVC
TBMVZR MVC
TBZROS DC
EXPAT
DC
QHM4
DC
QH3
DC
QH6
DC
QH84
DC
QH100
DC
QF1E8
DC
DRND
DC

AL1(Z1)
81840000
AL1(Z2)
82170000
AL1(Z3)
82500000
AL1(Z4)
82830000
AL1(Z5)
83160000
AL1(Z6)
83490000
AL1(Z7)
83820000
AL1(Z8)
84150000
AL1(Z9)
84480000
AL1(ZOVB)
FA
84810000
AL1(ZPER)
FB
85140000
AL1(ZBLANK)
FC
85470000
AL1(ZE)
FD
85800000
0,0(4)
SINGLE PRECISION DIVIDE
86130000
2
86460000
0,6
SINGLE PRECISION MULTIPLY
86790000
2
87120000
TBSTRING(0),TBSTRING+1
87450000
0(0,2),TBZROS
87780000
C'0000'
88110000
X'FD202120FCFCFC' LEADING E'S, TRAILING BLANKS
88440000
H'-4'
88770000
H'3'
89100000
H'6'
89430000
H'84'
89760000
H'100'
90090000
F'1E8'
90420000
E'5E14,5E13,5E12,5E11,5E10,5E9,5E8,5E7,5E6,5E5,5E4,5E3,5X90750000
E2,5E1,5E0,5E-1'
91080000
D1016
DC
D'1E16'
91410000
D106
DC
D'1E6'
91740000
D10
DC
D'10'
92070000
QBSD
DC
X'531834A1' 1E5 * 16**14 - 5E19 BIG SCALEDOWN THRESHOLD 92400000
QSSD
DC
X'4EFE3940' 16**14 - 5E15
SMALL SCALEDOWN ''
92730000
QBSU
DC
X'4A10A92A' 16**14 / 1E6 - 5E8 BIG SCALEUP
''
93060000
QSSU
DC
X'4E196C20' 16**14 / 10 - 5E13 SMALL SCALEUP
''
93390000
LTORG
93720000
TOBCDWK DSECT
94050000
TBFLTW0 DS
D
FLOATING HEX VALUE, SAVED FOR SIGN 94380000
TBFLTW1 DS
D
94710000
TBFLTW2 DS
D
95040000
WIDTH
DS
4F
CONTROL INFORMATION PARAMETER
95370000
TBCDRSV EQU WIDTH+4
95700000
IR
DS
XL1
96030000
TBFILL DS
XL12
LEADING BLANKS FOR TBSTRING
96360000
TBSTRING DS
CL44
OUTPUT STRING, PLUS 20 EXTRA PLACES 96690000
*
TO SAVE CALCULATING AN MVC COUNT
97020000
TOBEND EQU *
97350000
END
97680000
./ ADD
NAME=APLSTPIN
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
00020000
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
00040000
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
00060000
PRINT OFF
00080000
TPIN
TITLE 'S T A T E M E N T I N P U T A N D F U N C T I O NX00100000
D E F I N I T I O N'
00120000
PRINT ON
00140000
MACRO
00160000
&L
CMD &CMD,&ADR,&N,&FLAGS
00180000
LCLA &I
00200000

&L
.CM1
&I
&CHAR
&I

&QZ

TYPEIN

VALCON

LCLC &CHAR
00220000
DC
0F'0'
00240000
AIF (&I EQ &I).CM1
APL DEVELOPMENT GLITCH
00260000
ANOP
00280000
SETA &I+1
00300000
SETC '&CMD'(&I,1)
00320000
DC
AL1(Z&CHAR)
00340000
AIF (&I LT K'&CMD).CM1
00360000
SETA 4-K'&CMD
00380000
DC
&I.AL1(0)
00400000
DC
AL2(&ADR-SYSTO)
00420000
DC
AL1(&N)
00440000
DC
AL1(&FLAGS)
00460000
MEND
00480000
SPACE 1
00500000
MACRO
00520000
SCANT &X
00540000
ORG SCANT+4+(Z&QZ-ZPER)*2
00560000
DC
Y(&X-IDL)
00580000
MEND
00600000
SPACE 1
00640000
CSECT
00680000
COPY APLDEFN
00700000
COPY ZSYMBOLS
00720000
COPY PERTERM
00740000
EJECT
2230 00760000
APLSUPC ,
MAPS SUPPARS AREA IN APLSUP
2230 00780000
EQU 0
AVOIDS ASM ERROR
2230 00800000
PRINT OFF
00820000
TITLE 'S T A T E M E N T I N P U T A N D F U N C T I O NX00840000
D E F I N I T I O N'
00860000
PRINT NOGEN,ON
00880000
EJECT
00900000
ENTRY DPDIV
00920000
ENTRY DPMUL
00940000
EXTRN COPYID
00960000
EXTRN DIREMP
00980000
EXTRN DISPLAY
01000000
EXTRN DSIRMSG
'IMPROPER REFERENCE TO PRIVATE LIB' 01020000
EXTRN FETCH
01040000
EXTRN GCOL
01060000
EXTRN GETIME
01080000
EXTRN GETSPACE
01100000
EXTRN KMANHASH
01120000
EXTRN LOUT
01140000
EXTRN LOUTI
01160000
EXTRN LOUTN
01180000
EXTRN MKGARB
01200000
EXTRN PLINE
01220000
EXTRN PRNUM
01240000
EXTRN SUPPARS
MAPPED BY SUPPARD DSECT
2230 01260000
EXTRN PRWSNAME
01280000
EXTRN SOOKEXTX
01300000
EXTRN SOOKTXT
SEP ASSEMBLY FOR EASY MODIFICATION 01320000
EXTRN SQUIRT
01340000
EXTRN SYNTXX
01360000
EXTRN TOBCD
01380000
EXTRN TOPRINT
01400000
EXTRN WSLEN
01420000
EXTRN ZSYMDATE
DATE STORED IN ZSYMBOLS
01440000

CLEOS
CEOS
CREM
CDUM
CECONST
CBCONST
CICONST
CFCONST
CCCONST
CCOMMA
CLARROW
CSEMIC
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU
EQU

ZLEOS*2+1
ZEOS*2+1
ZREM*2+1
ZDUM*2+1
ZECONST*2+1
ZBCONST*2+1
ZICONST*2+1
ZFCONST*2+1
ZCCONST*2+1
ZCOMMA*2+1
ZLARROW*2+1
ZSEMIC*2+1

A NOTE ON KLUGEY TREATMENT OF MX, TOCORG, AND TOCPTR

DURING EXECUTION, THE LOWER BOUNDARY OF THE GARBAGE BETWEEN
LOW M AND HIGH M IS ALWAYS ADDRESSED BY MX.
THIS IS NOT SO IN TYPEIN. MX NORMALLY IS NOT MOVED UNTIL A
COMPLETE, ERROR-FREE CODESTRING HAS BEEN BUILT ABOVE MX,
ADDRESSED BY TOCORG AND TOCPTR. THIS GENERALLY CAUSES NO
TROUBLE. UNFORTUNATELY, ANY INPUT OR OUTPUT REQUESTED WHILE
SUCH A CODESTRING IS BEING BUILT MAY RESULT IN LOSS OF THE
CODESTRING (IF I/O CAUSES SUSPENSION CAUSING WORKSPACE TO BE
WRITTEN TO DISK.) MX CANNOT BE USED AS A RUNNING INDEX TO THE
NEW CODESTRING, BECAUSE IN THE EVENT OF AN ERROR (OR ANYTHING
ELSE WHICH WOULD INTERRUPT NORMAL PROCESSING) MX WOULD NOT BE
RESET TO ITS ORIGINAL VALUE, AND WE WOULD HAVE A CODESTRING
FRAGMENT DRIFTING AROUND IN M, WREAKING HAVOC AND MINOR NUISANCE. SO, MX MUST BE LEFT AT THE BASE OF THE CODESTRING
UNTIL WE ARE SURE IT IS A GOOD CODESTRING (AT CRL, Q.V.)
TO GET AROUND ALL OF THIS, INLINE (OR ITS CALLER, NAMELY
EOBSUB) ALWAYS SETS MX TO THE VALUE OF THE CODESTRING POINTER
BEFORE ALLOWING ANY I/O, AND RESTORES MX TO THE VALUE OF THE
CODESTRING ORIGIN IMMEDIATELY FOLLOWING THE TYI SEQUENCE.
A SIMILAR NOTE ON TREATMENT OF SVI AND SVIT
FOR REASONS EXPLAINED ABOVE, SVI ALWAYS POINTS TO THE LOWEST
LOCATION IN USE BELOW EXECUTION STACK. AT ENTRY TO TYPEIN,
THIS IS (OR SHOULD BE) PARREL-4. HOWEVER, M-ENTRIES FOR NEW
LONG PRINTNAMES ARE BUILT WORKING DOWNWARD FROM SVI WHILE A
CODESTRING IS BEING BUILT WORKING UPWARD FROM MX. SVI MUST
THEREFORE POINT TO THE LOWEST NEW M-ENTRY.
AT END-OF-STATEMENT, WHEN THE CODESTRING IS COMPLETE, MX IS
SET ABOVE THE NEW PRINTNAMES AND GARBAGE IS COLLECTED, MOVING
THE PRINTNAMES DOWN BELOW MX WHERE THEY SHOULD BE.
IN FUNCTION DEFINITION, 12-BYTE ENTRIES FOR NEW OR FRACTIONAL
LINE NUMBERS ARE ALSO BUILT WORKING DOWNWARD FROM THE STACK.
THESE, HOWEVER, ARE ADDED ONLY AFTER THE GARBAGE COLLECTION AT
END-OF-STATEMENT, AND ALWAYS RESIDE ABOVE ANY NEW PRINTNAMES.
THIS IS IMPORTANT, BECAUSE IT MEANS THAT FRACTIONAL-LINE
ENTRIES DO NOT NEED TO CONTAIN STORAGE-ALLOCATION OVERHEAD.
THE VARIABLE SVIT (ALWAYS GEQ SVI) POINTS TO 4 BYTES BELOW THE
LOWEST FRACTIONAL-LINE ENTRY. IT IS DROPPED BY 12 EACH TIME A
NEW FRACTIONAL LINE IS ADDED.
THE PURPOSE OF ALL OF THIS IS TO ALLOW GARBAGE COLLECTIONS
DURING FUNCTION DEFINITION, SO THAT SOMEONE WITH A WSFULL
ERROR IN DEFINITION MODE CAN DELETE LINES UNTIL IT IS POSSIBLE
TO CLOSE THE FUNCTION.

01460000
01480000
01500000
01520000
01540000
01560000
01580000
01600000
01620000
01640000
01660000
01680000
01700000
01720000
01740000
01760000
01780000
01800000
01820000
01840000
01860000
01880000
01900000
01920000
01940000
01960000
01980000
02000000
02020000
02040000
02060000
02080000
02100000
02120000
02140000
02160000
02180000
02200000
02220000
02240000
02260000
02280000
02300000
02320000
02340000
02360000
02380000
02400000
02420000
02440000
02460000
02480000
02500000
02520000
02540000
02560000
02580000
02600000
02620000
02640000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
TYPEIN

CHECKS ARE MADE FOR ADEQUATE FREE SPACE WHEN BUILDING A CODESTRING (AT FREECH), FORMING AN M-ENTRY FOR A NEW LONG PRINTNAME (AT SRCHB), CLOSING A CODESTRING IN DEFINITION MODE (AT
CRL5), AND WHEN CLOSING A DEFINITION (AT CRL9A.)
EACH CHECK INCLUDES A CERTAIN MARGIN OF SAFETY
FREECH HAS THE NARROWEST, SO THAT WSFULL ERRORS DETECTED
ELSEWHERE DO NOT PRECLUDE USER ATTEMPTS TO DELETE ITEMS.
CRL9A ALSO HAS A NARROW MARGIN BECAUSE DEFINITION CLOSING WILL
PROVIDE MORE FREE SPACE ANYWAY. CRL5 AND SRCHB HAVE A
WIDER MARGIN SO THAT THERE IS ROOM LATER TO ENTER ANY LINEDELETIONS NECESSARY FOR CLOSING DEFINITION.
DELL HAS THE WIDEST, TO AVOID OPENING A DEFINITION THAT CRL9A
WON'T LET US CLOSE.
CSECT
BALR
USING
LA
USING
LA
USING
L
L
S
ST
AR
USING
XC
LA
MVI

PR,0
*,PR
TYPTOP
10,4095(PR)
TYPTOP+4095,10
9,4095(10)
TYPTOP+2*4095,9
LR,=A(WSLEN)
ESTABLISH R13 STACK
LR,0(LR)
FROM KNOWN, RELIABLE QUANTITIES
LR,F103
CONTAINED IN READ-ONLY STORAGE.
LR,QR13STK
ENSURE CORRECT COPY IN M, TOO
LR,MR
PREPLOC,LR
PREPLOC(16),PREPLOC CLEAR 'PROLOG' REG SAVE AREA FOR SUP
TLR,(PREPLEND-PREPLOC+7)/8*8(LR)
BAKTOG,X'80'
SET FLAG TO INDICATE THAT CONTROL IS
*
IN TYPEIN INSTEAD OF SYNT.
XC
TUSR(QUADTOG+1-TUSR),TUSR CLEAR A NUMBER OF TOGGLES
SPACE 2
*
REENTRY FROM SUCCESSFUL )LOAD
*
WHICH MUST NOT ASSUME ANYTHING ABOUT VALUES IN TYPEIN'S
*
DSECT OR ABSOLUTE ADDRESSES (OF LOCATIONS IN THE INTER*
PRETER) IN M.
SPACE 2
TYPIN4 ON
DZ
SET ALL ON-CONDITIONS TO DEFAULT
ON
RNG
ON
XDZ
ON
XOF
ON
ATTN
ON
FP,ICVRER
ENABLE FLOATING TRAP
MVC DMASK(12),DTOPS
MOVE HIGH ENDS OF UNNORMALIZED
*
FLOATING CONSTS TO R13 AREA
L
1,MPTBASE
TM
IOB1-PERTERM(1),NSIGNM BYPASS SVI-SETTING IF NOT SIGNED
BZ
TYPIN4B
ON -- SVI ADDRESSES PERLIB TABLE
LM
1,2,MX ,SVI
AVOID SYS ERROR IF CHAR ERROR ON
ST
1,MING
SIGNON
B
TYPIN5
TYPIN4B MVC TLGCPTR,LGCPTR
FOR QUAD-PRIME INPUT OUTPUT-IGNORE
L
2,PARREL
SET QUAD AND QUAD-PRIME FLAGS
AR
2,MR
MVC QUADTOG(1),STFLAGS(2)
OI
STFLAGS(2),STIMBIT TURN ON IMMEDIATE-EXECUTION TOGGLE
NI
STFLAGS(2),255-STSTBIT AND RESET 'COMPLETE STATEMENT'

02660000
02680000
02700000
02720000
02740000
02760000
02780000
02800000
02820000
02840000
02860000
02880000
02900000
02920000
02940000
02960000
02980000
03000000
03020000
03040000
03060000
03080000
03100000
03120000
03140000
03160000
03180000
03200000
03220000
03240000
03260000
03280000
03300000
03320000
03340000
03360000
03380000
03400000
03420000
03440000
03460000
03480000
03500000
03520000
03540000
03560000
03580000
03600000
03620000
03640000
03660000
03680000
03700000
03720000
03740000
03760000
03780000
03800000
03820000
03840000

TM
BO
ICALL
TYPIN4A EQU
SPACE
*
SPACE
TYPIN3 L
BXLE
ICALL
SPACE
*
*
*
TYPIN2 L
LA
XC
*
ZDFNPTR XC
*
INITHOFL MVC
*
*
A
ST
TYPIN5 ST
B
SPACE
*
*
SPACE
BEGST1 TM
BZ
LA
*
*
*
UPLINE L
CVD
LA
LR
MVC
EDMK
*
*
SR
AR
A
CL
BL
L
ST
BR
*
*
*
*
BEGST2B EQU
*
*

QUADTOG,STQBIT+STQPBIT
TYPIN4A
IF NOT QP INPUT,
LOUTI
FORCE OUT ANY REMAINING OUTPUT
*
2
REENTRY FROM FUNCTION-DEFINITION CLOSE
2
1,MINGL
1,1,TYPIN2
GCOL
2
REENTRY FROM SIGNON AND SOME EDITING ERRORS
AS WELL AS MOST COMMANDS IF NOT IN DEFINITION MODE
2,PARREL
4,STCODE(2,MR)
0(4,4),0(4)

CLEAR REMAINS OF IMMEDIATEEXECUTION STATEMENT FROM STACK

CLEAR FUNCTION DEFINITION POINTERS
DFNPTR(PROTOG+1-DFNPTR),DFNPTR+0*(FDTOG-PINAB)
AND TOGGLES
HOFLN(LF108+4-HOFLN),HOFLSET INITIALIZE
3034
FRACTIONAL-LINE-NUMBER LIST
3034
AND M-RELATIVE ENDING FLAG
2,QFM4
2,SVI
SET SVIT AND SVI FOR STORING PNAMES
2,SVIT
AND FRACTIONAL-LINE-NO ENTRIES
BEGST2
NO LINE NUMBER IN IM-EX MODE
2
REENTRY FROM END-OF-STATEMENT PROCESSING IN DEFINITION
MODE
2
DPYTOG,DPYNMT
UPDATE THE LINE NUMBER UNLESS
BEGST2
LINE WAS EMPTY (AND NO DELETION)
LKR,BEGST2
EASIER THAN SHUFFLING CARDS
SUBROUTINE TO
ADD ONE TO LOW-ORDER NON-ZERO FRACTION DIGIT OF LINE NO.
2,FLINENO
2,DLINENO
GET THE LINE NUMBER IN DECIMAL
4,WPAT
FOR EDIT OPERATION.
1,4
WPAT(9),LINPAT
MOVE EDIT PATTERN TO WORK AREA
WPAT(9),DLINENO+5 PUT IN R1 THE ADDRESS OF THE RIGHTMOST NONZERO DIGIT POSITION IN THE
FRACTIONAL PART OF THE LINE NUMBER.
4,1
R4 IS -2 * DECIMAL PLACE
4,4
MAKE IT -4 TIMES
2,P10+16(4)
ADD IN POWER OF TEN
2,QF108
UNLESS THIS TAKES NUMBER OVER 10,000
*+8
2,QF9S
IN WHICH CASE MAKE IT 9999.9999
2,FLINENO
LKR
REENTRY FROM END-OF-STATEMENT PROCESSING ON EMPTY STATEMENT IN EXECUTION MODE
*
REENTRY FROM ALL ERRORS EXCEPT EDITING ERROR THAT CLOSES

03860000
03880000
03900000
03920000
03940000
03960000
03980000
04000000
04020000
04040000
04060000
04080000
04100000
04120000
04140000
04160000
04180000
04200000
04220000
04240000
04260000
04280000
04300000
04320000
04340000
04360000
04380000
04400000
04420000
04440000
04460000
04480000
04500000
04520000
04540000
04560000
04580000
04600000
04620000
04640000
04660000
04680000
04700000
04720000
04740000
04760000
04780000
04800000
04820000
04840000
04860000
04880000
04900000
04920000
04940000
04960000
04980000
05000000
05020000
05040000

*
*
*
*
*
BEGST2

.SOX1

*
*
*
BEGST4
BEGST3
*

*
LBRL1

LBRL2

LBRL3
BEGST7

DEFINITION, END-OF-STATEMENT PROCESSING ON EMPTY STATE- 05060000

MENT IN EXECUTION MODE, INITIAL ENTRY TO TYPEIN AT
05080000
SIGNON, AND SYSTEM COMMANDS IF IN FUNCTION DEFINITION
05100000
05120000
BEGIN PROCESSING NEXT LINE.
05140000
L
1,MX
SET UP CODESTRING POINTERS
05160000
LA
2,MCSORG-M(1)
05180000
STM 1,2,TOCORG
05200000
NI
QUADTOG,255-STREMBIT REMBIT MAY BE ON FROM PREVIOUS LINE 05220000
BAL LKR,INLINE
BRING IN NEXT INPUT LINE
05240000
TM
QUADTOG,STQPBIT
VERY SPECIAL ACTION FOR QUAD-PRIME 05260000
BO
QUADPL
WHICH ACCEPTS ENTIRE INPUT LINE
05280000
AGO .SOX1
05300000
ANOP
SOX 05340000
BAL LKR,SKBL
FIND FIRST SIGNIFICANT CHAR
05360000
L
1,MPTBASE
IF WE'RE NOT SIGNED ON,
05380000
TM
IOB1-PERTERM(1),NSIGNM
05400000
BO
SOPROC
RECOGNIZE ONLY )NNNN AND )OPR
05420000
05440000
REENTRY AFTER SEEING DEL FNAME DELIMITER -- I.E, SHORT FORM OF 05460000
EDITING.
05480000
MVI DPYTOG,DPYNMT
CLEAR DISPLAY TOGGLE INITIALLY
05500000
CLI FDTOG,0
ARE WE IN FUNCTION-DEFINITION MODE - 05520000
BE
BEGST7
NO.DON'T LOOK FOR LEFT BRACKET. P053 05540000
CLI 0(6),ZLBR
IS FIRST CHARACTER A LEFT BRACKET -- 05560000
BNE BEGST7
NO. GO CHECK FOR SYSTEM COMMANDS. 05580000
LEFT BRACKET BEGINNING A STATEMENT SEEN.
05600000
BAL LKR,SKBLI
BUMP INPUT POINTER PAST LBR
05620000
MVI DPYTOG,DPYNMT
ASSUME NO DISPLAY
05640000
MVC DTEMP+4(4),FLINENO SAVE THE LINE NUMBER TEMPORARILY
05660000
CLI 0(6),ZQUAD
IS THE NEXT CHAR A QUAD -05680000
BNE LBRL1
NO. DISPLAY ONE LINE AT MOST.
05700000
MVI DPYTOG,DPYNMT+DPYALL+DPYPAST YES. DISPLAY ENTIRE FUNCT 05720000
ION OR FN STARTING AT LINE N.
05740000
BAL LKR,SKBLI
SKIP PAST QUAD.
05760000
BAL LKR,INFLT
CONVERT THE LINE COUNTER
05780000
DC
Y(FNERR-TYPTOP,LBRL3-TYPTOP) IF ANY AND IF IN RANGE,
05800000
DC
2Y(D10000-TYPTOP) TO 'MIDPOINT' DECIMAL FIXED
05820000
NI
DPYTOG,255-DPYALL CANNOT BE A 'DISPLAY ALL'.
05840000
BAL LKR,SKBL
05860000
CLI 0(6),ZQUAD
IS CHARACTER FOLLOWING NUMBER
05880000
BNZ LBRL2
A QUAD -05900000
TM
DPYTOG,DPYPAST
YES. DID WE SEE A QUAD BEFORE -05920000
BO
FNERR
YES. EDITING ERROR.
05940000
OI
DPYTOG,DPYLIN
SET 'DISPLAY LINE' TOGGLE
05960000
BAL LKR,SKBLI
LOOK AT CHARS FOLLOWING QUAD
05980000
BAL LKR,ININT
IS THERE AN INTEGER -06000000
DC
Y(FNERR-TYPTOP,LBRL2-TYPTOP)
06020000
MVI DPYTOG,DPYNMT+DPYLIN+DPYED YES. CHAR EDIT REQUEST.
06040000
STH 3,INBUF-2
SAVE START COLUMN FOR EDITING
06060000
BAL LKR,SKBL
06080000
CLI 0(6),ZRBR
IS NEXT CHARACTER A RIGHT BRACKET -- 06100000
BNE FNERR
NO. FUNCTION ERROR.
06120000
MVC FLINENO(4),DTEMP+4 ALL OK. SAVE LINE NUMBER IN FLINENO 06140000
BAL LKR,SKBLI
06160000
B
BEGST3
AND LOOK FOR ANOTHER LBR OR STMT
06180000
TM
DPYTOG,DPYALL
NO LINE NUMBER. HAVE WE SEEN A QUAD 06200000
BZ
FNERR
NO. EDITING ERROR.
06220000
B
LBRL2
06240000
TM
DPYTOG,DPYLIN+DPYPAST SINGLE OR MLTPL LINE DISPLAY?P053 06260000

BEGST9

BZ
CLI
BNE
CLI
BE
TM
BO
CLI
BE
CLI
BNE
CLI
BE
CLI
BE
LA

*
*
TOCAST BCT
LINPAT DC
*
*
TOCODE1 L
STC
LA
B
*
*
TOCODE2 L
STC
SRL
STC
LA
TOCOM
ST
*
*
*
*
FREECH LA
FREECH1 A
FREECH2 C
BCR
BAL
*
TROUBLE L
TM
BO
BAL
DC
*
*
SKBLI
LA
SKBL
CLI
BE
CLI
BCR
STM
BAL
LM
B

BEGST9
PROTOG,0
FNERR
0(6),ZCR
BEGST9
DPYTOG,DPYED
FNERR
0(6),ZDEL
BEGST9
0(6),ZPDEL
FNERR
0(6),ZRPAR
SYSCMD
0(6),ZREM
REML
2,CEOS

NO.
P053
REQUEST TO DISPLAY A
P053
LOCKED FUNCTION IS AN ERROR.
P053
DISPLAY OR EDIT REQUEST FOLLOWEDP053
BY AN EMPTY LINE IS OK.
P053
EDIT REQUEST FOLLOWED BY
P053
A NON-EMPTY LINE IS AN ERROR. P053
DISPLAY REQUEST FOLLOWED
P053
BY A DEL OR
P053
A PDEL IS OK.
P053
ALL ELSE IS AN ERROR.
P053
IS THIS A SYSTEM COMMAND -YES.
NO. IS IT A COMMENT LINE -YES. TREAT LIKE QUAD-PRIME.
EVERY STATEMENT BEGINS WITH AN ENDOF-STATEMENT SYLLABLE.
ENTRY FOR CALLING TOCODE1 AND SCANNING THIS CHARACTER
6,SCANA
OFF TO BUILD A CODESTRING.
X'202220222022202220'

06280000
06300000
06320000
06340000
06360000
06380000
06400000
06420000
06440000
06460000
06480000
06500000
06520000
06540000
06560000
06580000
06600000
06620000
06640000
06660000
06680000
PUT A 1-BYTE SYLLABLE INTO THE CODESTRING
06700000
1,TOCPTR
06720000
2,M(1)
STORE R2 AT CURRENT ADDRESS
06740000
1,1(1)
AND UPDATE ADDRESS.
06760000
TOCOM
06780000
06800000
PUT A 2-BYTE SYLLABLE INTO THE CODESTRING
06820000
1,TOCPTR
06840000
2,M+1(1)
STORE LOW R2 1 BEYOND CURRENT ADDR 06860000
2,8
06880000
2,M(1)
AND HIGH R2 AT CURRENT ADDRESS
06900000
1,2(1)
UPDATE CODE ADDRESS BY 2
06920000
1,TOCPTR
06940000
06960000
CHECK FOR POSITIVE AMOUNT OF FREE STORAGE
06980000
BETWEEN TOCPTR AND SVIT.
07000000
FREECH USES ONLY R0.
07020000
0,20
REQUIRE 20 BYTES SLOP
07040000
0,TOCPTR
07060000
0,SVI
07080000
12,LKR
07100000
8,RELPNS
STORAGE MAY NOT BE COMPACT, AND
07120000
THERE MAY BE LONG PRINTNAMES AT SVI 07140000
4,MPTBASE
IF WE'RE BEING FORCED OFF, DON'T
07160000
IOB2-PERTERM(4),BOUNCM MINDLESSLY REPEAT 'WS FULL'
07180000
CMCLEAR
DESTROY THIS WORKSPACE
07200000
1,PPERR
WS FULL ERROR
07220000
AL1(7,ZW,ZS,ZBLANK,ZF,ZU,ZL,ZL)
07240000
07260000
SKIP BLANKS AND EOB'S IN INPUT.
07280000
6,1(6)
ENTRY TO PREBUMP INPUT POINTER
07300000
0(6),ZBLANK
07320000
SKBLI
07340000
0(6),ZEOB
07360000
7,LKR
07380000
LKR,5,SKBTEMP
INLINE USES 0 THROUGH 6
07400000
LKR,EOBSB2
07420000
LKR,5,SKBTEMP
07440000
SKBL
07460000

*
*
EOBL

07480000
EOB BEFORE CR SEEN.
07500000
LA
LKR,SCAN
IGNORE EOB EXCEPT TO FETCH CONTINUA- 07520000
BCTR 6,0
TION OF STATEMENT.
07540000
*
07560000
*
CHECK FOR EOB AND FETCH NEW LINE IF PRESENT
07580000
EOBSUBI LA
6,1(6)
ENTRY TO PREBUMP INPUT POINTER
07600000
CLI 0(6),ZEOB
IS THIS CHARACTER AN EOB -07620000
BCR 7,LKR
NO. RETURN IMMEDIATELY
07640000
EOBSB2 TM
COPTOG,COPIBIT
IF WE'RE A COPY SINK,
07660000
EOBSB3 ST
LKR,INLINK
OR AN OPEN QUOTE WHICH ENTERS HERE, 07680000
EX
0,INLINX
GET NEXT LINE WITH NO INTERVENING
07700000
BO
TYI
OUTPUT OF SIX SPACES.
07720000
*
FOR 1050'S (ALMOST EXCLUSIVELY),
07740000
ICALL LOUT
FORCE OUT THE OUTPUT BUFFER
07760000
B
INLINB
AND ASK FOR MORE TEXT.
07780000
SPACE 2
07800000
ININT
ST
LKR,ININTMP
SCAN AND CONVERT INTEGER CONSTANT. 07820000
MVI ICVFG,0
RESET ICV FLAGS
07840000
BAL LKR,ICV
CONVERT ONE CONSTANT
07860000
L
LKR,ININTMP
07880000
LH
2,0(LKR)
RETURN THROUGH 0(LKR) IF NOT GOOD
07900000
TM
ICVFG,FLBIT
INTEGER
07920000
BNZ TYPTOP(2)
07940000
LH
2,2(LKR)
RETURN THROUGH 2(LKR) IF NO CONSTANT 07960000
TM
ICVFG,QUBIT
AT ALL
07980000
BO
TYPTOP(2)
08000000
B
4(LKR)
OTHERWISE RETURN TO 4(LKR)
08020000
SPACE 2
08040000
INFLT
ST
LKR,ININTMP
SCAN AND CONVERT FLOATING CONSTANT. 08060000
MVI ICVFG,FLBIT
FORCE FLOATING TYPE
08080000
BAL LKR,ICV
CONVERT
08100000
L
LKR,ININTMP
RESTORE LINK
08120000
LH
1,2(LKR)
NO-CONSTANT EXIT
08140000
TM
ICVFG,QUBIT
08160000
BO
TYPTOP(1)
08180000
LH
1,0(LKR)
RANGE ERROR EXIT
08200000
AR
1,PR
PR = TYPTOP
08220000
LTER 0,0
CONSTANT MUST BE NONNEGATIVE
08240000
BCR 4,1
08260000
LH
2,4(LKR)
MAX VALUE
08280000
CD
0,0(2,PR)
08300000
BCR 11,1
TOO BIG
08320000
LH
2,6(LKR)
SCALE NUMBER BEFORE FIXING
08340000
MD
0,0(2,PR)
08360000
AD
0,ERND
ROUND TO NEAREST INTEGER
08380000
AW
0,DUNZ
08400000
STD 0,DTEMP
08420000
B
8(LKR)
RETURN
08440000
EJECT
08460000
*
08480000
*
08500000
*
THE NUMERIC INPUT CONVERSION ROUTINE
08520000
*
08540000
*
TOGGLES USED BY NUMERIC CONVERSION
08560000
FLBIT
EQU 1
RESULT IS FLOATING POINT
08580000
DPBIT
EQU 2
DECIMAL POINT SCANNED
08600000
EXBIT
EQU 4
WE'RE WORKING ON DECIMAL EXPONENT
08620000
OVBIT
EQU 8
OVERBAR SCANNED
08640000
QUBIT
EQU 16
QUIT BIT (USED BY NUML ONLY)
08660000

VEBIT
ICV
*
ICV3

ICV0
*
*
*
*
*
*
*
*
ICV1

ICV2

ICV4

ICV6

ICV5
ICV9
*
ICV7

EQU
NI

64
WE'RE CATENATING CONSTANT VECTOR
ICVFG,FLBIT+VEBIT RESET RELEVANT INDICATORS
REENTRY TO CONVERT DECIMAL EXPONENT
CLI 0(6),ZOVB
IS FIRST CHARACTER AN OVERBAR -BNE ICV0
NO.
OI
ICVFG,OVBIT
YES. RECORD FACT AND BUMP INPUT
LA
6,1(6)
POINTER.
SR
4,4
CLEAR WORKING REGISTERS
LR
5,4
STM 4,5,HN
R1 = CURRENT CHARACTER
R2,3 = DOUBLE REGISTER USED TO ACCUMULATE FRACTION
R4 = 0 - NUMBER OF DIGITS NOT CONVERTED TO THE LEFT OF
THE DECIMAL POINT BECAUSE OF EXCESSIVE FRACTION
(IRRELEVANT AFTER DECIMAL POINT IS SCANNED)
R5 = 0 - TOTAL NUMBER OF DIGITS SCANNED
R7 = 0 - (NUMBER OF FRACTION DIGITS CONVERTED + R4)
(RELEVANT ONLY AFTER DECIMAL POINT IS SCANNED)
SR
1,1
REENTRY FOR NEXT DIGIT
IC
1,0(6)
S
1,QZ0
GET TRUE DIGIT
CL
1,QF9
IS IT INDEED A DIGIT -BNH ICV2
YES. ADD IT IN.
TM
ICVFG,DPBIT+EXBIT ARE WE WORKING ON INTEGER PART -BNE ICV7
NO. DISCONTINUE CONVERSION.
LCR 7,4
R7 WILL BE EXPONENT OFFSET.
CLI 0(6),ZPER
IS CURRENT CHARACTER A PERIOD -BNE ICV7
NO. NO FRACTIONAL PART.
LA
6,1(6)
YES. BUMP POINTER PAST IT
OI
ICVFG,DPBIT
RECORD PERIOD
B
ICV1
AND CONTINUE CONVERSION.
L
3,HN
PREPARE TO MULTIPLY HIGH-ORDER HALF
CL
3,QFCVL
BY 10, PROVIDED MULTIPLY WILL NOT
BL
ICV4
OVERFLOW.
BCT 4,ICV9
TOO MANY DIGITS. BUMP LOST-DIGIT CT
M
2,P10+4
LR
0,3
SAVE HIGH PRODUCT
L
3,LN
MULTIPLY LOW-ORDER HALF
LTR 3,3
M
2,P10+4
BY 10
BNM ICV6
CORRECT HIGH-ORDER PRODUCT FOR
AL
2,P10+4
INCORRECT MULTIPLY IF NEGATIVE.
AR
2,0
COMBINE HIGH-ORDER HALVES
ALR 3,1
ADD IN NEW DIGIT
BC
12,ICV5
PROPAGATE CARRY TO HIGH-ORDER HALF.
AL
2,P10
BCTR 7,0
BUMP CONVERTED-DIGIT COUNT.
STM 2,3,HN
SAVE PARTIAL RESULT
LA
6,1(6)
BUMP INPUT POINTER TO NEXT CHAR
BCT 5,ICV1
BACK FOR THE NEXT DIGIT
CONSTANT DELIMITER HAS BEEN SEEN
LTR 5,5
DID 'NUMBER' CONTAIN ANY DIGITS -BZ
ICVER
NO. ERROR.
LM
2,3,HN
RELOAD FRACTION (OR EXPONENT)
TM
ICVFG,EXBIT
WERE WE WORKING ON FRACTION OR EXP BO
ICV8
EXPONENT.
TM
ICVFG,DPBIT+FLBIT FRACTION. IS THIS TO BE MADE A
BNE ICV10
FLOATING-POINT NUMBER -CLI 0(6),ZE
YES, CERTAINLY, IF NEXT CHARACTER
BE
ICV10
IS AN E.

08680000
08700000
08720000
08740000
08760000
08780000
08800000
08820000
08840000
08860000
08880000
08900000
08920000
08940000
08960000
08980000
09000000
09020000
09040000
09060000
09080000
09100000
09120000
09140000
09160000
09180000
09200000
09220000
09240000
09260000
09280000
09300000
09320000
09340000
09360000
09380000
09400000
09420000
09440000
09460000
09480000
09500000
09520000
09540000
09560000
09580000
09600000
09620000
09640000
09660000
09680000
09700000
09720000
09740000
09760000
09780000
09800000
09820000
09840000
09860000

ICV17
*
ICV10

LTR
BNE
LTR
BM
TM
BZ
LCR
ST
BR
OI
ST
ST
ST

ICV15

*
*
*
*
*
*
*
*
*
*
ICV8

*
*
ICV12

SDR
LD
ADR
AD
TM
BZ
XI
LCER
LCER
SR
CLI
BNE
LA
OI
B
NOTES

CL
BH
BXLE
L
TM
BZ
LCR
LA
LDR
ADR
BZ
SDR
ADR

*
*
*
*
LCR

2,2
ICV10
3,3
ICV10
ICVFG,OVBIT
ICV17
3,3
3,DTEMP
LKR

MAYBE NOT. IS IT SMALL ENOUGH TO BE 09880000

AN INTEGER -09900000
MAYBE. IT'S LESS THAN 2**32.
09920000
NO. IT'S MORE THAN 2**31-1.
09940000
YES. CHECK FOR MINUS SIGN
09960000
09980000
10000000
10020000
10040000
10060000
ICVFG,FLBIT
MAKE ALL FOLLOWING NUMBERS FLOATING. 10080000
2,DNASK+4
BEGIN FLOATING-POINT CONVERSION.
10100000
3,DMASK+4
MAKE FRACTION PARTS UNNORMALIZED
10120000
7,EN
FLOATING POINT.
10140000
R7 = OFFSET FROM TEXT EXPONENT.
10160000
0,0
PUT PIECES OF FRACTION INTO FLOATING 10180000
2,DMASK
REGISTERS AND NORMALIZE THEM.
10200000
2,0
10220000
0,DNASK
10240000
ICVFG,OVBIT
IF THERE WAS A PRECEDING OVERBAR,
10260000
ICV15
10280000
ICVFG,OVBIT
10300000
0,0
REVERSE THE SIGNS.
10320000
2,2
10340000
3,3
10360000
0(6),ZE
IS NEXT INPUT CHARACTER AN E -10380000
ICV12
NO. NO EXPONENT PART.
10400000
6,1(6)
YES. BUMP POINTER PAST E
10420000
ICVFG,EXBIT
AND SET TO WORK CONVERTING EXPONENT. 10440000
ICV3
10460000
DELIMITER FOR EXPONENT HAS BEEN SEEN
10480000
ON EXPONENT SIZE ..
10500000
EXPONENT OVERFLOW INTERRUPT WILL TERMINATE RUNAWAY
10520000
SCALE-UP LOOP. CHECK FOR 100 GEQ ABS EXPONENT WILL
10540000
PREVENT SCALE-DOWN LOOP FROM RUNNING AWAY. HERE WE MUST 10560000
MAKE SURE THAT EXPONENTS GTR 2*32 OR 'NEGATIVE' (BIT 0 10580000
OF R3 ON) ARE RECOGNIZED AS LARGE. WE CAN'T MAKE A
10600000
REALLY NARROW BOUND ON SIZE BECAUSE WE HAVEN'T FIGURED 10620000
IN EN, WHICH INDICATES SCALING DUE TO TRAILING FRACTION 10640000
DIGITS AND DIGITS IGNORED AT ICV2.
10660000
3,F104
10680000
*+8
EXPONENT MOD 2*32 BIGGER THAN 10000 10700000
2,3,*+8
EXPONENT LESS THAN 2*32
10720000
3,F104
MAKE EXPOENENT NON-RIDICULOUSLY BIG. 10740000
ICVFG,OVBIT
GIVE EXPONENT PROPER SIGN
10760000
ICV12
10780000
3,3
10800000
FRACTION IS IN F0, F2
10820000
DECIMAL EXPONENT IS IN R3 + EN
10840000
1,6
SET UP BXLE LOOP FOR LARGE SCALING. 10860000
4,0
*
10880000
0,2
*
FIRST MOVE AS MUCH SIGNIFICANCE AS 10900000
ICVSD
(NO SCALING FOR TRUE ZERO)
10920000
4,0
*
POSSIBLE TO F0.
10940000
2,4
******IMMUNE TO GUARD DIGIT (BYTE)
10960000
BECAUSE NO POSTNORMALIZATION AFTER 10980000
PRE-DENORMALIZATION EXCEPT ON
11000000
ADR 2,4 WHICH HAS PLENTY OF LOW- 11020000
ORDER ZEROS.
11040000
0,1
11060000

A
ST
BP
BZ
LCR
C
BNH
LA
LA

3,EN
3,EN
ICVSU
ICVSN
3,3
3,F102
*+8
3,100
3,7(3)

DD
DD
LA
BALR
BXH
LA
BALR
BCT
B
EQU
STD
DD
SDR
LER
LCDR
ADR
MD
MD
SD
ADR
SDR
DD
BR
EQU
SDR
LCER
ADR
ADR
SDR
MDR
MDR
BR
LA
LD
BALR
BXH
LD
BALR
BCT
LCDR
SDR
ADR
ADR
AER
SDR
TM
BZ
DD
STD
BR

0,D16M14
2,D16M14
4,D106
2,0
3,0,ICVDIV
4,D10
2,0
3,ICVDIV
ICVSN
*
0,0(TLR)
0,0(4)
6,6
6,0
4,6
4,0
4,0(4)
6,0(4)
6,0(TLR)
6,4
2,6
2,0(4)
2
*
4,4
4,0
4,0
2,4
0,4
0,6
2,6
2
3,7(3)
6,D106
2,0
3,0,ICVMUL
6,D10
2,0
3,ICVMUL
4,0
4,2
0,4
0,2
0,0
0,4
EN,X'80'
ICVSD
0,D1614
0,DTEMP
LKR

DPDIV
ICVDIV

DPMUL
ICVMUL

ICVSU

ICVSN

ICVSD

COMBINE EXPONENT AND OFFSET

SAVE FOR 16*14 SCALEDOWN AT ICVSN
SCALE UP IF POSITIVE.
ZERO. NO SCALING NEEDED.
TAKE ABSOLUTE VALUE OF EXPONENT
MIN 100 TO PREVENT EXTREMELY LONG
SCALING LOOPS.
BUMP BY 1 FOR BCT LOOP
AND BY 7 FOR BXH LOOP.
SCALE EXPONENTS UP TO AVOID UNDERFLW
ON LOW-ORDER HALF IN EXTREME CASES
SET RETURN FOR DIVIDE
THE BIG SCALING LOOP
THE LITTLE SCALING LOOP
SCALING DOWN ALL DONE.
USED BY TOBCD
THE FANCY DOUBLE-PRECISION DIVIDE.
OUTSIDE DIVIDE
COPY QUOTIENT TO F4 AND F6 IN TWO
PIECES SO GENUINELY LOSING MULTIPLY
DOESN'T LOSE ANY SIGNIFICANCE.
MULTIPLY PIECES BY 1E6 OR 10 .
F6 HAS AT LEAST 2 TRAILING HEX ZEROS
AND EXPONENT DIFFERENCE IS 1 OR 0.
ADD TRUE FLOATING REMAINDER TO F2,
FINALLY DIVIDE THE REMAINDER.
USED BY TOBCD
THE FANCY 1.5-PRECISION MULTIPLY
F4 = LOW 32 BITS OF F0 FRACTION
KEEP 1-BITS OUT OF LOW F0 SO THAT
LOSING MULTIPLY DOESN'T DROP BITS

BUMP BY 1 FOR BCT, 6 FOR BXLE.

LOAD BIG SCALING CONSTANT
BIG SCALEUP
SMALL SCALEUP
NOW COMBINE FRACTION PARTS
WITH 'ROUNDED' ADDITION -- THAT IS,
ADD IN DOUBLE THE IGNORED LOW-ORDER
BITS.
IGNORED BITS SURELY FIT IN ONE WORD
IF SO, EXPONENT WAS SCALED UP BY
16*14 AND MUST BE SCALED DOWN.
AND SAVE THE RESULT.
ALL CONVERTED.

11080000
11100000
11120000
11140000
11160000
11180000
11200000
11220000
11240000
11260000
11280000
11300000
11320000
11340000
11360000
11380000
11400000
11420000
11440000
11460000
11480000
11500000
11520000
11540000
11560000
11580000
11600000
11620000
11640000
11660000
11680000
11700000
11720000
11740000
11760000
11780000
11800000
11820000
11840000
11860000
11880000
11900000
11920000
11940000
11960000
11980000
12000000
12020000
12040000
12060000
12080000
12100000
12120000
12140000
12160000
12180000
12200000
12220000
12240000
12260000

*
ICVER

ICVE1
*
ICVE2

*
ICVRER

TM
BZ
BCTR
TM
BZ
BCTR
MVI
B

ICVFG,EXBIT
ICVE2
6,0
ICVFG,OVBIT
ICVE1
6,0
0(6),ZFE
ICV15

OI
TM
BCR
BCTR
BCR
BCTR

ICVFG,QUBIT
ICVFG,OVBIT+DPBIT
8,LKR
6,0
4,LKR
6,LKR

STD
OC
LD
BR

0,DTEMP
DTEMP,INFIN
0,DTEMP
LKR

*
CEFNERR LA
FNERR
BAL
DC
CHERR
MVI
BAL
DC
PPERR
ICALL
LA
PPERR2 LA
NI
LA
SR
ICALL
ICALL
LA
TM
BZ
B
CHER2
STC
LA
SH
BNP
MVI
ICALL
LA
STC
PPERR3 ICALL
LA
ICALL
ICALL
CHER3
TM
BM
LA
*
*
*
*
*

SYNTAX ERROR IN CONSTANT.

WE WEREN'T IN THE EXPONENT.
BACK UP TO E
OR TO OVERBAR, IF PRESENT,
IN WHICH CASE BACK UP AGAIN
PUT AN ILLEGAL E-PRINTING CHARACTER
IN CODESTRING AND FINISH
CONVERTING THE FRACTION.
ILLEGAL FRACTION -- NO DIGITS.
TELL NUML TO QUIT, THEN BACK INPUT
POINTER OVER NO, ONE, OR TWO CHARS.
RETURN TO CALLER.
FLOATING TRAP IN SCALING.
MAKE THE VALUE A SIGNED INFINITY

6,INBUF(5)
EDITING ERROR IN CHAR-EDIT MODE.
1,PPERR
DEFN ERROR
AL1(4,ZD,ZE,ZF,ZN)
'DEFN'
INTOG,0
RESET INLINE FLAGS
1,PPERR
CHARACTER ERROR.
AL1(9,ZC,ZH,ZA,ZR,ZA,ZC,ZT,ZE,ZR)
SQUIRT
3574
1,ERTEXT
PRINT THE WORD 'ERROR'.
3574
8,BEGST2
NORMAL EXIT ADDRESS.
3574
FDTOG,255-FDCLBIT IGNORE POSSIBLE CLOSING DEL.
3574
5,INBUF
START OF LINE DISPLAY
3574
6,5
LENGTH OF LINE DISPLAY.
3574
SQUIRT
3574
LOUT
3574
LKR,CHER3
COPTOG,COPIBIT
FOR SECURITY IN )COPY OPERATIONS,
CHER2
IF ERROR OCCURRED DURING FN DEF, 3053
ERFID
COMPLETELY UNDEFINE THE FUNCTION.
6,INBUF-1
LENGTH OF LINE DISPLAY.
3574
1,INBUF-1
START OF LINE DISPLAY.
3574
6,QH255
IF LENGTH IS LESS THAN 255,
3574
PPERR3
PRINT IT NOW.
3574
INBUF-1,X'FF'
OTHERWISE PRINT THE LINE IN
3574
SQUIRT
TWO PARTS.
3574
1,INBUF-1+255
PRINT THE REST OF THE LINE.
3574
6,INBUF-1+255
3574
SQUIRT
DISPLAY THE LINE.
3574
1,CHIND
APPEND LINEFEED AND CARET
SQUIRT
LOUT
FDTOG,X'FF'-FDDHBIT ARE WE IN FN DEFINITION MODE? 3032
*+8
BR YES-CONTINUE WITH DEFINITION 3053
8,TYPIN2
NO-RETURN WILL BE TO EXEC MODE 3032
MUST NOT LEAVE FN DEFINITION MODE ONCE TRULY IN -LONG PRINTNAMES, FRACTIONAL-LINE LIST, AND FUNCTION
DIRECTORY ARE IN AN ANOMALOUS STATE.
RELOCATE LONG PRINTNAMES THAT MAY BE SITTING BETWEEN

12280000
12300000
12320000
12340000
12360000
12380000
12400000
12420000
12440000
12460000
12480000
12500000
12520000
12540000
12560000
12580000
12600000
12620000
12640000
12660000
12680000
12700000
12720000
12740000
12760000
12780000
12800000
12820000
12840000
12860000
12880000
12900000
12920000
12940000
12960000
12980000
13000000
13020000
13040000
13060000
13080000
13100000
13120000
13140000
13160000
13180000
13200000
13220000
13240000
13260000
13280000
13300000
13320000
13340000
13360000
13380000
13400000
13420000
13440000
13460000

*
*
RELPNS

CHIND
ERTEXT
*
*
*
*
*
ERF2

*
ERFID

ERF1

*
*
*
SCANA1
*
SCANA
*
SCANUP
*
SCAN

SCANB1

SCANB2

SVI AND SVIT. ALSO RESET SVI.

R8 = RETURN LINK
L
1,MX
LCR 0,1
TURN FREE M INTO A HUGE PIECE OF GAR
A
0,SVI
BAGE.
S
0,QFM4
BYTE COUNT IS 4+SVI-MX
ST
0,MCOUNT(1)
AR
1,MR
MARK IT GARBAGE
MVI MGARB-M(1),MGBIT
L
1,SVIT
SET SVI ABOVE NEW PRINTNAMES.
IN EXECUTION MODE, THIS = PARREL-4
ST
1,SVI
SET MX ABOVE NEW PRINTNAMES AND
LA
1,4(1)
BELOW FRACTIONAL-LINE-NO ENTRIES
ST
1,MX
SO GARBAGE COLLECTOR LOOKS AT ALL M
ICALL GCOL
THE PAST IS PROLOGUE
BR
8
DC
AL1(2,ZLF,ZAND)
DC
AL1(6,ZBLANK,ZE,ZR,ZR,ZO,ZR)

13480000
13500000
13520000
13540000
13560000
13580000
13600000
13620000
13640000
13660000
13680000
13700000
13720000
13740000
13760000
13780000
13800000
13820000
13840000
ERASE FUNCTION IN DEFINITION
13860000
RETURN IS TO 0(LKR)
13880000
ON ENTRY, DFNPTR IS POINTER TO S.T. ENTRY, IF ANY
13900000
ON EXIT, R0 - R5, R8 DESTROYED
13920000
L
4,DFNPTR
MARK THE DIRECTORY, IF ANY, GARBAGE. 13940000
LR
3,4
13960000
BAL 1,MKCSGI
13980000
EX
0,ZDFNPTR
14000000
ENTRY
14020000
TM
FDTOG,FDDFBIT
BYPASS COMPLETELY IF NOT IN
14040000
MVI FDTOG,0
FOR SAFETY
14060000
BCR 8,LKR
FUNCTION DEFINITION
14080000
BAL 8,LINIT
SET UP TO ERASE ALL LINES
14100000
BAL 8,LINTRAC
LOCATE NEXT LINE
14120000
B
ERF2
OFF END OF FUNCTION
14140000
BAL 1,MKCSGI
MKCSGI CHECKS FOR EXISTENCE OF LINE 14160000
B
ERF1
14180000
EJECT
14200000
14220000
THE CENTRAL INPUT SCANNER
14240000
14260000
LA
2,1(2,2)
TURN ZSYMBOL INTO A SHORT SYLLABLE 14280000
ENTRY FROM TOCAST
14300000
BAL LKR,TOCODE1
AND STUFF IT.
14320000
REENTRY WITH INPUT POINTER UPDATED 14340000
LA
6,1(6)
14360000
REENTRY WITHOUT UPDATE
14380000
SR
2,2
14400000
IC
2,0(6)
PUT CURRENT CHARACTER IN R2
14420000
CL
2,QZ8BIT
IF IT'S SMALL ENOUGH,
14440000
BL
SCANA1
IT'S NOT AN ACTION CHARACTER.
14460000
S
2,QZDAU
CLASSIFY CHARACTER AS ZERO IF IT'S 14480000
BNL SCANB1
ALPHABETIC,
14500000
SR
2,2
14520000
BZ
SCANB2
14540000
S
2,QF9
AND AS 1 IF IT'S NUMERIC.
14560000
BP
SCANB2
14580000
LA
2,1
14600000
LA
2,0(2,2)
MAKE R2 A HALFWORD INDEX
14620000
LH
2,SCANT(2)
14640000
B
IDL(2)
BRANCH TO ACTION ROUTINE.
14660000

*
SCANT
PER
OVB
BLANK
QUOTE
COLON
DEL
CR
EOB
PDEL
LENGTH
*
*
COLNL

*
*
QUADPL
*
*
REML
QUADP1
*
*
QUOTL
*
QUOTL4
QUOTL8

QUOTL7
QUOTL3
*

DC
SCANT
SCANT
SCANT
SCANT
SCANT
SCANT
SCANT
SCANT
SCANT
SCANT
ORG

Y(IDL-IDL,NUML-IDL),(ZLENGTH-Z9)Y(CHERR-IDL)
PERL
OVBL
SCANUP
QUOTL
COLNL
DELL
CRL
EOBL
PDELL
COPVL

LA
L
AR
S
TM
BO
CLI
BNE
MVI
B

COLON SEEN.
2,ZFCOLON
1,TOCPTR
1,MR
1,QF3
2(1),1
SCANA1
0(1),1+2*ZEOS
SCANA1
0(1),1+2*ZLEOS
SCANA1

LA
BCT

QUAD-PRIME SPOTTED. ACTION IS VERY SIMILAR TO QUOTE.

2,CEOS
START BUILDING THE CODESTRING
6,QUADP1
COMPENSATE FOR LA AT QUOTL4

LA
OI
BAL

COMMENT SYMBOL SPOTTED. TREAT LINE LIKE QUAD-PRIME

2,CREM
LINE STARTS WITH COMMENT SYMBOL,
QUADTOG,STREMBIT
NOT END-OF-STATEMENT
LKR,TOCODE1

MVC
MVI
LA
TM
BZ
EQU
CLI
BNE
LA
TM
BO
B
EQU
CLI
BNE
L
S
BAL
LA
BAL
TM
BNZ

COLON REPLACED IN CODESTRING BY A

REPRESENTABLE SYMBOL.
ONLY IF THE PRECEDING SYLLABLES ARE
A LONG SYL
AND AN END-OF-STATEMENT SYL,
TURN EOS INTO A LABELLED-EOS SYL

OPENING QUOTE SPOTTED

TOCSAV(4),TOCPTR
REMEMBER PRESENT CODE-POINTER
FOR LENGTH CALCULATION.
INLTMP+1,0
CARRIER WILL BE AT LEFT MARGIN
6,1(6)
ADVANCE POINTER TO NEXT CHARACTER
QUADTOG,STQPBIT+STREMBIT IS THIS QUOTE INPUT -QUOTL1
*
3563
0(6),ZEOB
QUAD-PRIME OR COMMENT. EOB OR CR
QUOTL7
3563
LKR,QUOTL8
SET RETURN FROM EOBSB3
3563
COPTOG,COPIBIT
IS THIS A COPY SINK?
3563
QUOTL5
YES. GO GET CONTINUATION
3563
QUOTL3
NO. END THIS LINE.
3563
*
3563
0(6),ZCR
QUOTL2
2,TOCPTR
END OF QUOTED STRING.
DIFFERENCE OF OLD AND NEW CODE2,TOCSAV
POINTERS IS THE LENGTH OF THE STRING
LKR,TOCODE2
BUILD LENGTH SYLLABLE OF CONSTANT
2,CCCONST
THEN SEND CONSTANT SYLLABLE
LKR,TOCODE1
QUADTOG,STQPBIT+STREMBIT IN QUAD-PRIME OR COMMENT MODE,
CRL
QUIT NOW.

14680000
14700000
14720000
14740000
14760000
14780000
14800000
14820000
14840000
14860000
14880000
14900000
14920000
14940000
14960000
14980000
15000000
15020000
15040000
15060000
15080000
15100000
15120000
15140000
15160000
15180000
15200000
15220000
15240000
15260000
15280000
15300000
15320000
15340000
15360000
15380000
15400000
15420000
15440000
15460000
15480000
15500000
15520000
15540000
15560000
15580000
15600000
15620000
15640000
15660000
15680000
15700000
15720000
15740000
15760000
15780000
15800000
15820000
15840000
15860000

*
QUOTL6
QUOTL5
QUOTL1

QUOTL2

*
*
*
*
*
*
*
*
*
*
*
*
*
COPVL

B
LA
TM
B
CLI
BE
CLI
BNE
BAL
CLI
BNE
IC
BAL
B
EJECT

COPVL1

COPVL3

FOR QUOTED STRING,

RESUME SCANNING AFTER ENDING QUOTE.
SET RETURN FROM EOBSB3
3563
THIS IS A LOW, CHEAP TRICK TO
GET INTO EOBSUB FROM BACK WAY. 3563
HAVE WE REACHED END-OF-LINE -YES. ASK FOR MORE
3563
CHECK FOR EMBEDDED QUOTE
QUOTE. CHECK FOR FOLLOWING QUOTE.
QUOTE NOT DOUBLED -- END OF STRING.
PASS THIS CHARACTER ALONG TO
THE CODESTRING.

COPY-VARIABLE SIGNAL (CHARACTER = ZLENGTH) SCANNED.

FORMAT OF MESSAGE IS ..
IDENTIFIER
(ALREADY SCANNED)
ZLENGTH
1-BYTE SIGNAL, COPY MODE ONLY
BYTE COUNT OF M-ENTRY
4 BYTES
(OR SYMBOL TABLE ENTRY IF A KEYWORD)
SUCCEEDING INPUTS ARE LINKED BUFFERS OF RAW
M-ENTRY, STARTING WITH FIRST BYTE PAST MCOUNT.
RELIES ON R3 SAVED FROM SRCHID
BAL
LA
MVC
BAL
OI
BAL
L
LTR
BM
LA
BAL
L
L
ST
AR
ST
ST

LKR,TUSAG
LKR,DELCHV
DTEMP(4),1(6)
8,DELCHA
COPTOG,COPVBIT
8,RELPNS
1,DTEMP
1,1
COPOP
0,40(1)
LKR,FREECH1
1,MX
0,DTEMP
0,MCOUNT(1)
0,1
0,MX
3,MHEAD(1)

LR
O
ST

5,1
1,UNVAR
AND SYMBOL TABLE (INCLUDING CLASS =
1,M(3)
VARB) AT M-ENTRY.
REENTRY TO IGNORE VARIABLE OR KEYWORD
4,DTEMP
PREPARE TO IGNORE, OR FILL M-ENTRY.
4,QAMOVH
COUNT MINUS OVERHEAD IS AMT OF INPUT
BEGST2
CASE OF IGNORED KEYWORD

*
DELCHV

SCAN
LKR,QUOTL1
*+1,1
EOBSB3
0(6),ZEOB
QUOTL6
0(6),ZQUOTE
QUOTL2
LKR,EOBSUBI
0(6),ZQUOTE
QUOTL3
2,0(6)
LKR,TOCODE1
QUOTL4

L
S
BNP
TYI
AR
L
L
USING
LH

DETERMINE GLOBAL MEANING

GET NEW COUNT FROM INPUT
AND SEE IF WE REALLY WANT TO COPY
NOTE ACCEPTABILITY OF OBJECT
POSSIBLY RELOCATE PRINTNAME DOWNWARD
AND GET SPACE FOR NEW M-ENTRY.
NO M-ENTRY IF IT'S A KEYWORD
ADD 40 BYTES SLOP AND
5995
CHECK FOR WS FULL.
5995
BUILD M-ENTRY FOR VARIABLE
5995
5995
STORE M-ENTRY LENGTH
5995
5995
UPDATE MX
5995
POINT M-ENTRY AT SYMBOL TABLE
(OR STACK)

5,MR
ABSOLUTE SINK ADDRESS
3,MPTBASE
3,PTIBUF-PERTERM(3) POINT TO FIRST BUFFER
PERBUF,3
2,PBCCW+6
BYTES IN THIS BUFFER

15880000
15900000
15920000
15940000
15960000
15980000
16000000
16020000
16040000
16060000
16080000
16100000
16120000
16140000
16160000
16180000
16200000
16220000
16240000
16260000
16280000
16300000
16320000
16340000
16360000
16380000
16400000
16420000
16440000
16460000
16480000
16500000
16520000
16540000
16560000
16580000
16600000
16620000
16640000
16660000
16700000
16720000
16740000
16760000
16780000
16800000
16820000
16840000
16860000
16880000
16900000
16920000
16940000
16960000
16980000
17000000
17020000
17040000
17060000
17080000

TM
BZ
EX
AR
COPVL4 SR
TM
L
BZ
SR
LTR
BP
NI
B
COPVLMV MVC
DROP
COPOP
ST
B
*
*
EJECT
*
*
OVBL
EQU
PERL
EQU
NUML
MVC
SR
ST
ST
MVI
NUML14 BAL
TM
BNZ
AGO
.NUML1 ANOP
NUML15 LA
TM
BO
L
N
BZ
LA
*
*
*
*
*
NUML4
L
L
LR
A
C
BNH
ST
LTR
BZ
*
*
*
*
*

COPTOG,COPVBIT
COPVL4
2,COPVLMV
5,2
4,2
PBFLAG,LINEZ
3,PBTIC
COPVL3
5,MR
4,4
COPVL1
COPTOG,255-COPVBIT
BEGST2
MTYPE-M(0,5),PBSTAR
3
1,M(3)
BEGST2

NO MOTION IF IGNORANCE IN PROGRESS

AN EXTRA BYTE IS MOVED * * * * *
DEST IS DEST PLUS BUFFERLENGTH
REMAINING BYTES TO MOVE
TEST TO SEE IF PBTIC IS VALID
POINT TO PROBABLE NEXT BUFFER
NEXT BUFFER EXISTS
MAKE IT M-RELATIVE
ALL INPUT READ (SHOULD NEVER BE -)-RESET FLAG WITH LOCAL SIGNIFICANCE

STORE KEYWORD SYMBOL TABLE ENTRY

IN SYMBOL TABLE
THIS IS AN IDENTIFIER DEFINED AS
A PRIMITIVE OPERATOR OR OTHER SYMBOL

CONSTANT BEGINNER SPOTTED

*
*
TOCSAV(4),TOCPTR
SAVE INITIAL VALUE OF CODESTRING PTR
0,0
0,CCNT
SET CONSTANT COUNT TO 0
0,CTYP
ICVFG,0
RESET ALL INPUT CONVERT FLAGS
LKR,ICV
CONVERT CONSTANT
ICVFG,QUBIT
IF BAD SYNTAX WAS FOUND IN
P054
NUMCLS
ICV THEN CLOSE THIS CONSTANT
P054
.NUML1
P054
P054
3,2
DETERMINE IMPLIED TYPE OF THIS CONST
ICVFG,FLBIT
IS IT FLOATING -NUML4
YES.
3,DTEMP
IT'S INTEGER.
3,QFM2
IF IT'S 1 OR 0,
NUML4
CALL IT BOOLEAN.
3,1
NOW R3 = PRESENT CONSTANT TYPE - 1
CATENATE CURRENT CONSTANT TO PREVIOUS CONSTANTS IN VECTOR. TYPES MAY DIFFER, REQUIRING CONVERSION OF PREVIOUS
CONSTANTS.
4,TOCPTR
2,CCNT
0,3
0,CTYP
NO WORRIES IF TYPES ARE THE SAME
3,CTYP
NUML5
(LOW ONLY IF R3 = 0 AND CTYPE = 1)
3,CTYP
1,2
OR IF THIS IS THE FIRST CONSTANT.
NUML5
NEW ELEMENT OF VECTOR HAS HIGHER TYPE THAN OLD ELEMENTS.
EXPAND OLD ELEMENTS TO HIGHER TYPE BEFORE CATENATING
NEW ELEMENT.
FIRST DETERMINE ADDITIONAL STORAGE NEEDED.

17100000
17120000
17140000
17160000
17180000
17200000
17220000
17240000
17260000
17280000
17300000
17320000
17340000
17360000
17380000
17400000
17420000
17440000
17460000
17480000
17500000
17520000
17540000
17560000
17580000
17600000
17620000
17640000
17660000
17680000
17700000
17720000
17740000
17760000
17780000
17800000
17820000
17840000
17860000
17880000
17900000
17920000
17940000
17960000
17980000
18000000
18020000
18040000
18060000
18080000
18100000
18120000
18140000
18160000
18180000
18200000
18220000
18240000
18260000
18280000

*
*
*
*
*
*

NUML9
*
NUML6
*
*
NUML8

NUML18

NUML17

*
*
NUML19

*
*
*
*
*
NUML20

R0 = TYPE-CONVERSION CODE.
= 0 - 1 PLUS 1 - 2
= 1 BOOLEAN TO INTEGER
= 2 BOOLEAN TO FLOATING
= 3 INTEGER TO FLOATING

18300000
18320000
18340000
18360000
18380000
18400000
ST
0,FTEMP1
SAVE TYPE COMBINATION FOR LATER
18420000
SLL 1,2
18440000
BCT 0,NUML6
CONVERSION.
18460000
LA
2,7(2)
ROUND BITS UP TO EVEN BYTE
18480000
SRL 2,3
MAKE BYTE INDEX
18500000
SR
1,2
AND SUBTRACT CURRENT SIZE FROM SIZE 18520000
NEEDED FOR INTEGERS
18540000
BCT 0,NUML8
18560000
ALR 1,1
BOOLEAN TO FLOATING CONVERSION.
18580000
B
NUML9
ALMOST SAME AS INTEGER
18600000
NOW R1 = NUMBER OF BYTES NEEDED FOR HIGHER TYPE.
18620000
R4 = TOCPTR
18640000
AR
4,1
INTEGER TO FLOATING CONVERSION.
18660000
ST
4,TOCPTR
GIVE CODESTRING POINTER NEW VALUE. 18680000
BAL LKR,FREECH
MAKE SURE WE HAVE THE SPACE
18700000
CLI FTEMP1+3,3
18720000
BE
NUML19
18740000
ST
4,FTEMP2
THE BOOLEAN CONVERSIONS.
18760000
LM
2,4,CCNT
SET UP CALL OF FETCH
18780000
IC
3,TCCOD-1(3)
GET TYPE-CONVERSION CODE
18800000
BCTR 2,0
AND 0-ORIGIN INDEX
18820000
ICALL FETCH
18840000
ST
0,NTEMP
18860000
CLI FTEMP1+3,1
IS RESULT IN R0 OR F0 -18880000
BE
NUML17
18900000
STD 0,NTEMP
F0.
18920000
L
5,FTEMP1
18940000
IC
5,NUMTL-1(5)
FIND LENGTH OF CONVERTED CONSTANT
18960000
LCR 1,5
18980000
A
1,FTEMP2
DROP SINK ADDRESS BY CONSTANT LENGTH 19000000
ST
1,FTEMP2
19020000
AR
1,MR
ABSOLUTIZE IT
19040000
BCTR 5,0
19060000
EX
5,NUM18M
MOVE TARGET TO NEW CODESTRING LOCN. 19080000
LTR 2,2
HAVE ALL CONSTANTS BEEN MOVED -19100000
BP
NUML18
NO. DO THE NEXT.
19120000
B
NUML15
19140000
19160000
MOVE AND CONVERT INTEGER TO FLOATING
19180000
L
2,QFM4
DECREMENT FOR BXH
19200000
LA
3,M(2)
19220000
A
3,TOCSAV
19240000
LA
5,0(3,1)
19260000
AR
4,MR
19280000
NOW R1 = CCNT * 4
19300000
R2 = -4
19320000
R3 = TOCSAV - 4 (ABSOLUTE)
19340000
R5 = TOCSAV - 4 + CCNT * 4 (ABSOLUTE)
19360000
= INDEX OF LAST CONSTANT
19380000
S
4,QF8
BUMP SINK TO NEW SLOT
19400000
MVC DMASK+4(4),0(5)
MAKE INTEGER INTO
19420000
XI
DMASK+4,X'80'
(EXCESS 2*31)
19440000
LD
0,DMASK
NORMALIZED FLOATING.
19460000
SD
0,DTOPS
REMOVE EXCESS AND NORMALIZE
19480000

STD
MVC
BXH
B
*
*
*
*
NUML5
*

NUML11
NUML12

NUMCLS

NUMC1

.NUMLE

0,NTEMP
0(8,4),NTEMP
5,2,NUML20
NUML15

MOVE FLOATED CONSTANT INTO SINK

RESTORE REGISTERS

NOW R2 = CONSTANT COUNT

R3 = CURRENT CONSTANT TYPE
R4 = TOCPTR
LA
2,1(2)
BUMP CONSTANT COUNT
ST
2,CCNT
L
3,CTYP
ALREADY LOADED EXCEPT FOR THE CASE
2,1, IN WHICH CTYP = 1, R3 = 0
CLI CCNT+2,X'80'
DISALLOW CONSTANT VECTORS OF MORE
BNL TROUBLE
THAN 32,767 ELEMENTS
IC
3,BYPERT(3)
PREPARE TO MOVE CONSTANT INTO THE
LTR 3,3
CODESTRING.
BNE NUML11
LOOK AT TYPE.
BCTR 2,0
BOOLEAN CONSTANT. GET 0-ORIGIN
SRDL 2,3
BIT INDEX.
A
2,TOCSAV
IC
0,M(2)
PICK UP PREVIOUS BITS OF VECTOR
SRL 3,29
LCR 3,3
COMPUTE SHIFT QUANTITY
SRL 0,7(3)
N
0,QFM2
O
0,DTEMP
CATENATE NEW BIT TO RH END OF BITS
SLL 0,7(3)
STC 0,M(2)
AND PUT BITS BACK IN CODESTRING
LA
2,1(2)
TOCPTR IS 1 PAST THIS BYTE
B
NUML12
LA
2,1(3,4)
FIXED AND FLOATING MOVES.
AR
4,MR
JUST MOVE THE CONSTANT AT DTEMP.
EX
3,NUMVC
ST
2,TOCPTR
STORE UPDATED TOCPTR.
BAL LKR,FREECH
CHECK FOR 20 BYTES OF SLOP
P054
LR
5,6
SKIP OVER BLANKS (OR 1050 EOB)
P054
BAL LKR,SKBL
BUT
P054
CR
5,6
CLOSE THIS CONSTANT IF NO
P054
BE
NUMCLS
BLANKS OR EOB
P054
CLI 0(6),Z0
IF NONBLANK IS
P054
BL
NUMCLS
A CONSTANT BEGINNER
P054
CLI 0(6),ZOVB
THEN WE ARE BUILDING
P054
BNH NUML14
A VECTOR
P054
L
1,TOCSAV
RESET CODE STRING POINTER
P054
L
2,CCNT
FETCH CONSTANT COUNT
P054
LTR 2,2
AND IF WE HAVE
P054
BZ
NUMC1
SOMETHING THEN
P054
BAL LKR,TOCODE2
STUFF COUNT IN CODE STRING
P054
L
2,CTYP
FETCH APPROPRIATE
P054
IC
2,CONSYL(2)
CONSTANT SYLLABLE AND
P054
BAL LKR,TOCODE1
STUFF IT IN CODE STRING
P054
LA
2,ZFPER
CHECK FOR CAUSE OF ILLEGAL
P054
CLI 0(6),ZPER
CONSTANT DETECTED BY ICV
P054
BE
SCANA1
IF ITS A PERIOD OR OVERBAR
P054
LA
2,ZFOVB
SEND IT TO CODE STRING VIA
P054
CLI 0(6),ZOVB
SCANA1 SO THAT SCAN WILL
P054
BE
SCANA1
NOT CALL NUML AGAIN WITH THE
P054
B
SCAN
SAME CHARACTER
P054
AGO .NUMLE
P054
ANOP
P054

19500000
19520000
19540000
19560000
19580000
19600000
19620000
19640000
19660000
19680000
19700000
19720000
19740000
19760000
19780000
19800000
19820000
19840000
19860000
19880000
19900000
19920000
19940000
19960000
19980000
20000000
20020000
20040000
20060000
20080000
20100000
20120000
20140000
20160000
20180000
20200000
20220000
20240000
20260000
20280000
20300000
20320000
20340000
20360000
20380000
20400000
20420000
20440000
20460000
20480000
20500000
20520000
20540000
20560000
20580000
20600000
20620000
20640000
20660000
20680000

NUM18M
NUMVC
TCCOD
CONSYL
NUMTL
BYPERT
*
*
IDL

IDL2
IDL3

*
*
*
*
*
*
*
SRCHID

SRCHC
SRCHJ
SRCHCL

MVC
MVC
DC
DC
DC
DC
EJECT

0(0,1),NTEMP
MOVE IN CONSTANT-EXPANSION
20700000
0(0,4),DTEMP
FOR MOVING INT/FLT CONSTANTS TO CDST 20720000
AL1(CVBTOI,CVBTOF) TYPE-CONVERSION CODES
20740000
AL1(CBCONST,CICONST,CFCONST)
20760000
FL1'4,8'
20780000
FL1'0,3,7'
MOVE LENGTHS
20800000
20820000
20840000
BUILD AN IDENTIFIER
20860000
EQU *
20880000
LA
2,1+2*ZSDELTA
MAKE A QUICK, GLITCH CHECK
20900000
CLC 0(2,6),QZSD
FOR PROGRAMMED STOP (S DELTA)
20920000
BE
IDL2
20940000
LA
2,1+2*ZTDELTA
OR TRACE (T DELTA)
20960000
CLC 0(2,6),QZTD
PRECEDING IDENTIFIER.
20980000
BNE IDL3
21000000
LA
6,1(6)
IF PRESENT, LOP IT OFF THE IDENT
21020000
B
SCANA
AND SEND A 'STOP' OR 'TRACE' TO CS 21040000
BAL LKR,SRCHID
CATENATE CHARACTERS
21060000
ST
2,LASTID
SYMBOL MAY BE WANTED LATER.
21080000
BAL LKR,TOCODE2
STUFF THE LONG SYLLABLE
21100000
B
SCAN
21120000
21140000
BUILD AN IDENTIFIER AND SEARCH FOR IT IN THE SYMBOL TABLE.
21160000
IF IT'S NOT THERE, INSERT IT AND MAKE IT AN UNDEFINED VARB.
21180000
ON ENTRY, R6 = ABSOLUTE ADDRESS OF NEXT CHARACTER
21200000
ON EXIT, R6 = UPDATED CHARACTER ADDRESS
21220000
R5 = CHARACTER COUNT
21240000
R2 = M-RELATIVE ADDRESS OF SYMBOL ENTRY
21260000
ST
LKR,SRCHRET
SAVE RETURN LINK
21280000
BAL LKR,BLDID
BUILD THE IDENTIFIER
21300000
ST
6,SRCHRET+4
SAVE DELIMITER ADDRESS
21320000
LR
3,5
GET CHARACTER COUNT OFFSET BY 1 FOR 21340000
BCTR 3,0
CLC
21360000
LM
0,1,NEWID
SCRAMBLE FIRST 8 CHARS OF NEW NAME 21380000
SLL 1,4
21400000
ALR 1,0
21420000
ALR 1,5
21440000
M
0,FOLDER
21460000
ALR 1,0
21480000
L
8,QR13STK
DETERMINE SYMBOL TABLE SIZE
21500000
L
4,QSYMBOT
21520000
SR
8,4
21540000
LR
LKR,8
TOTAL LENGTH
21560000
SRL 8,3
NUMBER OF SYMBOLS
21580000
AR
4,MR
ABS ADDRESS, BOTTOM OF TABLE
21600000
SR
0,0
GET TABLE SIZE RESIDUE
21620000
SRL 1,3
OF HASHED SYMBOL FOR FIRST LOOKUP
21640000
DR
0,8
21660000
LR
1,0
21680000
SLL 1,3
SYMBOLS ARE DOUBLEWORDS
21700000
CLR 1,LKR
BRING R1 BACK INTO BOUNDS OF
21720000
BL
SRCHJ
SYMBOL TABLE
21740000
SR
1,LKR
21760000
LA
2,0(1,4)
GET ABS ADDRESS OF THIS BST ENTRY
21780000
CLI 4(2),0
IS THIS SPACE OCCUPIED -21800000
BE
SRCHB
NO. PUT OUR SYMBOL HERE.
21820000
EX
5,SRCHCL
DO CHARACTER COUNTS MATCH -21840000
BNE SRCHG
21860000
CLI 4(2),4
YES. FIND PRINT NAME OF SYMBOL.
21880000

SRCHD
SRCHG
QH168
*
*
*
*
*
SRCHK
*

SRCHCC
*
*
*
*
*
*
*
*
*
SRCHB

*
*
*
*

SRCHE
SRCHR

BL
L
LA
EX
LA
BE
LA
EQU

SRCHD
2,4(2)
2,MPNAME-4(2)
3,SRCHCC
2,0(1,4)
SRCHR
1,168(1)
SRCHG+2

21900000
21920000
21940000
21980000
22000000
22020000
22040000
22060000
DESIGNED TO AVOID INSPECTION OF A
22080000
SYMBOL WHICH IS A HAMMING DISTANCE 22100000
OF ONE FROM NEW ID. IT ALSO IS
22120000
RELATIVELY PRIME TO BST LENGTH SO
22140000
WE DON'T MISS ANY POSITIONS.
22160000
BCT 8,SRCHC
PROTECTION AGAINST FULL SYMBOL TABLE 22180000
TM
COPTOG,COPOBIT
CHECK FOR UNUSUAL CASE OF FULL S.T. 22200000
IN COPY SOURCE. TREAT THIS AS
22220000
BO
COPERR
'OBJECT NOT FOUND'.
22240000
BAL 1,PPERR
22260000
DC
AL1(17,ZS,ZY,ZM,ZB,ZO,ZL,ZBLANK,ZT,ZA,ZB,ZL,ZE,ZBLANK,ZF.22280000
,ZU,ZL,ZL)
22300000
CLC 5(0,2),0(7)
THE EXECUTED CLC
22320000
22340000
INSERT NEW SYMBOL IN SYMBOL TABLE.
22360000
NOW, R1 = BST-RELATIVE ADDRESS OF SYMBOL TABLE ENTRY
22380000
R2 = ABS ADDRESS OF SYMBOL TABLE ENTRY
22400000
R3 = CHARACTER COUNT - 1
22420000
R5 = CHARACTER COUNT
22440000
R6 = ABS ADDRESS OF NEXT INPUT CHARACTER
22460000
R7 = ABS ADDRESS OF FIRST CHAR OF ID
22480000
22500000
STC 5,4(2)
SET CHARACTER COUNT IN PNAME WORD
22520000
MVC 0(4,2),UNVAR
MAKE CLASS VARB, VALUE UNDEFINED
22540000
LR
1,2
22560000
CLI 4(2),4
IS IT THREE OR LESS -22580000
BL
SRCHE
YES. INSERT PRINT NAME DIRECTLY.
22600000
LA
4,MPNAME-M+4(5)
NO. RESERVE FULLWORDS IN M
22620000
N
4,QFM4
FOR PRINT NAME.
22640000
LA
0,60(4)
INCLUDE A SAFETY MARGIN, AND
22660000
L
6,SRCHRET+4
(FOR ERROR DISPLAY)
22680000
BAL LKR,FREECH1
CHECK FREE SPACE SITUATION.
22700000
LCR 1,4
SAVE LENGTH MOMENTARILY
22720000
A
1,SVI
PNAME ENTRY GOES ON THE STACK FOR
22740000
ST
1,SVI
THE MOMENT BECAUSE TOP OF M IS
22760000
OCCUPIED WITH AN OPEN CODESTRING.
22780000
LA
1,4(1)
BUMP R1 TO ADDRESS 1ST WORD OF ENTRY 22800000
NOW R1 = PNAME ADDRESS
22820000
R2 = ABSOLUTE BST ADDRESS
22840000
ST
1,4(2)
POINT PNAME WORD OF BST ENTRY AT
22860000
PNAME M-ENTRY
22880000
STC 5,4(2)
RE-STORE CHARACTER COUNT
22900000
STC 5,MPNAME(1)
22920000
ST
4,MCOUNT(1)
PUT BYTE COUNT IN COUNT WORD
22940000
LA
4,4(2)
BUMP R4 TO ADDRESS PNAME WORD OF
22960000
SR
4,MR
BST ENTRY
22980000
ST
4,MHEAD(1)
POINT M-ENTRY AT BST PNAME WORD
23020000
LA
1,MPNAME-4(1)
FIND ABS DATA ADDRESS IN M-ENTRY
23040000
EX
3,SRCHMV
AND MOVE PRINT NAME INTO IT.
23060000
LR
3,2
CALLER MAY WANT SYMBOL TABLE ADDR
23080000
SR
3,MR
M-RELATIVE
23100000
SR
2,LR
RELATIVIZE R2
23120000
PNAME OF 4 OR MORE CHARACTERS HAS
CHARACTERS STORED AS AN M-ENTRY.
COMPARE PNAME AGAINST NEW ID.
(RESTORE BST POINTER)
HOORAY -- THEY'RE THE SAME.
168 IS A SEMI-MAGIC CONSTANT

SRCHMV
*
*
*
*
*
*
BLDID

NEWIDZ
BLDID2

BLDID3
BLDID4

*
*
CDELL

*
*
CRL

WE ASSUME THAT LR = MR + R13STK

SRA
L
L
BR
MVC

RELOAD INPUT POINTER

EXECUTED MOVE FOR PRINT NAMES

BUILD AN IDENTIFIER.
ON ENTRY, R6 = ABSOLUTE INPUT CHARACTER POINTER
ON EXIT, R6 IS UPDATED TO 1 PAST LAST CHARACTER OF IDENTIFIER
R5 IS CHARACTER COUNT
R7 IS POINTER TO FIRST CHARACTER OF ID
LR
7,6
LA
5,NEWID-1
LA
2,1
LA
3,NEWID+7
SET UP BXH LOOP
XC
NEWID(8),NEWID
CLI 0(6),ZA
SCAN INPUT UNTIL NONALPHANUMERIC
BL
BLDID4
CHARACTER IS FOUND.
CLI 0(6),Z9
BH
BLDID4
BXH 5,2,BLDID3
MOVE FIRST EIGHT CHARACTERS OF
MVC 0(1,5),0(6)
IDENTIFIER INTO NEWID.
LA
6,1(6)
BUMP INPUT POINTER TO
B
BLDID2
NEXT CHARACTER.
LCR 5,7
DELIMITER SPOTTED.
AR
5,6
FIND LENGTH OF IDENTIFIER
C
5,QF77
IF IT'S MORE THAN 77 CHARACTERS,
BCR 13,LKR
LA
5,77
IGNORE THOSE PAST 77TH AND CALL ITS
BR
LKR
LENGTH 77.
EJECT
BAL
CLI
BNE
OI
LM
LA
N
LR
SR
ST
LA
SR
STH
CLI
BNE
C
BE

CRL1

2,2
LKR,SRCHRET
6,SRCHRET+4
LKR
5(0,1),0(7)

TM
BO
TM
BO
L
LA

CLOSING DEL SCANNED.

LKR,SKBLI
ENSURE THAT DEL IS LAST NONBLANK
0(6),ZCR
FNERR
ON LINE
FDTOG,FDCLBIT
DEFINITELY CLOSING THIS DEFINITION
CARRIAGE RETURN SCANNED. END OF STATEMENT.
1,2,TOCORG
(TOCORG, TOCPTR)
0,3(2)
POLISH OFF THE CODESTRING.
0,QFM4
ROUND IT UP TO A WORD BOUNDARY
5,0
0,1
PUT BYTE COUNT IN COUNT WORD.
0,MCOUNT(1)
0,MCSORG-M(1)
NOW GET TRUE BYTE COUNT
2,0
(I.E, BYTE COUNT OF SYLLABLES)
2,MCSCNT(1)
STORE BYTE COUNT OF SYLLABLES
FDTOG,0
ARE WE DEFINING A FUNCTION -CRL1
YES. BYPASS EMPTY-LINE CHECK.
2,P10
IF SYL CNT IS 1, CODESTRING CONSISTS
BEGST2
SOLELY OF AN EOS AND THE INPUT LINE
SOLELY OF A CR. ASK FOR MORE INPUT.
QUADTOG,STREMBIT
DITTO FOR COMMENT LINE IN IMMEDIATEBEGST2B
EXECUTION.
COPTOG,COPIBIT
ARE WE A COPY SINK
3575
TYOSDCOP
YES. MUST BE END-COPY MSG
3575
3,PARREL
SET CODESTRING INFORMATION
4,STCODE(3)
INTO THE STACK AND VICE VERSA.

23140000
23160000
23180000
23200000
23220000
23240000
23260000
23280000
23300000
23320000
23340000
23360000
23380000
23400000
23420000
23440000
23460000
23480000
23500000
23520000
23540000
23560000
23580000
23600000
23620000
23640000
23660000
23680000
23700000
23720000
23740000
23760000
23780000
23800000
23820000
23840000
23860000
23880000
23900000
23920000
23940000
23960000
23980000
24000000
24020000
24040000
24060000
24080000
24100000
24120000
24140000
24160000
24180000
24200000
24220000
24240000
24260000
24280000
24300000
24320000

ST
O
ST
STH
ST
CLI
BNE
ON
BAL
BAL
ON
*
CRL2

CRLM
*

*
*

*
*
CRL5

CRL5A
*
*
CRL5B

*
*
*
*
CRL7

ICALL
B
EQU
ST
BAL
L
BCT
MVC

4,MHEAD(1)
1,QCODCLS
1,STCODE(3,MR)
2,STCPTR(3,MR)
5,MX
FDTOG,0
CRL2
FP
8,RELPNS
LKR,TYOSD
ATTN,=V(BGATTNX)

POINT CODESTRING AT STACK

AND STACK AT CODESTRING.
PUT INITIAL SYLLABLE BYTE COUNT IN
IF WE'RE DEFINING A FUNCTION,
THERE IS MUCH MORE TO BE DONE.
REVERT TYPEIN-SET CONDITIONS
AND DO A GIANT GARBAGE COLLECTION.
POSSIBLY PRINT 'STACK DAMAGED'
ENABLE FORCED ATTENTION
IN CASE OF TIME LIMIT OR DOUBLE ATTN
OFF TO THE INTERPRETER -AND BACK TO THE TYPEWRITER.
END OF STATEMENT IN FUNCTION DEFINT.

SYNTXX
TYPTOP
*
2,SCSCNT
LKR,PRIFN
POSSIBLY DISPLAY, FIND OUR LINE NO.
7,SCSCNT
RECALL BYTE COUNT
7,CRL5
FOR CURRENT LINE. IS IT EMPTY -MX,TOCORG
YES. RELEASE ITS STORAGE.
***** WORKS ONLY BECAUSE WE KNOW CS IS LAST M-ENTRY ****
TM
LFTOG,X'10'
DID SOURCE CONTAIN A LINE-DELETING
BO
CRL5A
LINE-FEED -NI
DPYTOG,255-DPYNMT NO. IGNORE THIS LINE COMPLETELY.
SET DPYTOG TO INHIBIT LINE-BUMPING
TM
DPYTOG,DPYED
IS CHARACTER EDITING REQUESTED -BZ
CRL8A
CLI OBUF,ZLBR
YES. IGNORE REQUEST IF 1ST CHAR OF
LAST LINE WAS NOT A LEFT BRACKET -I.E. IF DISPLAYED STATEMENT EXTENDED
BNE CRL8A
OVER MORE THAN ONE LINE.
OI
INTOG,CEBIT
SET 'CHAR EDIT' FLAG FOR INLINE
MVC CETMP(2),LLLO
SAVE LENGTH OF DISPLAYED STATEMENT
B
CRL8A
NEW STATEMENT EXISTS.
REPLACE OLD STATEMENT (IF ANY) BY NEW STATEMENT (IF ANY)
LM
1,2,MX ,SVI
CALCULATE REMAINING FREE SPACE IN M
LA
0,80(1)
A01
SR
0,2
REJECT THE NEW CODESTRING UNLESS
BM
CRL5A
ENOUGH FREE STORAGE REMAINS TO AT
EX
0,CRLM
LEAST DELETE OTHER LINE IN THIS FN.
B
TROUBLE
PRINT 'WS FULL'
L
1,FLINENO
TAKE SPECIAL ACTION IF THIS IS
BXLE 1,1,FLOSC
FUNCTION HEADER ( LINE 0 )
THIS TEST MUST PRECEDE THE BAL 8,RELPNS AT CRL7
SINCE FLOSC MAY EXPAND THE CODESTRING FOR LINE 0
L
4,PRIFT
PREPARE TO DELETE OLD LINE
LTR 2,4
IS THERE AN OLD LINE WITH THIS NO.-BZ
CRL7
NO. MAKE NEW SPACE FOR THIS CODESTR
L
1,PARREL
ING AND CARRY OVER ANY TRACE, STOP
IC
0,MHEAD(4)
SETTINGS.
STC 0,STCODE(1,MR)
BAL 1,MKCSGI
MARK OLD LINE GARBAGE
B
CRL6
THIS LINE NUMBER IS NEW FRACTIONAL OR OUT-OF-RANGE INTEGRAL.
CREATE A 3-WORD ENTRY FOR CODESTRING POINTER (AND LINE NO)
ON THE STACK.
BXLE 1,7,CRL8A
A01
BAL 8,RELPNS
MOVE LONG PRINTNAMES DOWN
A01

24360000
24380000
24400000
24420000
24440000
24460000
24480000
24500000
24520000
24540000
24560000
24580000
24600000
24620000
24640000
24660000
24680000
24700000
24720000
24740000
24760000
24780000
24800000
24820000
24840000
24860000
24880000
24900000
24920000
24940000
24960000
24980000
25000000
25020000
25040000
25060000
25080000
25100000
25120000
25140000
25160000
25180000
25200000
25220000
25240000
25260000
25280000
25300000
25320000
25340000
25360000
25380000
25400000
25420000
25440000
25460000
25480000
25500000
25520000
25540000

WE NEED THE SPACE FOR FRLN ENTRY.

3,SVIT
RESERVE THREE WORDS AT SVIT
3,QF12
3,SVIT
3,SVI
2,4(3)
R2 IS POINTER TO FIRST WORD
4,LINTF
4,MR
GET ABSOLUTE ADDRESS OF ENTRY FOR
3,M(2)
NEXT LOWER-NO LINE, AND NEW SLOT
FLENT,3
FLENTLNK,FLENTLNK-FLENT(4) MOVE LOWER-NO LINK INTO
FLENTNO,FLINENO
NEW SPACE, NEW LINE INTO NEW SPACE,
2,FLENTLNK-FLENT(4) AND ADDR OF NEW LINE ENTRY INTO OLD
SPACE.
DROP 3
REENTRY FOR IN-RANGE INTEGRAL LINE NUMBER
NOW R2 = ADDRESS OF CODESTRING POINTER
R5 = ADDRESS OF CODESTRING + CODESTRING CLASS
R7 = BYTE COUNT OF CODESTRING SYLLABLES, - 1
L
3,PARREL
NEW CODESTRING POINTER WAS STORED
L
5,STCODE(3,MR)
IN STACK TEMPORARILY.
SR
0,0
CLEAR STACK LOCATION FOR
ST
0,STCODE(3,MR)
CLEANLINESS
ST
7,M+FLENTCSA-FLENTCSA(2) STORE ZERO IN DIRECTORY, OR,
BXLE 7,7,CRL8
IF CODESTRING IS NOT EMPTY,
STORE POINTER TO IT IN FN DIRECTORY
(OR FRACTIONAL-LINE LIST.)
ST
5,M+FLENTCSA-FLENTCSA(2)
ST
2,MHEAD(5)
POINT CODESTRING BACK AT CODESTRING
POINTER
BAL 8,RELPNS
MOVE LONG PRINTNAMES DOWN TO MX
DOING THIS EARLIER WOULD MAKE PRIFT
UNRELIABLE.
TM
FDTOG,FDCLBIT
ARE WE CLOSING THIS DEFINITION -BZ
BEGST1
NO, LINE ENDED WITH CR.
DEL. CLOSE OUT FUNCTION DEFINITION.
SET UP NEW FUNCTION DIRECTORY AT MX.
BAL 8,LINIT
INITIALIZE TRACE THROUGH ALL LINE
NUMBERS TO MOVE CODESTRING POINTERS
TO NEW DIRECTORY AND DEFINE ANY
LABELS.
SR
7,7
LINE COUNTER, TIMES FOUR
BAL 8,LINTRAC
GET NEXT ASCENDING LINE NUMBER
B
CRL10
PAST LAST LINE
L
4,M(4)
NOT PAST LAST LINE. LOAD CS PTR
LTR 4,4
IS LINE EMPTY -BZ
CRL9
YES. IGNORE IT.
L
2,MX
GET BASE ADDRESS OF DIRECTORY
LA
7,4(7)
ADD 1 TO LINE COUNT
AR
2,7
LA
0,80(2)
BAL LKR,FREECH2
ASSURE ADEQUATE SPACE FOR DIRECTORY
ST
4,MFCODE-4(2)
PUT LINE IN DIRECTORY
B
CRL9
L
5,MX
FINISH BUILDING THE NEW DIRECTORY
LR
0,7
SRL 7,2
STH 7,MFLINES(5)
NEW DIRECTORY LINE COUNTER
LM
2,3,LINAB
HAVING ASSURED OURSELVES OF ADEQUATE
L
1,DFNPTR
L
S
ST
ST
LA
L
AR
LA
USING
MVC
MVC
ST

*
*
*
*
*
CRL6

*
*
*
CRL8
*
*
CRL8A
*
*
*
*
*
CRL9

CRL10

25560000
25580000
25600000
25620000
25640000
25660000
25680000
25700000
25720000
25740000
25760000
25780000
25800000
25820000
25840000
25860000
25880000
25900000
25920000
25940000
25960000
25980000
26000000
26020000
26040000
26060000
26080000
26100000
26160000
26180000
26200000
26220000
26240000
26260000
26280000
26300000
26320000
26340000
26360000
26380000
26400000
26420000
26440000
26460000
26480000
26500000
26520000
26540000
26560000
26580000
26600000
26620000
26640000
26660000
26680000
26700000
26720000
26740000
26760000
26780000

4,M(1)

LTR
BZ
L
ST
BAL

1,1
CRL10A
LKR,UNVAR
LKR,M(1)
1,MKCSG

DS
ST
LA
STH

0H
2,MFLCLS(5)
2,MFCODE-M
2,MLSOS(5)

*
*
*
*
*
*
*

*
CRL10A

*
AR
ST
LA
L
ST
MVI
OC
ST
STC
LR
LA
AR
ST
*
*
CRL11

CRL12
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

L
ST
AR
CLI
BNE
LH
LA
STH
LA
BCT

STORAGE, MARK THE OLD FUNCTION

DIRECTORY GARBAGE.
PREPARE TO POINT CODESTRINGS TO THE
NEW DIRECTORY. THESE SHENANIGANS
ARE BEING PERFORMED SERIALLY IN
ORDER TO PRESERVE THE PREVIOUS STATE
OF THE FUNCTION IN CASE OF AN M FULL
ERROR.
NO DIRECTORY IF DFNPTR IS 0
FOLLOWING CODE WILL SET SYMBOL TBL
(WE MUSTN'T CALL MKGARB -- IT WOULD
GARBAGE ALL LINES AS WELL.)
STORE P/L/R WORD IN NEW DIRECTORY
AND LIST-OFFSET HALFWORD

BYTE COUNT IS 4 * LINE COUNT

2,0
PLUS OVERHEAD
2,MCOUNT(5)
4,M(5)
1,PINAB
POINT DIRECTORY AT BST ENTRY
1,MHEAD-M(4)
AND VICE VERSA
MLIST-M(4),MLSTBIT
MHEAD-M(1,4),PROTOG INCLUDE FUNCTION PROTECTION BIT
5,M(1)
STORE DIRECTORY POINTER IN SYMBOL TB
3,M(1)
STORE FN CLASS (DFN OR DFN0) LIKEWIS
8,5
PRESERVE A DIRECTORY POINTER
5,MFCODE-M(5)
SET UP R5 TO POINT TO LINE 0
0,5
FINALLY GIVE MX ITS NEW VALUE
0,MX
NOW R7 = 'COMPLEMENT' LINE NUMBER FOR BCT CLOSURE
R5 = ADDR OF CODESTRING PTR IN DIRECTORY
4,M(5)
PICK UP CODESTRING POINTER
5,M(4)
4,MR
MCSORG-M(4),CLEOS DOES FIRST SYL SAY 'LABEL' -CRL12
NO LABEL.
4,MFPARS(8)
LABEL.
4,16(4)
BUMP THE LABEL COUNT BY 1.
4,MFPARS(8)
5,4(5)
BUMP CODESTRING POINTER ADDRESS
7,CRL11
BACK FOR NEXT LINE, OR QUIT

CODE IN THIS VICINITY DAMAGES THE STACK

UNDER THE FOLLOWING CIRCUMSTANCES,
IN THIS MANNER ..
)ERASE FN
ALL STACKED INSTANCES OF 'FN'
CALLS DEL30, RETURNS TO BEGST2 EVENTUALLY
HEADER EDITING
ALL STACKED INSTANCES OF ORIGINAL DFN NAME
CALLS CRL18, RETURNS THROUGH CRL LOGIC
LABELS SCRAMBLED, CLOSE OF DEFN OF TOP-OF-STACK DFN
ALL STACKED INSTANCES OF DFN
GOES THROUGH REVAL, CRL17, RETURNS IMMEDIATELY TO TYPIN3
LABELS CHANGED, CLOSE OF DEFN OF TOP-OF-STACK DFN

26800000
26820000
26840000
26860000
26880000
26900000
26920000
26940000
26960000
26980000
27020000
27040000
27060000
27080000
27100000
27120000
27140000
27160000
27180000
27200000
27220000
27240000
27260000
27300000
27320000
27340000
27360000
27380000
27420000
27440000
27460000
27480000
27500000
27520000
27540000
27600000
27620000
27640000
27660000
27680000
27700000
27720000
27740000
27760000
27780000
27800000
27820000
27840000
27860000
27880000
27900000
27920000
27940000
27960000
27980000
28000000
28020000
28040000
28060000
28080000

*
*
* CLOSE
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
REVAL

REVAL4

REVAL2

REVAL3
REVAL7
*
*
REVAL8

ALL STACKED INSTANCES OF DFN BELOW TOP LEVEL

GOES THROUGH REVAL, CRL17, RETURNS IMMEDIATELY TO TYPIN3
OF DEFN OF NON TOP-OF-STACK DFN
ALL STACKED INSTANCES OF DFN (BELOW TOP LEVEL)
GOES THROUGH REVAL, CRL17, RETURNS IMMEDIATELY TO TYPIN3
REASSIGN VALUES TO LOCAL LABELS IF THIS FUNCTION IS SUSPENDED.
IN THE FOLLOWING,
R1 = STACK POINTER TO LABEL SHADOWS
R2 = SCRATCH
R3 = FUNCTION DIRECTORY POINTER
R4 = TRUE LINE NUMBER
R5 = REVAL1
R6 = COMPLEMENT LINE NUMBER FOR LOOP CLOSURE
R7 = CODESTRING POINTER
R8 = RELATIVE STACK POINTER
L
L
N
C
BNE
L
LA
LH
SR
B
LA
LA
L
LA
CLI
BNE
LA
CLI
BNE
L
LA
AR
CLI
BNE
BAL
CR
BNE
L
C
ST
BE
OI
BCT
TM
L

8,PARREL
3,STFNSPTR(8,MR)
COMPARE FUNCTION AT TOP OF STACK
3,QF24BITS
3,PINAB
TO NEWLY CLOSED FUNCTION.
REVAL7
UNLIKE. IT MUSTN'T MATCH LOWER FN.
3,M(3)
ADDRESS OF FN DIRECTORY
1,STSHADOW+24(8,MR) JUST BELOW FIRST LOCAL (IF ANY)
6,MFLINES(3)
SET UP TO LOOP THROUGH ALL LINES
4,4
OF FUNCTION
REVAL3
CASE OF DISEMBODIED FUNCTION
4,1(4)
ADVANCE LINE NUMBER
3,4(3)
ADVANCE CODESTRING POINTER
7,MFCODE(3)
7,3(MR,7)
STATEMENT MUST BEGIN WITH A ZLEOS
MCSORG-M-3(7),1+2*ZLEOS
REVAL3
OR IT'S NOT A LABELLED STMT.
1,8(1)
ADVANCE TO NEXT LOCAL OR LABEL
0(1),SHADOW+X'80' ONLY SURE TEST FOR END OF LOCALS
REVAL6
FAILURE -- ADDITIONAL LABELS DEFINED
2,0(1)
POINTER TO SYMBOL TABLE ENTRY OF
0,0(2)
LOCAL
2,MR
0(2),CONST
IF NOT CLASS=CONST, WE'RE NOT INTO
REVAL2
THE LABELS YET. CONTINUE LOOKING.
LKR,FLOSB2
GET THE S.T. ADDR OF THE LINE LABEL
2,0
REVAL6
FAILURE -- LABELS DELETED OR SHUFFLD
2,M(2)
M-ENTRY ADDR
4,MRHO(2)
COMPARE NEW TO OLD VALUE, THEN STORE
4,MRHO(2)
NEW LABEL VALUE
REVAL3
ALL SERENE
DSTOG,DSCLBIT
STACK DAMAGED IF FN APPEARS AGAIN
6,REVAL4
DSTOG,DSCLBIT
DONE WITH TOP LEVEL.
1,STFREG(8,MR)
START WITH NEXT STACK LEVEL

L
LA
BNZ
BR

RAMPAGE THROUGH ALL OR PART OF THE STACK,

LKR,PINAB
DESTROYING REFERENCES TO NEWLY- 2213
8,TYPIN3
CLOSED FUNCTION.
CRL19
CC MEANS DIFFERENT THINGS TO
8
DIFFERENT PREDECESSORS

28100000
28120000
28140000
28160000
28180000
28200000
28220000
28240000
28260000
28280000
28300000
28320000
28340000
28360000
28380000
28400000
28420000
28440000
28460000
28480000
28500000
28520000
28540000
28560000
28600000
28620000
28640000
28660000
28680000
28700000
28720000
28740000
28760000
28780000
28800000
28820000
28840000
28860000
28900000
28920000
28940000
28960000
28980000
29000000
29020000
29040000
29080000
29100000
29120000
29140000
29160000
29180000
29200000
29220000
29240000
29260000
29280000
29300000
29320000
29340000

REVAL6
*
*
*
*
DEL30A
DEL30
DEL30B

*
CRL18
CRL17

*
*
*
*
CRL16
CRL19

CRL15
*
*
*
MKCSGI
*
MKCSG

LTR
B

1,8
REVAL8

FAILURE -- LABELS SCRAMBLED.

REMOVE ALL REFERENCES FROM STACK

ERASE FUNCTION SPECIFIED BY R1 (= M-POINTER)

R3 = SYMBOL TABLE OR STACK POINTER
R8 = RETURN ADDRESS
MVI TUSR,0
ERASE CLASSIFICATION TOO
ICALL MKGARB
DELETE DIRECTORY AND ALL LINES
LTR LKR,3
2213
BCR 8,8
L
1,UNVAR
REPLACE THE S.T. ENTRY
ST
1,M(3)
BY AN UNDEFINED VARIABLE
ENTRY FROM HEADER EDITING
L
1,PARREL
AR
1,MR
L
2,STFNSPTR(1)
COMPARE NAME OF FN TO NAMES OF ALL
N
2,QF24BITS
FNS ON THE STACK.
SR
2,LKR
DIFF=0 IF FN IS IN )SI
2213
BNZ CRL16
ST
2,STFNSPTR(1)
CLEAR OUT ALL REFERENCES TO THIS DFN
TO INDICATE STRICTLY IMMEDIATE
EXECUTION -- THAT IS,
DON'T TRY TO RESUME FN EXECUTION
FOLLOWING A BRANCH.
MVI DSTOG,DSMSBIT
SET FLAG FOR LATER MESSAGE
L
1,STFREG(1)
ADVANCE TO NEXT LOWER FUNCTION
CR
1,LKR
AFTER TAKING INTO
A01 2213
BL
CRL15
CONSIDERATION POSSIBLE
A01
A
LKR,QFM4
SHADOWING OF NAME
A01 2213
L
LKR,M(LKR)
A01 2213
N
LKR,QF24BITS
A01 2213
BXH 1,MR,CRL17
UNLESS THIS IS END OF LIST
A01
BR
8

N
BCR
L
N
BCR
MKG
BR

MARK GARBAGE THE M-ENTRY ADDRESSED INDIRECTLY BY R4.

R1 = RETURN ADDR
4,QF24BITS
MAY BE A FALSE ALARM
8,1
4,M(4)
MARK GARBAGE THE M-ENTRY ADDRESSED BY R4.
4,QF24BITS
8,1
NO M-ENTRY
4
1

*
*
PRINT 'SI DAMAGE' IF THAT IS THE CASE.
*
TYOSDCOP BAL 8,RELPNS
RELOCATE PRINTNAME FOR 'SAVED'
LA
LKR,ENDCOPY
SET EXIT FROM TYOSD
TYOSD
TM
DSTOG,DSMSBIT
BCR 8,LKR
MVI DSTOG,0
TYO DSMSG
BR
LKR
*
WE WILL TYO THE CONTENTS OF THE INPUT BUFFER.
*
THE INPUT BUFFER CONTAINS A MESSAGE FROM THE COPY SOURCE
*
(NORMALLY, 'SAVED...', OR 'OBJECT NOT FOUND')
ENDCOPY LA
LKR,INBUF-1
GET LENGTH OF INPUT
SR
6,LKR
LINE.
STH 6,INBUF-2
STORE LENGTH FOR TYO

3575
3575

3575
3575
3575
3575
3575
3575

29360000
29380000
29400000
29420000
29440000
29460000
29480000
29500000
29520000
29540000
29560000
29580000
29600000
29620000
29640000
29660000
29680000
29700000
29720000
29740000
29760000
29780000
29800000
29820000
29840000
29860000
29880000
29900000
29920000
29940000
29960000
29980000
30000000
30020000
30040000
30060000
30080000
30100000
30120000
30140000
30160000
30180000
30200000
30220000
30240000
30260000
30280000
30300000
30320000
30340000
30360000
30380000
30400000
30420000
30440000
30460000
30480000
30500000
30520000
30540000

DSMSG
*
*
*
PRIFN
PRIF1
*
*
*

PRIF6
*
PRIF7

PRIF9

PRIFX
*
PRIFS

PRIF3

TYO INBUF-2
TYO THE INPUT LINE
3575
MVI COPTOG,0
TURN OFF COPY TOGGLE
3575
B
TYPIN2
RESUME, ASKING FOR NEXT LINE
3575
DC
H'10',AL1(ZS,ZI,ZBLANK,ZD,ZA,ZM,ZA,ZG,ZE,ZCR,ZEOB)
EJECT
PRINT FUNCTION OR SINGLE-LINE DISPLAY OR NOTHING,
DEPENDING ON DPYTOG. ALSO PUT A POINTER TO THE CODESTRING
POINTER IN PRIFT OR (IF NO CODESTRING EXISTS) LINTF.
ST
LKR,PRIFR
BAL 8,LINIT
INITIALIZE LINE-TRACING ROUTINE
BAL 8,LINTRAC
GET NO. AND CODESTRING PTR PTR OF
NEXT LINE.
B
PRIF9
ALL DONE -- BOTH LINE NOS ARE 10**8.
NOW R4 = ADDRESS OF CODESTRING POINTER
R5 = LINE NUMBER OF CODESTRING
TM
DPYTOG,DPYALL
ARE WE DISPLAYING EVERYTHING -BO
PRIF7
YES. DISPLAY THIS LINE.
C
5,FLINENO
DISPLAYING ONLY ONE LINE.
BL
PRIF1
SKIP PRINTING IF WE HAVEN'T REACHED
IT YET.
BE
PRIF6
JUST REACHED IT.
TM
DPYTOG,DPYPAST
PAST. ARE WE DISPLAYING FROM N ON BZ
PRIFX
NO. REALLY PAST.
ST
4,PRIFT
SAVE ADDR OF CODESTRING PTR FOR LINE
TM
DPYTOG,DPYLIN+DPYPAST IF NO DISPLAY, WE'RE NOT PRINTBZ
PRIFX
ING AT ALL, BUT SIMPLY FINDING THE
CODESTRING CORRESPONDING TO FLINENO.
L
2,M(4)
IF CODESTRING POINTER IS ZERO,
LTR 2,2
STATEMENT HAS BEEN DELETED.
BZ
PRIF1
STM 4,5,PRIFT ,FLINENO SAVE CODE PTR ADDR AND LINE NUMBER.
ATT ON=PRIF1,RESET=NO IF ATTN, SKIP DISPLAY BUT CONTINUE
TRACING THROUGH LINE-NUMBER LISTS.
BXH 5,5,*+8
LINE NO. 0 IS A FUNCTION HEADER.
BAL 5,PRIFS
PRINT SPACES AND DEL OR PDEL
BAL LKR,OLINO
PRINT BRACKETED LINE NUMBER.
L
3,PRIFT
RELOAD ADDRESS OF CODESTRING PTR
BAL LKR,COPCK
SOME INSURANCE OF REAL CODESTRING IF
BNE PRIF1
IT POINTS BACK TO DIRECTORY
L
3,QFM2
NON-ERROR FLAG
ICALL DISPLAY
PRINT THE STATEMENT.
B
PRIF1
BAL 5,PRIFS
PRINT DEL IF ENDING FN DISPLAY
B
PRIFX
ICALL LOUT
BAL LKR,UPLINE
UPDATE LINE NUMBER SO ANY NEW TEXT
SR
0,0
FOLLOWING DISPLAY REQUEST WILL
ST
0,PRIFT
APPEND RATHER THAN REPLACE.
L
LKR,PRIFR
RETURN TO CALLER
BR
LKR
TM
BCR
LA
CLI
BE
LA
ICALL
B
EJECT

DPYTOG,DPYALL
8,5
1,PRIDEL
PROTOG,0
PRIF3
1,PRIPDEL
SQUIRT
4(5)

30560000
30580000
30600000
30620000
30640000
30660000
30680000
30700000
30720000
30740000
30760000
30780000
30800000
30820000
30840000
30860000
30880000
30900000
30920000
30940000
30960000
30980000
31000000
31020000
31040000
31060000
31080000
31100000
31120000
31140000
31160000
31180000
31200000
31220000
31240000
31260000
31280000
31300000
31320000
31340000
31360000
31380000
31400000
31420000
31440000
31460000
31480000
31500000
31520000
31540000
31560000
THE DEL- OR PDEL-PRINTING SUBROUTINE 31580000
31600000
31620000
31640000
31660000
31680000
31700000
31720000
31740000

*
LINIT

LINIT2

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
DPYLIN
DPYALL
DPYNMT
*
DPYED
DPYPAST
LINTRAC

INITIALIZE ASCENDING-LINE-NUMBER SEARCH.

L
2,DFNPTR
LOCATE FUNCTION DIRECTORY
L
0,QF108
LTR 2,2
UNLESS NEW FUNCTION, WHICH HAS NONE
BZ
LINIT2
L
2,M(2)
R2 GIVES DIRECTORY ADDRESS
LA
1,MFCODE-M(2)
GET ADDRESS OF CODESTRING PTR FOR
LH
3,MFLINES(2)
LINE 0 (THE HEADER.)
SLA 3,2
AND ADDRESS PAST THE LAST ENTRY
AR
3,1
IN THE DIRECTORY.
SR
0,0
SET INTEGER LINE NO. TO 0
SR
2,2
SET 'LAST CODESTRING' TO EMPTY
ST
2,PRIFT
LA
2,HOFLN
POINT FRLNPTR TO THE FIRST FRACTIONSR
2,MR
AL LINE.
STM 0,3,ILN
SET INITIALIZED VALUES FOR LINTRAC
BR
8
FIND NEXT LARGER LINE NUMBER FROM FUNCTION DIRECTORY AND
FRACTIONAL-LINE-NUMBER LIST.
ON ENTRY,
ILN = NEXT INTEGER LINE NUMBER OR 100,000,000 (END FLAG)
ILNPTR = ADDRESS IN FUNCTION DIRECTORY OF CODESTRING
FOR LINE ILN
FRLNPTR = M-RELATIVE POINTER TO 3-WORD ITEM CONTAINING
NEXT FRLN
ON EXIT,
R4 = ADDRESS OF CODESTRING POINTER FOR THIS LINE
R5 = THIS LINE'S LINE NUMBER
WE DEPEND ON FIRST LINE NUMBER ALWAYS BEING -1, TO GIVE LINTF
AN INITIAL VALUE. TYPIN2 INITIALIZES FRACTIONAL LINE-NUMBER
LIST TO A SINGLE -1 ENTRY.
FORMAT OF FRACTIONAL-LINE-NUMBER ENTRY (DSECT FLENT)
WORD 1
WORD 2
WORD 3

POINTER TO CODESTRING M-ENTRY

LINE NUMBER * 10000
POINTER TO NEXT HIGHER FRACTIONAL-LINE ENTRY, OR 0

EQU
EQU
EQU

1
2
4

EQU
EQU
LM
USING
L
CR
BNL
LR
A
LR
LA
CR
BL
L

8
16
0,3,ILN
FLENT,2
5,FLENTNO(MR)
0,5
LINT2
5,0
0,F104
4,1
1,4(1)
1,3
LINT3
0,QF108

LINT3

*
*

DISPLAY SINGLE LINE OF FUNCTION

DISPLAY ENTIRE FUNCTION
CURRENT CODESTRING IS NOT EMPTY
(CONTROLS LINE-NUMBER BUMPING)
CHARACTER EDITING REQUESTED
DISPLAY FROM LINE N TO LAST LINE
PICK UP ILN,ILNPTR,FRLNPTR,ENDIR
WHICH LINE NUMBER IS LARGER -INTEGER, OR NEITHER.
FRACTIONAL.
BUMP LINE NO. TO NEXT INTEGER.
PICK UP ADDRESS OF CODESTRING POINTR
BUMP POINTER INTO FN DIRECTORY
ARE WE PAST THE END OF THE DIRECTORY
NO.
YES. LOAD END FLAG TO FORCE OUT ALL
REMAINING FRACTIONAL LINE NUMBERS.
FRACTIONAL LINE NO. IS LOWER.

31760000
31780000
31800000
31820000
31840000
31860000
31880000
31900000
31920000
31940000
31960000
31980000
32000000
32020000
32040000
32060000
32080000
32100000
32120000
32140000
32160000
32180000
32200000
32220000
32240000
32260000
32280000
32300000
32320000
32340000
32360000
32380000
32400000
32420000
32440000
32460000
32480000
32500000
32520000
32540000
32560000
32580000
32600000
32620000
32640000
32660000
32680000
32700000
32720000
32740000
32760000
32780000
32800000
32820000
32840000
32860000
32880000
32900000
32920000
32940000

LINT2

*
LINT4

LINT3

*
*
PDELL
*
*
*
DELL

BCR
C
BH
ST

8,8
5,FLINENO
LINT4
2,LINTF

QUIT NOW IF LINE NOS ARE BOTH 10**8.

IF THIS LINE NUMBER IS LESS THAN
CURRENT LINE NUMBER, SAVE ADDR OF CS
WE MAY NEED IT FOR 'INSERT AFTER'
OPERATION AT CRL7.
LR
4,2
RETURN ADDRESS OF CS PTR IN R4
L
2,FLENTLNK(MR)
AND GET ADDRESS OF NEXT FRACTIONAL
LTR 2,2
3-WORD ENTRY, IF ANY.
BNZ LINT3
IF LINK=0, WE ARE OFF THE END.
LA
2,LF108+FLENT-FLENTNO POINT R2 TOWARDS VERY LARGE NUMBER
SR
2,MR
WHICH WILL TERMINATE SEARCH.
STM 0,2,ILN
SAVE NEW POSITION IN I/F LINES.
B
4(8)
DROP 2
EJECT
PROTECTING DEL SCANNED.
MVI 0(6),ZDEL
MVI PROTOG,MFLKBIT

MAKE IT A DEL FOR REST OF CODE

BUT SET PROTECT BIT AT CLOSE OF DEFN

DEL SCANNED.

EQU
TM
BO
TM
BO
DELCOPY EQU
CLI
BNE
L
LA
S
BNZ
*
ST
BAL
B
BAL
MVI
LA
BAL
BAL
BAL
CLI
BE
CLI
BE
CLI
BE
LA
CLI
BCR
LA
TM
BO
*
CLI
BCR
*

*
COPTOG,COPIBIT
DELCOPY
QUADTOG,STQBIT
FNERR
*
FDTOG,0
CDELL
1,TOCORG
2,MCSORG+1-M(1)
2,TOCPTR
FNERR
2,FLINENO
LKR,DELIDS
FNERR
LKR,TOCODE2
FDTOG,FDDHBIT
0,100
LKR,FREECH1
LKR,TUSAG
LKR,SKBL
0(6),ZLBR
DEL3
0(6),ZDEL
DEL3
0(6),ZPDEL
DEL3
8,SCAN
0(6),ZCR
7,8
LKR,DELCHF
COPTOG,COPIBIT
DELCHA
TUSR,0
8,8

ARE WE A COPY SINK

BRANCH IF WE ARE
ARE WE IN QUAD INPUT MODE -YES. NO DEFINITION ALLOWED.

3575
3575

3575
IS IT AN OPENING OR CLOSING DEL -CLOSING.
OPENING. IS IT AT THE LEFT END OF
THE LINE -NO. ERROR.
PREPARE TO LOOK (TENTATIVELY) AT HDR
LINE NUMBER IS 0
FIND AND BUILD NEXT IDENTIFIER
NO IDENTIFIER AT ALL. ERROR.
SEND IT TO THE CODESTRING IN CASE
THIS IS INITIAL DEFINITON
ASSURE ENOUGH FREE SPACE TO PERMIT
CLOSING DEFINITION
FIND POSSIBLY SHADOWED S.T. ENTRY
ADVANCE TO NEXT NONBLANK
NOW LOOK AT ALLOWABLE DELIMITERS.

MOST INSIST ON PREVIOUS DEFINITION

UNRECOGNIZED. ASSUME INIT DEFN.
CR -- MIGHT BE INIT DEFN, MIGHT NOT.
MUST LOOK NOW FOR OLD VS NEW DEFN
COPY IS UNUSUAL -- IT UNDEFINES
ANY OLD DEFINITION
CONTINUE DEFINING IF INIT DEFINITION

32960000
32980000
33000000
33020000
33040000
33060000
33080000
33100000
33120000
33140000
33160000
33180000
33200000
33220000
33240000
33260000
33280000
33300000
33320000
33340000
33360000
33380000
33400000
33420000
33440000
33460000
33480000
33500000
33520000
33540000
33560000
33580000
33600000
33620000
33640000
33660000
33680000
33700000
33720000
33740000
33760000
33780000
33800000
33820000
33840000
33860000
33880000
33900000
33920000
33940000
33960000
33980000
34000000
34020000
34040000
34060000
34080000
34100000
34120000
34140000

DEL3
*
*

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
TUSAG

TUS1

TUS2

TUS3

CLI
BNE
ST

TUSR,2
FNERR
3,DFNPTR

34160000
34180000
34200000
34220000
34240000
L
2,M(3)
34260000
L
4,MFLCLS(2)
34320000
N
4,QPLMSK
34340000
LH
1,MFLINES(2)
34360000
M
0,F104
34380000
ST
1,FLINENO
NUMBER IN BRACKETS
34400000
IC
5,M(3)
CLASS FROM SYMBOL TABLE
34420000
STM 3,5,PINAB
SAVE FN INFO IN ABEYANCE
34440000
AR
2,MR
34460000
TM
MHEAD-M(2),MFLKBIT IF LOCKED FUNCTION,
34480000
BO
FNERR
DISALLOW ANY EDITING.
34500000
L
1,TOCORG
RESTORE TOCPTR TO LEFT END OF LINE 34520000
LA
1,MCSORG-M(1)
34540000
ST
1,TOCPTR
34560000
MVI FDTOG,FDDFBIT
NOW REALLY IN DEFINITION MODE
34580000
B
BEGST4
34600000
EJECT
34620000
34640000
TRACE UP STACK AFTER GLOBAL
34660000
LOCATE POSSIBLY SHADOWED GLOBAL OBJECT AND NOTE PENDENCY 34680000
ON ENTRY, R3 = M-RELATIVE SYMBOL TABLE POINTER
34700000
ON EXIT,
34720000
R3 = M-RELATIVE STACK OR SYMBOL TABLE POINTER
34740000
R1 = SAME, ABSOLUTE
34760000
R2 = SYMBOL TABLE POINTER OF OBJECT OR HOMONYM
34780000
( = R3 ON ENTRY)
34800000
R8 DESTROYED
34820000
TUSR = RESULT
34840000
TUSR = 0
UNDEFINED GLOBAL NAME
34860000
TUSR = 1
GLOBAL VARIABLE
34880000
TUSR = 2
FUNCTION, NOT PENDENT
34900000
TUSR = 3
FUNCTION, PENDENT
34920000
TUSR = 4
GROUP NAME
34940000
MVI TUSR,0
34960000
ST
3,TUST
SAVE FOR COMPARISONS
34980000
LA
1,M(3)
ASSUME SYMBOL NOT SHADOWED
35000000
L
8,PARREL
35020000
AR
8,MR
35040000
LR
2,8
LOOK AT LOCALS TO NEXT OUTER FN
35060000
L
8,STFREG(8)
35080000
BXLE 8,MR,TUS3
IF ANY
35100000
CLC TUST+1(3),STFNSPTR+1(2) NOTE PENDENT FN IF FN ON THIS
35120000
BNE TUS2
LEVEL MATCHES OUR SYMBOL TABLE PTR 35140000
TM
STFLAGS(2),STIMBIT AND IF THE IMMEDIATE-EXECUTION
35160000
BO
TUS2
BIT IS OFF.
35180000
MVI TUSR,1
35200000
LA
2,8(2)
ADVANCE TO NEXT SHADOW
35220000
CLI STSHADOW(2),SHADOW+X'80' RUN THROUGH ALL SHADOWED NAMES 35240000
BNE TUS1
35260000
CLC TUST+1(3),STSHADOW+1(2) COMPARE AGAINST OUR SYMBOL
35280000
BNE TUS2
NOT SHADOWING
35300000
LA
1,STPARAM(2)
SHADOWING. THIS MAY BE GLOBAL OBJ. 35320000
B
TUS2
35340000
SR
2,2
NOW R1 = ADDR OF GLOBAL SYM ENTRY
35360000
CLC 0(4,1),UNVAR
UNDEFINED VARIABLE ISN'T REALLY
35380000
MUST BE NON-PENDENT FUNCTION.
ALL SEEMS VALID. SAVE POINTER
TO FN SYMBOL TABLE ENTRY
(WHICH MAY BE IN THE STACK)
AND SET UP INFO FOR EDITING AND
NO. OF LOCALS AND PARAMS
NOT INCLUDING LABELS
NO. OF LINES, FOR PRINTING AS LINE

.APL1
TUS4
TUS6

TUSC

*
*
*
*
*
*
*
*
*
*
*
*
FLOSC

*
*
*
*
*
*
*
FLOSC1

FLOSC2

BE
IC
AGO
ANOP
AR
OC
LR
LR
SR
BR
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG

TUS6
2,0(1)
.APL1

A VARB. TUSR = 0
GET CLASS AND MAP IT TO TUS RESULT

35400000
35420000
35440000
35460000
2,10
35480000
TUSR(1),TUSC-TYPTOP-4095(2) = TUSC
35500000
2,3
RETAIN POINTER TO PRINTNAME
35520000
3,1
RELATIVIZE GLOBAL POINTER
35540000
3,MR
35560000
LKR
35580000
(GROUP)FL1'0'
TUSR CODES ORDERED BY CLASS
35600000
TUSC+1
35620000
FL1'0'
UNUSED
35640000
TUSC+VARB
35660000
FL1'1'
35680000
TUSC+DFN
35700000
FL1'2'
35720000
TUSC+DFN0
35740000
FL1'2'
35760000
TUSC+GROUP
35780000
FL1'4'
35800000
35820000
35840000
FUNCTION LINE 0 SCANNED. CHECK FOR VALIDITY.
35860000
EARLY SYNTAX CHECK IS NORMALLY NOT DONE IN APL, BUT
35880000
MUST BE DONE FOR HEADERS. WE CAN'T CLOSE A FUNCTION
35900000
DEFINITION UNLESS THERE'S A VALID HEADER WITH A VALID
35920000
FUNCTION NAME IN IT.
35940000
ALSO INSERT DUMMY PARAMETERS SO HEADER LOOKS LIKE
35960000
RES .= LARG FN RARG ETC. WITH ZEROS FOR DUMMY PARAMS 35980000
ON ENTRY,
36000000
R7 = BYTE COUNT OF CODESTRING, - 1
36020000
TOCORG = CODESTRING BASE ADDRESS
36040000
36060000
EX
0,CRLM
RESET MX IN CASE OF DEFN ERROR
36080000
A
7,TOCORG
LOCATE RH END OF CODESTRING
36100000
LA
7,M+1(7)
ABSOLUTE
36120000
LA
8,10(7)
R8 REMAINS SOMEWHAT HIGHER THAN R7. 36140000
AS EACH SYLLABLE IS SCANNED IT IS MOVED FROM R7 TO R8
36160000
DUMMY SYLLABLES ARE INSERTED AS NECESSARY, MOVING R8
36180000
SOMEWHAT CLOSER TO R7. AT THE END THE CODESTRING BYTE 36200000
COUNT IS RECALCULATED AND THE ENTIRE CODESTRING MOVED
36220000
DOWNWARD AGAIN TO WHERE IT SHOULD BE.
36240000
THE 10-BYTE OFFSET FROM R7 TO R8 IS JUST MORE THAN
36260000
ENOUGH TO GUARANTEE NO OVERLAP WHEN DUMMIES ARE ADDED. 36280000
LA
5,DFN0
R5 RECORDS THE DFN- OR DFN0-ALITY
36300000
SR
4,4
INITIAL LOCALS/PARAMS COUNT
36320000
BAL LKR,FLOSUB
LOOK AT NEXT SYLLABLE
36340000
BO
FNERR
MUST BE AN IDENTIFIER
36360000
LR
3,2
36380000
CLI MCSORG-M-1(7),1+2*ZSEMIC
36400000
BNE FLOSC2
THIS WASN'T A LOCAL
36420000
LA
4,1(4)
WAS. UP LOCALS COUNT
36440000
BCTR 8,0
36460000
BCT 7,FLOSC1
DROP CPTR FOR SHORT SYL
36480000
SLL 4,16
LOCALS COUNT IS LEFT HALFWORD
36520000
BAL LKR,FLOSUB
LOOK AT NEXT SYL
36540000
BC
14,FLOSC11
NOT A DELIMITER
36560000
MVC MCSORG-M(2,8),QF2 A DELIMITER OF SOME SORT. THIS IS 36580000
A DFN0 AND PREVIOUS SYL WAS FN NAME. 36600000

MVC MCSORG-M-2(2,8),MCSORG-M(7) RE-INSERT FN NAME

BCTR 8,0
BUMP R8 OVER DUMMY RIGHT ARG
BCT 8,FLOSC12
AND JOIN NO-LEFT-ARG CODE.
FLOSC11 LA
5,DFN
THIS ID IS FN NAME, AND IT'S A DFN.
AH
4,QH1
BUMP PARAM COUNT
LR
3,2
SAVE FN SYLLABLE
BAL LKR,FLOSUB
ADVANCE PAST LEFT ARG, IF ANY
BC
14,FLOSC8
FLOSC12 MVC MCSORG-M-3(3,8),FLOSAZ NO LEFT ARG.
BCTR 8,0
BCT 8,FLOSC3
BUMP R8 OVER DUMMY LEFT ARG
FLOSC8 AH
4,QH1
LEFT ARG EXISTS. PARAM COUNT IS 2
FLOSC3 CLI MCSORG-M-1(7),1+2*ZLARROW
BNE FLOSC9
NO RESULT PARAMETER
BCTR 7,0
BUMP CPTR PAST LEFT ARROW
BCTR 8,0
BAL LKR,FLOSUB
BO
FNERR
MUST BE A NAME
B
FLOSC4
FLOSC9 MVC MCSORG-M-4(4,8),FLOSCS DUMMY RESULT & DECORATIONS
S
8,QF3
FLOSC4 CLI MCSORG-M-1(7),1+2*ZEOS WE MUST BE AT BEGINNING OF LINE
BNE FNERR
ERROR IF NOT.
L
2,TOCORG
RECOMPUTE SYLLABLE COUNT AND BYTE
SR
7,8
COUNT.
LA
1,10(7)
R1 = NO. OF ADDED BYTES
AH
1,MCSCNT(2)
PLUS ORIGINAL NO. OF SYLLABLE BYTES
STH 1,MCSCNT(2)
LA
LKR,MCSORG-M+3(1) PLUS OVERHEAD
N
LKR,QFM4
ROUNDED UP TO WORD BDY
ST
LKR,MCOUNT(2)
AR
LKR,2
TO CORRECT MX TO POINT TO END OF
*
M-ENTRY
FLOSC10 IC
0,MCSCNT-M+1(8)
NOW MOVE CODESTRING LEFTWARD. R7
STC 0,MCSCNT-M+1(7,8) IS DIFF BETWEEN PRESENT AND CORRECT
LA
8,1(8)
POINT, AND R8 POINTS (OFFSET) TO
*
WHERE CODESTRING IS NOW.
BCT 1,FLOSC10
MVC LOOP IS TOO DIFFICULT
LR
7,LKR
SAVE NEW MX VALUE OVER TUSAG
C
3,DFNPTR
IF NEW FN NAME IS SAME AS OLD,
*
(NEVER TRUE ON INITIAL DEFINITION)
BE
FLOSC5
WE'RE OKAY.
BAL LKR,TUSAG
OTHERWISE, CHECK THAT NAME IS NOT
LA
LKR,DELCHF
BAL 8,DELCHA
THAT OF SOME OTHER QUANTITY
FLOSC5 STM 3,5,PINAB
SAVE ALL THIS FOR FUNCTION CLOSE
ST
7,MX
FINALLY SET NEW MX VALUE
L
3,DFNPTR
LTR LKR,3
2213
BZ
*+8
BAL 8,CRL18
MAKE ORPHANS OF STACKED LOCALS
NI
FDTOG,FDCLBIT
NOW TRULY IN FN-DEFINITION MODE
OI
FDTOG,FDDFBIT
ALTHOUGH PERHAPS ON THE WAY OUT
L
7,SCSCNT
RESTORE CODESTRING COUNT TO R7
BCT 7,CRL5B
AND REJOIN END-OF-STATEMENT LOGIC
*
FETCH A LONG SYLLABLE FROM CODESTRING
*
INCIDENTALLY MOVE 3 BYTES INTO NEW CODESTRING (R8) AREA
*
RETURNS SYMBOL TABLE ADDRESS IN R2
*
CONDITION CODE IS 3 IF NOT A LONG SYLLABLE, 2 OTHERWISE
*
R7 AND R8 DECREASED BY 2 IF LONG SYLLABLE

36620000
36640000
36660000
36680000
36700000
36720000
36740000
36760000
36780000
36800000
36820000
36840000
36860000
36880000
36900000
36920000
36940000
36960000
36980000
37000000
37020000
37040000
37060000
37080000
37100000
37120000
37140000
37160000
37180000
37200000
37220000
37240000
37260000
37280000
37300000
37320000
37340000
37360000
37380000
37400000
37420000
37440000
37460000
37480000
37500000
37520000
37540000
37560000
37580000
37600000
37620000
37640000
37660000
37680000
37700000
37720000
37740000
37760000
37780000
37800000

FLOSUB
*

FLOSB2

FLOSAZ
FLOSCS
DELIDS

*
*
*
*
*
*
*
*
*
*
*
*
*
*
DELCHA

*
*
*
*
DELCHF

MVC

MCSORG-M-3(3,8),MCSORG-M-3(7) MOVE POSSIBLE LONG SYL

(PLUS POSSIBLE SHORT SYL) TO R8 AREA
MCSORG-M-1(7),1
TEST FOR SHORT SYL
1,LKR
NO ACTION IF SHORT
8,QFM2
FTEMP1(2),MCSORG-M-2(7) MOVE IN 16-BIT SYLLABLE
2,FTEMP1
2,2
QUADRUPLE SYLLABLE
2,QR13STK
AND GET OFFSET FROM TOP OF S.T.
7,0
7,LKR
2
AL1(1+2*ZLARROW,0,0)
AL1(1+2*ZEOS,0,0,1+2*ZDUM)
2
0H'0'
LKR,DELIT
LKR,SKBLI
BUMP INPUT PTR AND LOOK AT NEXT
LKR,DELIT
0(6),ZA
NONBLANK.
4,LKR
IT'S TOO LOW TO BE ALPHA
0(6),ZDELTAU
2,LKR
OR TOO HIGH
LKR,SRCHID
IT'S JUST RIGHT. BUILD ID.
LKR,DELIT
4(LKR)

37820000
37840000
TM
37860000
BCR
37880000
A
37900000
MVC
37920000
LH
37940000
SLA
37960000
A
37980000
BCTR
38000000
BCTR
38020000
SPACE
38040000
DC
38060000
DC
38080000
SPACE
38100000
DC
38120000
ST
38140000
BAL
38160000
L
38180000
CLI
38200000
BCR
38220000
CLI
38240000
BCR
38260000
BAL
38280000
L
38300000
B
38320000
EJECT
38340000
38360000
CHECK DEFINITION STATUS OF GLOBAL
38380000
ALLOW REDEFINITION ONLY IF WE ARE SINK FOR AN
38400000
UNPROTECTING )COPY OPERATION.
38420000
RETURNS TO 0(8) IF OK TO REDEFINE (POSSIBLY AFTER
38440000
HAVING DESTROYED THE PRESENT DEFINITION.) ELSE,
38460000
EXITS TO FNERR (NOT COPY MODE) OR BEGST2 (COPY MODE),
38480000
IN THE LATTER CASE AFTER IGNORING THE NEW OBJECT.
38500000
ON ENTRY,
38520000
R2 = M-RELATIVE SYMBOL TABLE POINTER
38540000
R3 = M-RELATIVE GLOBAL STACK/SYMBOL POINTER
38560000
LKR = ADDR OF IGNORING ROUTINE
38580000
TUSR = CLASSIFICATION, FROM TUSAG
38600000
38620000
CLI TUSR,0
38640000
BCR 8,8
38660000
TM
COPTOG,COPIBIT+COPPBIT ELSE, IF NOT )COPY'ING,
38680000
BZ
FNERR
DEFN ERROR
38700000
L
1,M(3)
38720000
BM
DEL30A
OR IF )PCOPY, 'NOT COPIED'
38740000
S
2,QR13STK
MARK THIS OBJECT IN THE 'NOT COPIED' 38760000
'NOT COPIED' MARK IN SYMBOL TABLE GOES HERE
38780000
LA
7,BEGST2
38800000
EX
0,ZDFNPTR
38820000
NOW FOR THE TEDIOUS BUSINESS OF
38840000
BR
LKR
IGNORING THE DEFINITION, WHICH THE 38860000
SOURCE IS BOUND AND DETERMINED TO
38880000
SEND US.
38900000
BAL LKR,EOBSB2
FUNCTION. IGNORE UNTIL
38920000
CLC 0(5,6),PRIDEL+1
WE SEE SPACES AND A DEL
38940000
BCR 8,7
38960000
CLC 0(5,6),PRIPDEL+1
OR SPACES AND A PDEL
38980000
BCR 8,7
39000000

B
DELCHF
NOTE AMUSING BUG IN ABOVE
BALR LKR,0
IGNORE A GROUP DEFINITION
CLI 0(6),ZCR
BCR 8,7
B
SKBLI
TITLE 'S Y S T E M C O M M A N D S - - S I G N O N'
SOPROC CLI 0(6),ZRPAR
FIRST NONBLANK MUST BE A RIGHT PAREN
BNE SOPERR
INDICATING A SYSTEM COMMAND
BAL LKR,SKBLI
BAL LKR,ININT
CONVERT THE NUMBER FOLLOWING THE )
DC
Y(SOPERR-TYPTOP,SOP1-TYPTOP)
L
1,DTEMP
COMPUTE MANHASH RESIDUE MANNUMBER
C
1,PUBPRI
CHECK FOR SIGNON WITH PUBLIC LIBRARY
BL
SOPFAIL
NUMBER. (VERBOTEN)
SR
0,0
TO SEE IF MANNUMBER IS IN THIS
L
2,=A(KMANHASH)
D
0,0(2)
DIRECTORY. NO USE SEARCHING WRONG
CL
0,WFLMAN
DIRECTORY. (DIR NO. IN LOW M)
BNE CMLEMP
WRONG DIRECTORY, GET CORRECT ONE
BAL LKR,SKBL
LOOK FOR SIGNON PASSWORD
BAL 8,PASSUB
NOP 0
NO PASSWORD
CLI 0(6),ZCR
MUST BE END OF TEXT
BNE SOPERR
*
RESCAN SIGN-ON USING PROPER DIRECTORY
L
2,MANSTAR
GOT A MAN NUMBER. SEARCH FOR IT IN
LA
3,MANENTL
THE TABLE OF USERS IN M.
L
4,DTEMP
SOP2
LA
5,M(2)
R5 IS ABS ADDRESS OF MAN ENTRY
TM
LIBNUM-PERLIB(5),X'80' NEGATIVE MAN NUMBER
BO
SOPFAIL
SIGNALS END OF TABLE.
C
4,LIBNUM-PERLIB(5)
BNE SOP3N
DOES MAN NO. MATCH THE ONE TYPED -CLC SOPASS-PERLIB(8,5),NEWID DO PASSWORDS MATCH -BE
SOP3
YES.
B
SOPFAIL
NO, NO SENSE LOOKING ANY MORE
SOP3N
BXH 2,3,SOP2
TRY NEXT MAN ENTRY
SOPFAIL TYO SOPFTXT
MAN NUMBER NOT IN TABLE. TELL HIM
B
BEGST2
SO.
SOPERR TYO SOPERTX
INCORRECT SIGN-ON
B
BEGST2
SOPDUP TYO SOPDTXT
MAN NUMBER DUPLICATES SIGNED-ON USER
B
BEGST2
SOPLOCK TYO SOPLKTX
SEND 'NUMBER LOCKED OUT' MESSAGE
B
BEGST2
AGO .SOX2
.SOX2
ANOP
SOX
SOP3
ST
2,NTEMP
NUMBER FOUND. SEE IF HE'S ALREADY
BAL LKR,SOPSUB
SIGNED ON.
B
SOPDUP
ALREADY ON.
AR
2,MR
TM
PLMISC-PERLIB(2),LIBLOCK IS LOCKOUT BIT ON
BO
SOPLOCK
YES. POOR GUY WON'T GET SIGNED ON.
SR
1,1
L
8,MPTBASE
CL
4,OPMAN
CHECK FOR OPERATOR'S MAN NUMBER
BNE SOP4B
SVRAPE
,REMEMBER OPTERM FOR TYPEIN'S USE
ST
8,OPTERM
LA
1,1
PARAMETER TO SOOK
DELCHG

39020000
39040000
39060000
39080000
39100000
39120000
39140000
39160000
39180000
39200000
39220000
39240000
39260000
39280000
39300000
39320000
39340000
39360000
39380000
39400000
39420000
39440000
39460000
39480000
39500000
39520000
39540000
39560000
39580000
39600000
39620000
39640000
39660000
39680000
39700000
39720000
39740000
39760000
39780000
39800000
39820000
39840000
39860000
39880000
39900000
39920000
40500000
40520000
40540000
40560000
40580000
40600000
40620000
40640000
40660000
40680000
40700000
40720000
40740000
40760000

*
*
*
SOP4B
SOPD
*
SOP4D
*
*
SOP4C

SOP4E

SOP5

SOOK PARAMETERS..
R1 = 1 INDICATES SIGN ON OF OPERATOR
R2 = USING PERLIB,2 (ABSOLUTE ADDRESS)
TCOM SOOK
TELL APLSUP SIGNON IS OK
L
4,OPMAN
IF OPERATOR IS ALREADY SIGNED ON,
BAL LKR,SOPSUB

40780000
40800000
40820000
40840000
40860000
40880000
40900000
B
SOP4C
FINE. PRINT SIGNON MESSAGE.
40920000
TCOM DELAY,1500
DELAY HERE UNTIL OP WELL SIGNED ON 40940000
ATT OFF=SOPD,ON=CMOFFZ ATTENTION SIGNS HIM OFF FAST
40960000
NOW PRINT SIGN-ON MESSAGE TO OPERATR 40980000
THE FORMAT IS
TTT) HH.MM.SS MM/DD/YY USERNAME NNNNNN
41000000
LA
2,OBUF
41020000
BAL LKR,CVTERM
PRINT TERMINAL NUMBER
41040000
MVI OBUFPTR+1,3
41060000
ICALL GETIME
PRINT TIME OF DAY
41080000
LR
3,1
TIME TO R3 FOR PRINTTIME.
41100000
L
6,OPTERM
IF THIS ISN'T THE OPERATOR SIGNING 41120000
CL
6,MPTBASE
ON,
41140000
BE
SOP4E
41160000
L
0,F104
GIVE OPERATOR APPROX 30-SEC GRACE
41180000
A
0,PTSOTM-PERTERM(6) PERIOD AFTER SIGNON TO LOAD OPFNS, 41200000
CLR 0,3
SET UP A )HI MESSAGE, ETC.
41220000
BNL SOP4D
41240000
BAL 8,PRINTIME
41260000
BAL 8,PRINTDAT
PRINT TODAY'S DATE
41280000
L
1,NTEMP
PRINT USER NAME
41300000
IC
0,PLMISC-PERLIB(1,MR) SAVE AUTO-FLAG
41320000
STC 0,NTEMP+2
41340000
LA
1,HISNAME-PERLIB(1,MR)
41360000
ICALL SQUIRT
41380000
MVC NTEMP(2),OBUFPTR
SAVE LINE LENGTH W/O MAN NUMBER
41400000
ICALL DIREMP
CLEAR WS
41420000
MVI OBUF+3,ZRPAR
PLANT <RPAR>
41440000
ICALL LOUT
SEND SIGN-ON MSG TO USER
41460000
MVC OBUFPTR(2),NTEMP
RESTORE LINE LENGTH W/O MAN NUMBER 41480000
LA
1,ZBLANK
41500000
ICALL TOPRINT
41520000
L
0,DTEMP
PRINT MAN NUMBER
41540000
ICALL PRNUM
41560000
LH
1,OBUFPTR
THIS NONSENSE KEEPS USERS OF TRUE
41580000
A N D SS COUNTS HAPPY
41600000
LA
1,1(1)
41620000
STH 1,OBUFPTR
41640000
AR
1,MR
41660000
MVC OBUF-M-1(2,1),QZCREOB
41680000
L
4,MPTBASE
41700000
C
4,OPTERM
AVOID THE OTHER SIGN-ON OUTPUT
41720000
BE
SOP5
IF THIS IS THE OPERATOR.
41740000
TCOM LOG,OBUFPTR
TELL OPERATOR ABOUT SIGN ON
41760000
L
1,=A(SOOKTXT)
41780000
TM
IOB2-PERTERM(4),LOEXP EXPRESS VS NORMAL PORT
41800000
BZ
*+8
NORMAL PORT
41820000
L
1,=A(SOOKEXTX)
EXPRESS PORT
41840000
TYO 0(1)
AND THE FINAL LINE 'APL EXPAND'
41860000
MVI OBUFPTR+1,0
41880000
TM
NTEMP+2,LIBAUTOL
IF NO AUTO-LOAD,
41900000
BZ
TYPIN2
START EXECUTING.
41920000
EX
0,ZDFNPTR
CLEAR FN DEFN TOGGLES, ETC.
3034 41940000
EX
0,INITHOFL
IN CASE AUTO-LOAD FAILS.
3034 41960000

MVC
EX
MVC
MVI
MVC
B
CLC
AGO
ANOP
BNE
LA
BAL
MVI
B

SVIT(4),SVI
3034 41980000
0,SYSC12
42000000
PDSWSN-PDSLIB+OURSDP(13),SPDSAVE ELSE FAKE A )LOAD
42020000
PDSOPA-PDSLIB+OURSDP,XXLOAD
42040000
PDSLIB-PDSLIB+OURSDP(4),DTEMP THIS MAN NUMBER
42060000
SPDISK
42080000
SOP1
0(3,6),SYSCOPR
NEXT 3 CHARS HAD BETTER BE
SOX 42120000
.SOX4
SOX 42140000
.SOX4
SOX 42240000
SOPERR
'OPR'
42260000
6,4(6)
BUMP INPUT POINTER PAST 'OPR '
42280000
LKR,SKBL
GET FIRST NONBLANK OF MESSAGE
42300000
SCNO,1
42320000
CMOPR
42340000
*
SEE IF USER WITH NUMBER IN R4 IS
42360000
SOPSUB L
6,=A(SUPPARS)
SIGNED ON
2230 42380000
LM
6,8,PTBXLE-SUPPARD(6)
2230 42400000
SOP4
TM
IOB1-PERTERM(8),NSIGNM
42420000
BO
SOP4A
42440000
C
4,PTMAN-PERTERM(8)
42460000
BCR 8,LKR
RETURN TO 0(LKR) IF HE IS
42480000
SOP4A
BXLE 8,6,SOP4
INDEX THROUGH ALL PERTERMS
42500000
B
4(LKR)
RETURN TO 4(LKR) OTHERWISE
42520000
SPACE 2
42540000
CMDNUMBR TYO SOPNDTXT
SEND 'ALREADY SIGNED ON' MESSAGE
42560000
B
BEGST2
42580000
TITLE 'S Y S T E M C O M M A N D S - - S C A N N E R'
42600000
SYSCMD BAL LKR,SKBLI
SKIP TO START OF COMMAND
42620000
BAL LKR,ININT
SEE IF THIS FORGETFUL CHAP IS TRYING 42640000
DC
Y(CMDERR-TYPTOP,SYSC0-TYPTOP) SIGN ON AGAIN
42660000
B
CMDNUMBR
IF HE IS, SLAP HIS WRIST
42680000
SYSC0
BAL LKR,BLDID
GET COMMAND NAME IN NEWID
SOX 42720000
AGO .SOX6
SOX 42740000
.SOX6
ANOP
SOX 42840000
LM
1,3,SCSCH
PREPARE TO SEARCH TABLE OF COMMANDS 42860000
SYSC1
CLC NEWID(4),SCNAME-SCIMAGE(1) FOR MATCH WITH FIRST 4 CHARS 42880000
BE
SYSC2
42900000
BXLE 1,2,SYSC1
BACK FOR NEXT ENTRY OR QUIT
42920000
CMDERR TYO BADCOM
WITH BAD COMMAND MESSAGE.
42940000
B
CMEND2
42960000
SYSC2
MVC SCIMAGE(8),0(1)
SAVE COMMAND CONTROL INFO
42980000
SYSC12 XC
OURSDP(PDSLEN),OURSDP CLEAR SPACE FOR SPDISK PARS
43000000
MVC PDSOPA-PDSLIB+OURSDP(1),SCNO INSERT SPDISK OP
43020000
TM
SCFLG,SCINFN
IS THIS COMMAND ALLOWED IN FN-DEFN - 43040000
BO
SYSC3
YES.
43060000
TM
FDTOG,FDDFBIT+FDDHBIT NO. ARE WE IN FN-DEFINITION -43080000
BNZ CMDINFN
YES. ERROR.
43100000
SYSC3
TM
SCFLG,SCPRIV
IS THIS A PRIVILEGED COMMAND -43120000
BZ
SYSC4
NO. LET HIM USE IT.
43140000
L
1,=A(SUPPARS)
YES. IS USER PRIVILEGED
2230 43160000
L
1,PTBASE-SUPPARD(1) A(PERTERM) FROM PROTECTED CORE 2230 43180000
TM
IOB1-PERTERM(1),PRIVBIT
43200000
BZ
CMDERR
43220000
SYSC4
BAL LKR,SKBL
MOVE TO BEGINNING OF POSSIBLE ARG
43240000
TM
SCFLG,SCARG1
IS THERE SUPPOSED TO BE ONE -43260000
BZ
SYSC10
NO. CHECK FOR POSSIBLE SECOND ARG 43280000
BAL LKR,ININT
YES. BUILD INTEGER.
43300000
DC
Y(CMDERR-TYPTOP,SYSC6-TYPTOP)
43320000
L
1,DTEMP
43340000
LTR 1,1
43360000

BM
CLI
BE
CLI
BNE
B
TM
BZ
NI
L
L
L
ST
BAL
TM
BZ
CLI
BH
BAL
CL
BNH
LA
STC
LTR
BZ
BCTR
EX
B
MVC
TM
BZ
NI
BAL
TM
BZ
BAL
B
MVC
LTR
BNZ
MVI
LA
TM
BO
CLI
BCR
LH
MVC

CMDERR
0(6),ZBLANK
BLANK OR CR MUST FOLLOW
SYSC5
0(6),ZCR
CMDERR
SYSC5
SYSC6
SCFLG,SCIMP1
IS AN IMPLICIT FIRST ARG OK -CMDERR
NO. JUST PLAIN WRONG.
SCFLG,255-SCARG1
INDICATE ARGUMENT 1 OMITTED
1,=A(SUPPARS)
YES. IMPLIED ARG IS USER NO. 2230
1,PTBASE-SUPPARD(1) A(PERTERM) FROM PROTECTED CORE 2230
1,PTMAN-PERTERM(1)
SYSC5
1,PDSLIB-PDSLIB+OURSDP
LKR,SKBL
MOVE TO SECOND ARG, IF ANY
SYSC10
SCFLG,SCARG2
IS THERE A SECOND ARG -SYSC9
NO. CHECK FOR END OF COMMAND.
0(6),ZDELTAU
YES. MUST START WITH 'ALPHA' CHAR
SYSC7
LKR,BLDID
BLDID WILL TEST FOR ALPHANUMERIC
5,QF11
*+8
IGNORE CHARACTERS PAST 11TH
5,11
5,PDSWSN-PDSLIB+OURSDP
SAVE CHARACTER COUNT
5,5
WAS THERE A NAME -SYSC7
NO.
5,0
5,SYSMV
MOVE SECOND ARG INTO PARAM AREA
SYSC8
SYSMV
PDSWSN-PDSLIB+OURSDP+1(0),0(7)
SYSC7
SCFLG,SCIMP2
NEED THERE BE A SECOND ARG -CMDERR
YES. ERROR.
SCFLG,255-SCARG2
INDICATE ARGUMENT 2 OMITTED
SYSC8
LKR,SKBL
SCFLG,SCPASS
MAY THERE BE A PASSWORD -SYSC9
NO.
8,PASSUB
COLLECT THE PASSWORD
SYSC9
NO PASSWORD
SYSC11
PDSPASS-PDSLIB+OURSDP(8),NEWID
5,5
FOR )OFF AND )CONTINUE,
*+8
DISTINGUISH BETWEEN NO PASSWORD AND
NEWID,X'FF'
EMPTY PASSWORD.
SYSC9
LKR,CMDERR
LET EXECUTION ROUTINES USE BCR'S
SCFLG,SCADD
MAY OTHER SPECIAL-PURPOSE ARGUMENTS
SYSTO
BE PRESENT -0(6),ZCR
NO. NEXT CHAR MUST BE A CR.
7,LKR
SYSTO
2,SCAD
TAKE OFF TO THE COMMAND ROUTINE
NTEMP(5),PDSWSN-PDSLIB+OURSDP SAVE 'HOLD' FOR )OFF
*
AND )CONTINUE
L
1,PDSLIB-PDSLIB+OURSDP
*
BRANCH TO COMMAND EXECUTION ROUTINE
*
SCIMAGE CONTAINS CMD BLOCK, R1 CONTAINS FIRST ARG
*
R6 POINTS TO 1ST NONBLANK FOLLOWING LAST ARG COLLECTED
B
SYSTO(2)
CMDINFN TYO NOTINFN
B
BEGST2
TITLE 'S Y S T E M C O M M A N D S - - T A B L E'
SCSCH
DC
A(SYSCTXT,8,SYSCTND)
SYSCTXT DC
0F'0'
*
INQUIRY COMMANDS

43380000
43400000
43420000
43440000
43460000
43480000
43500000
43520000
43540000
43560000
43580000
43600000
43620000
43640000
43660000
43680000
43700000
43720000
43740000
43760000
43780000
43800000
43820000
43840000
43860000
43880000
43900000
43920000
43940000
43960000
43980000
44000000
44020000
44040000
44060000
44080000
44100000
44120000
44140000
44160000
44180000
44200000
44220000
44240000
44260000
44280000
44300000
44320000
44340000
44360000
44380000
44400000
44420000
44440000
44460000
44480000
44500000
44520000
44540000
44560000

CMD
CMD
CMD
CMD
CMD
CMD
CMD

FNS,CMFNS,0,SCINFN+SCARG2+SCIMP2
VARS,CMVARS,0,SCINFN+SCARG2+SCIMP2
GRPS,CMGRPS,0,SCINFN+SCARG2+SCIMP2
GRP,CMGRP,0,SCINFN+SCADD
LIB,SPDISK,XXLIB,SCINFN+SCARG1+SCIMP1
SI,CMSI,0,SCINFN
SIV,CMSI,1,SCINFN

44580000
44600000
44620000
44640000
44660000
44680000
44700000
*
44720000
*
WORKSPACE CONTROL COMMANDS
44740000
CMD ORIG,CMORG,0,SCINFN+SCARG1
44760000
CMD DIGI,CMDIGI,0,SCINFN+SCARG1
44780000
CMD WSID,CMWSID,0,SCINFN+SCARG1+SCIMP1+SCARG2+SCIMP2
44800000
CMD WIDT,CMWIDT,0,SCINFN+SCARG1
44820000
CMD ERAS,CMERA,0,SCINFN+SCADD
44840000
CMD CLEA,CMCLEAR,0,SCINFN
44860000
CMD COPY,CMCOPY,COPIBIT,SCARG1+SCIMP1+SCARG2+SCPASS+SCADD
44880000
CMD PCOP,CMCOPY,COPIBIT+COPPBIT,SCARG1+SCIMP1+SCARG2+SCPASS+.44900000
SCADD
44920000
CMD LOAD,SPDISK,XXLOAD,SCINFN+SCARG1+SCIMP1+SCARG2+SCPASS
44940000
CMD GROU,CMGROU,0,SCINFN+SCADD
44960000
CMD SYMB,CMSYMB,0,SCARG1
44980000
*
45000000
*
LIBRARY CONTROL COMMANDS
45020000
CMD SAVE,CMSAVE,XXSAVE,SCARG1+SCIMP1+SCARG2+SCIMP2+SCPASS
45040000
CMD DROP,SPDISK,XXDROP,SCINFN+SCARG1+SCIMP1+SCARG2
45060000
*
45080000
*
TERMINAL CONTROL COMMANDS
45100000
CMD OFF,CMOFF,XXOFF,SCINFN+SCARG2+SCIMP2+SCPASS
45120000
CMD CONT,CMCONT,XXOFF,SCARG2+SCIMP2+SCPASS
45140000
*
45160000
*
COMMUNICATION COMMANDS
45180000
CMD MSG,CMMSG,1,SCINFN+SCARG1+SCIMP1+SCADD
45200000
CMD MSGN,CMMSG,0,SCINFN+SCARG1+SCIMP1+SCADD
45220000
SYSCOPR CMD OPR,CMOPR,1,SCINFN+SCADD
45240000
CMD OPRN,CMOPR,0,SCINFN+SCADD
45260000
CMD PORT,CMPORT,0,SCINFN+SCARG2+SCIMP2
45280000
*
45300000
*
COMMUNICATION COMMANDS (OPERATOR)
45320000
CMD HIPA,CMOPR,3,SCINFN+SCPRIV+SCADD
45340000
CMD PA,CMOPR,2,SCINFN+SCPRIV+SCADD
45360000
CMD HI,CMOPR,4,SCINFN+SCPRIV+SCADD
45380000
*
45400000
*
SYSTEM ADMINISTRATION COMMANDS (OPERATOR)
45420000
CMD ADD,CMADD,XXADD,SCINFN+SCPRIV+SCARG1+SCARG2+SCADD+SCPASS 45440000
CMD DELE,CMDELE,XXDEL,SCINFN+SCPRIV+SCARG1
45460000
CMD LOCK,SPDISK,XXLOCK,SCINFN+SCPRIV+SCARG1
45480000
CMD UNLO,SPDISK,XXUNLK,SCINFN+SCPRIV+SCARG1
45500000
SYSCTND EQU *-4
45520000
SPACE 2
45540000
*
BITS IN SCFLG
45560000
SCPRIV EQU X'80'
PRIVILEGED COMMAND
45580000
SCINFN EQU X'40'
COMMAND ALLOWED IN FN-DEFINITION
45600000
SCARG1 EQU X'20'
COMMAND HAS (NUMERIC) 1ST ARGUMENT 45620000
SCIMP1 EQU X'10'
1ST ARGUMENT MAY BE OMITTED
45640000
SCARG2 EQU X'08'
COMMAND HAS (ALPHA) 2ND ARGUMENT
45660000
SCIMP2 EQU X'04'
2ND ARGUMENT MAY BE OMITTED
45680000
SCPASS EQU X'02'
COMMAND MAY HAVE PASSWORD
45700000
SCADD
EQU X'01'
COMMAND MAY HAVE ADDITIONAL ARGUMENT 45720000
TITLE 'S Y S T E M C O M M A N D S - - M E S S A G E S'
45740000
*
45760000

*
*
CMMSG

CMMS1
CMOPR
CMMS2
*

CMOP1

*
CMOP2

SEND MESSAGE TO OPERATOR OR TO ANOTHER PORT

TM
BZ
LTR
BNZ
LA
B
CLC
BNE
LA
SR
S

SCFLG,SCARG1
CMMS1
1,1
CMMS2
1,4000
CMMS2
0(3,6),SYSCOPR
CMDERR
6,3(6)
1,1
6,QF7

MVI
N
LA
BAL
MVI
MVI
CLI
BNE
CLI
BE
MVI
L
SR
CH
BL
LA
LA
MVC

6(6),ZBLANK
6,QFM2
2,2(6)
LKR,CVTERM
5(6),ZCOLON
6(6),ZBLANK
SCNO,1
CMOP1
0(2),ZO
CMOP1
6(6),ZRU
3,INLCH
3,2
3,QH126
CMOP2
3,126
2,124(2)
1(2,2),QZCREOB

STH
SR

3,0(6)
6,MR

IF ARG WAS PRESENT,

IT MUST BE POSITIVE.
TERM 0 IS SPECIAL GLITCH FOR LOGGING
AVAILABLE ONLY INTERNALLY
IF NO PORT NUMBER, ONLY ALTERNATIVE
IS 'OPR '
SKIP OPR TEXT
)OPR -- SEND MESSAGE TO OPERATOR
BUMP INPUT POINTER BACK TO PROVIDE

*
CLI
BE
BH
CMOPC
TCOM
L
ATT
TYO
B
CMOP3
TYO
TM
BO
CMOP4
CLI
BZ
TCOM
B
CMOKMSG DC
QZCREOB EQU
CMSREJ DC
DC
PATXT
DC
CMHI
LA
MVC
TCOM
CLI

SPACE FOR SENDER'S TERMINAL NO. AND

THE CHARACTER COUNT (A HALFWORD).
FOLLOW TERM NO BY A COLON
FOLLOW COLON BY BLANK
OR, IF REPLY IS EXPECTED,
AND SENDER IS NOT THE OPERATOR,
BY 'R'
INLCH IS ADDR PAST LAST CHAR OF MESS
FIND NO. OF CHARS IN MESSAGE
TRUNCATE MESSAGES OF EXCESSIVE LGTH

MAKE SURE TRUNCATED MESSAGE ENDS

WITH CR AND EOB
MAKE R6 M-RELATIVE -- WE MAY
QUANTUM END
IS THIS A BROADCAST -YES, )PA
YES,)HI OR )HIPA

SCNO,2
CMPA
CMHI
MSG,M(6)
4,MPTBASE
IF THE MESSAGE WAS REJECTED,
OFF=CMOP3,MPTBASE=(4) ATTN MEANS THE MSG WAS
CMSREJ
NEVER SENT. TELL THE SENDER SO.
BEGST2
CMOKMSG
SEND 'SENT' MESSAGE
IOB2-PERTERM(4),RECMM IF A PERMANENTLY-RECEIVING TERM
BEGST2
SENT THE MESSAGE, WE'RE DONE.
SCNO,0
NOW SUSPEND FOR REPLY IF THAT WAS
BEGST2
SUSPEND
REQUESTED
BEGST2
AL1(0,5,ZS,ZE,ZN,ZT,ZCR,ZEOB)
'SENT'
*-2
H'13'
'MESSAGE LOST'
AL1(ZM,ZE,ZS,ZS,ZA,ZG,ZE,ZBLANK,ZL,ZO,ZS,ZT,ZCR,ZEOB)
AL1(ZP,ZA,ZSHRIEK)
'PA:'
1,M(6)
MOVE IN OPR
2(3,1),SYSCOPR
HI,M(6)
SCNO,3
CHECK FOR COMBINED HI AND PA

45780000
45800000
45820000
45840000
45860000
45880000
45900000
45920000
45940000
45960000
45980000
46000000
46020000
46040000
46060000
46080000
46100000
46120000
46140000
46160000
46180000
46200000
46220000
46240000
46260000
46280000
46300000
46320000
46340000
46360000
46380000
46400000
46420000
46440000
46460000
46480000
46500000
46520000
46540000
46560000
46580000
46600000
46620000
46640000
46660000
46680000
46700000
46720000
46740000
46760000
46780000
46800000
46820000
46840000
46860000
46880000
46900000
46920000
46940000
46960000

46980000
47000000
47020000
YES.
47040000
47060000
*
47080000
*
)PORTS -- LIST PORTS IN USE AND USER CODES
47100000
CMPORT L
3,=A(SUPPARS)
INIT TO LOOP THRU PERTERMS
2230 47120000
LM
6,8,PTBXLE-SUPPARD(3)
2230 47140000
AR
8,6
IGNORE COPY-SOURCE TERMINAL
47160000
USING PERTERM,8
PERTERM BEING EXAMINED
47180000
IC
1,PDSWSN-PDSLIB+OURSDP AN UNPLEASANT GLITCH FOR NAMES 47200000
LA
1,PDSWSN-PDSLIB+OURSDP(1) OF UNDER 3 CHARS -- REPLACE
47220000
MVC 1(2,1),INDENT+1
TRAILING ZEROES BY BLANKS
47240000
CMPORT1 TM
IOB1,NSIGNM
IGNORE UNCONNECTED TERMINALS
47260000
BO
CMPORT8
47280000
TM
SCFLG,SCARG2
IS THIS A SELECTIVE LISTING
47300000
BZ
CMPORT2
NO, LIST EVERYBODY
47320000
CLC PDSWSN+1-PDSLIB+OURSDP(3),PTMANI DO WE LIST THIS USER 47340000
BNE CMPORT8
NO, TRY NEXT ONE
47360000
CMPORT2 MVI OBUFPTR+1,7
OUTPUT LINE LENGTH
47380000
LA
2,OBUF
TARGET FOR CVTERM
47400000
LR
5,8
47420000
BAL LKR,CVTERMA
MOVE 3-DIGIT PORT NUMBER TO OBUF
47440000
MVI OBUF+3,ZBLANK
THEN BLANK,
47460000
MVC OBUF+4(3),PTMANI
THEN USER INITIALS
47480000
ICALL LOUT
OUTPUT THIS LINE
47500000
CMPORT8 BXLE 8,6,CMPORT1
47520000
MVI OBUFPTR+1,0
RESET BUFFER POINTER
47540000
B
BEGST2
47560000
DROP 8
47580000
*
47600000
*
)WSID -- WORK SPACE IDENTIFICATION
47620000
CMWSID TM
SCFLG,SCARG2
IF HE WANTS TO CHANGE WSID
47640000
BZ
CMWS5
TYPE 'WAS '
47660000
EX
0,CMPRTWAS
47680000
CMWS5
MVC PDSLIB-PDSLIB+OURSDP+20(16),PDSLIB-PDSLIB+OURSDP
47700000
LA
1,WFLLIB
PRINT WS IDENTIFICATION
47720000
ICALL PRWSNAME
47740000
TM
SCFLG,SCARG2
TEST IF WSID IS TO BE CHANGED
47760000
BZ
BEGST2
NO, RETURN
47780000
MVC WFLLIB(16),PDSLIB-PDSLIB+OURSDP+20 MOVE IN WSID
47800000
B
BEGST2
47820000
SPACE 2
47840000
*
)ORIGIN -- SET WORKSPACE ORIGIN
47860000
CMORG
CL
1,QF2
47880000
BCR 11,LKR BNL
ALLOW ONLY 0 AND 1
47900000
L
0,IORIGIN
47920000
ST
1,IORIGIN
47940000
B
CMPRTWAS
47960000
SPACE 2
47980000
*
)WIDTH -- SET WIDTH OF PRINT LINE
48000000
CMWIDT CL
1,QF130
SET WIDTH OF PRINT LINE
48020000
BCR 2,LKR BH
NO GREATER THAN 130
48040000
CLI PDSLIB-PDSLIB+3+OURSDP,30
48060000
BCR 4,LKR BL
AND NO LESS THAN 30 (TROUBLE WITH
48080000
*
DISPLAY OF FLOATING PT NUMBERS)
48100000
LH
0,OBUFLIM
48120000
STH 1,OBUFLIM
48140000
B
CMPRTWAS
48160000
CMPA

BH
LA
MVC
TCOM
B

BEGST2
1,M(6)
2(3,1),PATXT
PA,M(6)
BEGST2

HI WITHOUT PA
MOVE IN PA SHRIEK

*
CMDIGI

*
*
CMSYMB

SPACE 2
)DIGITS -- SET NUMBER OF SIGNIF DIGITS
CH
1,QH16
NO GREATER THAN 16
BCR 2,LKR BH
LTR 1,1
BCR 13,LKR BNP
MUST ALSO BE GREATER THAN 1
L
0,OSIGDIG
ST
1,OSIGDIG
B
CMPRTWAS

)SYMBOLS -- SET SYMBOL TABLE SIZE

C
1,QF26
MUST BE GREATER THAN 20
BCR 4,LKR BL
LM
3,4,QR13STK ,QSYMBOT POINTERS TO ENDS OF SYMBOL TABLE
L
2,SVI
WORKSPACE MUST BE REALLY CLEAR
LA
0,STPARAM+8(2)
WHICH MEANS SVI AT HIGHEST POSITION
SVSBDIF EQU *-2
LR
5,4
NEEDED FOR LATER CLEARING
SR
0,4
BCR 7,LKR BNZ
AND ALSO S.T. EMPTY (CHECKED LATER)
D
0,QFM21
DESIRED NO. OF SYMBOLS, PLUS
BCTR 1,0
MH
1,QH168
ROUNDING UP TO HASHING INTERVAL,
LA
2,8
AR
1,2
LESS 1 TO MAKE TABLE LENGTH RELAAR
1,3
TIVELY PRIME TO HASHING INTERVAL.
C
1,MX
CHECK FOR EXCESSIVELY LARGE TABLE
BCR 4,LKR
NOTE BARE POSSIBILITY OF SVI LSS MX
*
AND MX LSS SYMBOT HERE. WE'LL LET
*
APLSUP FORCE A LOAD-EMPTY.
LCR 0,4
GET OLD CAPACITY OF TABLE
AR
0,3
TO BE PRINTED
SRL 0,3
ASSURE EMPTY SYMBOL TABLE, SINCE
AR
3,MR
CHANGING SIZE CHANGES THE HASH.
AR
4,MR
BCTR 3,0
CMSYMB1 OC
0(8,4),0(4)
ZERO TEST
BCR 7,LKR BNE
BXLE 4,2,CMSYMB1
ST
1,QSYMBOT
SH
1,SVSBDIF
ADJUST SVI AND PARREL
LA
2,4(1)
STM 1,2,SVI ,PARREL
ST
1,SVIT
LA
3,M(2)
ABSOLUTE NEW PARREL
SR
2,2
LA
4,4
CLEAR SPACE BETWEEN NEW AND OLD
CMSYMB2 ST
2,M(1)
SYMBOT (AND STACK)
BXLE 1,4,CMSYMB2
IF REDUCING TABLE SIZE, THIS IS
MVI STFLAGS(3),STIMBIT SUPERFLUOUS
*
CMPRTWAS MVC OBUFPTR+1(5),CMWASMSG OUTPUT 'WAS NNN'
ICALL PRNUM
*
*
ENTRY TO PRINT LINE, IF ANY, AND RESUME NORMAL OPERATION
CMEND
ICALL LOUTI
FORCE OUT PRINT LINE
CMEND2 BAL 8,RELPNS
RELOCATE ANY PRINT NAMES COLLECTED
CLI FDTOG,0
BE
TYPIN2
CLEAR SWITCHES IF NOT IN FN DEFN
B
BEGST2

48180000
48200000
48220000
48240000
48260000
48280000
48300000
48320000
48340000
48360000
48380000
48400000
48420000
48440000
48460000
48480000
48500000
48520000
48540000
48560000
48580000
48600000
48620000
48640000
48660000
48680000
48700000
48720000
48740000
48760000
48780000
48800000
48820000
48840000
48860000
48880000
48900000
48920000
48940000
48960000
48980000
49000000
49020000
49040000
49060000
49080000
49100000
49120000
49140000
49160000
49180000
49200000
49220000
49240000
49260000
49280000
49300000
49320000
49340000
49360000

*
*
*
*
CMSI
CMDELT6

CMDELT2
CMDELT4

CMDELT5

CMDELT8
CMDELT3
*
CMFNS
*

*
*
CMVARS
*

*
*
CMGRPS
*

)SI -- )SIV
49380000
DISPLAY FUNCTION NAMES, LINE NUMBERS, AND SUSPENSION (IMM-EX) 49400000
FOR ALL FUNCTIONS CURRENTLY ON THE EXECUTION STACK.
49420000
49440000
LA
3,PARREL-M-STFREG
49460000
L
3,STFREG(3,MR)
49480000
L
1,STFREG(3,MR)
49500000
BXLE 1,1,BEGST2
49520000
LA
4,M(3)
49540000
LA
1,ZQUAD
PRINT A QUAD
49560000
TM
STFLAGS(4),STQBIT IS THIS QUAD INPUT MODE
49580000
BO
CMDELT2
49600000
LR
1,3
NO, PRINT FN AND LINE NO OR BLANKS. 49620000
ICALL PLINE
49640000
LA
4,M(3)
WERE WE IN IMMEDIATE-EXECUTION ON
49660000
TM
STFLAGS(4),STIMBIT THIS LEVEL -49680000
BZ
CMDELT4
NO
49700000
LA
1,ZSTAR
YES. PRINT '*' FOR SUSPENSION.
49720000
ICALL TOPRINT
49740000
CLI SCNO,0
IF )SI, WE DON'T LIST VARIABLE NAMES 49760000
BZ
CMDELT3
49780000
BAL 2,CMINDENT
INDENT FOR FIRST OBJECT
49800000
LA
4,M+8(3)
49820000
CLI STSHADOW(4),SHADOW+X'80' DETERMINE IF ALL VARS HAVE BEEN 49840000
BNE CMDELT3
LISTED. IF SO SKIP AHEAD
49860000
L
6,STSHADOW(4)
49880000
SR
4,MR
M-RELATIVE REG 4
49900000
N
6,QF24BITS
KNOCK OFF HIGH ORDER GARBAGE
49920000
BZ
CMDELT8
IF LOCAL OMITTED, NOTHING TO LIST
49940000
CLI OBUFPTR+1,0
INDENT IF ON A NEW LINE
49960000
BNE *+8
49980000
BAL 2,CMINDENT
50000000
BAL 2,PRDENT
PRINT & INDENT
50020000
LA
4,M+8(4)
50040000
B
CMDELT5
GO TRY NEXT ONE
50060000
ICALL LOUTI
OUTPUT LINE
50080000
B
CMDELT6
50100000
SPACE 2
50120000
)FNS -- LIST FUNCTIONS
50140000
BAL 8,CMDPY
SET UP TO PRINT ALPHABETICAL LIST OF 50160000
DEFINED FUNCTIONS
50180000
CLI DTEMP,DFN
50200000
BE
4(LKR)
50220000
CLI DTEMP,DFN0
50240000
BE
4(LKR)
50260000
BR
LKR
RETURN TO 0(LKR) ON NO
50280000
50300000
)VARS -- LIST VARIABLES
50320000
BAL 8,CMDPY
SETUP FOR LIST OF VARIABLES
50340000
50360000
CLI DTEMP,VARB
50380000
BCR 7,LKR
50400000
N
0,QF24BITS
50420000
BCR 8,LKR
50440000
B
4(LKR)
50460000
50480000
)GRPS -- LIST GROUPS
50500000
BAL 8,CMDPY
SETUP FOR LIST OF GROUP NAMES
50520000
50540000
CLI DTEMP,GROUP
50560000

BE
BR

4(LKR)
LKR

*
.APL2
*
CMDPY

*
*
*
*
*
*
*
*
*
*
CMDP4
CMDP3

CMDP7

CMDP6
*
*
*
*
PRDENT

AGO .APL2
ANOP
L
ST
MVI
L
BCTR
CLI
BH
L
ST
A
L
LA
L
BCTR

6,SVI
ALPHABETIC DISPLAY ROUTINE
8,NTEMP
SAVE RETURN REG.
3036
PDSWSN-PDSLIB+OURSDP,3 USE ONLY FIRST LETTER GIVEN
1,PDSWSN-PDSLIB+OURSDP MAKE IT SLIGHTLY SMALLER
1,0
PDSWSN+1-PDSLIB+OURSDP,0
*+8
1,QLOWNM
START SEARCH WITH VERY LOW PRINT
1,M(6)
NAME AS 'LAST NAME PRINTED'.
6,QFM4
POINTERS ARE ALL LOW BY 4
3,QSYMBOT
START LOOP AT BOTTOM OF SYMBOL TABLE
4,8
5,QR13STK
END IT AT TOP
5,0
FIX BXLE END TEST
IN THE FOLLOWING,
R1 = RUNNING INDEX TO PNAME BEING EXAMINED
R2 = SECOND ARG ADDRESS FOR SYMBOL COMPARE
R3 = LOWEST ADDR WHICH NEED BE INSPECTED
R4 = 8 = SYMBOL TABLE ENTRY LENGTH
R5 = LOOP LIMIT (TOP OF TABLE)
R6 = ADDR OF CURRENT CANDIDATE FOR PRINTING
R7 = ADDR OF LAST SYMBOL PRINTED
R8 = ADDRESS OF 'IS VARB', 'IS DFN', OR 'IS GRP' TESTER

LR
BAL
B
LR
LR
BAL
B
LR
LR
LR
BXH
BAL
B
LR
BAL
B
LR
BAL
LR
NOPR
B
LA

1,3
LKR,CMDIF
CMDP5
1,3
2,6
LKR,SCOMP
CMDP5
7,6
6,3
1,3
1,4,CMDP6
LKR,CMDIF
CMDP7
2,7
LKR,SCOMP
CMDP7
2,6
LKR,SCOMP
6,1
0
CMDP7
2,CMDP3

CAN LOWER LIMIT OF SEARCH BE UPPED YES. SYMBOL NOT A VARB (DFN).
WE MUST LOOK AT SYMBOL
IF IT'S LOWER THAN SYMBOL PREVIOUSLY
PRINTED, WE CAN IGNORE IT.
IT'S ALREADY BEEN PRINTED.
END OF LOWER LIMIT ADJUSTMENT
SET NEW 'LAST SYMBOL PRINTED' AND
RUNNING INDEX.
HAVE WE SWEPT ENTIRE TABLE -NO. SKIP CURRENT SYMBOL
IF IT'S NOT A VARB (DFN).
IT IS. MATCH IT AGAINST LAST SYMBOL
PRINTED
IT'S HIGH, SO IT HASN'T BEEN PRINTED
YET. MATCH IT AGAINST CURRENT
CANDIDATE FOR PRINTING.
SKIP THE LR IF IT'S NOT LOWER.
BACK FOR NEXT SYMBOL COMPARISON
FAKE CALL & RETURN FROM PRDENT
PRINT NAME FROM R6 WITH FOLLOWING
TAB. R2 = LINK REG

LA
CLI
BNH
L

1,M+4(6)
0(1),3
CMDP8
1,M+4(6)

MAKE R1 = M-REL ADDR OF PRINT NAME

ADDRESS FOR LONG PRINT NAME

50580000
50600000
50620000
50640000
50660000
50680000
50700000
50720000
50740000
50760000
50780000
50800000
50820000
50840000
50860000
50880000
50900000
50920000
50940000
50960000
50980000
51000000
51020000
51040000
51060000
51080000
51100000
51120000
51140000
51160000
51180000
51200000
51220000
51240000
51260000
51280000
51300000
51320000
51340000
51360000
51380000
51400000
51420000
51440000
51460000
51480000
51500000
51520000
51540000
51560000
51580000
51600000
51620000
51640000
51660000
51680000
51700000
51720000
51740000
51760000

LA
ICALL
QUEND
CMINDENT LA
ICALL
LH
N
BNZ
ATT
BR
CMDP5
BXLE
CMDP9
ICALL
B
CMDIF
L
LTR
BCR
ST
C
BCR
STM
LR
BAL
QUEND
L
ST
L
LM
L
BR
*
*
*
*
*
*
*
*
SCOMP
STM
BAL
LR
LR
BAL
IC
SC3
CLC
BL
IC
SC1
BCTR
EX
BNE
EX
SC2
LM
BCR
B
*
SCSB
AR
CLI
BCR
L
LA
BR
CMDP8

1,M+8(1)
SQUIRT
1,ZBLANK
TOPRINT
1,OBUFPTR
1,QF7
CMINDENT
ON=CMDP9,RESET=NO
2
3,4,CMDP4
LOUTI
BEGST2
0,M(1)
0,0
8,LKR BZ
0,DTEMP
0,QFDFN
11,8 BNL
LKR,3,SKBTEMP
3,1
LKR,TUSAG

IMITATE TAB STOPS

0,M(3)
0,DTEMP
LKR,SKBTEMP
1,3,SKBTEMP+8
8,NTEMP
8

GET SYMBOL-TYPE CODE

TO SPACE NAMES OUT IN REASONABLE

COLUMNS.
BACK FOR MORE IF NO ATTENTION
BUMP THE LOWER LIMIT OF SEARCH
FORCE OUT PRINT LINE
PAST TOP OF TABLE -- ALL DONE.
IF SYMBOL TABLE ENTRY IS
COMPLETELY EMPTY...
THEN RETURN TO CALLER
STORE RESULT IN CASE FN OR GRP
SEARCH STACK ONLY IF A VAR
BR IF NOT A VAR
SAVE REGS THRU TUSAG
POINTS TO S.T. ENTRY
FIND GLOBAL DEFN OF SYMBOL

RESTORE CALLER'S REGS. KEEP

R0 AS-IS FOR )VARS CHECK.
PICK UP RETURN REG

3036
3036
3036
3036
3036
3036
3036
3036
3036
3036
3036
3036
3036
3036
3036

THE SYMBOL COMPARISON ROUTINE

COMPARES A AND B UP TO THE LENGTH OF THE SHORTER
COMPARES LENGTHS IF ALPHAS ARE EQUAL
ON ENTRY, R1 = A ADDRESS
R2 = B ADDRESS
RETURNS TO 0 ON A LEQ B, 4 ON A GTR B
1,4,ILN
ILN IS CONVENIENT AND UNUSED
4,SCSB
FIND REAL PRINT NAME
3,1
1,2
FOR BOTH ARGUMENTS
4,SCSB
2,4(3)
GET LENGTH OF A
4(1,3),4(1)
IS IT SHORTER THAN LENGTH OF B -SC1
YES
2,4(1)
NO. GET LENGTH OF B INSTEAD.
2,0
MAKE IT AN SS COUNT
2,SCLC
COMPARE ALPHABETICS
SC2
NOT EQUAL. RETURN IMMEDIATELY.
0,SC3
EQUAL.. COMPARE LENGTHS
1,4,ILN
RELOAD SAVED REGISTERS
13,LKR
BRANCH NOT HIGH TO 0
4(LKR)
BRANCH HIGH TO 4
1,MR
4(1),3
13,4
1,4(1)
1,M+4(1)
4

FIND PRINT NAME GIVEN SYMBOL ADDRESS

IS IT A SHORT PRINT NAME -YES. NO WORK.
NO. FIND M-ENTRY OF PRINT NAME
OFFSET R1 BY 4 FROM PRINT NAME

51780000
51800000
51820000
51840000
51860000
51880000
51900000
51920000
51940000
51960000
51980000
52000000
52020000
52040000
52060000
52080000
52100000
52120000
52140000
52160000
52180000
52200000
52220000
52240000
52260000
52280000
52300000
52320000
52340000
52360000
52380000
52400000
52420000
52440000
52460000
52480000
52500000
52520000
52540000
52560000
52580000
52600000
52620000
52640000
52660000
52680000
52700000
52720000
52740000
52760000
52780000
52800000
52820000
52840000
52860000
52880000
52900000
52920000
52960000
52980000

SCLC

CLC 5(0,3),5(1)
SPACE 2
)GRP -- LIST NAMES IN A GROUP
BAL 8,SCANID
PICK UP GROUP NAME
B
CMDERR
ERROR IF NONE PROVIDED
CLI TUSR,4
IGNORE COMMAND IF NOT A GROUP NAME
BNE CMEND
L
5,M(3)
LOCATE GROUP DEFINITION
LH
7,MLSCT(5)
PICK UP NUMBER OF MEMBERS
L
6,MLSORG(5)
PICK UP S.T. POINTER FOR A MEMBER
BAL 2,PRDENT
PRINT NAME & TAB
LA
5,4(5)
ADVANCE TO NEXT MEMBER
BCT 7,CMGRPA
B
CMEND
EXIT
SPACE 2
)ERASE
ERASE ZERO OR MORE GLOBAL OBJECTS (VARS, FNS, GROUPS)
ERASING A GROUP UNDEFINES ITS MEMBERS, TO ONE LEVEL.
BAL 8,SCANID
LOOK AT NEXT ARG OF COMMAND
B
CMERZ
DONE.
SR
6,MR
RELATIVIZE OVER POSSIBLE OUTPUT
ST
6,SRCHRET+4
OPERATION
L
5,M(3)
SYMBOL TABLE ENTRY OF GLOBAL
LR
1,5
BAL 8,CMERASB
ERASE IT IF POSSIBLE
CLI TUSR,4
IF IT'S A GROUP,
BNE CMERA1
LH
7,MLSCT(5)
NO. OF MEMBERS
L
3,MLSORG(5)
NEXT GROUP MEMBER
BAL LKR,TUSAG
FIND GLOBAL SIGNIFICANCE
L
1,M(3)
R1 = SYMBOL TABLE OR STACK ENTRY
BAL 8,CMERASB
AND ERASE
LA
5,4(5)
ADVANCE TO NEXT MEMBER
BCT 7,CMERA2
L
6,SRCHRET+4
INPUT STRING POINTER, SAVED OVER ALL
AR
6,MR
PREVIOUS GOINGS-ON.
B
CMERA
DONE WITH GROUP. BACK TO INPUT CMD
CLI 0(6),ZCR
MUST BE END OF LINE
BNE CMDERR
B
CMEND

53000000
53020000
*
53040000
CMGRP
53060000
53080000
53100000
53120000
53140000
53180000
CMGRPA
53200000
53220000
53240000
53260000
53280000
53300000
*
53320000
*
53340000
*
53360000
CMERA
53380000
53400000
53420000
53440000
53460000
53480000
53500000
53520000
53540000
53580000
CMERA2
53600000
53620000
53640000
53660000
53680000
53700000
CMERA1
53720000
53740000
53760000
CMERZ
53780000
53800000
53820000
*
53840000
*
ERASE SUBROUTINE
53860000
*
ON ENTRY,
53880000
*
R1 = SYMBOL TABLE (OR STACK) ENTRY OF OBJECT
53900000
*
R2 = POINTER TO SYMBOL TABLE ENTRY (FOR PRINTNAME) 53920000
*
R3 = POINTER TO SYMBOL TABLE OR STACK ENTRY OF OBJEC 53940000
*
R8 = LINK
53960000
CMERASB CL
3,PINAB
SPECIAL TREATMENT FOR FUNCTION
53980000
*
CURRENTLY BEING DEFINED.
54000000
BNE DEL30
ERASE ORDINARY OBJECT
54020000
STM 5,8,ACCTG
CONVENIENT HIDEY HOLE
54040000
BAL LKR,ERFID
54060000
LM
5,8,ACCTG
FOR R5 AND R8
54080000
B
DEL30B
54100000
*
54120000
*
)GROUP -- DEFINE A GROUP
54140000
CMGROU BAL 8,SCANID
PICK UP GROUP NAME
54160000
B
CMDERR
ERROR IF OMITTED
54180000
TM
COPTOG,COPIBIT
ARE WE A COPY SINK
5992 54200000
BO
CMGROU2
BR IF COPY SINK
5992 54220000

TM
TUSR,X'03'
IF DFN OR VAR, ERROR
BNZ CMGRUSED
WE ASSUME TUSR IN 0 - 7
CMGROU2 EQU *
5992
MVC NTEMP(1),TUSR
SAVE TUSR
STM 2,3,DTEMP
SAVE POINTERS FOR GROUP NAME
L
5,MX
SR
7,7
INITIALIZE NUMBER OF NAMES IN
STH 7,MLSCT(5)
GROUP TO ZERO
LA
7,MLSORG-M
INITIALIZE AMOUNT OF OVERHEAD
STH 7,MLSOS(5)
AR
7,5
ST
7,TOCPTR
POINT TO TOP OF LIST
BAL LKR,FREECH
MAKE SURE WE HAVE ROOM
CMGROU1 BAL 8,SCANID
PICK UP NEXT NAME
B
CMGREND
IF OMITTED, GO CLEAN-UP
C
2,DTEMP
IF HE WANTS OLD DEFN, GO COPY IT IN
BE
CMGRCOPY
O
2,QFMSMALL
SET HIGH BIT TO INDICATE S.T. PNTR
BAL 8,CMGRSCAN
ADD THIS NAME TO LIST IF NOT
B
CMGROU1
ALREADY THERE.
*
COPY IN THE OLD DEFN OF NAMED GROUP
*
CAUTION... WE ASSUME THAT WE NEVER WILL HAVE A NULL
*
GROUP, OR A GROUP THAT CONTAINS ITSELF.
CMGRCOPY CLI NTEMP,0
IF GROUP WAS NOT DEFINED PREVIOUSLY
BE
CMGROU1
IGNORE THIS NAME
L
3,DTEMP+4
PICK UP OLD DEFN ADDRESS
L
3,M(3)
LH
4,MLSCT(3)
PICK UP NUMBER OF NAMES IN SOURCE
LA
3,MLSORG-M(3)
IGNORE OVERHEAD
CMGRCPY1 L
2,M(3)
PICK UP NEXT NAME
BAL 8,CMGRSCAN
PUT INTO GROUP IF NEEDED
LA
3,4(3)
LOOP THRU LIST UNTIL DONE
BCT 4,CMGRCPY1
B
CMGROU1
*
SCAN GROUP DEFN & ADD NAME IF NOT ALREADY THERE.
*
R2=S.T. ADDR R3 & R4 PRESERVED R8=LINK
CMGRSCAN L
5,MX
LH
7,MLSCT(5)
PICK UP CURRENT LIST ENTRY COUNT
LTR 1,7
IF NULL, WE SURE WON'T FIND IT
BZ
CMGRSCN2
LA
5,MLSORG-M(5)
IGNORE OVERHEAD
CMGRSCN1 C
2,M(5)
DOES THIS ENTRY MATCH
BCR 8,8
YES, WE DON'T WANT DUPLICATES
LA
5,4(5)
TRY NEXT ENTRY, UNTIL DONE
BCT 1,CMGRSCN1
CMGRSCN2 L
5,TOCPTR
SAVE S.T. POINTER FOR NEW NAME
ST
2,M(5)
LA
5,4(5)
INCREMENT TOP OF LIST BY 4
ST
5,TOCPTR
LA
7,1(7)
INCREMENT NUMBER OF ENTRIES BY 1
L
5,MX
STH 7,MLSCT(5)
BAL LKR,FREECH
RESERVE MORE ROOM
BR
8
RETURN
CMGREND DS
0H
*
IF )GROUP CMD SEEN DURING )PCOPY, PROTECT OLD DEFN.
5992
*
(WE WAITED UNTIL NOW FOR THIS CHECK BECAUSE WE WANT TO GET5992
*
ALL OF THE INPUT FROM COPY SOURCE.)
5992
TM
COPTOG,COPPBIT
WAS )GROUP SEEN DURING )PCOPY 5992
BZ
CMGREND1
BR IF NOT A )PCOPY
5992

54240000
54260000
54280000
54300000
54320000
54340000
54360000
54380000
54400000
54420000
54440000
54460000
54480000
54500000
54520000
54540000
54560000
54580000
54600000
54620000
54640000
54660000
54680000
54700000
54720000
54740000
54760000
54800000
54820000
54840000
54860000
54880000
54900000
54920000
54940000
54960000
54980000
55000000
55020000
55040000
55060000
55080000
55100000
55120000
55140000
55160000
55180000
55200000
55220000
55240000
55260000
55280000
55300000
55320000
55340000
55360000
55380000
55400000
55420000
55440000

CLI NTEMP,0
WAS GROUP NAME PREV DEFINED
5992
BNE CMEND
BR IF PREV DEFINED
5992
CMGREND1 EQU *
5992
L
3,DTEMP+4
DISPERSE THE OLD DEFINITION
L
1,M(3)
MARK THE OLD DEFN (IF ANY) GARBAGE
BAL 8,DEL30
AND CLEAR THE S.T. ENTRY
L
7,MX
LH
6,MLSCT(7)
IF NEW DEFN IS A NULL GROUP,
LTR 6,6
LEAVE IT UNDEFINED
BZ
CMEND
O
7,QGRCODE
POINT S.T. TO DEFN
ST
7,M(3)
O
3,QLSTCODE
POINT DEFN TO SYMBOL TABLE
N
7,QF24BITS
CLEAN HIGH BYTE OF JUNK
ST
3,MHEAD(7)
SLA 6,2
CONVERT WORD COUNT TO BYTES
LA
6,MLSORG-M(6)
ADD IN OVERHEAD
ST
6,MCOUNT(7)
PUT BYTE COUNT IN M
AR
7,6
ST
7,MX
UPDATE MX
B
CMEND
EXIT
CMGRUSED TYO CMGRNUSD
ERROR, NAME IN USE
B
CMEND
TITLE 'S Y S T E M C O M M A N D S - - S P E C I A L D I S K'
*
OURSDP EQU OBUF+16
TYPEIN'S LOCATION FOR SPEC DISK
*
PARAMETERS BEFORE SDREQ TAKES THEM
SPACE 3
*
)CLEAR -- CLEAR WS
CMCLEAR SR
0,0
INDICATE DIRECTORY 0
CMLEMP LEMP ,
LOAD DIRECTORY
SPACE 2
*
)DELETE -- DELETE USER FROM SYSTEM
CMDELE L
4,PDSLIB-PDSLIB+OURSDP
BAL LKR,SOPSUB
IS HE SIGNED-ON NOW?
B
SOPDUP
YES, SEND 'NUMBER IN USE' MESSAGE
B
SPDISK
NO, LET'S GET BUSY DELETING HIM
SPACE 2
*
)SAVE -- SAVE WS -- SPECIAL CHECK FOR MISSING NAME
CMSAVE TM
SCFLG,SCARG2
CHECK FOR ELIDED NAME
BO
SPDISK
TM
SCFLG,SCARG1
LIB NUMBER MUST THEN BE ELIDED TOO
BCR 1,LKR BO
CLI PDSPASS-PDSLIB+OURSDP,0 PASSWORD MUST BE ELIDED
BCR 7,LKR BNE
MVC PDSLIB-PDSLIB+OURSDP(16),WFLLIB MOVE FILE LABEL INFO
MVC PDSPASS-PDSLIB+OURSDP(8),WFLPASS INTO PARAM AREA
B
SPDISK
SPACE 2
*
ENTRY FOR FORCED SIGNOFF
CMFOFF EX
0,NEWIDZ
NO CHANGE IN SIGNON PASSWORD
MVI SCNO,XXOFF
READ SPDISK OP IS )OFF
MVI NTEMP,0
DROP LINE AFTER SIGNOFF
BAL 8,RELPNS
RELOC ANY PNAMES NOW ABOVE SVI 2534
SPACE 2
*
)CONTINUE COMMAND
*
MOVE 'CONTINUE' TO WSID
CMCONT MVC PDSWSN-PDSLIB+OURSDP(14),SPDSAVE
MVC PDSPASS-PDSLIB+OURSDP(8),WFLPASS
*
IS TO FAKE A )SAVE.

55460000
55480000
55500000
55520000
55540000
55560000
55580000
55600000
55620000
55640000
55660000
55680000
55700000
55720000
55760000
55780000
55800000
55820000
55840000
55860000
55880000
55900000
55920000
55940000
55960000
55980000
56000000
56020000
56040000
56060000
56080000
56100000
56120000
56140000
56160000
56180000
56200000
56220000
56240000
56260000
56280000
56300000
56320000
56340000
56360000
56380000
56400000
56420000
56440000
56460000
56480000
56500000
56520000
56540000
56560000
56580000
56600000
56620000
56640000
56660000

CMOFFA

*
*
CMADD

*
CMCOPY

NI
LA
CL
BNL
L
L
MVC
CLI
BE
CLC
BNE
B

SCFLG,255-SCARG2
'HOLD' DOESN'T REALLY COUNT AS ARG
0,FREE-M
NO SAVE AT ALL IF WORKSPACE
0,MX
IS EMPTY
CMOFF
1,=A(SUPPARS)
GET LIB NO. OF THIS MAN
2230
1,PTBASE-SUPPARD(1) A(PERTERM) FROM PROTECTED CORE 2230
PDSLIB-PDSLIB+OURSDP(4),PTMAN-PERTERM(1)
THIS MAN'S.
NTEMP,X'00'
CHECK FOR 'HOLD' OMITTED
3033
SPDISK
BRANCH IF OMITTED
3033
NTEMP(5),QZHOLD
WAS OPERAND 'HOLD'
3033
CMDERR
ERROR IF NOT 'HOLD'
3033
SPDISK

BAL
DC
STH
BAL
BAL
DC
DC
MVC
LTDR
BNZ
MVI
B

ADD COMMAND HAS FURTHER NUMERIC PARAMETERS

LKR,ININT
FIND NUMBER FOLLOWING AND SEND IT
2Y(CMDERR-TYPTOP) AS INCREMENTAL WSS FOR THIS USER.
3,PDSWSQI-PDSLIB+OURSDP
LKR,SKBL
SKIP ANY BLANKS
LKR,INFLT
BUILD CPU TIME LIMIT
Y(CMDERR-TYPTOP,SPDISK-TYPTOP)
Y(D3000-TYPTOP,D10-TYPTOP)
PDSCPUL-PDSLIB+OURSDP,DTEMP+6
0,0
0 LIMIT MEANS RESET TO INFIN
SPDISK
PDSCPUL-PDSLIB+OURSDP,X'80'
MARK FOR APLSUP
SPDISK

MVC
MVI
BAL
STC
MVC

*
BAL
CLI
BNE
*
*
SPDISK
*
*
*
*
*
*
*
*
*
*
*
*
*
*
SDRET

COPTOG(1),SCNO
COPTOG SHOWS DEGREE OF PROTECTION
PDSOPA-PDSLIB+OURSDP,XXCOPY ONLY CMPS WHERE SCNO NE SDOP
LKR,BLDID
5,PDSID-PDSLIB+OURSDP
PDSID+1-PDSLIB+OURSDP(77),0(7) MOVE 78 CHARACTERS
(LONGEST NAME) INTO THE PARAM BLOCK
LKR,SKBL
OBJECT NAME MUST BE LAST NONBLANK
0(6),ZCR
CMDERR

SPECIAL DISK OPERATIONS.

SDREQ OURSDP
WE COMMUNICATE WITH APLSUP AND
DIRECTORY SEARCH THROUGH OURSDP AND
PDSLIB (IN PERTERM)
EJECT
ENTRY SDRET
THIS CURIOUS CODE IS NEEDED BECAUSE WHENEVER APLSUP LOADS A
SAVED WORKSPACE (OR CONTINUES EXECUTION WITH A CURRENT WORKSPACE WHICH HAS JUST EXECUTED SDREQ), IT JAMS A(SDRET) INTO
THE WORKSPACE'S SAVED PSW. THIS IS DONE SO THAT BETWEEN THE
TIME THAT A WORKSPACE IS SAVED AND LOADED, IT IS POSSIBLE TO
REASSEMBLE AND RELINK THE INTERPRETER. AT THE POINT THAT
MACRO SDREQ WAS EXECUTED, THE ONLY PROGRAM- LOCATION-DEPENDENT
VALUES ALIVE ARE THE PROGRAM BASE REGISTERS AND THE SAVED PSW.
THE DISK OP IS IN PDSOP (IN PERTERM.)
EXCEPTION.. )CONTINUE AND )SAVE USE R13 STORAGE FREELY
BECAUSE WE KNOW THAT WORKSPACE HAS NOT JUST BEEN LOADED.
BALR
USING
DROP
DROP
L

PR,0
*,PR
10
9
PR,ATYPTOP

REESTABLISH PROGRAM BASE REGISTERS

56680000
56700000
56720000
56740000
56760000
56780000
56800000
56820000
56840000
56860000
56880000
56900000
56920000
56940000
56960000
56980000
57000000
57020000
57040000
57060000
57080000
57100000
57120000
57140000
57160000
57180000
57200000
57220000
57240000
57260000
57280000
57300000
57320000
57340000
57360000
57380000
57400000
57420000
57440000
57460000
57480000
57500000
57520000
57540000
57560000
57580000
57600000
57620000
57640000
57660000
57680000
57700000
57720000
57740000
57760000
57780000
57800000
57820000
57840000
57860000

USING
LA
USING
LA
USING
LA
L
AR
MVC
MVI
L
L
USING

TYPTOP,PR
57880000
10,4095(PR)
57900000
TYPTOP+4095,10
57920000
9,4095(10)
57940000
TYPTOP+2*4095,9
57960000
TLR,(PREPLEND-PREPLOC+7)/8*8(LR)
57980000
2,PARREL
SET QUAD AND QUAD-PRIME FLAGS
58000000
2,MR
58020000
QUADTOG(1),STFLAGS(2)
58040000
INTOG,0
CLEAR INLINE TOGGLES
58060000
4,=A(SUPPARS)
A(PERTERM) FROM PROTECTED CORE 2230 58080000
4,PTBASE-SUPPARD(4)
2230 58100000
PERTERM,4
BASE REGISTER TO PERTERM BLOCK
58120000
*
'COPY WRITE' MODE MEANS WE HAVE BEEN 58140000
TM
IOB1,COPYWM
RESURRECTED FROM THE LIBRARY TO
58160000
BO
COPST
SERVE AS A COPY SOURCE.
58180000
*
58200000
* * * * *THE ORDER OF THESE TESTS IS CRITICAL. COPY SOURCE HAS A
58220000
*
CUT-DOWN PERTERM WHICH CONTAINS NO SDOP. COPY TEST MUST
58240000
*
THEREFORE BE PERFORMED FIRST.
58260000
*
58280000
TM
IOB1,COPYRM
58300000
BO
BEGST2
'COPY READ' MODE MEANS WE'RE A SINK. 58320000
CLI PDSOP,XXOFF
SPECIAL ACTION FOR )OFF OR )CONTINUE 58340000
BE
CMOFF1
58360000
*
IF WE HAVE JUST RETURNED FROM AN UN- 58380000
TM
IOB1,TRREJ
SUCESSFUL )LOAD, )SAVE, OR )DROP
58400000
BO
SPD7
AVOID PRINTING ANY MESSAGE
58420000
CLI PDSOP,XXLOAD
PRINT MSG FOR )LOAD, )SAVE, )DROP. 58440000
BH
BEGST2
58460000
BL
SPD3
AS ('SAVED') DATE TIME (WSID)
58480000
MVC OBUFPTR+1(6),SAVMSG MOVE IN 'SAVED ' MESSAGE
58500000
SPD3
L
3,WFLTIME
)LOAD AND )SAVE PRINT TIMESTAMP
58520000
LA
1,WFLDATE
FROM WS FILE LABEL
58540000
CLI PDSOP,XXDROP
58560000
BNE SPD4
)DROP, HOWEVER,
58580000
ICALL GETIME
PRINTS CURRENT TIME AND DATE NO
58600000
LR
3,1
58620000
L
1,=A(ZSYMDATE)
MATTER WHAT
58640000
SPD4
BAL 8,PRINTIME
58660000
BAL 8,PRINDATE
58680000
L
4,=A(SUPPARS)
A(PERTERM) FROM PROTECTED CORE 2230 58700000
L
4,PTBASE-SUPPARD(4)
2230 58720000
CLI PDSOP,XXSAVE
FORGET ABOUT NAME IF NOT )SAVE
58740000
BNE SPD6
58760000
TM
SCFLG,SCARG2
PRINT NAME IF NAMELESS )SAVE
58780000
BO
SPD6
OR )CONTINUE
58800000
LA
1,WFLLIB
58820000
ICALL PRWSNAME
58840000
SPD6
ICALL LOUTI
58860000
CLI PDSOP,XXSAVE
58880000
BL
BEGST2
RETURN NORMALLY FOR )DROP, OR
58900000
BH
TYPIN4
TO INITIALIZATION FOR )LOAD
58920000
SPD7
CLI SCNO,XXOFF
FOR )SAVE, CHECK FOR )SAVE FAKED BY 58940000
BNE BEGST2
)CONTINUE OR FORCED SIGNOFF.
58960000
SPACE
58980000
DROP 4
59000000
SPACE 2
59020000
EX
0,SYSC12
CLEAR SPECIAL DISK PARAM BLOCK
59040000
CLI WFLPASS,0
NO AUTO-LOAD IF CONTINUE LOCKED
59060000

BNE
MVI

*
CMOFF

CMOFF1

*
*
ACCL

CMOFFY
CMOFFZ
TITLE
*
*
*
*
*
*
COPST

CMOFF
PDSWSQI-PDSLIB+OURSDP,X'80' SET AUTO LOAD FLAG
REENTRY FOR NON-SAVING )CONTINUE OR FORCED SIGNOFF
MVC PDSPASS-PDSLIB+OURSDP(8),NEWID MOVE IN SIGNON PASSWORD
MVI PDSOPA-PDSLIB+OURSDP,XXOFF AND SPDISK OP FOR )OFF
B
CMOFFA
SPACE 2
MVC ACCTG(16),OURSDP
SIGN-OFF ACCOUNTING.
LA
2,OBUF
BAL LKR,CVTERM
CONVERT THE TERMINAL NUMBER
MVI OBUFPTR+1,3
ICALL GETIME
LR
3,1
INSERT TIME OF DAY, DATE
BAL 8,PRINTIME
BAL 8,PRINTDAT
L
4,MPTBASE
USING PERTERM,4
MVC OBUF+23(3),PTMANI MOVE IN USER CODE
MVI OBUFPTR+1,26
MAKE A GUESS AT THE LENGTH
ICALL LOUT
LOUT TELLS US HOW LONG THE LINE
MVC OBUFPTR(2),LLLO
REALLY IS.
TCOM LOG,OBUFPTR
TELL OPERATOR ABOUT SIGN OFF
DROP 4
MVC OBUFPTR(32),ACTMS1 SET UP TO PRINT
CONNECTED HH.MM.SS , TO DATE HH.MM.SS
CPU TIME HH.MM.SS , TO DATE HH.MM.SS
L
6,QFM4
INDEX TO ACCTG
L
3,ACCTG+12(6)
PICK UP TODAY'S TIME
BAL 8,PRINTIME
CONVERT IT
LA
7,30
SET OUTPUT PTR FOR CUMULATIVE TIME
STH 7,OBUFPTR
L
3,ACCTG+4(6)
PICK UP CUMULATIVE TIME
BAL 8,PRINTIME
AND CONVERT IT TOO
ICALL LOUT
MVC OBUFPTR(11),ACTMSG2 CHANGE TITLE FROM 'CONN' TO 'CPU'
S
6,QFM4
BUMP INDEX UP 4
BZ
ACCL
AND RETURN TO PRINT CPU TIME
TCOM RECEIVE
RCV MESSAGES BEFORE DROPPING LINE
L
LKR,=A(SUPPARS)
A(PERTERM) FROM PROTECTED CORE 2230
L
LKR,PTBASE-SUPPARD(LKR)
2230
CL
LKR,OPTERM
2230
BNE CMOFFY
NOT SIGN OFF OF OPERATOR
SVRAPE
,PREVENT FUTURE MATCH
MVI OPTERM+1,X'FF'
UNEQUAL TO MPTBASE
CLC NTEMP(5),QZHOLD
IF COMMAND INCLUDED THE WORD 'HOLD'
BNE CMOFFZ
TCOM OFFH
SIGN OFF BUT HOLD TELEPHONE LINE
TCOM OFF
OTHERWISE DROP LINE IMMEDIATELY
SPACE 2
'S Y S T E M C O M M A N D S - - C O P Y S O U R C E'

MVC
MVC
MVI
MVI

59080000
59100000
59120000
59140000
59160000
59180000
59200000
59220000
59240000
59260000
59280000
59300000
59320000
59340000
59360000
59380000
59400000
59420000
59440000
59460000
59480000
59500000
59520000
59540000
59560000
59580000
59600000
59620000
59640000
59660000
59680000
59700000
59720000
59740000
59760000
59780000
59800000
59820000
59840000
59860000
59880000
59900000
59920000
59940000
59960000
59980000
60000000
60020000
60040000
60060000
60080000
WE ARE SOURCE WORKSPACE FOR A COPY COMMAND.
60100000
60120000
SOME OF THE ACTIONS TAKEN HERE DESTROY THE STATE OF THE 60140000
SOURCE WORKSPACE, AND MAY BE ALLOWED ONLY BECAUSE THE
60160000
SOURCE IS DISCARDED AFTER THE COPY IS DONE.
60180000
HOFLN(12),HOFLSET MAKE SURE FRACTIONAL-LINE-NO LIST
60200000
LF108(4),QF108
IS EMPTY
60220000
DPYTOG,DPYALL
'DISPLAY ALL' FOR FUNCTION COPY
60240000
COPTOG,COPOBIT
SET COPY-WRITE MODE
60260000

MVI
L
CLI
BE

OBUFLIM+1,130
6,=A(COPYID)
0(6),0
COPALL

LA
BAL
B
LA
CLI
BL
BE
CLI
BE

6,1(6)
8,SCANID
COPERR
8,COPTYI
TUSR,1
COPERR
COPVSUB
TUSR,4
COPG

*
*
*
COPFSUB ST
BAL
BCR
IC
STC
NI
L
BAL
BCR
ST
BAL
L
BR
SPACE
COPG
STM
BAL
BCR
LH
COPG1
STM
L
BAL
BAL
LM
LA
BCT
LM
BAL
B
*
*
COPGSUB LR
BAL
*
BCR
LR
LH
MVC
BAL
COPGSUB1 ICALL
*
L
BAL
LA

ASSURE WIDE PRINT LINE

POINT TO PARAMETER
NO NAME FOLLOWING WORKSPACE NAME IN
COMMAND MEANS COPY ALL OBJECTS
SKIP COUNT
BUILD, LOCATE, AND CLASSIFY THE IDEN
ALMOST IMPOSSIBLE EXIT
SUBROUTINE EXIT TO TERMINATE COPY
CLASSIFY GLOBAL NAME AS ...
UNDEFINED. OBJECT NOT FOUND.
VARIABLE.
GROUP
FUNCTION, PENDENT OR OTHERWISE

3,DFNPTR
LKR,COPCK
7,8
0,MHEAD(2)
0,PROTOG
PROTOG,MFLKBIT
3,MFCODE(2)
LKR,COPCK
7,8
8,INLINK
LKR,PRIFN
8,INLINK
8
2
2,3,CGTEMP1
LKR,COPCK
7,8
1,MLSCT(2)
1,2,CGTEMP2
3,MLSORG(2)
LKR,TUSAG
8,COPST3
1,2,CGTEMP2
2,4(2)
1,COPG1
2,3,CGTEMP1
8,COPGSUB
COPTYI
6,2
LKR,COPCK
7,8
3,2
4,MLSCT(3)
OBUFPTR+1(8),GRPTXT
2,PRDENT
LOUTN
6,MLSORG(3)
2,PRDENT
3,4(3)

SET UP FOR PRIFN

VERIFY EXISTENCE OF DIRECTORY
DAMAGED DIRECTORY
ESTABLISH PROTECTEDNESS
ESTABLISH EXISTENCE OF HEADER
HEADLESS FUNCTION. IGNORE.
INLINK IS CONVENIENT UNUSED TEMP
DISPLAY ENTIRE FUNCTION,

SAVE GROUP NAME ST LOCATION AND PNAM

VERIFY POINTER
NUMBER OF OBJECTS
SAVE OBJECT COUNT, ENTRY ADDR
PICK UP SYMBOL TABLE ENTRY OF OBJECT
FIND GLOBAL MEANING
PRESENT IT TO SINK WORKSPACE
RECALL COUNT AND ADDR
ADVANCE TO NEXT OBJECT
RECALL GROUP NAME TO COPY ITS DEFN
DONE
SUBROUTINE TO COPY GROUP DEFINITION
HOLD GROUP PRINTNAME FOR DISPLAY
GROUP INTEGRITY VERIFICATION
(A GOOD SOCIOLOGY THESIS TOPIC)
NUMBER OF OBJECTS
BEGIN WITH ')GROUP '
DISPLAY GROUP NAME
PRINT EACH NAME SEPARATELY, ENDING
WITH EOB, TO AVOID CARRIAGE RETS.
NEXT OBJECT SYMBOL TABLE POINTER
PRINT ITS NAME
ADVANCE TO NEXT OBJECT

60280000
60300000
60320000
60340000
60360000
60380000
60400000
60420000
60440000
60460000
60480000
60500000
60520000
60540000
60560000
60580000
60600000
60620000
60640000
60660000
60700000
60720000
60740000
60760000
60780000
60800000
60820000
60840000
60860000
60880000
60900000
60920000
60940000
60960000
60980000
61000000
61020000
61040000
61060000
61080000
61100000
61120000
61140000
61160000
61180000
61200000
61220000
61240000
61260000
61280000
61300000
61320000
61360000
61380000
61400000
61420000
61440000
61460000
61480000
61500000

BCT
ICALL
BR
SPACE
L

4,COPGSUB1
LOUT
8
2
3,QSYMBOT

61520000
A CARRIAGE RETURN TO END DEFINITION 61540000
61560000
61580000
COPALL
PREPARE TO COPY OUT EVERY DEFINED
61600000
*
GLOBAL SYMBOL.
61620000
COPST1 ST
3,ACCTG
61640000
BAL LKR,TUSAG
FIND GLOBAL MEANING AND CLASSIFY
61660000
LA
8,COPST2
RETURN LINK FROM COPY SUBROUTINES
61680000
*
ENTRY TO COPY AN OBJECT FOR GROUP COPY
61700000
COPST3 CLI TUSR,1
61720000
BCR 4,8
IGNORE UNDEFINED SYMBOLS
61740000
BE
COPVSUB
VARIABLE
61760000
CLI TUSR,4
61780000
BL
COPFSUB
FUNCTION
61800000
B
COPGSUB
GROUP
61820000
COPST2 L
3,ACCTG
61840000
LA
3,8(3)
BUMP TO NEXT SYMBOL
61860000
C
3,QR13STK
61880000
BL
COPST1
NOT PAST END OF TABLE -- CONTINUE. 61900000
COPTYI MVC OBUFPTR+1(6),SAVMSG END COPY MODE
3575 61920000
L
3,WFLTIME
SET UP TO PRINT
61940000
BAL 8,PRINTIME
'SAVED HHH.MM.SS MM/DD/YY'
61960000
LA
1,WFLDATE
61980000
BAL 8,PRINDATE
62000000
ICALL LOUT
62020000
TYI
, THIS ENDS IT
62040000
*
62060000
AGO .APL3
62080000
.APL3
ANOP
62100000
*
SUBROUTINE TO COPY VARIABLE FROM SOURCE WORKSPACE.
62120000
*
ON ENTRY,
62140000
*
R1 = ABSOLUTE SYMBOL OR STACK ADDR OF GLOBAL
62160000
*
R2 = M-RELATIVE SYMBOL TABLE ADDR FOR PRINT NAME
62180000
*
R3 = M-RELATIVE SYMBOL OR STACK ADDR OF GLOBAL
62200000
*
R8 = LINK
62220000
*
62240000
COPVSUB LR
6,2
LET PRDENT PRINT THE VARIABLE NAME 62260000
BAL LKR,COPCK
CHECK VALIDITY OF S.T. ENTRY
62280000
BCR 7,8
AND GET M-PTR INTO R2
62300000
L
5,MCOUNT(2)
4-BYTE COUNT FIELD OF M-ENTRY
62320000
COPVS3 BAL 2,PRDENT
62340000
ST
5,DTEMP+4
FOLLOW NAME BY A ZLENGTH (TO SIGNAL 62360000
MVC DTEMP+2(2),Q5LGT
'COPY VARB' FOLLOWED
62380000
LA
1,DTEMP+2
BY M-ENTRY COUNT
62400000
ICALL SQUIRT
62420000
ICALL LOUTN
FORCE OUT NAME, ZLENGTH, AND COUNT 62440000
L
2,M(3)
RECALL M-POINTER
62460000
LA
3,128
SET UP TO MOVE VARIABLE IN 128-BYTE 62480000
L
4,MCOUNT(2)
CHUNKS, VIA TYPEWRITER BUFFER
62500000
S
4,QAMOVH
WE DON'T MOVE MHEAD OR MCOUNT
62520000
LA
5,127
WE NEED SS COUNT TOO
62540000
COPVS1 SR
4,3
DROP COUNT BY 128
62560000
BNP COPVS2
IS THIS LAST SEGMENT TO BE MOVED -- 62580000
STH 5,MTYPE-2(2)
NO. STORE SS COUNT IN M-ENTRY JUST 62600000
TYO MTYPE-2(2)
BEFORE THIS SEGMENT
62620000
AR
2,3
BUMP SOURCE POINTER BY 128
62640000
B
COPVS1
AND GO MOVE THE NEXT SEGMENT.
62660000
COPVS2 AR
4,5
62680000
STH 4,MTYPE-2(2)
MOVE THE LAST SEGMENT SIMILARLY.
62700000

COPERR
*
*
*
*
*
*
*
*
*
*
COPCK

TYO
BR
TYO
B
SPACE

MTYPE-2(2)
8
RETURN TO CALLER
COPERM
COPY ERROR (PRINTED SNEAKILY)
BEGST2
TERMINATE COPY
2
CHECK M-POINTER AND ST-POINTER COINCIDENCE
ON ENTRY,
R3 = M-RELATIVE SYMBOL TABLE OR STACK POINTER
LKR = LINK
ON EXIT,
R1 = WHAT M-POINTER IN R2 POINTS TO (BYTE 0 = 0)
R2 = M-POINTER
R3 = SAME AS ON ENTRY EXCEPT BYTE 0 = 0
CONDITION CODE = 0 IF POINTERS ARE CORRECT

LA
3,0(3)
L
2,M(3)
M-POINTER
L
1,MHEAD(2)
SHOULD POINT BACK TO SYMBOL TABLE
LA
1,0(1)
LOSE FLAG BYTE FOR COMPARISON
CLR 1,3
SET CC FOR CALLER
BR
LKR
TITLE 'S Y S T E M C O M M A N D S - - S U B R O U T I N E S'
CVTERM L
3,=A(SUPPARS)
SUBROUTINE TO CONVERT TERM NO 2230
L
5,MPTBASE
LEAVING TENS DIGIT IN R5 AND UNITS
CVTERMA CL
5,OPTERM
GIVE APL OPERATOR SPECIAL PORT NO.
BE
CVTOP
S
5,8+PTBXLE-SUPPARD(3) IN R4.
2230
SR
4,4
D
4,PTBXLE-SUPPARD(3) THIS SHUFFLE GETS TERM NO
2230
*
ADDRESS OF PERTERM AREA
CVD 5,PTEMP
CONVERT TERMINAL NO. TO THREE DIGITS
MVC PTEMP(4),CVTPAT
DIGITS ARE TO THE RIGHT
ED
PTEMP(4),PTEMP+6
MVC 0(3,2),PTEMP+1
TR
0(3,2),VTOZ
CONVERT EBCDIC TO Z
BR
LKR
CVTOP
MVC 0(3,2),SYSCOPR
OPERATOR TERMINAL MESSAGE ID IS
BR
LKR
'OPR'
CVTPAT DC
X'F0202020'
SPACE 2
*
SYSTEM COMMAND IDENTIFIER SCANNER
*
SKIPS TO NONBLANK, AND INSERTS FOLLOWING ALPHA INTO
*
SYMBOL TABLE AND CLASSIFIES GLOBAL DEFINITION VIA TUSAG.
*
RETURNS TO 0(8) IF NONBLANK IS NOT ALPHA, 4(8) OTHERWISE
*
ON EXIT,
*
R2 = SYMBOL TABLE POINTER (FOR PRINT NAME)
*
R3 = SYMBOL TABLE OR STACK POINTER OF GLOBAL
*
R0, R1, R4, R5, R6, R7, LKR DESTROYED
SCANID BAL LKR,SKBL
CLI 0(6),ZA
BCR 4,8
CLI 0(6),ZDELTAU
BCR 2,8
NONALPHABETIC
ST
8,FTEMP3
SAVE LINK OVER SRCHID
BAL LKR,SRCHID
BAL LKR,TUSAG
FIND GLOBAL AND CLASSIFY
L
8,FTEMP3
B
4(8)
*
PASSUB EX
0,NEWIDZ
FORM AND HASH SIGNON OR WS PASSWORD

62720000
62740000
62760000
62780000
62800000
62820000
62840000
62860000
62880000
62900000
62920000
62940000
62960000
62980000
63000000
63020000
63060000
63100000
63140000
63160000
63180000
63200000
63220000
63240000
63260000
63280000
63300000
63320000
63340000
63360000
63380000
63400000
63420000
63440000
63460000
63480000
63500000
63520000
63540000
63560000
63580000
63600000
63620000
63640000
63660000
63680000
63700000
63720000
63740000
63760000
63780000
63800000
63820000
63840000
63860000
63880000
63900000
63920000
63940000
63960000

CLI
BCR
BAL
BAL
*
*
*
*
PRINT
LM
LR
LR
SRDL
XR
XR
SRDL
XR
XR
PRINT
*
*
STM
BAL
B
*
*
PRINTDAT L
PRINDATE LH
*
*
*
AR
MVI
MVC
MVI
LA
SR
STH
BR
*
PRINTIME SR
LH
LA
STH
AR
A
D
SR
D
LR
SR
D
LR
M
AR
M
AR
CVD
MVC
ED

0(6),ZCOLON
7,8
LKR,SKBLI
SKIP COLON AND FOLLOWING BLANKS
LKR,BLDID
BUILD 8 CHARS OF PASSWORD
FOLLOWING UNLISTED CODE HASHES THE PASSWORD, LEAVING
IT IN R0, R1. SUGGEST LEAVING PRINT OFF IN TO AVOID
SECURITY PROBLEMS WITH OLD LISTINGS LEFT LYING AROUND.
ALSO DESTROYS R2, R3
OFF
0,1,NEWID
2,0
3,1
0,1
0,2
1,3
0,3
0,2
1,3
ON
AS FOR SYSTEM PROGRAMMERS, EVERYONE K N O W S THEY'RE
HONEST AND INCORRUPTIBLE.
0,1,NEWID
LKR,SKBL
4(8)

63980000
64000000
64020000
64040000
64060000
64080000
64100000
64120000
64140000
64160000
64180000
64200000
64220000
64240000
64260000
64280000
64300000
64320000
64340000
64360000
64380000
64400000
64420000
64440000
64460000
64480000
1,=A(ZSYMDATE)
64500000
2,OBUFPTR
PRINT ' MM/DD/YY '
64520000
R1 = ADDR OF DATE
64540000
R3 = VALUE OF REALTIME
64560000
R8 = LINK
64580000
2,MR
MOVE IT DIRECTLY IN TO THE BUFFER
64600000
OBUF-M(2),ZBLANK
64620000
OBUF+1-M(8,2),0(1)
64640000
OBUF+9-M(2),ZBLANK
64660000
2,10(2)
BUMP THE OUTPUT POINTER
64680000
2,MR
64700000
2,OBUFPTR
64720000
8
64740000
PRINT BHH.MM.SS
64760000
2,2
REALTIME IS STORED IN 300THS OF SECS 64780000
7,OBUFPTR
64800000
7,10(7)
64820000
7,OBUFPTR
64840000
7,MR
64860000
3,QF150
ROUND UP TO SECONDS
64880000
2,QF300
SCALE DOWN TO SECONDS
64900000
2,2
64920000
2,QF60
NOW CONVERT FROM RADIX 24,60,60
64940000
5,2
TO RADIX 1000,100,100
64960000
2,2
64980000
2,QF60
GET HOURS
65000000
4,2
AND MINUTES
65020000
2,QF100
CONVERT TO 'DECIMAL' HOURS AND MINUT 65040000
3,4
65060000
2,QF100
AND SECONDS
65080000
3,5
65100000
3,PTEMP
TAKE IT TO DECIMAL
65120000
OBUF-M-10(10,7),PTPAT THENCE TO
65140000
OBUF-M-10(10,7),PTEMP+4 HHH.MM.SS
65160000

*
*
*
*
*
*
*
*
*
*
*
INLINE
INLIND

*
*
INLINX
INLING

*
*
*
*
INLINM
*
*
INLINC

*
INLINL

TR
OBUF-M-10(10,7),VTOZ
KEEP IT IN INTERNAL CODE
65180000
BR
8
65200000
TITLE 'F E T C H A N D M A S S A G E N E X T I N P U T' 65220000
65240000
BRING IN THE NEXT LINE FROM THE TERMINAL.
65260000
EDIT OVERSTRIKES AND DELETIONS. LINE IS TERMINATED BY AN EOB 65280000
AND MAY CONTAIN CARRIAGE RETURNS.
65300000
ON ENTRY, THE OUTPUT BUFFER IS EMPTY UNLESS 1) WE ARE INITI- 65320000
ATING A SUPEREDIT SEQUENCE OR 2) WE ARE ASKING FOR QUAD-PRIME 65340000
INPUT FOLLOWING QUAD-PRIME OUTPUT. FOR CASE 1, SEE DISCUSSION 65360000
AT INLINF. FOR CASE 2, LGCPTR GIVES THE STARTING POSITION 65380000
OF THE LAST QUAD-PRIME OUTPUT TEXT IN THE OUTPUT BUFFER.
65400000
TEXT LEFT OF LGCPTR IS ACCEPTED AS BLANKS, TEXT RIGHT OF
65420000
LGCPTR IS ACCEPTED AS INPUT.
65440000
ST
LKR,INLINK
65460000
BZ
INLIND
65480000
L
4,MPTBASE
WE NEED TO LOOK AT PERTERM.
65500000
MVC INLTMP(2),QF2
CLEAR INLTMP
65520000
TM
IOB1-PERTERM(4),COPYRM CHECK IF COPY-SINK
65540000
BNZ TYI
AVOID MESSAGE-SWITCHING.
65560000
TM
IOB2-PERTERM(4),BOUNCM HAS APLSUP FORCED SIGNOFF -65580000
BZ
INLING
65600000
TM
IOB1-PERTERM(4),NSIGNM YES. INSTANT SIGNOFF IF NOT
65620000
BO
CMOFFZ
SIGNED ON
65640000
EX
0,INL2
(RESET MX BEFORE EXIT)
65660000
CLI FDTOG,0
YES. IF NOT IN FN-DEFINITION,
65680000
BE
CMFOFF
SIGN OFF IMMEDIATELY.
65700000
MVC INBUF(6),UNQIS
OTHERWISE FAKE FN, STMT CLOSERS
65720000
LA
6,INBUF
TO TELL TYPEIN TO QUIT AFTER
65740000
B
INL30
CLOSING FUNCTION DEFINITION.
65760000
BRANCH TO INLIND FROM INLINQ+ EXECUTES INLINX SPURIOUSLY 65780000
WHICH DOESN'T HURT SINCE TOCPTR HASN'T BEEN CHANGED.
65800000
MVC MX(4),TOCPTR
SEE COMMENT AT HEAD OF LISTING
65820000
MVI COPTOG,0
SHOULDN'T BE NEEDED TO END COPY
65840000
BAL LKR,TYOSD
WE MAY WANT TO PRINT 'STACK DAMAGED' 65860000
TM
IOB2-PERTERM(4),RECMM
65880000
BC
14,INLINC
IF THIS IS MESSAGE-RECEIVING TERM, 65900000
DON'T ASK FOR INPUT.
65920000
INSTEAD, ENTER THE 'WAIT FOR RESPONSE TO MESSAGE' STATE 65940000
SO THAT USER'S SIGNON AND OTHER MESSAGES CAN GET THROUGH.
65960000
ASK FOR INPUT ONLY IF OPERATOR PUSHED 'REQUEST' BUTTON.
65980000
TCOM SUSPEND
SUSPEND OPERATOR
66000000
ATT OFF=INLIND
NO ATTENTION -- IT MUST BE MESSAGE 66020000
OR BOUNCE.
66040000
66060000
CLI FDTOG,0
ARE WE IN FUNCTION-DEFINITION MODE - 66080000
BNE INLINF
YES. PRINT A LINE NUMBER.
66100000
TM
QUADTOG,STQBIT+STQPBIT
66120000
BZ
INLINB
IF THIS IS INPUT FOR QUAD OR QUAD', 66140000
BO
INLINL
66160000
MVI INLTMP+1,6
TYPE QUAD, COLON, SPACES, LINEFEED 66180000
(FOR QUAD ONLY)
66200000
MVC OBUFPTR(9),QUADLN
66220000
MVC INBUF(6),INDENT+1
66240000
B
INLINH
66260000
GLORIOUS QUAD-PRIME INPUT AND OUTPUT 66280000
LH
1,OBUFPTR
RIGHT END OF TEXT AWAITING OUTPUT
66300000
STH 1,INLTMP
SAVE RIGHT END FOR INPUT EDITING
66320000
LTR 1,1
IF NORMAL (NO OUTPUT) CASE,
66340000
BZ
TYI
JUST GET INPUT.
66360000

EX
LH
LTR
BNP
MVI
BCTR

1,INLMVC
1,TLGCPTR
1,1
INLINH
INBUF-1,ZBLANK
1,0

QUADLN
INLINF

EX
B
DC
TM
BZ

1,CEMV3
INLINH
AL1(0,7,ZQUAD,ZCOLON,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZLF)
INTOG,CEBIT
IS THIS A CHARACTER EDIT REQUEST -INLINJ
NO. NORMAL FUNCTION INPUT.

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*

WE ARE NOW INITIATING A FANCY CHARACTER-EDITING SEQUENCE.

THE CURRENT STATE OF THE UNIVERSE IS ...
THE STATEMENT HAS BEEN DISPLAYED, AND IS STILL SITTING
IN OBUF. THE COUNT (OBUFPTR) HAS BEEN DESTROYED BY LOUT
BUT A COPY IS IN CETMP.
WE MUST DO THE FOLLOWING BEFORE RETURNING FROM INLINE ...
PRINT BLANKS TO POSITION THE CARRIAGE IN COLUMN K (THE
COLUMN REQUESTED FOR START OF CONTROL INFORMATION).
ACCEPT INPUT LINE (THE CONTROL LINE) AND MASSAGE IT ON
TOP OF THE BLANKS.
USING THE CONTROL LINE, MOVE THE CONTENTS OF THE OUTPUT
BUFFER INTO THE HIGH END OF THE INPUT BUFFER (INBUF+259
DOWNWARD).
MOVE THIS RESULT TO THE LOW END OF INBUF.
DISPLAY IT AND ENOUGH BACKSPACES TO POSITION THE
CARRIAGE AT THE LEFTMOST CREATED BLANK.
ACCEPT INPUT TO MODIFY THE LINE IN INBUF.
CARE MUST BE TAKEN NOT TO LOSE THE OUTPUT BUFFER. THUS, WE
MUST BYPASS ALL CALLS ON LOUT OR LOUTN IN INLINE. UGH

LH
LTR
BP
LA
C
BL
L
MVI

1,INBUF-2
1,1
*+8
1,1
1,QF130
*+8
1,QF130
INBUF-1,ZBLANK

BCTR
EX
STH
STH
LTR
BZ
LA
MVI
TYO
B
BAL
LH
STH
EX

1,0
1,CEMV3
1,INBUF-2
1,INLTMP
1,1
TYI
1,INBUF(1)
0(1),ZEOB
INBUF-2
TYI
LKR,OLINO
1,OBUFPTR
1,INLTMP
1,INLMVC

INLINJ
INLINA
*
*
*
INLINH

TCOM RECEIVE

ELSE MOVE ENTIRE OUTPUT LINE TO

INPUT BUFFER AND REPLACE WITH BLANKS
ANY TEXT NOT GENERATED BY IMMEDIATELY PRECEDING CALL OF LOUT
THIS IS THE SRA GLITCH TO ALLOW LAST
OUTPUT TO 1) MERELY POSITION THE
CARRIER, 2) BE ACCEPTED AS INPUT,
OR 3) CREATE NIGHTMARISH ANOMALIES.

FIND REQUESTED STARTING COLUMN

TAKE 1 MAX 130 MIN K

SET UP LINE OF BLANKS

INBUF-1 IS (THROWAWAY) POSITION 0
SAVE SS BLANK COUNT
SAVE AGAIN FOR MASSAGE SETUP
SKIP EMPTY OUTPUT
APPEND EOB
AND PRINT THE BLANKS.

ACCEPT LINE NO OR BLANKS AS INPUT

MOVE TEXT OF LINE NUMBER TO INPUT
BUFFER. THE INTERPRETER-PRINTED
LINE NUMBER IS TREATED EXACTLY LIKE
TERMINAL INPUT.
ACCEPT ANY MESSAGES

66380000
66400000
66420000
66440000
66460000
66480000
66500000
66520000
66540000
66560000
66580000
66600000
66620000
66640000
66660000
66680000
66700000
66720000
66740000
66760000
66780000
66800000
66820000
66840000
66860000
66880000
66900000
66920000
66940000
66960000
66980000
67000000
67020000
67040000
67060000
67080000
67100000
67120000
67140000
67160000
67180000
67200000
67220000
67240000
67260000
67280000
67300000
67320000
67340000
67360000
67380000
67400000
67420000
67440000
67460000
67480000
67500000
67520000
67540000
67560000

ICALL LOUTN

FORCE PRINTING, NO CARRIAGE RETURN. 67580000

67600000
ENTRY FROM EOBSUBI IN COPY-READ MODE.
67620000
TYI
, REQUEST INPUT
67640000
QUEND
UNNECESSARY EXCEPT FOR COPY, WHICH 67660000
*
CAN SPEND SECONDS EMPTYING BUFFER
67680000
ATT OFF=INL2
IF ATTENTION WAS SIGNALLED,
67700000
* SEND A CARRIER RETURN WITH MAX IDLES(1050 DOESN'T NEED IDLES), 3587 67720000
* SINCE WE DON'T KNOW WHERE THE CARRIER IS CURRENTLY LOCATED.
3587 67740000
INLINQ CLI PTTYPE-PERTERM(1),Q1050 1050 DOESN'T NEED IDLES
3587 67760000
LA
1,CRIDLE
ASSUME IT IS NOT A 1050,
3587 67780000
BL
INLINR
AND SEND CR WITH MAX IDLES.
3587 67800000
LA
1,CRNOIDLE
IT IS A 1050. JUST NEED CR.
3587 67820000
INLINR ICALL SQUIRT
MOVE CR TO OBUF.
3587 67840000
ICALL LOUTN
SEND THE CR.
3587 67860000
*
IF THIS USER IS BEING BOUNCED, SUPERVISOR SETS FORCM
67880000
*
AND RESETS 'AWAITING INPUT' (INWAIT). THUS WE MUST
67900000
*
TEST AGAIN (AT INL3) FOR FORCED SIGNOFF.
67920000
MVI INTOG,0
SHUN CHARACTER-EDIT MODE
67940000
*
TYI WAS IGNORED. RETRY IT.
67960000
*
BRANCH IS TO INLIND TO AVOID TURN- 67980000
*
ING ON PROCEED AFTER TERM 0 FINISHES 68000000
*
A COPY.
68020000
*
HOWEVER IT MEANS OP REALLY HAS TO POUND ATTENTION TO GET IN
68040000
*
UNDER CERTAIN CIRCUMSTANCES.
68060000
ATT OFF=INLIND
WE MANAGED TO PRINT THE CR,EOB
68080000
B
INLINQ
TIMING PROBLEM, TRY AGAIN
68100000
*
68120000
INL2
MVC MX(4),TOCORG
SEE COMMENT AT HEAD OF LISTING
68140000
L
1,MPTBASE
68160000
TM
IOB1-PERTERM(1),COPYRM
68180000
BZ
INL3
IF 'COPY READ' IS ON,
68200000
*
THIS IS COPY OPERATION, BUFFER IS IN INTERNAL CHARACTERS
68220000
L
3,PTIBUF-PERTERM(1)
68240000
LA
5,INBUF
INITIALIZE DESTINATION
68260000
USING PERBUF,3
68280000
INLCP1 MVC 0(L'PBSTAR,5),PBSTAR MOVE A FULL BUFFER
68300000
AH
5,PBCCW+6
INCREMENT DESTINATION
68320000
TM
PBFLAG,LINEZ
TEST FOR LAST BUFFER
68340000
L
3,PBTIC
POINT TO POSSIBLE NEXT BUFFER
68360000
BZ
INLCP1
YES VIRGINIA, THERE IS ANOTHER BUFF 68380000
*
R5 POINTS JUST BEYOND LAST BYTE OF LINE
68400000
BAL LKR,INL6
JOIN COMMON CODE, INDICATING NO CHAR 68420000
*
ERRORS. NOTE USE OF ILC IN LKR.
68440000
DROP 3
PERBUF
68460000
INLMVC MVC INBUF(0),OBUF
68480000
*
68500000
*
ENTRY FROM EOBSUBI, WHICH WANTS AN INPUT LINE WITH NO NONSENSE 68520000
*
EOBSUB SETS RETURN BY STORING LKR IN INLINK.
68540000
INLINB LA
1,INDENT
NO LINE NUMBER -- JUST SPACE OVER 6. 68560000
ICALL SQUIRT
68580000
B
INLINA
68600000
*
68620000
*
NOW MASSAGE THE CHARACTER STRING, REMOVING BACKSPACES, 68640000
*
LINEFEEDS, OVERSTRIKES AND SO ON.
68660000
*
DURING MASSAGE,
68680000
*
R3 = SOURCE POINTER (TO SUPERVISOR'S BUFFER)
68700000
*
R4 = SINK POINTER
68720000
*
R5 = FIRST UNTYPED POSITION (ALWAYS GEQ R4)
68740000
*
R6 = POINTER TO LEFTMOST CHARACTER ON LINE (LEQ R4)
68760000
*
*
TYI

*
*
*
*
*
INL3

LKR= POINTER TO LEFTMOST ILLEGAL CHARACTER ON LINE,

OR NEGATIVE
NOTE THAT WE START WITH INTERPRETER-PRODUCED TEXT
ALREADY IN INPUT BUFFER.
TM
BO
TCOM
L
LA
LA
ST
MVI
LR
AH
LR
MVI

IOB2-PERTERM(1),BOUNCM MAY HAVE BEEN SET WHILE KYBD 3039

INLIND
WAS LOCKED AND WE WERE
3039
RECEIVE
SUSPEND IN INWAIT.
3039
3,PTIBUF-PERTERM(1) POINTER TO FIRST INPUT BUFFER. 3039
4,INBUF
SET ALL POINTERS
6,INBUFEND
INITIALIZE MAXIN WITH ADDRESS 3574
6,MAXIN
OF LAST VALID INBUF POSITION. 3574
MAXINSW,0
3574
6,4
4,INLTMP
5,4
LFTOG,1
ENABLE LINE-DELETE TOGGLE
*
REENTRY TO FINISH CHARACTER EDITING
INL19
EQU *
3039
LCR LKR,6
LKR NEGATIVE = NO CHARACTER ERROR
ST
LKR,SVLKR
CLEAR SVLKR
3574
TM
QUADTOG,STQPBIT
TEST FOR QUAD PRIME
BZ
INL16
CLC PBSTAR-PERBUF(6,3),QZQPOUT GLITCH TO GET OUT OF QUAD-PRI
BE
INL18
'O' BS 'U' BS 'T' WAS TYPED
INL16
ST
3,OLINK
SAVE BUFFER ADR FOR LINKING TO NEXT
LA
3,PBSTAR-PERBUF(3) ADVANCE TO DATA AREA OF BUFFER
*
REENTRY TO PROCESS NEXT CHARACTER
INL14
CLI 0(3),ZBFZ
IS THIS END OF BUFFER --BNE INL20
L
3,OLINK
YES. LOCATE START OF CURRENT BUFFER
L
3,PBTIC-PERBUF(3) AND FIND NEXT ONE.
B
INL16
INL20
CLI 0(3),ZCR
IS NEXT CHAR A CARRIAGE RETURN -BNE INL7
NO.
LTR 6,LKR
TEST FOR ILLEGAL CHARACTERS IN LINE
BP
INL6
LKR NONNEG IS ADDR OF ILLEGAL CHAR
LA
6,1(5)
CARRIAGE RETURN. BUMP LEFT-MARGIN
LR
4,5
POINTER AND SOURCE POINTER.
*
(THE CASE OF A B C BS BS CR)
B
INL11
STUFF CR IN STRING.
INL7
CLI 0(3),ZLF
IS NEXT CHAR A LINEFEED -BNE INL8
NO.
MVO LFTOG,LFTOG
YES. SET LFTOG IF ENABLED BY RBR.
CR
LKR,4
SET LKR NEGATIVE IF IT'S CURRENTLY
BL
INL5
POINTING AT ILG CH TO THE RIGHT OF
LCR LKR,6
CARRIER.
ST
LKR,SVLKR
UPDATE SAVED VALUE ALSO.
3574
B
INL5
RESET RIGHT-HAND-CHAR POINTER
INL9
TM
MAXINSW,1
LINE EXCEEDED MAX ALLOWABLE?
3574
BZ
INL9A
NO.
3574
* LKR IS A COUNT OF CHARACTERS PAST INBUF+EMAXIN. WHEN LKR GOES 3574
* NEGATIVE, THE USER HAS ENTERED ENOUGH BACKSPACES TO REPOSITION 3574
* SINK TO THE LEFT OF INBUF+EMAXIN. WHEN THIS OCCURS, LKR IS
3574
* RESTORED FROM SVLKR.
3574
INL9B
SH
LKR,QH1
WHEN LKR GOES MINUS,
3574
BNM INL10
SINK IS LEFT OF INBUF+6+MAXIN. 3574
L
LKR,SVLKR
RESTORE LKR.
3574
INL9C
MVI MAXINSW,0
RE-ENABLE CODE AT INL11A.
3574
BCTR 5,0
RIGHTMOST CAN'T BE GT SINK.
3574

68780000
68800000
68820000
68840000
68860000
68880000
68900000
68920000
68940000
68960000
68980000
69000000
69020000
69040000
69060000
69080000
69100000
69120000
69140000
69160000
69180000
69200000
69220000
69240000
69260000
69280000
69300000
69320000
69340000
69360000
69380000
69400000
69420000
69440000
69460000
69480000
69500000
69520000
69540000
69560000
69580000
69600000
69620000
69640000
69660000
69680000
69700000
69720000
69740000
69760000
69780000
69800000
69820000
69840000
69860000
69880000
69900000
69920000
69940000
69960000

INL9A
INL8

CR
BNH
BCT
CLI
BE
CLI
BE
CL
BNL
CLI
BE
MVI

4,6
INL10
4,INL10
0(3),ZEOB
INL15
0(3),ZBS
INL9
4,MAXIN
INL11A
0(3),ZBLANK
INL13
LFTOG,0

CLR
BL
CLI
BE

LKR,4
OSB
0(3),ZILG
OSB

CLI
BNE
MVI

0(3),ZRBR
INL13
LFTOG,1

*
*

*
*
*
INL13

MOVE SINK LEFTWORD

3574
IF IT'S NOT AT THE LEFT MARGIN
ALREADY.
IS NEXT CHAR AN EOB -YES.
NO. IS IT A BACKSPACE -YES.
LINE EXCEEDED MAX ALLOWED?
3574
YES - IGNORE THE CHARACTER.
3574
BLANK IS ONLY CHAR WHICH DOESN'T
AFFECT THE LINEFEED TOGGLE.
PREVENT A 'DELETE' SIGNAL FROM
BECOMING A 'LINE DELETE' SIGNAL ACCI
-DENTALLY.
LOOK NO FURTHER IF WE ARE TO THE
RIGHT OF A CHARACTER ERROR
IS IT AN ILLEGAL CHARACTER -YES. SOMEONE HIT PREFIX.
C002
UPSHIFT ON A 1050, ETC.
IS CHAR A RIGHT BRACKET -NO. IT'S A NORMAL CHARACTER.
ENABLE LINEFEED TOGGLE (USED BY
FUNCTION EDITING TO DISTINGUISH
BETWEEN A TOTALLY EMPTY LINE AND A
STATEMENT-DELETE REQUEST.)
IF SINK = RIGHTMOST POSITION (NO
OVERSTRIKE), MOVE SOURCE TO SINK.
OR, IF WE ARE OVERSTRIKING A BLANK.

CR
4,5
BNL INL11
CLI 0(4),ZBLANK
BNE INL12
INL11
MVC 0(1,4),0(3)
* IF LINE IS PAST INBUF+EMAXIN, SINK PTR IS NOT UPDATED AND THE
* CHARACTER IS DUMPED INTO THE BUCKET AT INBUFEND.
CL
4,MAXIN
LINE EXCEEDED MAX ALLOWABLE ?
BL
INL17
NO.
INL11A TM
MAXINSW,1
BO
INL11B
* SINCE THE SINK PTR IS NOT INCREMENTED PAST INBUF+EMAXIN, LKR IS
* USED TO KEEP TRACK OF HOW MANY CHARACTERS ARE ENTERED PAST
* INBUF+EMAXIN. THE FOLLOWING CODE IS EXECUTED WHEN SINK REACHES
* INBUF+EMAXIN. IT SAVES LKR AT SVLKR. LKR IS RESTORED AT INL26
* SO THAT A CHARACTER ERROR WHICH OCCURED BEFORE INBUF+EMAXIN CAN
* BE DETECTED. SVLKR IS INITIALLY SET AT INL19. IT IS UPDATED
* HERE AND AT OSB .
MVI MAXINSW,255
ST
LKR,SVLKR
SR
LKR,LKR
INL11B LA
LKR,1(LKR)
B
INL17A
*
REENTRY FOR IGNORABLE OVERSTRIKES
INL17
LA
4,1(4)
UPDATE SINK POINTER
INL17A CR
4,5
DON'T UPDATE RIGHTMOST PTR
BL
INL10
IF IT'S EQUAL TO SINK.
*
REENTRY FOR LINEFEED
INL5
LR
5,4
INL10
LA
3,1(3)
UPDATE SOURCE POINTER ALWAYS.
B
INL14
BACK FOR NEXT CHARACTER.
*
('O' BS 'U' BS 'T') DETECTED IN QUAD PRIME INPUT
INL18
OI
RUNCTL,RCQEBIT
INL15
MVI 0(5),ZEOB
END OF BLOCK.
*
STUFF EOB INTO SINK AND QUIT.

3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574
3574

69980000
70000000
70020000
70040000
70060000
70080000
70100000
70120000
70140000
70160000
70180000
70200000
70220000
70240000
70260000
70280000
70300000
70320000
70340000
70360000
70380000
70400000
70420000
70440000
70460000
70480000
70500000
70520000
70540000
70560000
70580000
70600000
70620000
70640000
70660000
70680000
70700000
70720000
70740000
70760000
70780000
70800000
70820000
70840000
70860000
70880000
70900000
70920000
70940000
70960000
70980000
71000000
71020000
71040000
71060000
71080000
71100000
71120000
71140000
71160000

INL6
INL26

INL27

INL30
*
*
INL12

L
TM
BO
TCOM
L
LTR
BP
TM
BZ
LA
LA
B
LA
TM
BO
ST
L
BR
CLI
BE
CLC
BE
SR
IC

*
*
*
*
*
*

OS1

OS4
OS2

OSCLI
OS3

*
OS5
*
*
*

S
BNL
LA
CL
BH
CLI
BNE
LA
B
LA
EX
BE
B
CLI
CLI
BNE
SR
IC
S
CL
BNH
B
IC

SLL

6,MPTBASE
3574
IOB1-PERTERM(6),NSIGNM DON'T RELEASE BUFFERS
3574
INL26
IF NOT SIGNED ON
BREL
RELEASE BUFFER CHAIN
LKR,SVLKR
SEE COMMENTS AT INL11A.
3574
6,LKR
CHECK FOR CHARACTER ERROR.
3574
CHERR
MAXINSW,1
DID LINE EXCEED MAX ALLOWABLE? 3574
INL27
NO.
3574
1,RESEND
'RESEND'
3574
6,INBUFEND
POINT TO LAST ALLOWABLE
3574
PPERR2
INPUT CHARACTER. PRINT 'RESEND' 3574
6,INBUF
LOAD ABSOLUTE CHARACTER POINTER 3574
INTOG,CEBIT
WAS THIS CONTROL LINE FOR CHARACTER
CEDIT
EDIT -- IF SO, LOTS MORE WORK.
5,INLCH
SAVE POSITION OF EOB FOR MSG COMMAND
LKR,INLINK
LKR
RETURN WITH MASSAGED LINE IN INBUF.

71180000
71200000
71220000
71240000
71260000
71280000
71300000
71320000
71340000
71360000
71380000
71400000
71420000
71440000
71460000
71480000
71500000
71520000
71540000
OVERSTRIKES. SOME IGNORED, SOME BOUGHT, SOME ILLEGAL. 71560000
0(3),ZBLANK
71580000
INL17
IGNORE OVERSTRIKE BY BLANK.
71600000
0(1,3),0(4)
ALSO IGNORE OVERSTRIKE OF A
71620000
INL17
CHARACTER BY ITSELF.
71640000
1,1
NOW FOR THE GRUBBY PART.
71660000
1,0(4)
CHECK FOR ALL POSSIBILITIES OF
71680000
UNDERBAR OVERSTRIKES. THEY ARE -- 71700000
SOURCE
SINK
71720000
ALPHA
..
71740000
..
ALPHA
71760000
AULPHA
..
71780000
AULPHA
ALPHA
71800000
1,QZAU
SUBTRACT OFF 'AU'
71820000
OS1
IF NEGATIVE, IT'S NOT UNDERBARRED. 71840000
1,ZAU-ZA(1)
SUBTRACT OFF JUST 'A'
71860000
1,QF26
IS THIS CHARACTER ALPHABETIC -71880000
OS3
NO.
71900000
0(3),ZUND
SINK IS ALPHABETIC. IS SOURCE AN
71920000
OS2
UNDERBAR -71940000
0,ZAU(1)
YES. MAKE SINK AN UNDERBAR LETTER. 71960000
OS8
71980000
2,ZA(1)
SINK IS ALPHA OR AULPHA AND SOURCE 72000000
2,OSCLI
IS NOT AN UNDERBAR
72020000
OS4
SOURCE IS SAME ALPHA.
72040000
OS5
PROBABLY ILLEGAL OVERSTRIKE
72060000
0(3),0
EXECUTED CLI
72080000
0(4),ZUND
SINK IS NON-ALPHABETIC. IS IT UND - 72100000
OS5
NO. TRY SPECIAL OVERSTRIKES.
72120000
1,1
72140000
1,0(3)
PICK UP OFFENDING SOURCE CHARACTER 72160000
1,QZA
72180000
1,QF26
IS IT ALPHABETIC -72200000
OS4
YES. MAKE SINK CHAR AULPHABETIC.
72220000
OSB
BAD OVERSTRIKE -- UNDERBAR VS NONALF 72240000
72260000
0,0(3)
OVERSTRIKE MUST BE A SPECIAL
72280000
OPERATOR, LIKE VECTOR REVERSAL.
72300000
SEARCH TABLE OF ALL POSSIBLE WAYS
72320000
TO OVERSTRIKE SUCH THINGS.
72340000
0,24
MAKE SOURCE, SINK CHARACTERS INTO
72360000

OS9
OS6

OSB
*

SRA
IC
LA
LA
MVC
TR
CH
BE
BCTR
BCT
LA
C
BL
LA

0,16
0,0(4)
2,OSP
1,8
DTEMP(8),OSTPAT
DTEMP(8),0(2)
0,DTEMP-2(1)
OS7
1,0
1,OS6
2,3(2)
2,OSPEND
OS9
0,ZILG

A SIGNED HALFWORD.
START OF OVERSTRIKE TABLE
2 X NO. OF COMBINATIONS TO CONSIDER
MAP 3 CHARS INTO 8
COMPARE POTENTIAL OVERSTRIKE TO ALL
LEGAL COMBINATIONS
ADVANCE TO NEXT OVERSTRIKE IN TABLE
END TEST
BAD OVERSTRIKE. INSERT CANONICAL
BAD CHARACTER.
SET LKR TO LEFTMOST ILG CHARACTER

CLR LKR,4
BNH OS8
LR
LKR,4
ON LINE.
* SVLKR IS UPDATED BECAUSE THIS ERROR IS LEFT OF THE PREVIOUS ONE. 3574
ST
LKR,SVLKR
SAVE UPDATED LKR.
3574
B
OS8
OS7
IC
0,DTEMP+1
PICK UP THE INTERNAL CODE FOR THE
OS8
STC 0,0(4)
OVERSTRIKE AND PUT IT IN THE SINK.
B
INL17
SPACE 2
CEDIT
MVI INTOG,0
COMBINE OLD DISPLAY AND CONTROL LINE
*
NOW R6 = ABS ADDRESS OF FIRST CONTROL CHARACTER
*
R5 = ABS ADDRESS OF EOB ON CONTROL LINE
LR
2,6
USED LATER FOR ABSOLUTIZING ETC
LA
6,260
REL POSITION OF LAST CHAR OF MERGED
*
LINE, PLUS 1
LR
LKR,6
SR
5,2
NUMBER OF CONTROL CHARACTERS, -1
LH
4,CETMP
LENGTH OF FUNCTION DISPLAY LINE
BCTR 4,0
IN OBUF, LESS 2 (POINTS TO CR)
CR
5,4
IF CONTROL LINE IS LONGER THAN
BNH CE1
DISPLAYED STATEMENT,
LR
5,4
TRUNCATE IT
CE1
BCTR 6,0
DROP RESULT PTR TO NEXT POSITION
CE2
BCTR 4,0
DROP DISPLAY POINTER
IC
1,OBUF(4)
MOVE CHAR FROM STATEMENT DISPLAY
STC 1,INBUF(6)
TO MERGE AREA
CR
5,4
HAVE WE REACHED THE CONTROL INFO -BNH CE1
NO. NO CONTROL FOR RIGHT END OF LIN
LA
3,INBUF-1(5)
YES. LOOK AT CONTROL CHARACTER.
CLI 0(3),ZSLASH
BE
CE8
SLASH DELETES CHAR FROM STATEMENT
*
BY NOT UPDATING MERGE POINTER
SR
1,1
IC
1,0(3)
PICK UP CONTROL CHAR
SH
1,QZ9
LOOK FOR DECIMAL DIGIT
BP
CE7
A
1,QF9
BNM CE5
(IT IS)
AH
1,QH55
OR ALPHABETIC
BNH CE7
TREAT AS A BLANK OTHERWISE
MH
1,QH5
ALPHA BECOMES 5 * A...Z IOTA CHAR
CE5
BZ
CE3
NO INSERT IF 0 -- JUST MARK IT 2539
LA
0,ZBLANK
2539
CE4
BCTR 6,0
DROP MERGE POINTER

72380000
72400000
72420000
72440000
72460000
72480000
72500000
72520000
72540000
72560000
72580000
72600000
72620000
72640000
72660000
72680000
72700000
72720000
72740000
72760000
72780000
72800000
72820000
72840000
72860000
72880000
72900000
72920000
72940000
72960000
72980000
73000000
73020000
73040000
73060000
73080000
73100000
73120000
73140000
73160000
73180000
73200000
73220000
73240000
73260000
73280000
73300000
73320000
73340000
73360000
73380000
73400000
73420000
73440000
73460000
73480000
73500000
73520000
73540000
73560000

C
BL
STC
BCT
LR

6,QF130
CEFNERR
0,0(6,2)
1,CE4
LKR,6

STOP A RUNAWAY INSERT NOW

2539 73580000
2539 73600000
LENGTH UNDER 130, INSERT BLNK 2539 73620000
TEST BLANK-INSERTION COUNT
73640000
CE3
RECALL LEFTMOST BLNK ADDR FOR 2539 73660000
*
COMPUTED BACKSPACE COUNT
73680000
CE7
BCTR 6,0
DROP MERGE PTR TO NEXT FREE SPACE
73700000
C
6,QF130
CHECK LENGTH OF MERGED LINE
73720000
BL
CEFNERR
WHOOPS -- LONGER THAN PRINT LINE
73740000
CE8
BCT 5,CE2
BACK FOR MORE IF CONTROL INFO IS
73760000
*
NOT FINISHED. NOTE CONTROL LINE
73780000
*
HAS AT LEAST 1 CHARACTER -- EOB.
73800000
LA
5,259
73820000
SR
LKR,6
COLUMN TO BACKSPACE TO
73840000
BCTR LKR,0
73860000
SR
5,6
LENGTH OF MERGED LINE
73880000
STH 5,INLTMP
LINE LEN. FOR UPCOMING MASSAGE. 3587 73900000
BZ
CE10
73920000
L
1,MPTBASE
PERTERM ADDRESS.
3587 73940000
CLI PTTYPE-PERTERM(1),Q1050 1050 DOESN'T NEED IDLES
3587 73960000
BNL CE9
SO DON'T SEND ANY.
3587 73980000
* TYO USED CARRPOS TO COMPUTE IDLES TO PREVENT OVERPRINT.
3587 74000000
STH 5,CARRPOS-M(MR)
CURRENT CARRIER POSITION.
3587 74020000
CE9
EQU *
3587 74040000
AR
6,2
REL ADDR, LEFT END OF MERGE LINE
74060000
EX
5,CEMV1
MOVE MERGE LINE DOWN INTO LOW INBUF 74080000
STH 5,INBUF-2
74100000
LA
0,ZEOB
74120000
STC 0,INBUF(5)
NO CR -- WE STAY ON SAME LINE FOR BS 74140000
SR
5,LKR
NUMBER OF BACKSPACES REQUIRED
74160000
MVI OBUF,ZBS
FILL OUTPUT BUFFER WITH BACKSPACES 74180000
EX
5,CEMV2
74200000
STC 0,OBUF(5)
74220000
EX
0,INLINX
GET MX SET WRONG AGAIN
74240000
TYO INBUF-2
TYPE MERGED LINE
74260000
LTR 5,5
FOLLOWED (IF NECESSARY)
74280000
BZ
CE10
74300000
STH 5,OBUFPTR
BY BACKSPACES
74320000
TYO OBUFPTR
74340000
MVC OBUFPTR(2),QF2
SET OBUFPTR TO ZERO
3587 74360000
CE10
TYI
ACCEPT INPUT (CHANGES FOR LINE
74380000
*
SITTING IN INBUF).
74400000
L
1,MPTBASE
TO GET PTIBUF ADDRESSABILITY
74420000
ATT ON=INLINQ,MPTBASE=(1)
74440000
CLI PTTYPE-PERTERM(1),Q1050 1050 DOESN'T NEED IDLES
3587 74460000
BNL CE16
SO DON'T SEND ANY.
3587 74480000
* SEND IDLES TO PREVENT OVERPRINT. NUMBER OF IDLES IS COMPUTED BY 3587 74500000
* FINDING THE LENGTH OF THE EDITED LINE IN INBUF.
3587 74520000
L
3,PTIBUF-PERTERM(1) FIRST BUFFER ADDRESS.
3587 74540000
SR
6,6
POINT PAST WHAT'S
3587 74560000
LH
6,INLTMP
ALREADY BEEN ENTERED.
3587 74580000
LA
5,1
INCREMENT FOR CE12
3587 74600000
B
CE11
3587 74620000
CE14
L
3,PBTIC-PERBUF(3) ADDRESS OF NEXT BUFFER.
3587 74640000
CE11
LA
4,PBSTAR-PERBUF-1(3) POINT TO DATA AREA.
3587 74660000
CE12
LA
4,1(4)
LOOK AT THE NEXT CHAR.
3587 74680000
CLI 0(4),ZBFZ
END OF BUFFER?
3587 74700000
BE
CE14
YES-GET THE NEXT ONE.
3587 74720000
CLI 0(4),ZEOB
ZEOB IS THE END OF THE LINE.
3587 74740000
BE
CE15
END OF THE LINE
3587 74760000

CE17
CE15
CE16

CLI
BNE
S
BXH
STH
L
EX
LA

0(4),ZBS
CE17
6,QF2
6,5,CE12
1,CARRPOS-M(MR)
3,PTIBUF-PERTERM(1)
0,INL2
4,INBUF(LKR)

LA
LR
AH
B
MVC
MVC
MVC

6,INBUF
5,6
5,INBUF-2
INL19
INBUF(0),1(6)
OBUF+1(0),OBUF
INBUF(0),INBUF-1

ST
LA
ICALL
MVC
LD
DD
STD
LM
L
MVI
SR
LA
ICALL

LKR,OLINK
1,ZLBR
TOPRINT
DMASK+4(4),FLINENO
0,DMASK
0,D10000
0,DTEMP
0,1,DTEMP
4,OSIGDIG
OSIGDIG+3,8
3,3
2,3
TOBCD

CEMV1
CEMV2
CEMV3
*
OLINO

*
*
*
ST
LA
ICALL
OLIN2
LA
ICALL
CLI
BL
L
BR
TITLE
Q1050
EQU
CRNOIDLE DC
CRIDLE DC
DC
INDENT DC
PRIDEL DC
PRIPDEL DC
UNQIS
DC
Q5LGT
DC
DC
DC
ORG
*
BITB
DC
FOLDER DC
DC
QZQPOUT DC

BACKSPACE?
3587
NO.
3587
DON'T LET BACKSPACE FOOL US.
3587
KEEP TRACK OF WHERE WE ARE.
3587
CURRENT CARRIER POSITION.
3587
FOR INL19
3587
RESET MX TO CODESTRING ORIGIN
POSITION SINK PTR AT 1ST INSERTED
BLANK.
THIS PARALLELS SETUP AT INL3

THE EXECUTED MVC'S

PRINT BRACKETED LINE NUMBER.

FIRST THE LEFT BRACKET
FLOAT THE LINE NUMBER
AND READJUST IT TO TRUE FRACTION
SAVE CURRENT )DIGITS SETTING
WHILE WE PRINT THE LINE NUMBER
LOAD PARAMETERS FOR OUTPUT
CONVERSION AND CONVERT THE LINE NO.
TOBCD WILL PRINT IT WITH NO LEADING
SPACES AND WITH NO TRAILING FRACTIONAL ZEROES.
RESTORE PROPER SIG DIGITS SETTING
APPEND RIGHT BRACKET

4,OSIGDIG
1,ZRBR
TOPRINT
1,ZBLANK
AND AT LEAST ONE BLANK
TOPRINT
OBUFPTR+1,6
ENSURE INDENTATION OF AT LEAST 6
OLIN2
LKR,OLINK
LKR
'C O N S T A N T S A N D D S E C T S'
64
PTTYPE FOR 1050.
3587
AL1(1,ZCR)
CR.
3587
AL1(16,ZCR)
CR AND MAX IDLES.
3587
15AL1(ZEOB)
3587
AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK)
AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZDEL,ZBLANK)
AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZPDEL,ZBLANK)
AL1(ZDEL,ZCR,ZQUOTE,ZDEL,ZCR,ZEOB)
AL1(5,ZLENGTH)
FL1'0'
FILL
0F'0'
ALIGNMENT
*-1
TO FULLWORD BYTE 3
NEXT 3 CARDS MUST BE IN SEQUENCE
X'80'
X'40201008'
X'040201'
AL1(ZO,ZBS,ZU,ZBS,ZT,ZCR) 'O' BS 'U' BS 'T' CR

74780000
74800000
74820000
74840000
74860000
74880000
74900000
74920000
74940000
74960000
74980000
75000000
75020000
75040000
75060000
75080000
75100000
75120000
75140000
75160000
75180000
75200000
75220000
75240000
75260000
75280000
75300000
75320000
75340000
75360000
75380000
75400000
75420000
75440000
75460000
75480000
75500000
75520000
75540000
75560000
75580000
75600000
75620000
75640000
75660000
75680000
75700000
75720000
75740000
75760000
75780000
75800000
75820000
75840000
75860000
75880000
75900000
75920000
75940000
75960000

QZSD
QZTD
QZ9
QH1
QH5
QH16
QH55
QH126
QH255
OPMAN
OPTERM
QFDFN
QFM21
QFM4
QFM2
QF2
QF3
QF7
QF8
QF9
QF10
QF11
QF12
QF26
QF60
QF77
QF100
QF130
QF150
QF300

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
AGO
.SOX7
ANOP
QPLMSK DC
QF9S
DC
HOFLSET DC
*
QF108
DC
QZ0
DC
QFCVL
DC
ATYPTOP DC
QAMOVH DC
QCODCLS DC
UNVAR
DC
QINTYPE DC
QLOWNM EQU
DS
QLSTCODE DC
QGRCODE DC
DC
DTOPS
DC
QFMSMALL DC
DC
QF24BITS DC
*
ERND
DC
DUNZ
DC
D10
DC
D3000
DC
D10000 DC
D106
DC

AL1(ZS,ZDELTA)
AL1(ZT,ZDELTA)
Y(Z9)
H'1'
H'5'
H'16'
H'55'
H'126'
H'255'
F'314159'
A(0)
AL1(DFN,0,0,0)
F'-21'
F'-4'
F'-2'
F'2'
F'3'
F'7'
F'8'
F'9'
F'10'
F'11'
F'12'
F'26'
F'60'
F'77'
F'100'
F'130'
F'150'
F'300'
.SOX7
X'FFFF000F'
F'9999.9999E4'
F'0,-1,0'

3574
MAN NUMBER FOR OPERATOR
MODIFIED TO POINT TO PERTERM $ $ $ $
CHECKS FOR NON-VARS IN S.T.
3036

CHARACTERS PER IDLE.

3587

SOX
FOR MASKING OUT LABEL COUNT IN DIR
INITIAL VALUE FOR FRACTIONAL-LINE-NO
LIST USED IN CRL.
MUST FOLLOW HOFLSET

F'1E8'
A(Z0)
F'429496729'
ONE TENTH WORD CAPACITY
A(TYPTOP)
A(MTYPE-M)
M-ENTRY OVERHEAD
A(CDST*X'1000'*X'1000')
AL1(VARB,0,0,0)
FL1'2,0,0,0'
QINTYPE
QLOWNM IS JUST N000 , N LEQ 3
0F
AL1(MLSTBIT,0,0,0)
AL1(GROUP,0,0,0)
0D'0'
X'4E000000'
TOP OF 1ST UNNORMALIZED FL PT CONST
X'80000000'
X'56000000'
TOP OF 2ND UNNORMALIZED FL PT CONST
X'00FFFFFF'
A CONVENIENT SPOT
YOU GUESSED IT -- THEY MUST BE 8 APART.
D'.5'
X'4E00000000000000'
D'10'
D'3000'
D'10000'
D'1000000'

75980000
76000000
76020000
76040000
76060000
76080000
76100000
76120000
76140000
76160000
76180000
76200000
76220000
76240000
76260000
76280000
76300000
76320000
76340000
76360000
76380000
76400000
76420000
76440000
76460000
76480000
76500000
76520000
76540000
76560000
76580000
76620000
76640000
76660000
76680000
76700000
76720000
76740000
76760000
76780000
76800000
76820000
76840000
76860000
76880000
76900000
76920000
76940000
76960000
76980000
77000000
77020000
77040000
77060000
77080000
77100000
77120000
77140000
77160000
77180000

D16M14
D1614
INFIN
PTPAT
*
SOPFTXT

DC
DC
DC
DC

X'3310000000000000'
77200000
X'4F10000000000000'
77220000
X'7FFFFFFFFFFFFFFF'
77240000
X'FA202120FB2020FB2020'
77260000
'NUMBER NOT IN SYSTEM'
77280000
DC
H'21'
77300000
DC
AL1(ZN,ZU,ZM,ZB,ZE,ZR,ZBLANK,ZN,ZO,ZT,ZBLANK,ZI,ZN,ZBLANK77320000
K,ZS,ZY,ZS,ZT,ZE,ZM,ZCR,ZEOB)
77340000
*
'NUMBER IN USE'
77360000
SOPDTXT DC
H'14'
77380000
DC
AL1(ZN,ZU,ZM,ZB,ZE,ZR,ZBLANK,ZI,ZN,ZBLANK,ZU,ZS,ZE,ZCR,ZE77400000
EOB)
77420000
*
'INCORRECT SIGN-ON'
77440000
SOPERTX DC
H'18'
77460000
DC
AL1(ZI,ZN,ZC,ZO,ZR,ZR,ZE,ZC,ZT,ZBLANK,ZS,ZI,ZG,ZN,ZMINUS,77480000
,ZO,ZN,ZCR,ZEOB)
77500000
QZHOLD DC
AL1(4,ZH,ZO,ZL,ZD) 'HOLD'
77520000
*
'NUMBER LOCKED OUT'
77540000
SOPLKTX DC
H'18'
77560000
DC
AL1(ZN,ZU,ZM,ZB,ZE,ZR,ZBLANK,ZL,ZO,ZC,ZK,ZE,ZD,ZBLANK,ZO,77580000
,ZU,ZT,ZCR,ZEOB)
77600000
CMWASMSG DC
AL1(4,ZW,ZA,ZS,ZBLANK)
'WAS '
77620000
*
'ALREADY SIGNED ON'
77640000
SOPNDTXT DC
H'18'
77660000
DC
AL1(ZA,ZL,ZR,ZE,ZA,ZD,ZY,ZBLANK,ZS,ZI,ZG,ZN,ZE,ZD)
77680000
DC
AL1(ZBLANK,ZO,ZN,ZCR,ZEOB)
77700000
*
'INCORRECT COMMAND'
77720000
BADCOM DC
H'18'
77740000
DC
AL1(ZI,ZN,ZC,ZO,ZR,ZR,ZE,ZC,ZT,ZBLANK,ZC,ZO,ZM,ZM,ZA,ZN,Z77760000
ZD,ZCR,ZEOB)
77780000
*
'NOT WITH OPEN DEFINITION'
77800000
NOTINFN DC
H'25'
77820000
DC
AL1(ZN,ZO,ZT,ZBLANK,ZW,ZI,ZT,ZH,ZBLANK,ZO,ZP,ZE,ZN,ZBLAN.77840000
K,ZD,ZE,ZF,ZI,ZN,ZI,ZT,ZI,ZO,ZN,ZCR,ZEOB)
77860000
AGO .SOX8
77880000
.SOX8
ANOP
SOX 77960000
VTOZ
EQU *-C'0'
VD TO INTERNAL CODE
77980000
DC
AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,ZBLANK,ZPER)
78000000
*
'CONNECTED XX/XX/XX , TO DATE '
78020000
ACTMS1 DC
AL1(0,10,ZC,ZO,ZN,ZN,ZE,ZC,ZT,ZE,ZD,ZBLANK,0,0,0,0,0,0,0,78040000
)
78060000
DC
AL1(0,ZBLANK,ZCOMMA,ZBLANK,ZBLANK,ZT,ZO,ZBLANK,ZD,ZA,ZT,X78080000
ZE,ZBLANK)
78100000
ACTMSG2 DC
AL1(0,10,ZC,ZP,ZU,ZBLANK,ZT,ZI,ZM,ZE,ZBLANK) 'CPU TIME' 78120000
DS
0H
78140000
SPDSAVE DC
AL1(8,ZC,ZO,ZN,ZT,ZI,ZN,ZU,ZE,0,0,0)
78160000
DC
Y(XXSAVE)
)SAVE OP CODE
78180000
SAVMSG DC
AL1(5,ZS,ZA,ZV,ZE,ZD) 'SAVED'
78200000
COPERM DC
H'17'
'OBJECT NOT FOUND'
3575 78220000
DC
AL1(ZO,ZB,ZJ,ZE,ZC,ZT,ZBLANK,ZN,ZO,ZT,ZBLANK)
3575 78240000
DC
AL1(ZF,ZO,ZU,ZN,ZD,ZCR,ZEOB)
3575 78260000
*
'NOT GROUPED, NAME IN USE'
78280000
GRPTXT DC
AL1(7,ZRPAR,ZG,ZR,ZO,ZU,ZP,ZBLANK) ')GROUP '
78300000
CMGRNUSD DC
H'25'
78320000
DC
AL1(ZN,ZO,ZT,ZBLANK,ZG,ZR,ZO,ZU,ZP,ZE,ZD,ZCOMMA,ZBLANK) 78340000
DC
AL1(ZN,ZA,ZM,ZE,ZBLANK,ZI,ZN,ZBLANK,ZU,ZS,ZE,ZCR,ZEOB) 78360000
RESEND DC
AL1(6)
'RESEND'
3574 78380000
DC
AL1(ZR,ZE,ZS,ZE,ZN,ZD)
3574 78400000
QZA
DC
A(ZA)
78420000
QZAU
DC
A(ZAU)
78440000

QZ8BIT
QZDAU
P10
F102
PUBPRI
F103
F104
*
OSP

DC
DC
DC
EQU
EQU
EQU
EQU
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC

.DOL1
OSPEND
OSTPAT
FLENT
FLENTCSA
FLENTNO
FLENTLNK
PREPLOC
DLINENO

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
AGO
ANOP
DC
DC
LTORG
DSECT
DS
DS
DS
DSECT
DS
DS

A(ZA-1)
A(ZDELTAU)
F'1,10,100,1000,10000'
P10+8
P10+12
P10+12
P10+16
TABLE OF LEGITIMATE SPECIAL OVERSTRIKES
AL1(ZCIRCLE,ZMOD,ZREV)
AL1(ZQUOTE,ZPER,ZSHRIEK)
AL1(ZCIRCLE,ZBSLASH,ZTRAN)
AL1(ZCIRCLE,ZSTAR,ZLOG)
AL1(ZBASE,ZREP,ZHIST)
AL1(ZAND,ZNOT,ZNAND)
AL1(ZOR,ZNOT,ZNOR)
AL1(ZCAP,ZNULL,ZREM)
AL1(ZQUOTE,ZQUAD,ZQUADP)
AL1(ZDEL,ZNOT,ZPDEL)
AL1(ZDELTA,ZMOD,ZUPGRADE)
AL1(ZDEL,ZMOD,ZDNGRADE)
AL1(ZCIRCLE,ZMINUS,ZCOLREV)
AL1(ZSLASH,ZMINUS,ZCOLSLSH)
AL1(ZBSLASH,ZMINUS,ZCOLBSLH)
AL1(ZQUAD,ZDIV,ZDOMINO)
TABLE OF PSEUDO-LEGITIMATE SPECIAL OVERSTRIKES
AL1(ZCOMMA,ZPER,ZCOMMA)
AL1(ZSEMIC,ZPER,ZSEMIC)
AL1(ZCOLON,ZCOMMA,ZSEMIC)
AL1(ZSEMIC,ZCOLON,ZSEMIC)
AL1(ZSEMIC,ZCOMMA,ZSEMIC)
AL1(ZCOLON,ZPER,ZCOLON)
AL1(ZPLUS,ZMINUS,ZPLUS)
AL1(ZDIV,ZMINUS,ZDIV)
AL1(ZDOMINO,ZMINUS,ZDOMINO)
AL1(ZNE,ZEQ,ZNE)
AL1(ZEQ,ZSLASH,ZNE)
AL1(ZL,ZF,ZE)
THE DARK, IMMORAL SIDE
AL1(ZF,ZE,ZE)
AL1(ZO,ZQ,ZQ)
OF VISUAL FIDELITY
AL1(ZL,ZE,ZE)
AL1(ZP,ZR,ZR)
AL1(ZI,ZT,ZT)
AL1(ZMAX,ZMIN,ZLBR)
AL1(ZQUOTE,ZCOLON,ZSHRIEK)
AL1(ZPER,ZQUERY,ZQUERY)
AL1(ZMINUS,ZLARROW,ZLARROW)
AL1(ZMINUS,ZRARROW,ZRARROW)
AL1(Z3,Z8,Z8)
.DOL1

78460000
78480000
78500000
78520000
78540000
78560000
78580000
78600000
78620000
78640000
78660000
78680000
78700000
78720000
78740000
78760000
78780000
78800000
78820000
78840000
78860000
78880000
78900000
78920000
78940000
78960000
78980000
79000000
79020000
79040000
79060000
79080000
79100000
79120000
79140000
79160000
79180000
79200000
79220000
79240000
79260000
79280000
79300000
79320000
79340000
79360000
79380000
79400000
79420000
F005 79480000
A(*-1)
79500000
FL1'1,2,0,2,1,0,0,1' TRANSLATE TABLE FOR OVERSTRIKES
79520000
79540000
FORM OF ENTRY IN FRACTIONAL-LINE LST 79560000
A
CODESTRING ADDRESS
79580000
F
FRACTIONAL LINE NO * 10000
79600000
A
ADDR OF NEXT HIGHER LINE NUMBER
79620000
79640000
4F
MUST BE ZERO TO END SUP BACKTRACE
79660000
D
LINE NUMBER BUMPING WORKSPACE
79680000

NTEMP
DTEMP
DMASK
DNASK
PTEMP
SKBTEMP
INLINK
OLINK
INLCH
NEWID
HN
LN
EN
CCNT
*
FTEMP1
TOCSAV
FTEMP2
TOCORG
TOCPTR
SRCHRET
DELIT
DFNPTR
*
PINAB
LINAB
CINAB
FDTOG
FDDHBIT
FDDFBIT
FDCLBIT
PROTOG
LASTID
SVIT
HOFLN
LF108
ILN
ILNPTR
*
FRLNPTR
*
ENDIR
PRIFT
*
FLINENO
PRIFR
LINTF
*
*
SCSCNT
FTEMP3
CTYP
ININTMP
SCIMAGE
SCNAME
SCAD
SCNO
SCFLG
ACCTG
*

DS
DS
DS
DS
DS
DS
DS
DS
DS
DS
DS
EQU
DS
DS

D
D
D
D
D
7F
A
A
F
2F
2F
HN+4
F
3F

EQU
EQU
DS
DS
EQU
DS
DS
DS

CCNT+4
CCNT+8
F
2F
TOCORG+4
2A
A
F

DS
EQU
EQU
DS
EQU
EQU
EQU
DS
DS
DS
DS
DS
DS
EQU

3F
PINAB+4
PINAB+8
FL1
X'01'
X'02'
X'04'
FL1
F
F
3F
F
4F
ILN+4

EQU

ILN+8

EQU
DS

ILN+12
2F

EQU
DS
DS

PRIFT+4
A
F

DS
DS
DS
DS
DS
EQU
EQU
EQU
EQU
DS

F
F
F
A
RETURN LINK FOR ININT
2F
SYSTEM COMMAND CONTROL INFO
SCIMAGE
4 CHARACTERS OF COMMAND NAME
SCIMAGE+4
HALFWORD OF COMMAND ROUTINE ADDRESS
SCIMAGE+6
USEFUL BYTE WITH VARYING MEANINGS
SCIMAGE+7
FLAGS GIVING COMMAND SYNTAX
4F
ACCOUNTING INFORMATION AT SIGNOFF
CUMULATIVE CONNECTION TIME

ICV FLOATING WORKSPACE

INLINE RETURN ADDR

RETURN ADDRESS FOR OLINO
ABS ADDR OF EOB IN INPUT
ICV FIXED-POINT FRACTION
ICV DECIMAL EXPONENT
NUMBER OF CONSTANTS IN CODESTRING
VECTOR
SAVED COPY OF CODESTRING POINTER
M-REL POINTER TO CODESTRING ORIGIN
M-REL POINTER TO SYL POS IN CODESTR
LINK BACK FOR DELIDS
S.T. PTR OF DFN BEING DEFINED
EVEN IF HEADER HAS BEEN CHANGED
FN POINTER, IN ABEYANCE
LOCALS COUNT, IN ABEYANCE
CLASS (DFN OR DFN0), IN ABEYANCE
FUNCTION-DEFINITION INDICATOR
DEFINING FUNCTION HEADER
FUNCTION DEFINITION MODE PROPER
CLOSING FUNCTION DEFINITION
LOCK BIT FOR FN BEING DEFINED
TOP OF NEW PNAMES, BOT OF FLENTS
HEAD OF FRACTIONAL-LINE-NO. LIST
VERY LARGE LINENO TO END LINTRAC SCH
NEXT INTEGER LINE NO (FN EDITING)
POINTER TO ILN'S CODESTRING POINTER
IN 3-WORD-ENTRY LIST ON STACK
POINTER TO FRLN'S CODESTRING POINTER
IN FUNCTION DIRECTORY
M-REL ADDR OF END OF FN DIRECTORY
POINTER TO CODESTRING OF LAST STMT
LOOKED AT BY PRIFN
DECIMAL MIDPOINT FUNCTION LINE NO.
RETURN ADDRESS FOR PRIFN
ADDR OF LAST CODESTRING PTR
WITH NUMBER LESS THAN CURRENT ON
FRACTIONAL-LINE-NUMBER LIST
TEMP, NEW CS BYTE COUNT IN FN DEFN
LINK FROM SCANID

79700000
79720000
79740000
79760000
79780000
79800000
79820000
79840000
79860000
79880000
79900000
79920000
79940000
79960000
79980000
80000000
80020000
80040000
80060000
80080000
80100000
80120000
80140000
80160000
80180000
80200000
80220000
80240000
80260000
80280000
80300000
80320000
80340000
80360000
80380000
80400000
80420000
80440000
80460000
80480000
80500000
80520000
80540000
80560000
80580000
80600000
80620000
80640000
80660000
80680000
80700000
80720000
80740000
80760000
80780000
80800000
80820000
80840000
80860000
80880000

*
*
*
CGTEMP1
CGTEMP2
TUST
INLTMP
CETMP
TLGCPTR
*
TUSR
OFFTOG
LFTOG
*
DPYTOG
COPTOG
COPIBIT
COPPBIT
COPVBIT
COPOBIT
DSTOG
DSCLBIT
DSMSBIT
INTOG
CEBIT
ICVFG
QUADTOG
WPAT
EMAXIN

TODAY'S CONNECTION TIME

CUMULATIVE CPU TIME
TODAY'S CPU TIME
DS
2F
REG SAVE IN COPY GROUP
DS
2F
REG SAVE IN COPY GROUP
DS
F
PUTATIVE GLOBAL POINTER IN TUSAG
DS
H
INLINE TEMP FOR LINE NO. POS & LENGT
DS
H
SS COUNT OF DISPLAYED UNEDITED LINE
DS
H
OBUF POS OF 1ST CHAR, LAST OUTPUT
(FOR QUAD-PRIME INPUT OUTPUT-IGNORE)
DS
FL1
OUTCOME OF LOOKING IN STACK FOR FN
DS
FL1
SIGN-OFF FORCED BY SUPERVISOR
DS
FL1
LINEFEED SEEN FOLLOWING RIGHTMOST
RIGHT BRACKET (USED BY FN EDITING)
DS
FL1
LINE AND FUNCTION DISPLAY TOGGLE
DS
FL1
COPY/PCOPY SINK TOGGLE
EQU X'01'
COPY SINK
EQU X'02'
PCOPY
EQU X'04'
USED BY COPY-VARIABLE SINK
EQU X'10'
COPY SOURCE
DS
FL1
STACK DAMAGE INFORMATION
EQU X'01'
LABELS CHANGED IN EDITING
EQU X'02'
USER DESERVES A 'STACK DAMAGED' MSG
DS
X
FLAGS FOR INLINE SUBROUTINE
EQU 1
CHARACTER-EDIT REQUEST FOR INLINE
DS
FL1
NUMERIC INPUT CONVERSION FLAGS
DS
FL1
QUAD BITS FROM STFLAGS
DS
CL9
LINE NUMBER BUMPING WORKSPACE
EQU 266
MAXIMUM ALLOWABLE LINE LENGTH. 3574
DS
H
USED IN CHAR EDIT GAMES
*
INBUF-1 IS USED AS CHARACTER COUNT FOR CALL OF SQUIRTM.
INBUF
DS
(EMAXIN)C
SINK AREA FOR EDITED INPUT.
3574
*
*******
SUPEREDIT MAY USE ANOTHER 154 BYTES
*
OR SO
INBUFEND DS
1C
BUCKET FOR CHAR PAST EMAXIN.
3574
MAXINSW DS
FL1
FF WHEN LINE PAST INBUF+EMAXIN 3574
MAXIN
DS
A
ADDRESS OF INBUFEND.
3574
SVLKR
DS
A
SAVEAREA FOR ILLEGAL CHAR PTR. 3574
PREPLEND EQU *
COPY DIRSECT
END
./ ADD
NAME=APLSTRTA
TRTA
TITLE 'A P L T R A N S L A T E T A B L E S
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&INT
TYOGN &EXT1,&EXT2
GBLC &TYOA,&TYOT,&TYIT
GBLC &GARB
TO GENERATE FAIL SAFE ORG CARDS
LCLC &A
ORG &GARB
.*
GENERATE TYO TRANSLATE TABLES
ORG &INT+&TYOA
DC
X'&EXT1'
AIF ('&INT' NE 'ZUND').A2
.*
USE UNDERBAR VALUE
ORG &TYOT+ZAU
DC
27X'&EXT1'
.A2
AIF (T'&EXT2 EQ 'O').A1

80900000
80920000
80940000
80960000
80980000
81000000
81020000
81040000
81060000
81080000
81100000
81120000
81140000
81160000
81180000
81200000
81220000
81240000
81260000
81280000
81300000
81320000
81340000
81360000
81380000
81400000
81420000
81440000
81460000
81480000
81500000
81520000
81540000
81560000
81580000
81600000
81620000
81640000
81660000
81680000
81700000
00150000
00300000
00450000
00600000
00750000
00900000
01050000
01200000
01350000
01500000
01650000
01800000
01950000
02100000
02250000
02400000
02550000
02700000

.*

BACKSPACE AND OVERSTRIKE REQUIRED

ORG &INT+&TYOT
DC
X'&EXT2'
MEXIT
.A1
ORG &TYIT+X'&EXT1'
DC
AL1(&INT)
AIF ('&INT' EQ 'ZDELTA').A4
AIF (K'&INT NE 2).A3
&A
SETC '&INT'(2,1)
AIF ('&A' LT '0').A4
.A3
MEXIT
.A4
ORG &TYOA+&INT.U
DC
X'&EXT1'
DIERESIZED ALPHABET
MEND
*
MACRO
TYOTABG &DEV
GBLC &TYOA,&TYOT,&TYIT
GBLC &GARB
TO GENERATE FAIL SAFE ORG CARDS
&TYOT
SETC 'YO&DEV.TT'
&TYOA
SETC 'TYO&DEV'
&TYIT
SETC 'TYI&DEV'
&GARB
SETC 'FMRM&DEV'
ORG
ENTRY &TYOA,&TYIT
&TYOA
DC
(ZLENGTH)C'Z'
&TYOT
DC
(ZLENGTH)X'00'
&TYIT
DC
256AL1(ZILG)
&GARB
DC
4AL1(ZILG)
THROWAWAY REGION
MEND
*
GBLC &TYOA,&TYOT,&TYIT
GBLB &DIVA,&CP67
TRTABS CSECT
PRINT OFF
COPY ZSYMBOLS
COPY ZSYMBOLS
TITLE 'A P L T R A N S L A T E T A B L E S
05/11/70'
PRINT ON
PRINT NOGEN
TRTABS CSECT
TITLE '1 0 5 2 T R A N S L A T E T A B L E S
05/11/70'
*
TYOTABG 1052
PHYSICIAL 1052-7
ZILG
TYOGN 00
BCD IDLE CHARACTER
ZPFX
TYOGN 00
ZFCOLON TYOGN 4A
ZFPER
TYOGN 4B
ZALPHA TYOGN C1
ZAND
TYOGN 4F
ZBASE
TYOGN C2
ZBLANK TYOGN 40
ZBSLASH TYOGN 6D
ZCAP
TYOGN C3
ZCIRCLE TYOGN D6
ZCOLBSLH TYOGN 6D,6E
ZCOLON TYOGN 4A
ZCOLREV TYOGN D6,6E
ZCOLSLSH TYOGN 61,6E
ZCOMMA TYOGN 6B
ZCR
TYOGN 15

02850000
03000000
03150000
03300000
03600000
03750000
03900000
04050000
04200000
04350000
04500000
04650000
04800000
04950000
05100000
05250000
05400000
05550000
05700000
05850000
06000000
06150000
06300000
06450000
06600000
06750000
06900000
07050000
07200000
07350000
07500000
07650000
07800000
08250000
08400000
08550000
08700000
08850000
09000000
09150000
09300000
22800000
22950000
23100000
23250000
23400000
23550000
23700000
23850000
24000000
24150000
24300000
24450000
24600000
24750000
24900000
25050000
25200000
25350000
25500000

ZCUP
ZDARROW
ZDEL
ZDELTA
ZDIER
ZDIV
ZDNGRADE
ZDOMINO
ZEOB
ZEPS
ZEQ
ZFE
ZFOVB
ZGE
ZGT
ZHIST
ZIOTA
ZLARROW
ZLBR
ZLE
ZLOG
ZLPAR
ZLT
ZMAX
ZMIN
ZMINUS
ZMOD
ZNAND
ZNE
ZNOR
ZNOT
ZNULL
ZOMEGA
ZOR
ZOVB
ZPDEL
ZPER
ZPLUS
ZQUAD
ZQUADP
ZQUERY
ZQUOTE
ZRARROW
ZRBR
ZREM
ZREP
ZREV
ZRHO
ZRPAR
ZRSUB
ZSEMIC
ZSHRIEK
ZSLASH
ZSTAR
ZSUB
ZTIMES
ZTRAN
ZUARROW
ZUND
ZUPGRADE

TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN

E5
E4
C7
C8
4D
6C
C7,D4
D3,6C
00
C5
5D
85
4E
5E
5C
C2,D5
C9
60
5B
5F
D6,D7
5A
4C
E2
C4
6E
D4
4F,E3
7D
7F,E3
E3
D1
E6
7F
4E
C7,E3
4B
50
D3
D3,D2
D8
D2
6F
7B
C3,D1
D5
D6,D4
D9
7E
E7
7A
D2,4B
61
D7
E9
7C
6D,D6
E8
C6
C8,D4

1052-7 PSEUDO EOB

1052-7 -- PREMPTED

1052-7 -- PREMPTED

25650000
25800000
25950000
26100000
26250000
26400000
26550000
27150000
27300000
27450000
27600000
27750000
27900000
28050000
28200000
28350000
28500000
28650000
28800000
28950000
29100000
29250000
29400000
29550000
29700000
29850000
30000000
30150000
30300000
30450000
30600000
30750000
30900000
31050000
31200000
31350000
31500000
31650000
31800000
31950000
32100000
32250000
32400000
32550000
32700000
32850000
33000000
33150000
33300000
33450000
33600000
33750000
33900000
34050000
34200000
34350000
34500000
34650000
34800000
34950000

ZBSUC
ZBS
ZLF
*

TYOGN E9
TYOGN E9 (16)
1052-7 FAKE BS -- U/C Z
TYOGN E7 (25)
1052-7 PSEUDO LF -- U/C X
HANDLE ALPHABETS WITHOUT TYOGN
ORG &TYOA+Z0
HANDLE DIGITS
DC
C'0123456789'
ORG &TYOA+ZA
FIRST ALPHABET
DC
C'abcdefghijklmnopqrstuvwxyz'
LOWERCASE
ORG &TYOA+ZAU
SECOND ALPHABET
DC
C'abcdefghijklmnopqrstuvwxyz'
LOWERCASE
ORG &TYIT+C'A'-X'40'
DC
AL1(ZA,ZB,ZC,ZD,ZE,ZF,ZG,ZH,ZI)
ORG &TYIT+C'J'-X'40'
DC
AL1(ZJ,ZK,ZL,ZM,ZN,ZO,ZP,ZQ,ZR)
ORG &TYIT+C'S'-X'40'
DC
AL1(ZS,ZT,ZU,ZV,ZW,ZX,ZY,ZZ)
ORG &TYIT+C'0'
DC
AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9)
TITLE '1 0 5 0 T R A N S L A T E T A B L E S
05/11/70'

*
ZHIST
ZREM
ZREV
ZSHRIEK
ZQUADP
ZTRAN
ZLOG
ZNAND
ZNOR
ZPDEL
ZCOLREV
ZCOLSLSH
ZCOLBSLH
ZUPGRADE
ZDNGRADE
ZDOMINO
ZILG
ZFPER
ZFCOLON
Z1
Z2
Z3
Z4
Z5
Z6
Z7
Z8
Z9
Z0
ZRBR
ZEOB
ZLARROW
ZSLASH
ZS
ZT
ZU
ZV
ZW
ZX

TYOTABG 1050
TYOGN CA,E4
TYOGN E7,C3
TYOGN CC,C9
TYOGN 76,C5
TYOGN C6,C5
TYOGN CC,A3
TYOGN CC,CF
TYOGN 95,A6
TYOGN 93,A6
TYOGN EE,A6
TYOGN CC,C0
TYOGN 23,C0
TYOGN A3,C0
TYOGN F0,C9
TYOGN EE,C9
TYOGN C6,E1
TYOGN FF
TYOGN 76
TYOGN F6
TYOGN 02
TYOGN 04
TYOGN 07
TYOGN 08
TYOGN 0B
TYOGN 0D
TYOGN 0E
TYOGN 10
TYOGN 13
TYOGN 15
TYOGN 16
TYOGN 1F
TYOGN 20
TYOGN 23
TYOGN 25
TYOGN 26
TYOGN 29
TYOGN 2A
TYOGN 2C
TYOGN 2F

ZCAP,ZNULL

BCD IDLE CHARACTER

CRC ON INPUT OK

35100000
35250000
35400000
35700000
35850000
36000000
36150000
36300000
36450000
36600000
36750000
36900000
37050000
37200000
37350000
37500000
37650000
37800000
37950000
38100000
38250000
38400000
38550000
38700000
38850000
39000000
39150000
39300000
39450000
39600000
39750000
39900000
40050000
40200000
40350000
40500000
40650000
41250000
41400000
41550000
41700000
41850000
42000000
42150000
42300000
42450000
42600000
42750000
42900000
43050000
43200000
43350000
43500000
43650000
43800000
43950000
44100000
44250000
44400000
44550000

ZY
ZZ
ZCOMMA
ZLF
ZPLUS
ZJ
ZK
ZL
ZM
ZN
ZO
ZP
ZQ
ZR
ZLBR
ZCR
ZBSUC
ZBS
ZBS
ZTIMES
ZA
ZB
ZC
ZD
ZFE
ZE
ZF
ZG
ZH
ZI
ZPER
ZBLANK
ZBLANK
ZDIER
ZFOVB
ZOVB
ZLT
ZLE
ZEQ
ZGE
ZGT
ZNE
ZOR
ZAND
ZRPAR
ZEOB
ZRARROW
ZBSLASH
ZMAX
ZNOT
ZDARROW
ZCUP
ZOMEGA
ZRSUB
ZUARROW
ZSUB
ZSEMIC
ZLF
ZEOB
ZMINUS

TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN

31
32
37
3B
40
43
45
46
49
4A
4C
4F
51
52
57
DB
DD
DD
5D
61
62
64
67
68
6B
6B
6D
6E
70
73
76
7A
81
82
84
84
87
88
8B
8D
8E
90
93
95
96
9F
A0
A3
A5
A6
A9
AA
AC
AF
B1
B2
B7
BB
BD
C0

FAKE E

FAKE OVERBAR

CRC ON INPUT OK

44700000
44850000
45000000
45150000
45300000
45450000
45600000
45750000
45900000
46050000
46200000
46350000
46500000
46650000
46800000
46950000
47100000
47250000
47400000
47550000
47700000
47850000
48000000
48150000
48300000
48450000
48600000
48750000
48900000
49050000
49200000
49350000
49500000
49650000
49800000
49950000
50100000
50250000
50400000
50550000
50700000
50850000
51000000
51150000
51300000
51450000
51600000
51750000
51900000
52050000
52200000
52350000
52500000
52650000
52800000
52950000
53100000
53250000
53400000
53550000

ZNULL
ZQUOTE
ZQUAD
ZMOD
ZREP
ZCIRCLE
ZSTAR
ZQUERY
ZRHO
ZLPAR
ZCR
ZDIV
ZALPHA
ZBASE
ZCAP
ZMIN
ZEPS
ZUND
ZDEL
ZDELTA
ZIOTA
ZCOLON
ZBLANK
ZBLANK
ZEOB
*
*
ZPFX

*
ZHIST
ZREM
ZREV
ZSHRIEK
ZQUADP
ZTRAN
ZLOG
ZNAND
ZNOR
ZPDEL
ZCOLREV
ZCOLSLSH
ZCOLBSLH
ZUPGRADE
ZDNGRADE
ZDOMINO
ZILG
ZFPER
ZFCOLON
Z1
Z2
Z3
Z4
Z5
Z6

TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN

C3
C5
C6
C9
CA
CC
CF
D1
D2
D7
5B
E1
E2
E4
E7
E8
EB
ED
EE
F0
F3
F6
FA
01
3D

53700000
53850000
54000000
54150000
54300000
54450000
54600000
54750000
54900000
55050000
55200000
55350000
55500000
55650000
55800000
55950000
56100000
56250000
56400000
56550000
56700000
56850000
57000000
57150000
57300000
57450000
ORG TYO1050+ZEOB
57600000
DC
X'3D'
MAKE SURE REAL EOB IS USED ON OUTPUT 57750000
57900000
TYOGN 3E
58050000
ORG TYI1050+X'3E'
58200000
DC
AL1(ZILG)
DON'T ALLOW PFX ON INPUT
58350000
TITLE 'T S 4 1 T R A N S L A T E T A B L E S
05/11/70' 58500000
58650000
TYOTABG TS41
TSS 2741 CHARACTER SET
58800000
TYOGN CA,E4
58950000
TYOGN E7,C3
ZCAP,ZNULL
59100000
TYOGN CC,C9
59250000
TYOGN 76,C5
59400000
TYOGN C6,C5
59550000
TYOGN CC,A3
59700000
TYOGN CC,CF
59850000
TYOGN 95,A6
60000000
TYOGN 93,A6
60150000
TYOGN EE,A6
60300000
TYOGN CC,C0
60450000
TYOGN 23,C0
60600000
TYOGN A3,C0
60750000
TYOGN F0,C9
60900000
TYOGN EE,C9
61050000
TYOGN C6,E1
61200000
TYOGN FF
BCD IDLE CHARACTER
61800000
TYOGN 76
61950000
TYOGN F6
62100000
TYOGN 02
62250000
TYOGN 04
62400000
TYOGN 07
62550000
TYOGN 08
62700000
TYOGN 0B
62850000
TYOGN 0D
63000000

Z7
Z8
Z9
Z0
ZRBR
ZEOB
ZLARROW
ZSLASH
ZS
ZT
ZU
ZV
ZW
ZX
ZY
ZZ
ZCOMMA
ZLF
ZPLUS
ZJ
ZK
ZL
ZM
ZN
ZO
ZP
ZQ
ZR
ZLBR
ZBSUC
ZBS
ZBS
ZTIMES
ZA
ZB
ZC
ZD
ZFE
ZE
ZF
ZG
ZH
ZI
ZPER
ZBLANK
ZBLANK
ZDIER
ZFOVB
ZOVB
ZLT
ZLE
ZEQ
ZGE
ZGT
ZNE
ZOR
ZAND
ZRPAR
ZEOB
ZRARROW

TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN

0E
10
13
15
16
1F
20
23
25
26
29
2A
2C
2F
31
32
37
3B
40
43
45
46
49
4A
4C
4F
51
52
57
DD
DD
5D
61
62
64
67
68
6B
6B
6D
6E
70
73
76
7A
81
82
84
84
87
88
8B
8D
8E
90
93
95
96
9F
A0

CRC ON INPUT OK

FAKE E

FAKE OVERBAR

CRC ON INPUT OK

63150000
63300000
63450000
63600000
63750000
63900000
64050000
64200000
64350000
64500000
64650000
64800000
64950000
65100000
65250000
65400000
65550000
65700000
65850000
66000000
66150000
66300000
66450000
66600000
66750000
66900000
67050000
67200000
67350000
67500000
67650000
67800000
67950000
68100000
68250000
68400000
68550000
68700000
68850000
69000000
69150000
69300000
69450000
69600000
69750000
69900000
70050000
70200000
70350000
70500000
70650000
70800000
70950000
71100000
71250000
71400000
71550000
71700000
71850000
72000000

ZBSLASH
ZMAX
ZNOT
ZDARROW
ZCUP
ZOMEGA
ZRSUB
ZUARROW
ZSUB
ZSEMIC
ZLF
ZMINUS
ZNULL
ZQUOTE
ZQUAD
ZMOD
ZREP
ZCIRCLE
ZSTAR
ZQUERY
ZRHO
ZLPAR
ZCR
ZCR
ZDIV
ZALPHA
ZBASE
ZCAP
ZMIN
ZEPS
ZUND
ZDEL
ZDELTA
ZIOTA
ZCOLON
ZBLANK
ZBLANK
ZEOB
ZEOB
ZPFX
ZPFX
*

TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN

A3
A5
A6
A9
AA
AC
AF
B1
B2
B7
BB
C0
C3
C5
C6
C9
CA
CC
CF
D1
D2
D7
DB
5B
E1
E2
E4
E7
E8
EB
ED
EE
F0
F3
F6
FA
01
3D
BD
BE
3E

CRB ON INPUT OK
CRB ON INPUT OK

ORG TYOTS41+ZEOB
DC
X'7F'
BCD IDLE CHAR
TITLE '2 7 4 1 T R A N S L A T E T A B L E S
*
ZFOVB
ZFE
ZFPER
ZFCOLON
ZHIST
ZLOG
ZNAND
ZNOR
ZQUADP
ZREM
ZREV
ZSHRIEK
ZTRAN

TYOTABG 2741
TYOGN 84
TYOGN 29
TYOGN 45
TYOGN C5
TYOGN B7,A5
TYOGN D1,E8
TYOGN 93,A0
TYOGN 96,A0
TYOGN B1,AC
TYOGN AF,E1
TYOGN D1,C3
TYOGN AC,45
TYOGN D1,F0

GENUINE 2741 CHARACTER SET

ZCAP,ZNULL

72150000
72300000
72450000
72600000
72750000
72900000
73050000
73200000
73350000
73500000
73650000
73800000
73950000
74100000
74250000
74400000
74550000
74700000
74850000
75000000
75150000
75300000
75450000
75600000
75750000
75900000
76050000
76200000
76350000
76500000
76650000
76800000
76950000
77100000
77250000
77400000
77550000
77700000
77850000
78000000
78150000
78300000
78450000
78600000
05/11/70' 78750000
78900000
79050000
79200000
79350000
79500000
79650000
79800000
79950000
80100000
80250000
80400000
80550000
80700000
80850000
81000000

ZPDEL
ZCOLREV
ZCOLSLSH
ZCOLBSLH
ZUPGRADE
ZDNGRADE
ZDOMINO
ZILG
ZA
ZB
ZC
ZD
ZE
ZF
ZG
ZH
ZI
ZJ
ZK
ZL
ZM
ZN
ZO
ZP
ZQ
ZR
ZS
ZT
ZU
ZV
ZW
ZX
ZY
ZZ
Z0
Z1
Z2
Z3
Z4
Z5
Z6
Z7
Z8
Z9
ZALPHA
ZBASE
ZCAP
ZMIN
ZEPS
ZUND
ZDEL
ZDELTA
ZIOTA
ZNULL
ZQUOTE
ZQUAD
ZMOD
ZREP
ZCIRCLE
ZSTAR

TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN
TYOGN

E2,A0
D1,F6
70,F6
F0,F6
B2,C3
E2,C3
B1,E4
FF
4F
37
2F
2A
29
67
62
32
4C
61
2C
31
43
25
51
68
6D
4A
52
20
26
46
57
23
73
15
13
02
04
07
10
08
0D
0B
0E
16
CF
B7
AF
AA
A9
E7
E2
B2
CC
E1
AC
B1
C3
A5
D1
E8

BCD IDLE CHARACTER

81150000
81300000
81450000
81600000
81750000
81900000
82050000
82650000
82800000
82950000
83100000
83250000
83400000
83550000
83700000
83850000
84000000
84150000
84300000
84450000
84600000
84750000
84900000
85050000
85200000
85350000
85500000
85650000
85800000
85950000
86100000
86250000
86400000
86550000
86700000
86850000
87000000
87150000
87300000
87450000
87600000
87750000
87900000
88050000
88200000
88350000
88500000
88650000
88800000
88950000
89100000
89250000
89400000
89550000
89700000
89850000
90000000
90150000
90300000
90450000

ZQUERY
ZRHO
ZMAX
ZNOT
ZDARROW
ZCUP
ZOMEGA
ZRSUB
ZUARROW
ZSUB
ZLARROW
ZRBR
ZTIMES
ZLBR
ZCOMMA
ZSEMIC
ZPER
ZCOLON
ZSLASH
ZPLUS
ZDIER
ZOVB
ZLT
ZEQ
ZGT
ZGE
ZNE
ZLE
ZAND
ZOR
ZRARROW
ZRPAR
ZDIV
ZLPAR
ZBSLASH
ZMINUS
ZLF
ZLF
ZCR
ZCR
ZBSUC
ZBS
ZBS
ZBLANK
ZBLANK
ZEOB
ZEOB
ZEOB
ZEOB
ZPFX
ZPFX
ZBLANK
ZBLANK

TYOGN ED
TYOGN CA
TYOGN D2
TYOGN A0
TYOGN A6
TYOGN C6
TYOGN D7
TYOGN A3
TYOGN F3
TYOGN 95
TYOGN 40
TYOGN 49
TYOGN 64
TYOGN 6B
TYOGN 6E
TYOGN EE
TYOGN 45
TYOGN C5
TYOGN 70
TYOGN 76
TYOGN 82
TYOGN 84
TYOGN 87
TYOGN 88
TYOGN 8B
TYOGN 8D
TYOGN 8E
TYOGN 90
TYOGN 93
TYOGN 96
TYOGN C0
TYOGN C9
TYOGN E4
TYOGN EB
TYOGN F0
TYOGN F6
TYOGN 3B
TYOGN BB
TYOGN DB
TYOGN 5B
TYOGN DD
TYOGN DD
TYOGN 5D
TYOGN 7A
TYOGN FA
TYOGN 9F
TYOGN 1F
TYOGN 3D
CRB ON INPUT OK
TYOGN BD
CRB ON INPUT OK
TYOGN BE
TYOGN 3E
TYOGN 81
TYOGN 01
ORG TYO2741+ZEOB
DC
X'7F'
BCD IDLE CHAR
ORG
END
./ ADD
NAME=APLSVDOP
VDOP
TITLE 'VARIABLE DIMENSION OPERATORS
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970

90600000
90750000
90900000
91050000
91200000
91350000
91500000
91650000
91800000
91950000
92100000
92250000
92400000
92550000
92700000
92850000
93000000
93150000
93300000
93450000
93600000
93750000
93900000
94050000
94200000
94350000
94500000
94650000
94800000
94950000
95100000
95250000
95400000
95550000
95700000
95850000
96000000
96150000
96300000
96450000
96600000
96750000
96900000
97050000
97200000
97350000
97500000
97650000
97800000
97950000
98100000
98250000
98400000
98550000
98700000
98850000
99000000
05/11/70' 00080000
00160000

*
*

5736-XM6 COPYRIGHT IBM CORP. 1969, 1970

REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
APLDEFN, ZSYMBOLS, OPSECT
VDOP
CSECT
COPY APLDEFN
COPY ZSYMBOLS
COPY OPSECT
TITLE 'VARIABLE DIMENSION OPERATORS
05/11/70'
PRINT ON,NOGEN,NODATA
VDOP
CSECT
EXTRN ARTHTP
EXTRN BLOWRTN
EXTRN ERROR
EXTRN FETCH
EXTRN FETCHINT
EXTRN IDENTS
EXTRN MBLOWRTN
EXTRN OPSPACE
EXTRN OPTAG
ENTRY EXBASE
ENTRY EXREP
ENTRY MATRIX
ENTRY REDUCE
USING OPSECT-16,13
AX
EQU 8
BX
EQU 7
ZXR
EQU 6
EJECT
USING *,9
MATRIX ST
12,CALLBASE
SAVE THE CALLING ROUTINE BASE REG
DROP 9
BALR 12,0
USING *,12
ST
LKR,RREG
LA
14,(LEND-OPSECT+7)/8*8+16(,13)
P052
*
*
PROD
SR
ZXR,ZXR
ST
ZXR,RPTEST
THIS IS MATRIX PRODUCT
SR
1,1
CHECK RIGHT OPERATOR
IC
1,OPERATOR+3
A
1,=A(OPTAG)
TM
1(1),1
IS RIGHT OP SCALAR?
BZ
SYNTERR
NO
*
DETERMINE GOOD STUFF ABOUT LEFT OPE
LR
0,ZXR
A ZERO
LR
1,ZXR
CLI INDBASE,0
IS AN INDEX SPECIFIED ?
BNZ SYNTERR
YES
ST
ZXR,OUT
ASSUME OUTER PRODUCT
CLI OPERATOR+2,1+2*ZNULL IS IT ?
BNE PROD3
NO USE INNER
LM
1,5,TYPINFO
AVOID CONSTANT NEED TO CHECK FOR
B
PROD5
INNER OR OUTER
PROD3
MVC OUT,=F'4'
MARK IT INNER PRODUCT
IC
1,OPERATOR+2
A
1,=A(OPTAG)
TM
1(1),1
IS OP1 SCALAR ?
BZ
SYNTERR
NO
LR
1,ZXR

00240000
00320000
00480000
00560000
00640000
00720000
00800000
00880000
00960000
01040000
01120000
01200000
01280000
01360000
01440000
01520000
01600000
01680000
01760000
01840000
01920000
02000000
02080000
02160000
02240000
02320000
02400000
02480000
02560000
02640000
02720000
02800000
02880000
02960000
03040000
03120000
03200000
03280000
03360000
03440000
03520000
03600000
03680000
03760000
03840000
03920000
04000000
04080000
04160000
04240000
04320000
04400000
04480000
04560000
04640000
04720000
04800000
04880000
04960000
05040000

IC
L
LR
ICALL
STM

1,OPERATOR+2
2,RSTYPE
3,2
ARTHTP
1,5,AOP1

GET GOOD STUFF ABOUT LEFT OPER

05120000
05200000
05280000
05360000
PROD5
05440000
*
05520000
*
05600000
*
05680000
DOPROD BAL LKR,CONFORM
05760000
B
FILL
CONFORM FOUND EMPTY RESULT OR
05840000
*
FILLED WITH AN IDENTITY ELEMENT 05920000
MVC CALC1,BALIN
06000000
*
ASSUME NO CONVERSION
06080000
*
NEEDED FROM OP2 RESULT
06160000
MVC INCSTP(2),BRZXR
TO OP1 ARG TYPE
06240000
*
GEE WHERE HAVE I SEEN THIS BEFORE
06320000
L
1,RTYPE
06400000
SLA 1,2
GET CODE TO CONVERT LEFT OP RESULT 06480000
A
1,OP1CTP
TO LEFT OP ARG TYPE.
06560000
IC
1,FTCHTYP-5(1)
06640000
ST
1,RTOSCODE
CONVERSION NOT DONE UNLESS NEEDED
06720000
DOPROD7 MVC CALC2,BINFOP1
ASSUME INNER LOOP IS FLOATING
06800000
CLI OP1CTP+3,3
GOOD GUESS ?
06880000
BE
DOPROD11
YES
06960000
MVC CALC2,BINIOP1
NO MAKE IT FIXED
07040000
*
07120000
DOPROD11 BAL LKR,SETSTORE
SET UP RESULT STORE
07200000
ON
XOF,BLOW
ENABLE FIXED OVERFLOW
07280000
CLI OUT+3,0
IS THIS OUTER PROD ?
07360000
BNZ DOPROD13
NO
07440000
BAL LKR,ALTER1
07520000
L
5,ZPT
RESULT STARTS AT RIGHT
07600000
OUTL1
L
BX,BRT
B STARTS AT RIGHT
07680000
OUTL3
C
BX,LASTB
DONE WITH ELE OF A
07760000
BE
OUTL7
YES
07840000
S
BX,LB
NO,MOVE TO NEXT ELE OF B
07920000
EX
0,CALC1
08000000
LR
9,5
08080000
EX
0,SRESULT
STORE RESULT
08160000
S
5,LZ
MOVE TO NEXT ELEMENT OF Z
08240000
QUEND
08320000
B
OUTL3
08400000
OUTL7
S
AX,AINC
MOVE TO NEXT ELEMENT OF A
08480000
C
5,LASTZ
ALL DONE ?
08560000
BNL OUTL1
08640000
B
DOEND
08720000
DOPROD13 BAL LKR,ALTER
08800000
*
WORRY ABOUT CONVERTING THE
08880000
*
RESULT OF SCAN OPERATOR BACK TO
08960000
*
THE ARG TYPE OF THE SCAN
09040000
MVC INCSTS,BLOOP5
09120000
CLC RTYPE+3(1),OP1CTP+3 IS CONVERSION NEEDED
09200000
BE
DOPROD14
NO
09280000
MVC INCSTS(2),NOP
IT IS
09360000
DOPROD14 CLC OP1CTP+3(1),RSTYPE+3
09440000
BE
DOPROD15
YES
09520000
CLC SD,=F'1'
IF SCAN IS OVER ONE COMPONENT,
09600000
*
THEN NO CONVERSION TO SCAN ARG
09680000
*
TYPE NO MATTER WHAT THE OP IS
09760000
BE
DOPROD15
09840000

MVC

09920000
10000000
MVC PTOSCODE,OP1LFC
10080000
DOPROD15 B
OLOOP
10160000
DOEND
L
LKR,RREG
10240000
ON
XOF
DISABLE FIXED OVERFLOW
10320000
ON
XDZ
DISABLE FIXED DIVISION BY ZERO
10400000
L
12,CALLBASE
10480000
BR
LKR
10560000
*
10640000
*
10720000
*
INNER AND OUTER PRODUCT INITIAL VALUE ROUTINES
10800000
*
10880000
*
EX 0,INCSTP CONVERTS RESULT OF OP1 TO ARG TYPE OF
10960000
*
SCAN
11040000
*
11120000
*
MATRIX PRODUCT INITIAL VALUE ROUTINE
11200000
IN
EX
0,AGET
GET ELEMENT OF A INTO R1 OR F0
11280000
EX
0,BGET
GET ELEMENT OF B INTO R2 OR F2
11360000
L
9,OPRN
11440000
BALR LKR,9
EXECUTE THE OPERATOR (WHAT ELSE)
11520000
EX
0,INCSTP
11600000
*
11680000
*
11760000
*
CONVERT OP2 RESULT TO OP1 ARG TYPE
11840000
*
GETD WILL RETURN TO ADDRESS IN LINKS
11920000
INCSTP1 ST
1,PRESULT
STORE INTEGER RESULT
12000000
ST
ZXR,LINKS
RETURN FROM GETD
12080000
MVC CCODE,PTOSCODE
12160000
CLI RSTYPE+3,3
12240000
BNE GETD
CONVERT IT
12320000
STD 0,PRESULT
STORE FLOATING RESULT
12400000
B
GETD
CONVERT IT
12480000
*
12560000
*
12640000
*
FLOATING INNER LOOP FOR MATRIX PRODUCT
12720000
INFOP1 S
AX,TAR
MOVE TO NEXT ELEMENT OF A
12800000
STD 0,TPROD
SAVE RESULT OF SCAN SO FAR
12880000
EX
0,CALC1
FORM NEXT PRODUCT
12960000
*
LEFT OPERAND ALL SET UP
13040000
LD
2,TPROD
RIGHT OPERAND
13120000
INFOP11 L
9,AOP1
13200000
BALR LKR,9
EXECUTE THE SCAN OPERATOR
13280000
BCT 5,INFOP15
THIS THE LAST PARTIAL RESULT ?
13360000
B
LOOP6
YES - DON'T BOTHER TO
13440000
*
CHECK FOR CONVERSION
13520000
INFOP15 EX
0,INCSTS
CONVERSION NEEDED ?
13600000
*
ONLY LOGICAL OPERATORS COULD NE 13680000
ST
1,PRESULT
13760000
MVC CCODE,RTOSCODE
13840000
MVC LINKS,=A(LOOP5)
SET GETD RETURN ADDRESS
13920000
B
GETD
14000000
*
14080000
*
14160000
*
FIXED INNER LOOP FOR MATRIX PRODUCT
14240000
INIOP1 S
AX,TAR
MOVE TO NEXT ELEMENT OF A
14320000
ST
1,TPROD
SAVE RESULT OF SCAN SO FAR
14400000
EX
0,CALC1
FORM NEXT PRODUCT
14480000
*
LEFT OPERAND ALL SET UP
14560000
L
2,TPROD
RIGHT OPERAND
14640000
*

INCSTP,BINCSTP1

WIN ONE,LOSE ONE

SAVE LEFT OPERAND
FETCH CODE
OFF TO COMMON OUTER LOOP

*
*
BALIN
BLOOP5
*
*
BINFOP1
BINIOP1
*
*
BINCSTP1
FTCHTYP
EXBASE

*
*
BASEV

DOBASE

INFOP11

BAL
B

ZXR,IN
LOOP5

B
B

INNER LOOP CALC (CALC2)

INFOP1
FLOATING INNER LOOP
INIOP1
INTEGER INNER LOOP

DOB2
EXREP

MATRIX PROD INITIAL VAL ROUTINE

B
DC
EJECT
USING
ST
L
DROP
ST
LA

INCSTP1
CONVERT SCAN RESULT TO PRODUCT
FL1'1,5,6,13,7,2,8,13,9,10,3,13,13,13,13,4'

SR
LA
ST
MVC
MVC
BAL
B

ZXR,ZXR
1,1
1,RPTEST
RTYPE,RSTYPE
OUT,=F'4'
LKR,CONFORM
FILL

MVC
MVC
CLI
BE
MVC
BAL
ON
BAL
LM
L
SR
AR
LCR
LCR
LR
S
ST
STM
S
A
ST
B
EJECT
USING
ST
L
DROP
ST
LA

CALC1,BALBASE
CALC2,BBALOOPF
COMTYP+3,3
DOB1
CALC2,BBALOOPI
LKR,SETSTORE
XOF,BLOW
LKR,ALTER
2,3,TBR1
BX,BRT
BX,3
BX,2
2,2
3,3
1,3
1,LB
1,SBRM1
2,3,TBR1
AX,AINC
AX,LA
AX,APT1
OLOOP

*,9
12,CALLBASE
SAVE THE CALLING ROUTINE BASE REG
12,=A(MATRIX+6)
9
LKR,RREG
14,(LEND-OPSECT+7)/8*8+16(,13)
P052

DOB1

REST SAME AS FLOATING

IN CASE SPECIAL IDENTITY ELE NEEDED

FOR COMPATIBILITY WITH MATRIX PRODU
IS BASE VALUE
CONFORM FOUND EMPTY RESULT OR
FILLED RESULT WITH IDENTITY ELE
ASSUME FLOATING INNER LOOP
GOOD GUESS ?
YES
NO, MAKE IT FIXED
SET UP RESULT STORE
ENABLE FIXED OVERFLOW
GET SBR AND TBR1
WE DO BASE FROM LEFT TO RIGHT
POINTS ONE TOO HIGH
NEGATE TBR1
NEGATE SBR
RECALCULATE SBRM1 NOW IT IS
- ( SBR+1 ) COLS GO IN USUAL ORDER

*,9
12,CALLBASE
SAVE THE CALLING ROUTINE BASE REG
12,=A(MATRIX+6)
9
LKR,RREG
14,(LEND-OPSECT+7)/8*8+16(,13)
P052

14720000
14800000
14880000
14960000
15040000
15120000
15200000
15280000
15360000
15440000
15520000
15600000
15680000
15760000
15840000
15920000
16000000
16080000
16160000
16240000
16320000
16400000
16480000
16560000
16640000
16720000
16800000
16880000
16960000
17040000
17120000
17200000
17280000
17360000
17440000
17520000
17600000
17680000
17760000
17840000
17920000
18000000
18080000
18160000
18240000
18320000
18400000
18480000
18560000
18640000
18720000
18800000
18880000
18960000
19040000
19120000
19200000
19280000
19360000
19440000

*
REP

SR
LA
ST
MVC

ZXR,ZXR
1,1
1,RPTEST
RTYPE,RSTYPE

ST
BAL
B

0,OUT
LKR,CONFORM
DOEND

*
DOREP
*
MVC
CLI
BE
MVC
DOREP11 BAL
BAL
*
*
*
ON
ON
L
S
ST
L
L
REPL1
L
REPL5
C
BE
SR
BAL
B
REPL6
LR
EX
QUEND
L
L
S
ST
B
REPL7
S
ST
C
BH
B
DOREPC1 DC
DOREPC2 DC
*
*
*
BALOOPI A
*
EX
MR
SLDA
LR
BL
EX
AR
BCT

REPIORF,BREPLF1
COMTYP+3,3
DOREP11
REPIORF,BREPLI1
LKR,SETSTORE
LKR,ALTER

THIS IS REPRESENT
FOR COMPATIBILITY WITH MATRIX PRODU
R0 = 0 FROM LOCATE
CONFORM FOUND AN EMPTY RESULT OR
FILLED RESULT WITH IDENTITY ELEMENT
ASSUME FLOATING
GOOD GUESS?
YES
NO, MAKE IT FIXED
SET UP RESULT STORE
ALTER CONSTANTS TO PROPER INDEX TYPE

OUTER LOOP (REPRESENT)

XOF,BLOW
XDZ,REPIZD
1,APT1
1,TAR
OUTER LOOP ON AX
1,PTOSCODE
AN UNUSED LOCATION
4,LB
LENGTH OF B
5,ZPT
BX,BRT
BX,LASTB
REPL7
BX,4
ZXR,REPF
OUTER LOOP
REPLOOP
INNER LOOP
9,5
0,SRESULT
AX,APT1
RESET A TO SAME ROW
5,ZPT
5,LZ
5,ZPT
REPL5
AX,LA
AX,APT1
AX,PTOSCODE
REPL1
DOEND
ALL DONE, CLEAN UP AND QUIT
AL1(0,4,8,0,0,4,8)
AL1(0,0,0,4,8,4,8)
INTEGER HORNER'S METHOD
AX,TAR
INCREMENT LEFT ARG. THIS CAUSES
FIRST ELE OF LEFT ARG SKIPPED.
0,AGET
GET NEXT ELE OF LEFT INTO REG1
0,2
MULTIPLY BY IT
0,32
MAKE SURE RESULTS FITS IN A
1,0
FULLWORD
BLOW
IT DOESNT. TRY FLOATING POINT
0,BGET
GET NEXT ELE OF RT INTO R2
2,1
NEXT PARTIAL RESULT IN R2
5,LOOP5
CONTINUE LOOP IF NECESSARY

19520000
19600000
19680000
19760000
19840000
19920000
20000000
20080000
20160000
20240000
20320000
20400000
20480000
20560000
20640000
20720000
20800000
20880000
20960000
21040000
21120000
21200000
21280000
21360000
21440000
21520000
21600000
21680000
21760000
21840000
21920000
22000000
22080000
22160000
22240000
22320000
22400000
22480000
22560000
22640000
22720000
22800000
22880000
22960000
23040000
23120000
23200000
23280000
23360000
23440000
23520000
23600000
23680000
23760000
23840000
23920000
24000000
24080000
24160000
24240000

LR
B
*
*
*
BALOOPF A
EX
MDR
EX
ADR
BCT
LDR
B
EJECT
*
REPF
EX
EX
*
*
*
REPLI1 ST
EX
SRDA
DR
LTR
BNL
LPR
*
AR
REP1
LR
L
SR
SRDA
DR
LR
LR
BR
*
*
*
REPLF1 EX
LTDR
BNZ
LDR
SDR
BR
REPLF3 STD
STD
L
BALR
LDR
LD
SDR
DD
LDR
*
BR
*
*
*

1,2
LOOP6

RESULT STORED OUT OF R1

FLOATING HORNERS METHOD

AX,TAR
INCREMENT LEFT ARG
0,AGET
GET NEXT ELE OF LEFT INTO E0
0,2
MULTIPLY BY IT
0,BGET
2,0
NEXT PARTIAL RESULT IN E2
5,LOOP5
CONTINUE LOOP IF NECESSARY
0,2
RESULT STORED OUT OF E0
LOOP6
INITIAL CALC REPRESENT
0,BGET
0,REPIORF
INTEGER REPRESENT
2,TPROD
SAVE CURRENT P (OR B)
0,AGET
GET AN ELEMENT OF A
2,32
PUT IN ODD REG,SIGN EXTENDED
2,1
P/A,REMAINDER IN 2
2,2
IS REMAINDER <0 ?
REP1
NO, GOODIE
0,1
THIS IS ABSOLUTELY THE VALUE
OF A
2,0
MAKE REMAINDER RESIDUE
9,2
RESULT IN R9
2,TPROD
RESTORE P
2,9
SUBTRACT THE RESIDUE
2,32
MOVE INTO R3, SIGN EXTENDED
2,1
NEW P IN R2
2,3
1,9
RESULT IN R1 AND R9 ON EXIT
ZXR
RETURN
FLOATING REPRESENT
0,AGET
0,0
REPLF3
0,2
2,2
ZXR
0,TPROD
2,TPROD1
9,=V(EXRES)
LKR,9
6,0
2,TPROD1
2,6
2,TPROD
0,6
F2 = NEW B,F0,F6 =
ZXR

GET ELEMENT OF A
A = 0 ?
YES, RESULT IS REMAINING B
NEW B = 0
RETURN
SAVE A FOR NOW
SAVE B FOR NOW
USE FLOATING RESIDUE
SAVE RESULT
RESTORE B
SUBTRACT RESIDUE
GET NEW B
ANS
RETURN

HERE ON FIXED ZERO DIVIDE

24320000
24400000
24480000
24560000
24640000
24720000
24800000
24880000
24960000
25040000
25120000
25200000
25280000
25360000
25440000
25520000
25600000
25680000
25760000
25840000
25920000
26000000
26080000
26160000
26240000
26320000
26400000
26480000
26560000
26640000
26720000
26800000
26880000
26960000
27040000
27120000
27200000
27280000
27360000
27440000
27520000
27600000
27680000
27760000
27840000
27920000
28000000
28080000
28160000
28240000
28320000
28400000
28480000
28560000
28640000
28720000
28800000
28880000
28960000
29040000

REPIZD

LTR
BL
LR
SR
BR

*
*
*
REPLOOP LA
REPLOOP1 S
C
BL
QUEND
LR
EX
EX
REPLOOP3 S
B
*
*
BALBASE BAL
*
BBALOOPI B
BBALOOPF B
BREPLOOP B
BREPLI1 B
BREPLF1 B
EJECT
USING
REDUCE ST
L
DROP
ST
LA
MVC
MVC
L
SR
ST
IC
A
TM
BZ
LA
*
CLI
BE
CLI
BE
B
*
R5
LH
SRL
R10
TM
BZ
BO
L
LA
R19
ST
R20
BAL

2,2
RANGERR
1,3
2,2
ZXR

IS B<0
YES, 0 RESIDUE UNDEFINED
REST OF B IS LAST RESIDUE
NEW VALUE OF B
RETURN

29120000
29200000
29280000
29360000
29440000
29520000
29600000
INNER LOOP FOR REPRESENT (CALC2)
29680000
ZXR,REPLOOP3
RETURN ADDRESS FOR REPIORF
29760000
AX,TAR
MOVE TO NEXT ELE OF A
29840000
AX,LASTA
ALL DONE?
29920000
REPL6
YES,RETURN
30000000
30080000
9,5
30160000
0,SRESULT
RESULT IS IN R1 OR F0
30240000
0,REPIORF
30320000
5,TRZ
30400000
REPLOOP1
ITERATE
30480000
30560000
30640000
ZXR,BASE
30720000
INNER LOOP FOR BASE (CALC2)
30800000
BALOOPI
BRANCH FOR INTEGER BASE
30880000
BALOOPF
BRANCH FOR FLOATING BASE
30960000
REPLOOP
INNER LOOP REPRESENT (CALC2)
31040000
REPLI1
FIXED (REPIORF)
31120000
REPLF1
FLOATING (REPIORF)
31200000
31280000
*,9
31360000
12,CALLBASE
SAVE THE CALLING BASE REG
31440000
12,=A(MATRIX+6)
31520000
9
31600000
LKR,RREG
31680000
14,(LEND-OPSECT+7)/8*8+16(,13)
P052 31760000
RTYPE,RSTYPE
FOR COMPATIBILITY WITH MATRIX PROD 31840000
POSTBLOW,=A(MBLOWRTN)
31920000
BX,RHBASE
M-REL POINTER TO RIGHT ARG
32000000
1,1
32080000
1,RPTEST
NOT REPRESENT
32160000
1,OPERATOR+3
32240000
1,=A(OPTAG)
32320000
1(1),1
IS IT A SCALAR OP
32400000
SYNTERR
NO
32480000
4,1
ASSUME WE HAVE A BARRED SLASH
32560000
DEFAULT INDEX TO 1
32640000
OPERATOR+2,1+2*ZCOLSLSH
32720000
R10
YES WE GUESSED RIGHT
32800000
OPERATOR+2,1+2*ZSLASH
32880000
R5
ITS A NORMAL SLASH
32960000
SYNTERR
MUST BE SCAN OR OTHER, SYNT ER G01 33040000
33120000
4,MRANK(BX)
DEFAULT INDEX IS
33200000
4,2
RHORHO B
33280000
INDBASE,X'C0'
33360000
R19
33440000
INDEXER
33520000
4,INDEX
33600000
4,1(4)
WHY DO I WANT 1 ORIGIN
33680000
4,INDEX1
STORE IN NEW PLACE INCASE BLOWUP
33760000
LKR,DORED
33840000

DOR40

DOR50

RLOOP1
RLOOP3

RLOOP5
*
RLOOP6

B
L
LTR
BNE
L
LD
L
BAL
MVC
MVC
CLI
BE
MVC
BAL
L
IC
LM
SLL
SLL
ST
ST
S
ST
LA
BAL
L
SLA
A
IC
ST
ON
L
L
S
L
A
ST
EX
L
BCT
QUEND
B
S
QUEND
EX
BCT
L
EX
S
ST
L
BCT
BCT
B

*
*
*
REDUCEI ST
EX
L

DOEND
3,SD
3,3
DOR40
1,TPROD
0,TPROD2
2,RXRHO
LKR,FILL
CALC1,BRCCI
CALC2,BREDUCEF
COMTYP+3,3
DOR50
CALC2,BREDUCEI
LKR,SETSTORE
9,LB
9,SLIST-1(9)
1,3,TBR
1,0(9)
3,0(9)
3,SBR
1,TBR1
3,LB
3,SBRM1
5,1
LKR,ALTER6
1,RTYPE
1,2
1,COMTYP
1,FTCHTYP-5(1)
1,RTOSCODE
XOF,BLOW
BX,BRT
AX,TBL
BX,SBR
4,TBR
BX,SBRM1
4,R4SAVE
0,CALC1
5,SD
5,RLOOP5

INDEX WAS OUT OF RANGE

DO I FILL WITH IDENTITY?

33920000
34000000
34080000
34160000
34240000
34320000
34400000
FILL UP THE ARRAY
34480000
34560000
ASSUME FLOATING INNER LOOP
34640000
GOOD GUESS?
34720000
TA DA
34800000
34880000
34960000
35040000
35120000
35200000
TBR
35280000
SBR
35360000
35440000
35520000
SBR - 1
35600000
35680000
FOR COMPARISONS IN ALTER
35760000
SHARE SETUP OF Z AND B
35840000
DEFINE CONVERSION CODE
35920000
TO CONVERT RESULT OF OPERATION
36000000
BACK TO THE ARGUMENT
36080000
TYPE
36160000
ONLY USED IF NEEDED
36240000
36320000
36400000
36480000
MOVE TO NEXT HYPERPLANE
36560000
36640000
MOVE TO NEXT STARTING POINT
36720000
SCALAR OP ROUTINE MAY USE REG 4
36800000
36880000
NUMBER OF ELEMENTS FORMING ONE RESUL 36960000
GET OUT EARLY ON
37040000
2549 37120000
RLOOP6
REDUCTION OF ONE ELEMENT
37200000
BX,TBR1
37280000
37360000
0,CALC2
37440000
5,RLOOP5
THIS IS DONE IN REDUCE
37520000
9,ZPT
37600000
0,SRESULT
37680000
9,LZ
37760000
9,ZPT
37840000
4,R4SAVE
37920000
4,RLOOP3
38000000
AX,RLOOP1
38080000
DOEND
38160000
38240000
38320000
FIXED INNER LOOP REDUCE
38400000
1,TPROD
RESULT SO FAR
38480000
0,CALC1
GET NEXT ELEMENT
38560000
2,TPROD
PREVIOUS RESULT
38640000

B
*
*
*
REDUCEF STD
EX
LD
RD11
L
BALR
BCT
B
RD15
CLC
*
BE
CLI
BE
ST
MVC
MVC
B
*
*
*
BASE
DS
RCCI
EX
LR
LDR
BR
*
*
BRCCI
BAL
BREDUCEI B
BREDUCEF B
EJECT
*
*
ALTER
L
IC
LM
SLL
SLL
STM
S
ST
*
*
ALTER1 L
IC
LM
SLL
SLL
STM
LA
C
BNE
SR
ALTER5 ST
L
BCTR
SLL

RD11

38720000
38800000
38880000
FLOATING INNER LOOP REDUCE
38960000
0,TPROD
RESULT SO FAR
39040000
0,CALC1
GET NEXT ELEMENT
39120000
2,TPROD
39200000
9,OPRN
39280000
LKR,9
EXECUTE OPERATOR
39360000
5,RD15
IS THIS THE LAST PARTIAL RESULT
39440000
RLOOP6
YES
39520000
RTYPE+3(1),COMTYP+3 MUST RESULT BE CONVERTED BACK TO
39600000
ARG TYPE OF OPERATOR
39680000
RLOOP5
NO
39760000
COMTYP+3,4
CHECK FOR EQ OR NEQ RED OF CHAR 3047 39840000
RLOOP5
BRANCH IF EQ OR NEQ OF CHAR
3047 39920000
1,PRESULT
ONLY A LOGICAL OPERATOR NEEDS THIS
40000000
CCODE,RTOSCODE
YES,SET CONVERSION CODE
40080000
LINKS,=A(RLOOP5)
SET GETD RETURN ADDRESS
40160000
GETD
40240000
40320000
40400000
REDUCE INITIAL CALC
40480000
0H
BASE VALUE INITIAL CALC
40560000
0,BGET
GET AN ELEMENT OF B
40640000
1,2
40720000
0,2
IN R1 OR F0
40800000
ZXR
40880000
40960000
41040000
ZXR,RCCI
41120000
REDUCEI
41200000
REDUCEF
41280000
41360000
MAKE ALL CONSTANTS ELEMENT,FULLWORD ,OR DOUBLEWORD
41440000
ENTRY FOR IN-BASE
41520000
9,LB
B CONSTANTS
41600000
9,SLIST-1(9)
AMOUNT OF SHIFT FOR B
41680000
2,3,TBR1
41760000
2,0(9)
TBR1
41840000
3,0(9)
SBR
41920000
2,3,TBR1
42000000
3,LB
SBR-1
42080000
3,SBRM1
42160000
42240000
ENTRY FOR OUT-REP
42320000
9,LA
42400000
9,SLIST-1(9)
42480000
1,2,AINC
42560000
1,0(9)
AINC
42640000
2,0(9)
TAR
42720000
1,2,AINC
42800000
5,1
FOR COMPARISONS
42880000
5,LA
IS A AN ELEMENT INDEX
42960000
ALTER5
NO
43040000
AX,AX
YES,DEFINE IT SO
43120000
AX,LASTA
43200000
1,LHXRHO
ELEMENTS IN A
43280000
1,0
MAKE IT ZERO ORIGIN
43360000
1,0(9)
43440000

ALTER6
ALTER7

*
*

ALTER9

SLIST
*
*
BLOW

*
AFETCH

*
*
BFETCH

AR
ST
L
M
ST
C
BNE
SR
ST
L
BCTR
M
AR
ST
ST

AX,1
AX,APT1
1,TRZ
0,LZ
1,TRZ
5,LZ
ALTER7
ZXR,ZXR
ZXR,LASTZ
1,RXRHO
1,0
0,LZ
ZXR,1
ZXR,ZPT
ZXR,ZPT1

START A AT RIGHTMOST ELEMENT

43520000
43600000
43680000
43760000
43840000
IS Z AN ELEMENT INDEX ?
43920000
NO
44000000
YES, DEFINE IT SO
44080000
44160000
ELEMENTS IN RESULT
44240000
MAKE IT ZERO ORIGIN
44320000
44400000
44480000
44560000
44640000
FROM HERE ZPT NOT ZXR IS
44720000
THE RESULT INDEX
44800000
C
5,LB
IS B AN ELEMENT INDEX
44880000
BNE ALTER9
NO
44960000
SR
BX,BX
YES, DEFINE IT SO
45040000
ST
BX,LASTB
45120000
L
1,RHXRHO
45200000
M
0,LB
45280000
AR
BX,1
45360000
ST
BX,BRT
B STARTS 1 BEYOND RIGHT ELEMENT
45440000
BR
LKR
45520000
DC
AL1(0,0,0,2,0,0,0,3)
AMOUNT OF SHIFT FOR GIVEN LENGTH 45600000
45680000
45760000
L
9,SVI
ALL WAS FOR NOTHING (SIGH)
45840000
LA
9,4(9)
45920000
ST
9,SVI
46000000
L
1,M(9)
46080000
MKG 1
GET RID OF FIXED RESULT
46240000
LA
0,3
FORCE FLOATING TYPE
46320000
L
9,POSTBLOW
ADDRESS OF RESTART ROUTINE
46400000
L
12,CALLBASE
OPCTL BASE REG
46480000
BR
9
46560000
DC
H'0'
REMOVE THIS CARD TO SAVE 2 BYTES
46640000
EJECT
46720000
FETCH ROUTINES
46800000
STM 2,4,FTSAVE
DON'T DISTROY B ARG IF ANY
46880000
LM
3,4,LCFTYPE
TYPE AND DATA ORIGIN
46960000
LR
2,AX
ELEMENT INDEX
47040000
LR
9,LKR
SAVE RETURN
47120000
ICALL FETCH
RESULT IN R0 OR F0
47200000
LR
1,0
FIXED RESULT IN R1
47280000
LM
2,4,FTSAVE
47360000
BR
9
RETURN
47440000
47520000
47600000
STM 1,4,FTSAVE
DON'T DISTROY A ARG IF ANY
47680000
STD 0,DTEMP
SAVE FLOATING A ARG
47760000
LM
3,4,RCFTYPE
TYPE AND DATA ORIGIN
47840000
LR
2,BX
ELEMENT INDEX
47920000
LR
9,LKR
48000000
ICALL FETCH
RESULT IN R0 OR F0
48080000
LDR 2,0
PUT FLOATING RESULT IN F2
48160000
LD
0,DTEMP
RESTORE FLOATING A ARG
48240000
LR
2,0
FIXED RESULT IN R2
48320000

L
LM
BR
*
*
GETD

*
*
AFTOF
*
*
BFTOF
*
*
*
*
*
*
FTOF

*
LOADF
*
ADBASE

*
*
OLOOP
LOOP
LOOP3

LOOP5

1,FTSAVE
3,4,FTSAVE+8
9

48400000
48480000
48560000
48640000
48720000
STM 2,4,FTSAVE
48800000
L
3,CCODE
THE CONVERSION CODE
48880000
LA
4,PRESULT
ADDRESS OF INTERMEDIATE RESULT
48960000
SR
4,MR
RELATIVEIZE IT
49040000
SR
2,2
ELEMENT INDEX
49120000
ICALL FETCH
RESULT IN R0 OR F0
49200000
LR
1,0
FIXED RESULT IN R1
49280000
L
LKR,LINKS
RETURN ADDRESS
49360000
LM
2,4,FTSAVE
49440000
BR
LKR
49520000
49600000
49680000
SR
9,9
AN A ARG
49760000
LR
2,AX
ELEMENT INDEX
49840000
B
FTOF
49920000
50000000
50080000
LA
9,4
A B ARG
50160000
LR
2,BX
ELEMENT INDEX
50240000
B
FTOF
50320000
50400000
50480000
INLINE CONVERSION ROUTINES
50560000
50640000
OFF BOUNDARY FLOATING TO FLOATING CONVERT
50720000
R2 HAS 0-ORIGIN ELEMENT INDEX
50800000
SLA 2,3
MAKE IT A DOUBLEWORD INDEX
50880000
EX
0,ADBASE(9)
50960000
AR
2,MR
ABSOLUTE ADDRESS OF DATA
51040000
LM
2,3,0(2)
51120000
STM 2,3,DTEMP1
PUT IT ON BOUNDARY
51200000
EX
0,LOADF(9)
PUT IN PROPER REGISTER
51280000
BR
LKR
RETURN
51360000
51440000
LD
0,DTEMP1
51520000
LD
2,DTEMP1
51600000
LD
0,DTEMP1
51680000
51760000
A
2,LHORG
51840000
A
2,RHORG
51920000
BCR 0,0
52000000
EJECT
52080000
THE CENTRAL COMMON LOOP
52160000
THIS IS 'THE' LOOP
52240000
S
BX,SBR
52320000
ST
BX,BRT
52400000
L
4,TBR
THE NUMBER OF COLUMNS
52480000
A
BX,SBRM1
52560000
ST
4,R4SAVE
52640000
L
5,SD
52720000
EX
0,CALC1
PERFORM THE INITIAL CALCULATION
52800000
BCT 5,LOOP5
MORE THAN ONE ELEMENT PER RESULT
52880000
QUEND
2549 52960000
B
LOOP7
NO
53040000
S
BX,TBR1
MOVE TO NEXT COL OF B
53120000

QUEND
EX
0,CALC2
*
LOOP5A
LOOP6
LOOP7
*
*

BCT
S
L
EX
S
ST
L
L
BCT
S
ST
L
C
BNL
B
EJECT

*
*
*
*
FILL

FILL3

TO WHOM IT MAY CONCERN

FORM NEXT PARTIAL RESULT
INNER PRODUCT DOES ITS OWN BCT
GO BACK IF STILL MORE ELEMENTS

5,LOOP5
BX,TBR1
9,ZPT
RECALL ZXR USED FOR LINKAGE NOT Z INDEX
EXCELLENT JOB SECURITY
0,SRESULT
STORE THE ANSWER
9,LZ
POSITION FOR NEXT RESULT
9,ZPT
AX,APT1
SET A TO SAME ROW
4,R4SAVE
4,LOOP3
TAKE ROW OF A AGAINST NEXT COL OF B
AX,AINC
MOVE TO NEXT ROW OF A
AX,APT1
BX,BRT
START OVER ON B WITH NEW ROW OF A
9,LASTZ
ALL DONE ?
LOOP
CONTINUE IF NOT
DOEND
FILL AN M ENTRY WITH A CONSTANT
R1 OR F0 = CONSTANT ( DEPENDS ON RTYPE)
R2 = # OF ELEMENTS ( 0 IS OK)
ZXR = M-REL ADDRESS OF DATA
4,2
DOEND
NOTHING TO MOVE
LKR,SETSTORE
3,LZ
LENGTH OF ONE ITEM
3,=F'1'
CAN I STORE RESULT DIRECTLY
FILL3
YES
ZXR,ZXR
NO GET ELEMENT INDEX
9,ZXR
0,SRESULT
ZXR,3

LTR
BNP
BAL
L
C
BNE
SR
LR
EX
AR
QUEND
BCT 4,FILL3
B
DOEND

*
*
FSTOREF LR
SLL
STD
AR
A
MVC
BR
CSTORE LR
A
SRL
STC
BR
*
*
*
*
BSTORE STM
LR
SRDL
A

10,9
10,3
0,TPROD2
10,MR
10,RESORG
0(8,10),TPROD2
LKR
10,9
10,RESORG
1,24
1,0(10,MR)
LKR

STORE ON BOUNDARY
MOVE TO OFF BOUNDARY
R10 IS OFFSET TO RESULT
STORE SINGLE-CHARACTER ARG
AS RESULT.

3037
3037
3037
3037
3037

THE FOLLOWING CODE IS TAKEN FROM THE ORIGINAL

ONLY THE NAMES HAVE BEEN CHANGED TO PROTECT THE CODER
2,3,RSAVE1
2,9
ELEMENT INDEX
2,3
R2 = BYTE INDEX (DATA REL)
2,RESORG
BYTE INDEX (M-REL)

53200000
53280000
53360000
53440000
53520000
53600000
53680000
53760000
53840000
53920000
54000000
54080000
54160000
54240000
54320000
54400000
54480000
54560000
54640000
54720000
54800000
54880000
54960000
55040000
55120000
55200000
55280000
55360000
55440000
55520000
55600000
55680000
55760000
55840000
55920000
56000000
56080000
56160000
56240000
56320000
56400000
56480000
56560000
56640000
56720000
56800000
56880000
56960000
57040000
57120000
57200000
57280000
57360000
57440000
57520000
57600000
57680000
57760000
57840000
57920000

LA
SRL
LTR
BNL
IC
EX
LM
BR
BSTORE0 IC
EX
LM
BR
ONES
DC
ZEROS
DC
NI
NI
OI
OI
SPACE
BRZXR
BR
NOP
BCR
EJECT
*
*
*
CONFORM ST
L
L
MVC
SR
LA
MVC
MVC
ST
LR
LR
LH
LH
LTR
BZ
AR
L
SR
C1
LTR
BZ
L
C3
C
BE
ST
ST
CR
BE
CR
BE
ST
CR
BE
B
*
*
C7
ST
L

2,M(2)
3,29
1,1
BSTORE0
3,ONES(3)
3,OI
2,3,RSAVE1
LKR
3,ZEROS(3)
3,NI
2,3,RSAVE1
LKR
X'8040201008040201'
X'7FBFDFEFF7FBFDFE'
0(2),0
0(2),0
6
ZXR
0,0

BYTE INDEX (ABSOLUTE)

BIT INDEX
STORE A ONE
RETURN
STORE A ZERO
DO IT
RETURN

ASSUMES AX,BX HAVE M-REL POINTERS

ASSUMES RTYPE OF OPERATOR IS KNOWN
ALL RESULTS ARE ELEMENT INDEXES
LKR,LINKS
AX,LHBASE
BX,RHBASE
POSTBLOW,=A(BLOWRTN) BLOWUP RECOVERY
ZXR,ZXR
9,1
NEEDED OFTEN
LCFTYPE,LCTYPE
RCFTYPE,RCTYPE
9,SD
SUPPRESSED DIMENSION
2,9
ASSUME A SCALAR
3,9
ASSUME B SCALAR
0,MRANK(AX)
RANK OF A
1,MRANK(BX)
RANK OF B
0,0
IS A SCALAR
C1
YES
AX,0
2,MRHO-4(AX)
GET RHOA(RHORHOA)
AX,0
1,1
IS B SCALAR
C3
YES
3,MRHO(BX)
GET RHOB(1)
ZXR,OUT
IS THIS AN OUTER PRODUCT
C7
YES
2,AINC
NO,CHECK CONFORMABILITY
3,SD
SD=RHOB(1)
2,3
RHOA(RHORHOA) = RHOB(1) ?
C21
YES,STANDARD CONFORMABILITY
2,9
RHOA(RHORHOA) = 1 ?
C21
YES,EXTENDED CONFORMABILITY
2,SD
SD=RHOA(RHORHOA)
3,9
RHOB(1) = 1 ?
C21
YES, EXTENDED CONFORMABILITY
CONERR
ARGS DO NOT CONFORM
CALC ALL SORTS OF USEFUL NUMBERS
HERE FOR OUTER PRODUCT AND REPRESENT
9,AINC
5,=F'-4'

58000000
58080000
58160000
58240000
58320000
58400000
58480000
58560000
58640000
58720000
58800000
58880000
58960000
59040000
59120000
59200000
59280000
59360000
59440000
59520000
59600000
59680000
59760000
59840000
59920000
60000000
60080000
60160000
60240000
60320000
60400000
60480000
60560000
60640000
60720000
60800000
60880000
60960000
61040000
61120000
61200000
61280000
61360000
61440000
61520000
61600000
61680000
61760000
61840000
61920000
62000000
62080000
62160000
62240000
62320000
62400000
62480000
62560000
62640000
62720000

C9

C21

C21A
*
*
*
C21B
C22
C25

C26

*
C28

C29

C30

STM
LA
LR
LR
AR
BXLE
M
BXH
ST
M
ST
L
M
B
C
BNE
SR
IC
BAL
C
BNE
MVC

0,1,DTEMP
SAVE RANKS
62800000
ZXR,MRHO+4(AX)
GET PROD OF RT DIMENSIONS OF A
62880000
3,9
PRIME THE PRODUCT
62960000
4,0
63040000
4,5
63120000
4,5,C9
REDUCE RANK BY ONE
63200000
2,M-M(4,ZXR)
63280000
4,5,*-4
63360000
3,TAR
63440000
2,RHXRHO
63520000
3,TRZ
63600000
1,LHXRHO
DETERMINE NUMBER OF
63680000
0,RHXRHO
ELEMENTS IN THE RESULT
63760000
C41
63840000
ZXR,SD
ZERO DIMENSION ?
63920000
C21A
NO, OK
64000000
5,5
64080000
5,OPERATOR+2
64160000
LKR,GETID
GET IDENTITY ELEMENT AND ALTER R 64240000
9,SD
DIMENSION = 1
64320000
C21B
64400000
RTYPE+3(1),RSTYPE+3 OK FOR BASE
64480000
RESULT TYPE = ARG TYPE, RESULT IS B
64560000
SUBTRACT ONE FROM RANK OF A & B IF NOT SCALAR
64640000
SO RESULT RANK WORKS OUT
64720000
LTR 0,0
CHECK A
64800000
BZ
C22
NOT SCALAR
64880000
S
0,OUT
ISN'T THIS PLANNING AHEAD
64960000
LTR 1,1
CHECK B
65040000
BZ
C25
65120000
S
1,OUT
65200000
ST
9,TAR
65280000
ST
3,SBR
SBR USED AS A TEMP ONLY
65360000
CR
9,2
1=RHOA(RHORHOA)
65440000
BNE C26
65520000
ST
ZXR,TAR
65600000
STM 0,1,DTEMP
SAVE RANKS
65680000
L
5,=F'-4'
65760000
LA
ZXR,MRHO+4(BX)
GET PROD OF RT DIM OF B
65840000
LR
3,9
PRIME THE PRODUCT
65920000
BXLE 1,5,C28
REDUCE RANK BY ONE
66000000
REMEMBER RANKS ALREADY REDUCED BY ONE
66080000
M
2,M-M(1,ZXR)
66160000
BXH 1,5,*-4
66240000
ST
3,TBR
66320000
ST
3,TBR1
66400000
C
9,SBR
1 = RHOB(1) ?
66480000
BNE C29
NO
66560000
XC
TBR1(4),TBR1
66640000
LR
1,3
STORAGE FROM B
66720000
LA
ZXR,MRHO(AX)
GET PROD OF LEFT DIM OF A
66800000
LR
3,9
PRIME THE PRODUCT
66880000
LR
4,0
66960000
BXLE 4,5,C30
REDUCE RANK BY ONE
67040000
M
2,M-M(4,ZXR)
67120000
BXH 4,5,*-4
67200000
MR
0,3
NUM OF ELEMENTS IN RESULT
67280000
L
5,SBR
67360000
M
4,TBR1
67440000
ST
5,SBR
67520000

C41

ST
LTR
BNZ
L
A
C
BH
L
LR
L
LR
L
BALR
STH
STC
ST
LA

*
L
L
*

C47

LA
LH
S
BAL
LR
LA
SR
CLI
BNE
LH
BAL
LR

C53
C55
*
*
*
*
*
*
*

SR
SR
SR
ST
ST
ST
SR
L
LTR
BNP
C
BNE
L
LD
L
BR
BAL
L
B

1,RXRHO
0,0
IN CASE OVERFLOW IN NUMBER
WSFULL
OF ELEMENTS
ZXR,DTEMP
ZXR,DTEMP+4
=4 * RANK OF RESULT
ZXR,=F'256'
RANKERR
1,RXRHO
2,ZXR
3,RTYPE
5,3
SAVE TYPE FOR LATER
10,=A(OPSPACE)
LKR,10
ZXR,MRANK(1)
STUFF RANK
5,MTYPE(1)
AND TYPE
1,RBASE
ZXR,MRHO(1)
AT RHOZ (ABSOLUTE)
IN CASE OF A GARBAGE COLLECTION
AX,LHBASE
BX,RHBASE
MOVE IN RESULT DIMENSION
5,MRANK(AX)
AT RANK A (ABSOLUTE)
4,M-M(5)
GET RANK OF A
4,OUT
=# OF BYTES TO MOVE
LKR,MOVED
AX,5
AX POINTS TO DATA (ABSOLUTE)
5,MRANK(BX)
AT RANK B (ABSOLUTE)
4,4
ASSUME INNER PRODUCT
OUT+3,0
IS IT OUTER
C47
NO
4,M-M(5)
GET RANK B
LKR,MOVED
BX,5
BX POINTS TO DATA (ABSOLUTE)
MAKE ALL POINTERS TO DATA M-REL
AX,MR
BX,MR
ZXR,MR
AX,LHORG
BX,RHORG
ZXR,RESORG
0,0
2,RXRHO
2,2
IF NO ELE IN RESULT WERE ALL DONE
C53
FILL WILL GET OUT EARLY
0,SD
IF SD=0,THIS IS INNER PROD,FILL
C55
WITH IDENTITY ELEMENT
1,TPROD
FIXED IDENTITY ELEMENT
0,TPROD2
FLOATING IDENTITY ELEMENT
LKR,LINKS
LKR
RETURN - ALL DONE
LKR,GETLINK
LKR,LINKS
4(LKR)
NORMAL RETURN
GET IDENTITY ELEMENT OF NOP1
DISTROYS F0
PUTS ELEMENTS IN TPROD(FIXED),TPROD2(FLOAT)
USES RSAVE AS A SAVE AREA
ALTERS RTYPE TO BE TYPE OF IDENTITY ELEMENT

67600000
67680000
67760000
67840000
67920000
68000000
68080000
68160000
68240000
68320000
68400000
68480000
68560000
68640000
68720000
68800000
68880000
68960000
69040000
69120000
69200000
69280000
69360000
69440000
69520000
69600000
69680000
69760000
69840000
69920000
70000000
70080000
70160000
70240000
70320000
70400000
70480000
70560000
70640000
70720000
70800000
70880000
70960000
71040000
71120000
71200000
71280000
71360000
71440000
71520000
71600000
71680000
71760000
71840000
71920000
72000000
72080000
72160000
72240000
72320000

GETID

GETID3

CLI
BE
ST
ST
BR
ST
LR
SLA
A
L
LTR
BZ
ST
EX
ST
STD
L
LA
BR

*
*
*
GETLINK SR
LM
C
BNE
LA
N
BNZ
LA
GETL3
IC
ST
SLL
L
ST
GETL5
C
BNE
LA
N
BNZ
LA
GETL13 IC
ST
SLL
L
ST
BR
*
*
*
*
DC
ALIST
BAL
L
BAL
BAL
BAL
BAL
BAL
BAL

RPTEST+3,0
GETID3
ZXR,TPROD
9,RTYPE
LKR
0,RSAVE1
9,5
9,2
9,=A(IDENTS-4)
0,4(9)
0,0
RANGERR1
0,RTYPE
0,0(9)
0,TPROD
0,TPROD2
0,RSAVE1
9,1
LKR

IS THIS INNER OR BASE.

72400000
ITS INNER,GET IDENTITY OF THE OPERA 72480000
ITS BASE, IDENTITY = 0
72560000
TYPE IS BOOLEAN
72640000
72720000
72800000
72880000
INSTRUCTION FOR
72960000
IDENTITY ELEMENT
73040000
GET TYPE OF IDENTITY
73120000
IF ZERO,NO IDENTITY
73200000
73280000
73360000
LOAD THE ELEMENT
73440000
FIXED
73520000
FLOATING
73600000
73680000
73760000
73840000
73920000
74000000
AX,BX =M-REL ADDRESSES OF DATA (NOT BASE ADDRESS)
74080000
4,4
74160000
2,3,LCTYPE
GET CONVERT TYPE OF ARGS
74240000
2,=F'3'
IS IT FLOATING TO FLOATING ?
74320000
GETL3
NO
74400000
9,M(AX)
ABSOLUTE POINTER TO DATA
74480000
9,=F'7'
IS IT ON BOUNDARY
74560000
GETL3
NO, WEEFETCH IT
74640000
2,14
A SPECIAL LOAD TYPE FOR ON BOUND
74720000
4,LLIST-1(2)
GET LENGTH OF A
74800000
4,LA
74880000
2,2
GET INDEX TO BRANCH LIST
74960000
9,ALIST-4(2)
75040000
9,AGET
75120000
3,=F'3'
FLOATING TO FLOATING
75200000
GETL13
NO
75280000
9,M(BX)
ABSOLUTE POINTER TO DATA
75360000
9,=F'7'
IS IT ON BOUNDARY
75440000
GETL13
NO,WE FETCH IT
75520000
3,14
A SPECIAL LOAD TYPE FOR ON BOUND
75600000
4,LLIST-1(3)
GET LENGTH OF B
75680000
4,LB
75760000
3,2
GET INDEX TO BRANCH LIST
75840000
9,BLIST-4(3)
75920000
9,BGET
76000000
LKR
76080000
76160000
76240000
76320000
BRANCH LIST FOR A (LEFT) ARG
76400000
0F'0'
76480000
LKR,AFETCH
B-B
76560000
1,M(AX)
I-I
76640000
LKR,AFTOF
F-F OFF BOUNDARY
76720000
LKR,AFETCH
C-C
76800000
LKR,AFETCH
B-I
76880000
LKR,AFETCH
B-F
76960000
LKR,AFETCH
I-B
77040000
LKR,AFETCH
I-F
77120000

*
*
*
*
BLIST

*
*
*
LLIST

BAL
BAL
BAL
BAL
LA
LD

LKR,AFETCH
LKR,AFETCH
LKR,AFETCH
LKR,AFETCH
1,255
0,M(AX)

F-B
F-I
F-B UNFUZZED
F-I UNFUZZED
N-C
F-F ON BOUNDARY

BAL
L
BAL
BAL
BAL
BAL
BAL
BAL
BAL
BAL
BAL
BAL
LA
LD

BRANCH LIST FOR B (RIGHT) ARG

LKR,BFETCH
B-B
2,M(BX)
I-I
LKR,BFTOF
F-F ON BOUNDARY
LKR,BFETCH
C-C
LKR,BFETCH
B-I
LKR,BFETCH
B-F
LKR,BFETCH
I-B
LKR,BFETCH
I-F
LKR,BFETCH
F-B
LKR,BFETCH
F-I
LKR,BFETCH
F-B UNFUZZED
LKR,BFETCH
F-I UNFUZZED
2,255
N-C
2,M(BX)
F-F OFF BOUNDARY

DC
AL1(1,4,1,1,1,1,1,1,1,1,1,1,1,8) ARGUMENT LENGTHS
EJECT
*
GENERAL MOVE DIMENSION ROUTINE
*
R5 = ABSOLUTE PT TO RANK OF SOURCE
*
R4 = 4*ZERO ORIGIN SUPPRESSED DIMENSION
*
ASSUMES ZX IS ABSOLUTE PT TO RHOZ
*
ZX AND R5 POINT TO DATA AT END
MOVED
LH
3,0(5)
GET RANK OF SOURCE
*
CAN ANYTHING BE OVED LEFT OF SD
MOVED5 LTR 4,4
SD
BP
MOVED7
YES
SR
4,4
SCALAR GIVES -4
B
MOVED9
MOVED7 BCTR 4,0
REG4 IS AMOUNT TO BE MOVED
EX
4,MOVE1
GOODY ALL MOVED
LA
4,1(4)
MOVED9 LA
5,MRHO-MRANK(4,5) NOW 5 POINTS AT WORD BOUNT
LA
ZXR,0(4,ZXR)
Z READY FOR MORE
*
FIND OUT HOW MUCH IS LEFT
LA
4,4(4)
SO WE SKIP SUPPRESSED DIM
SR
3,4
BNP MOVED21
NO MORE TO MOVE
BCTR 3,0
GET THE LENGTH CODE
EX
3,MOVE2
LA
ZXR,1(3,ZXR)
DONE AT LAST
LA
5,1(5)
MOVED21 LA
5,4(3,5)
COUNT SKIPPED DIMENSION
*
LEAVE 5 PT AT DATA (ABSOLUTE)
BR
LKR
MOVE1
MVC 0(0,ZXR),MRHO-MRANK(5)
MOVE2
MVC 0(0,ZXR),4(5)
EXECUTED MVC
EJECT
DORED
ST
LKR,LINKS

77200000
77280000
77360000
77440000
77520000
77600000
77680000
77760000
77840000
77920000
78000000
78080000
78160000
78240000
78320000
78400000
78480000
78560000
78640000
78720000
78800000
78880000
78960000
79040000
79120000
79200000
79280000
79360000
79440000
79520000
79600000
79680000
79760000
79840000
79920000
80000000
80080000
80160000
80240000
80320000
80400000
80480000
80560000
80640000
80720000
80800000
80880000
80960000
81040000
81120000
81200000
81280000
81360000
81440000
81520000
81600000
81680000
81760000
81840000
81920000

DOR3

MVC
LH
L
SLL
LA
LTR
BP
LTR
BNZ
ST
LR
ST
LR
B
CR
BL

LR

RCFTYPE,RCTYPE
2,MRANK(BX)
4 * RANK OF B
5,INDEX1
5,2
4* INDEX
9,1
NEEDED OFTEN
5,5
IS INDEX TOO LOW
DOR3
NO
2,2
LET A SCALAR SLIP BY
INDEXER
NOT A SCALAR
9,TBL
ALL DIMENSION PRODUCTS = 1
5,9
5,SD
1,9
DOR10
JUMP BACK IN
2,5
IS INDEX TOO LARGE
INDEXER
GET PRODUCT OF DIMENSIONS TO THE LEFT
1,9
PRIME THE PRODUCT
AX,MRHO-4(BX)
AT RHOB ABSOLUTE
3,4
INCREMENT
4,3
R4 USED AS
4,5
HAVE I REACHED INDEXED DIMENSION
DOR7
YES
4,2
AT END OF DIMENSION VECTOR?
DOR7
YES
0,0(AX,4)
MULTIPLY IN NEXT DIMENSION
0,MR,WSFULL
CHECK FOR OVERFLOW DURING MULT 2537
4,3,DOR5
MOVE TO NEXT DIMENSION
2537
1,TBL
IF CONDITION CODE IS SET = THEN
INDEX IS IN RANGE
1,9
RESET PRODUCT

L
ST
AR
CR
BH
M
BXH
BXH
ST
LR
BCTR
MR
ST
LTR
BNZ
SR
IC
BAL
CR
BNE
IC
STC
STC
STC

5,0(AX,4)
5,SD
4,3
4,2
DOR10
0,0(AX,4)
0,MR,WSFULL
4,3,DOR9
1,TBR
4,5
5,0
0,5
1,SBR
4,4
DOR17
5,5
5,OPERATOR+3
LKR,GETID
4,9
DOR19
ZXR,MTYPE(BX)
ZXR,RTYPE+3
ZXR,RCTYPE+3
ZXR,RCFTYPE+3

SR
BNL

2,3
*+6

DOR5

DOR7
*
*
*
DOR8
DOR9

DOR10

DOR17

*
DOR19

LR
LA
LA
LR
CR
BNL
CR
BH
M
BXH
BXH
ST

82000000
82080000
82160000
82240000
82320000
82400000
82480000
82560000
82640000
82720000
82800000
82880000
82960000
83040000
83120000
83200000
83280000
83360000
83440000
83520000
83600000
83680000
83760000
83840000
83920000
84000000
84080000
84160000
84240000
84320000
84400000
84480000
84560000
GET SUPPRESSED DIMENSION
84640000
84720000
SKIP SUPPRESSED DIMENSION
84800000
ALL DIMENSIONS USED ?
84880000
YES
84960000
MULTIPLY IN NEXT DIMENSION
85040000
CHECK FOR OVERFLOW DURING MULT 2537 85120000
MOVE TO NEXT DIMENSION
2537 85200000
85280000
KEEP IT AROUND FOR LATER
85360000
85440000
GET DISTANCE FROM ONE
85520000
HYPERPLANE TO THE NEXT
85600000
IS SUPPRESSED DIMENSION = 0
85680000
NO
85760000
85840000
85920000
GET IDENTITY OF OPERATOR
86000000
SUPPRESSED DIMENSION = 1 ?
86080000
NO
86160000
SET RESULT TYPE = ARG TYPE
86240000
86320000
SET FETCH CODE TO TYPE OF ARG
86400000
BOTH PLACES
86480000
RESULT WILL BE B WITH ONE LESS RANK 86560000
R2 = RANK, R3 = 4
86640000
86720000

DOR22
WSFULL
SYNTERR
INDEXER
RANKERR
CONERR
RANGERR1
RANGERR
ER1

SR
LR
L
LR
L
LTR
BM
M
LTR
BNZ
ST
L
BALR
STH
STC
ST
LA
L
LA
L
SLL
S
BAL
LR
SR
SR
ST
ST
L
LTR
BNP
LA
L
BAL
L
B
L
BR
SPACE
LA
B
LA
B
LA
B
LA
B
LA
B
LA
EQU
ICALL
DROP

2,2
ZXR,2
3,RTYPE
5,3
1,TBL
1,1
WSFULL
0,TBR
0,0
WSFULL
1,RXRHO
10,=A(OPSPACE)
LKR,10
ZXR,MRANK(1)
5,MTYPE(1)
1,RBASE
ZXR,MRHO(1)
BX,RHBASE
5,MRANK(BX)
4,INDEX1
4,2
4,=F'4'
LKR,MOVED
BX,5
ZXR,MR
BX,MR
BX,RHORG
ZXR,RESORG
2,RXRHO
2,2
DOR22
2,0
3,RCTYPE
LKR,GETL5
LKR,LINKS
4(LKR)
LKR,LINKS
LKR
2
1,EMFULL
ER1
1,ESYNTAX
ER1
1,EINDEX
ER1
1,ERANK
ER1
1,ELENGTH
ER1
1,ERANGE
RANGERR1
ERROR
12

A SCALAR REMAINS A SCALAR

KEEP RANK AROUND
KEEP TYPE AROUND
CHECK FOR POSSIBLE NEGAT PROD
BRANCH IF NEGATIVE
NUMBER OF ELEMENTS IN RESULT

A01
A01

AT RHOZ (ABSOLUTE)
IS CASE OF GARBAGE COLLECTION
AT RANK B ( ABSOLUTE)
MAKE IT ZERO ORIGIN
MOVE IN DIMENSIONS
POINTS TO DATA (ABSOLUTE)
MAKE POINTERS M-REL

NUMBER OF
ARE THERE
NO. THESE
A DOESN'T

ELEMENTS
ANY
ARE EASY TO COMPUTE
EXIST SO FAKE GETLINK

SKIP ANALYSIS OF A
NORMAL RETURN
QUIT EARLY

*
*
USING
*
*
*
SETSTORE BALR

2537
2537

MATRIX+6,12
ASSUME ZX POINTS AT DATA (M-REL)
ASSUMES RTYPE IS KNOWN
USES R2,R3,R9
3,0

A01
A01

86800000
86880000
86960000
87040000
87120000
87200000
87280000
87360000
87440000
87520000
87600000
87680000
87760000
87840000
87920000
88000000
88080000
88160000
88240000
88320000
88400000
88480000
88560000
88640000
88720000
88800000
88880000
88960000
89040000
89120000
89200000
89280000
89360000
89440000
89520000
89600000
89680000
89760000
89840000
89920000
90000000
90080000
90160000
90240000
90320000
90400000
90480000
90560000
90640000
90720000
90800000
90880000
90960000
91040000
91120000
91200000
91280000
91360000
91440000
91520000

SETST3

SETLZ
*
STORE
STORE2
STORE3
STORE4
STORE5
*
*
PATCH

USING
L
SR
C
BNE
LA
N
BZ
LA
IC
ST
SLL
L
ST
BR
DC

*,3
2,RTYPE
GET RESULT TYPE
9,9
2,=F'3'
IS IT FLOATING ?
SETST3
NO
9,M(ZXR)
SEE IF ON BOUNDARY
9,=F'7'
SETST3
IT IS OK
2,5
ITS FLT OFF BOUNDARY
9,SETLZ-1(2)
9,LZ
2,2
2,STORE-4(2)
2,SRESULT
LKR
AL1(1,4,8,1,1)
LINKAGE TO STORE ROUTINES
DS
0F'0'
BAL LKR,BSTORE
STORE BOOLEAN RESULT FORM R1
ST
1,M(9)
STORE INTEGER RESULT FROM R1
STD 0,M(9)
ON BOUNDARY FLT STORE FROM F0
BAL LKR,CSTORE
CHAR STORE
BAL LKR,FSTOREF
OFF BOUND FLT RESULT
DROP 3

DC
LTORG
EJECT
OPSECT DSECT
CALC1
DS
CALC2
DS
SRESULT DS
POSTBLOW DS
INCSTP DS
INCSTS DS
AGET
DS
BGET
DS
*
LINKS
DS
DTEMP1 DS
TPROD
DS
TPROD1 DS
TPROD2 DS
PRESULT DS
RSAVE1 DS
FTSAVE DS
LA
DS
LB
DS
LZ
DS
AOP1
DS
OP1LFC DS
OP1RFC DS
RTYPE
DS
OP1CTP DS
*
TBL
DS
TBR
DS
TBR1
EQU
SBR
EQU

10F'0'

F
EXECUTED ENTRY POINT (INITIAL VALUE
F
EXECUTED ENTRY FOR INNER LOOP
F
EXECUTED ENTRY FOR STORE ROUTINES
F
EXECUTED REENTRY FOR AFTER BLOWUP
F
TO CONVERT RESULT OF PROD TO SCAN AR
F
TO CONVERT RESULT OF SCAN TO SCAN AR
F
EXECUTED TO LOAD AN ELEMENT OF LEFT
F
EXECUTED TO LOAD AN ELEMENT OF RIGHT
THE FOLLOWING ARE TEMP VARS USED EVERYWHERE
F
SAVES LINK REG
D
SETUP AND FETCH
D
D
D
D
RESULT OF OP2
2D
RANKS AND DIMENSIONS AND MISC.
2D
SAVE AREA FOR FETCH ROUTINES
F
BYTE LENGTH OF AN ELEMENT OF A
F
BYTE LENGTH OF AN ELEMENT OF B
F
BYTE LENGTH OF AN ELEMENT OF Z
F
ADDRESS OF EX ROUTINE FOR OP1
F
LEFT FETCH CODE
F
RT FETCH CODE
F
RESULT TYPE
F
COMPUTE TYPE
LOOP VARS
F
PRODUCT OF DIMENSION OF B TO LEFT
3F
PRODUCT OF DIMENSIONS OF B TO RT
TBR+4
INC TO INDEX UP A COL OF B
TBR+8

91600000
91680000
91760000
91840000
91920000
92000000
92080000
92160000
92240000
92320000
92400000
92480000
92560000
92640000
92720000
92800000
92880000
92960000
93040000
93120000
93200000
93280000
93360000
93440000
93520000
93600000
93680000
93760000
93840000
93920000
94000000
94080000
94160000
94240000
94320000
94400000
94480000
94560000
94640000
94720000
94800000
94880000
94960000
95040000
95120000
95200000
95280000
95360000
95440000
95520000
95600000
95680000
95760000
95840000
95920000
96000000
96080000
96160000
96240000
96320000

AINC
TAR
R4SAVE
TRZ
SD
SBRM1
BRT
LASTA
LASTB
LASTZ
ZPT
ZPT1
APT1
PTOSCODE
*
RTOSCODE
*
OUT
RPTEST
OLOOPS
LOOPS
REPIORF
REPGETA
RREG
CALLBASE
CCODE
INDEX1
LEND

DS
EQU
DS
DS
DS
DS
DS
DS
DS
DS
DS
DS
DS
DS

2F
AINC+4
F
F
F
F
F
F
F
F
F
F
F
F

DS

SAVE LOOP REG OVER OPERATOR CALL

SUPPRESSED DIMENSION
DISPLACEMENT TO RTMOST ELE OF B
STOP TEST FOR LOOP
STOP TEST FOR OLOOP

TYPE TO CONVERT RESULT OF OP2

TO ARG TYPE OF OP1
FETCH TYPE TO CONVERT RESULT
OF OP1 TO ARG TYPE OF OP1
=0 OUTER PROD,REP--4=INNER,BASE
NONZERO IF REPRESENT OR BASE
LINK REG AND SAVE AREA
LINK REG AND SAVE AREA
SELECT FIXED OR FLOATING REPRESENT
FETCH A OPERAND OF REPRESENT
RETURN ADDRESS IN OPCTL
BASE REG OF CALLING PROG (OPCTL)

DS
F
DS
F
DS
F
DS
F
DS
F
DS
F
DS
F
DS
F
DS
F
DS
F
ADJUSTED INDEX FOR REDUCE
EQU *
END
./ ADD
NAME=APLSXREF
XREF
TITLE 'A P L S X R E F APL CROSS REFERENCE MAP'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
SPACE 3
*
* THIS MODULE PROVIDES A CROSS-REFERENCE MAP FOR DEBUGGING.
* IT IS REFERENCED BY THE 'MAP' FUNCTION IN WORKSPACE '314159 OPFNS'.
*
SPACE 1
APLSXREF CSECT
DC
A(APLXREFZ-APLXREF) LENGTH OF XREF DATA
C049
APLXREF EQU *
C049
ENTRY APLXREF
C049
DC
CL8'VERSION '
DC
H'1',H'1'
VERSION 1, MOD LEVEL 1
C049
DC
CL8'COIBM '
DC
V(COIBM)
DC
CL8'PUBENTG '
DC
V(PUBENTG)
DC
CL8'CONFIG '
DC
V(CONFIG)
DC
CL8'PERTERMG'
DC
V(PERTERMG)
DC
CL8'SWAPPARS'
DC
V(SWAPPARS)
DC
CL8'APLSDCBS'
DC
V(APLSDCBS)
DC
CL8'LIBPARS '
DC
V(LIBPARS)

96400000
96480000
96560000
96640000
96720000
96800000
96880000
96960000
97040000
97120000
97200000
97280000
97360000
97440000
97520000
97600000
97680000
97760000
97840000
97920000
98000000
98080000
98160000
98240000
98320000
98400000
98480000
98560000
98640000
00400000
00800000
01200000
01600000
02000000
02400000
02800000
03200000
03600000
04000000
05200000
05600000
06000000
06400000
06800000
07200000
08000000
08400000
08800000
09200000
09600000
10000000
10400000
10800000
11200000
11600000
12000000
12400000
12800000
13200000

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC

CL8'CONFINIT'
V(CONFINIT)
CL8'SOFTPARS'
V(SOFTPARS)
CL8'GETSPACE'
V(GETSPACE)
CL8'ARTHTYP '
V(ARTHTYP)
CL8'EXCATEN '
V(EXCATEN)
CL8'BLOWUP '
V(BLOWUP)
CL8'EXIOTA '
V(EXIOTA)
CL8'DISPLAY '
V(DISPLAY)
CL8'EXRANDOM'
V(EXRANDOM)
CL8'EXRHO '
V(EXRHO)
CL8'DIRSEAR '
V(DIRSEAR)
CL8'EXTRAN '
V(EXTRAN)
CL8'EXCEINTF'
V(EXCEINTF)
CL8'EXEPS '
V(EXEPS)
CL8'SEVERAL '
V(SEVERAL)
CL8'FFSS
'
V(FFSS)
CL8'GOUT
'
V(GOUT)
CL8'EXMSORT '
V(EXMSORT)
CL8'INDEX '
V(INDEX)
CL8'EXMMATD '
V(EXMMATD)
CL8'EXMHIST '
V(EXMHIST)
CL8'EXMIOTA '
V(EXMIOTA)
CL8'MSCOPS0 '
V(MSCOPS0)
CL8'EXMTRAN '
V(EXMTRAN)
CL8'OPEXEC '
V(OPEXEC)
CL8'SCNSETUP'
V(EXRAVEL)
CL8'EXRAVEL '
V(SCNSETUP)
CL8'NEXTVECT'
V(NEXTVECT)
CL8'EXDCIRSL'
V(EXDCIRSL)
CL8'EXMREV '
V(EXMREV)

13600000
14000000
14400000
14800000
15200000
15600000
16000000
16400000
16800000
17200000
17600000
18000000
18400000
18800000
19200000
19600000
20000000
20400000
20800000
21200000
21600000
22000000
22400000
22800000
23200000
23600000
24000000
24400000
24800000
25200000
25600000
26000000
26400000
26800000
27200000
27600000
28000000
28400000
28800000
29200000
29600000
30000000
30400000
30800000
31200000
31600000
32000000
32400000
32800000
33200000
33600000
34000000
34400000
34800000
35200000
35600000
36000000
36400000
36800000
37200000

DC
CL8'SCOPS '
DC
V(SCOPS)
DC
CL8'SELECT '
DC
V(SELECT)
DC
CL8'SYNTXX '
DC
V(SYNTXX)
DC
CL8'ARROWS '
DC
V(ARROWS)
DC
CL8'TOBCD '
DC
V(TOBCD)
DC
CL8'TYPEIN '
DC
V(TYPEIN)
DC
CL8'VDOP
'
DC
V(VDOP)
DC
CL8'PCSUB '
DC
V(PCSUB)
DC
CL8'HDIR
'
DC
V(HDIR)
DC
CL8'APLSUP '
DC
V(APLSUP)
DC
CL8'IODCON'
C034
DC
V(IODCON)
C034
DC
CL8'HTAB
'
DC
V(HTAB)
DC
CL8'PERDEVXG'
DC
V(PERDEVXG)
DC
CL8'TRTABS '
DC
V(TRTABS)
DC
CL8'APLOS '
DC
V(APLOS)
DC
CL8'UGHS'
CATASTROPHIC ERROR
DC
V(UGHS)
CATASTROPHIC ERROR
DC
CL8'PATCH'
PATCH AREA
DC
V(PATCH)
PATCH AREA
APLXREFZ DC
X'FF'
C049
END
./ ADD
NAME=APLUBILL
BILL
TITLE 'A P L B I L L I N G
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
ENTRY APLUBILP
EXTRN APLUBILF
EXTRN APLUBILN
EXTRN CCREJ
EXTRN DIRREAD
EXTRN DIRWRT
EXTRN KMANHASH
EXTRN LOC8MAN
EXTRN OUTWRT
EXTRN OUTWRTL
EXTRN WSLOC
EXTRN PCHDCB
EXTRN UTCARDNL
PRINT OFF
COPY APLDEFN
COPY APLDEFN
TITLE 'A P L B I L L I N G
05/11/70'
PRINT ON,NOGEN
DROP 11
USING M,10

37600000
38000000
38400000
38800000
39200000
39600000
40000000
40400000
40800000
41200000
41600000
42000000
42400000
42800000
43200000
43600000
44000000
44400000
44800000
45200000
45600000
46000000
46400000
46800000
47200000
47600000
48000000
48400000
48800000
49200000
49600000
50000000
50400000
50800000
51200000
98400000
00210000
00420000
00630000
00840000
01680000
01890000
02100000
02310000
02520000
02730000
02940000
03150000
03360000
03570000
03780000
04410000
04620000
05880000
06090000
06300000
06510000
06720000
06930000

*
BILL

CSECT
PROLOG
STM 12,14,DOSREGS
L
1,=A(KMANHASH)
L
1,0(1)
ST
1,MANHASH
L
1,=A(WSLOC+4)
LM
2,4,0(1)
LR
3,4
ST
2,BRPXLE

NEXTDIR

NEXTLIB

TST1

NEXTMAN

TLASTMAN

TLASTPSV
FIXLIBAD
TLASTDIR

SRA
AR
ST
LA
LA
ST
LR
SR
D
ST
L
SR
LR
SR
SR
ST
ICALL
L
AR
USING
L
C
BE
C
BNL
L
LTR
BZ
AR
L
B
CLC
BNE
SR
IC
AH
STH
B
BXLE
BXH
MVC
MVC
MVI
L
B
LA
B
L

, PUNCH BILLING INFO

ADDR OF WS1, WS2, AND WSLEN

2214
PUT WSLEN IN REG 3
2214
FIRST HALF OF WS1 IS USED AS A
BUFF FOR READING AHEAD IN BILL 2214
INPUT. SECOND HALF IS USED TO
HOLD TRACK COUNTS OF COMMON LIB WSS
CHARGED TO INDIVIDUAL USERS
FOR PROTECTION FROM BXLE END CONDITN
WE CONSTRUCT A TABLE OF
TRACKS OF WSS IS PUBLIC LIBS
BY MAN NUMBER. WE SEARCH ALL
DIRECTORIES FOR PUBLIC LIBS AND ADD
ITS TRACKS TO OUR TABLE.
START, STOP CRITERION FOR BUFFERRING
INPUT IS BUFFER HALF FULL
LIMIT OF TRACK COUNT TABLE
6-BYTE ENTRIES

3,1
2,3
2,BRPXLE+8
2,88(2)
4,6
2,LIBMAN
5,2
2,2
2,=F'170'
3,HALFFULL
9,4(1)
9,4
8,4
0,0
1,1
1,DIR
DIRREAD
READ A DIRECTORY
7,MANSTAR
7,10
PERLIB,7
1,LIBNUM
1,ENDFLAG
TLASTDIR
END OF LIBS THIS DIRECTORY
1,=F'1000'
FIXLIBAD
NOT A COMMON LIBRARY
2,LIBLINK
2,2
FIXLIBAD
2,10
3,LIBMAN
SCAN TABLE FOR THIS MANNO
TLASTMAN
0(4,3),PSMAN-PERSAVW(2)
TLASTMAN
0,0
0,PSLEN-PERSAVW(2)
0,4(3)
MANNO FOUND, ADD TRKCOUNT
0,4(3)
TLASTPSV
3,4,NEXTMAN
5,8,OVFLTBL
NOT FOUND, MAKE NEW ENTRY
0(4,5),PSMAN-PERSAVW(2)
5(1,5),PSLEN-PERSAVW(2)
4(5),0
2,PSLINK-PERSAVW(2)
TST1
7,MANENTL(7)
NEXTLIB
1,DIR

07140000
07350000
07560000
07770000
07980000
08190000
08400000
08610000
08820000
09030000
09240000
09450000
09660000
09870000
10080000
10290000
10500000
10710000
10920000
11130000
11340000
11550000
11760000
11970000
12180000
12390000
12600000
12810000
13020000
13230000
13440000
13650000
13860000
14070000
14280000
14490000
14700000
14910000
15120000
15330000
15540000
15750000
15960000
16170000
16380000
16590000
16800000
17010000
17220000
17430000
17640000
17850000
18060000
18270000
18480000
18690000
18900000
19110000
19320000
19530000

OVFLTBL
DIR
LIBMAN
TBLCNTR
ENDFLAG
OVFLMSG
DOBILLS

BCI1
*
BIL1
BIL2
TSTEND

BILX
MANHASH
BRPXLE
ENDPARM
*
*
*
*
BREAD

LA
ST
C
BL
L
AR
STM
B
ICALL
DC
B
DS
DS
DS
DC
DC
DC
MVI
MVI
MVI
MVI
MVI
LM
MVI
BXLE

1,1(1)
1,DIR
1,MANHASH
NEXTDIR
3,LIBMAN
3,4
3,5,TBLCNTR
DOBILLS
OUTWRTL
AL4(OVFLMSG)
DOBILLS
F
A
3A
X'FFFFFFFF'
C'TRACK COUNTS FROM
X'FF'
BRCOM,0
BPCOM,0
FBI,0
BRDGO,1
PSWITCH,0
1,3,BRPXLE
0(1),0
1,2,BCI1
THE COMMUTATOR
BAL LKR,BREAD
BAL LKR,BPUNCH
CLI BRCOM,0
BE
BIL1
CLI BPCOM,0
BE
BIL2
CLI FBI,1
BE
BIL2
MVI FBI,1
LA
13,SAVREG1
L
15,=A(APLUBILF)
LTR 15,15
BZ
NOUINST
CALL (15),(BLANK,MONES)

19740000
19950000
20160000
20370000
20580000
20790000
21000000
21210000
TABLE TOO LARGE LOG MESSAGE
21420000
21630000
21840000
22050000
22260000
22470000
22680000
COMMON LIBRARIES ARE INCOMPLETE'
22890000
23100000
INITIALIZE FOR MAIN PART OF PROGRAM 23310000
23520000
23730000
23940000
INITIALIZE EXIT FRON BPUNCH
24150000
MARK ALL AREAS UNOCCUPIED
24360000
24570000
24780000
24990000
READ A CARD OR DON'T
25200000
PUNCH A CARD OR DON'T
25410000
27090000
NOT FINISHED READING
27300000
27510000
NOT FINISHED PUNCHING
27720000
27930000
28140000
28350000
28560000
MAKE SURE INST ROUTINE IS DEFINED
28770000
28980000
29190000
SIGNAL INSTALLATION FORMATTING
29400000
ROUTINE THAT WE ARE DONE.
29610000
LA
1,ENDPARM
ADDRESS OF BLANK CARD
29820000
LA
13,SAVREG1
30030000
L
15,=A(APLUBILP)
30240000
BALR 14,15
30450000
LM
13,14,DOSREGS+4
30660000
L
1,WFLMAN-M(10)
30870000
ICALL DIRWRT
31080000
IRETURN
32130000
DC
F'0'
34020000
DC
A(0,85,0)
34230000
DC
A(BLANK),X'80',AL3(MONES)
34440000
34650000
34860000
35070000
POSSIBLY READ A CARD. SET BRCOM IF END FILE.
35280000
ST
LKR,BRLINK
35490000
CLI BRCOM,0
36750000
BCR 7,LKR
PREVIOUS END FILE
36960000
L
1,BRCCW
37170000

BREAD5
BREAD6

BREAD2
BREAD1

BREAD3

BREAD8

BREAD9
BREAD4
BRCCW
BRDCW
BRCOM
BRDGO
*
*
BPUNCH

N
BZ
BCTR
LR
MVC
LA
LA
CLI
BNE
BXLE
CLC
BE
MVI
MVC
LM
SR
CLI
BNE
LA
LA
CLI
BNE
BXLE
MVI
C
BCR
MVI
A
ST
LR
SR
ICALL
B
L
BR
MVI
B
CCW
CCW
DS
DS
ST
MVC

*
LM
SR
BPUNCH2 CLI
*
BE
LA
MVC
L
ST
LTR
BNZ
*
LA
L

1,=A(X'FFFFFF')
BREAD2
1,0
4,1
BRCCW(8),BRDCW
2,1
3,79(1)
1(1),C' '
BREAD6
1,2,BREAD5
1(4,1),=C'END '
BREAD4
0(4),X'FF'
81(4,4),=F'0'
1,3,BRPXLE
4,4
0(1),0
BREAD3
4,1(4)
5,1(1)
BRDGO,0
BREAD8
1,2,BREAD1
BRDGO,0
4,HALFFULL
4,LKR BL
BRDGO,1
5,BRDCW
5,BRCCW
1,5
0,0
UTCARDNL
BREAD4
LKR,BRLINK
LKR
BRCOM,X'FF'
BREAD9
X'02',0,X'20',80
X'02',0,X'20',80
XL1
XL1

37380000
LAST CARD READ WAS PROCESSED PREVIOU 37590000
'COLUMN 0' IS BUFFER OCCUPANCY CODE 37800000
38010000
CLEAR ADDRESS OF CCW
38220000
39900000
40110000
40320000
40530000
40740000
40950000
41160000
SET BUFFER OCCUPANCY FLAG
41370000
MARK MAN NUMBER UNSCANNED
41580000
LOOK FOR UNOCCUPIED BUFFER AREA
41790000
INIT COUNT OF FREE BUFFERS
42000000
42210000
OCCUPIED
42420000
FOUND. UP COUNT OF FREE BUFFERS
42630000
42840000
IF IN A READING MOOD, CONTINUE
43050000
43260000
43470000
NOT IN READ CYCLE ANYMORE
43680000
UNLESS OVER THE THRESHOLD
43890000
NOT
44100000
READING CYCLE AGAIN
44310000
CCW ADDRESS FIELD AND COMMAND
44520000
44730000
45990000
46200000
46410000
46620000
47040000
47250000
DONE READING
48510000
48720000
49770000
49980000
READ COMPLETE FLAG
50190000
50400000
50610000
MAYBE PUNCH A CARD OR TWO OR READ OR WRITE THE DISK
50820000
LKR,BPLINK
51030000
BPCOM(1),BRCOM
IF EXIT WITHOUT PUNCHING CARDS,
52710000
PUNCHING COMPLETED IFF READING COMPL 52920000
5,7,BRPXLE
53130000
8,8
INIT COUNT OF BUFFERS IN USE
53340000
0(5),0
SEARCH FOR FILLED BUFFER BELONGING 53550000
TO CURRENT DIRECTORY.
53760000
BPUNCH1
53970000
8,1(8)
UP COUNT OF BUFFERS IN USE
54180000
INBUF(84),1(5)
MOVE BUFFER TO INTERFACE AREA
54390000
1,FMANNO
WE MAY HAVE SCANNED THIS CARD BEFORE 54600000
1,MANNO
54810000
1,1
55020000
BPUNCH3
AVOID PRESENTING CARD TO USER CODE 55230000
MORE THAN ONCE
55440000
13,SAVREG1
SAVE AREA
55650000
15,=A(APLUBILN)
MAKE SURE INST ROUTINE IS DEFINED
55860000

BPUNCH3

TST

ALLPSVW
NEXTENT

TESTMAN
CALLF

BPUNCHR
BPUNCH1

LTR
BZ
CALL
LM
MVC
MVC
L
LTR
BZ
BM
MVI
SR
D
ST
C
BNE
MVI
L
ICALL
B
MVC
XC
MVC
MVC
MVC
L
SR
SR
LTR
BZ
AR
IC
AR
L
B
STH
LM
CLC
BNE
LH
AH
STH
B
BXLE
LA
L
LTR
BZ
CALL
LM
L
BR
BXLE
L
CLI
BCR
C
BNL
CLI
BCR

15,15
NOUINST
(15),(INBUF,MANNO) GET MAN NUMBER
13,14,DOSREGS+4
1(80,5),INBUF
MOVE CARD IMAGE BACK TO BUFFER
81(4,5),MANNO
ASSOCIATE SCANNED NO. WITH CARD IMAG
1,MANNO
1,1
BILREJ
ZERO MANNO MEANS INVALID CARD
BILREJ2
NEGATIVE MEANS REJECT QUIETLY
BPCOM,0
0,0
0,MANHASH
0,SAVDIR
0,WFLMAN-M(10)
BPUNCH1
RIGHT DIRECTORY
0(5),0
MARK NONOCCUPANCY
0,MANNO
LOC8MAN
BILNF
CONN(8),CUMCON-PERLIB(1)
CUMCON-PERLIB(8,1),CUMCON-PERLIB(1) RESET TIMES
BILNAME(12),HISNAME-PERLIB(1)
BILWSQ(2),MANWSQ-PERLIB(1)
BILWSA(2),MANWSA-PERLIB(1)
2,LIBLINK-PERLIB(1) SCAN PERSAVW'S TO ACCUMULATE
6,6
TRKCOUNT
4,4
2,2
ALLPSVW
2,10
6,PSLEN-PERSAVW(2)
4,6
2,PSLINK-PERSAVW(2)
TST
4,WSTRACKS
3,5,TBLCNTR
SCAN TABLE OF TRKCOUNTS FROM
MANNO(4),0(3)
COMMON LIBRARYS AND ADD INTO
TESTMAN
TRKCOUNT IF MANNO IS MATCHED
6,WSTRACKS
6,4(3)
6,WSTRACKS
CALLF
3,4,NEXTENT
13,SAVREG1
15,=A(APLUBILF)
MAKE SURE INST ROUTINE IS DEFINED
15,15
NOUINST
(15),(INBUF,BILINFO) DO ACCOUNTING
13,14,DOSREGS+4
LKR,BPLINK
LKR
5,6,BPUNCH2
KEEP LOOKING FOR CARD IN THIS DIR
LKR,BPLINK
NONE
BPCOM,0
7,LKR
REALLY DONE
8,HALFFULL
IF BUFFER IS RELATIVELY EMPTY,
BPCH4
BRCOM,0
DON'T DO DIRECTORY READ UNLESS
8,LKR
BREAD REACHED END OF FILE

56070000
56280000
56490000
56700000
56910000
57120000
57330000
57540000
57750000
57960000
58170000
58380000
58590000
58800000
59010000
59220000
59430000
59640000
59850000
60060000
60270000
60480000
60690000
60900000
61110000
61320000
61530000
61740000
61950000
62160000
62370000
62580000
62790000
63000000
63210000
63420000
63630000
63840000
64050000
64260000
64470000
64680000
64890000
65100000
65310000
65520000
65730000
65940000
66150000
66360000
66570000
66780000
66990000
67200000
67410000
67620000
67830000
68040000
68250000
68460000

BPCH4

L
ICALL
L
ICALL
B

1,WFLMAN-M(10)
DIRWRT
1,SAVDIR
DIRREAD
BPUNCHR

GET SOME OTHER DIRECTORY

*
* APLUBILP.....PUNCHING ROUTINE CALLED BY APLUBILF. INCLUDES ERROR
*
RECOVERY. RETURNS TO THE COMMUTATOR DIRECTLY TO
*
AWAIT COMPLETION OF THE PUNCHING
APLUBILP SAVE (14,12)
CNOP 2,4 ASSEMBLER WILL FLAG US IF WE ARE NOT CAREFUL
BALR 12,0
RESTORE ADDRESSABILITY
ST
13,SAVE13-*(12)
LM
12,14,DOSREGS-(*-4)(12)
L
0,0(1)
STM 13,15,R13SAVE
LA
13,OSSAVE
L
1,=A(PCHDCB)
PUT (1),(0)
LM
13,15,R13SAVE
BAL LKR,BREAD
L
13,SAVE13
RETURN (14,12)
*
ERROR CONDITIONS
BILNF
NOP BILNF1
FIRST TIME ONLY, PRINT WARNING
OI
BILNF+1,X'F0'
ON SYSLOG
ICALL OUTWRTL
DC
AL4(NFMSG)
BILNF1 MVC NUMB(4),MANNO
ICALL OUTWRT
DC
AL4(BILNTX)
B
BPUNCHR
BILREJ NOP BILREJ1
FIRST TIME ONLY, PRINT WARNING
OI
BILREJ+1,X'F0'
ON SYSLOG
ICALL OUTWRTL
DC
AL4(WRNMSG)
BILREJ1 MVC REJCRD(80),1(5)
ICALL OUTWRT
DC
AL4(REJMSG)
BILREJ2 MVI 0(5),0
UNOCCUPY THE BUFFER
B
BPUNCH1
*
NOUINST LM
12,14,DOSREGS
ICALL OUTWRTL
NO INSTALLATION ROUTINE DEFINED
DC
AL4(NOUIMSG)
ICALL CCREJ
BPCOM
DS
XL1
FBI
DS
CL1
PSWITCH DS
XL1
BRLINK DS
F
R13SAVE DS
3F
OSSAVE DS
18F
BPLINK DS
A
BPUNCH LINK
HALFFULL DS
F
NO. OF CARD IMAGES THAT HALF FILL
*
THE READ BUFFER
INBUF
DS
10D
FMANNO DS
F
USER-SCANNED MAN NO.
SAVE13 DS
F
DS
0D
MANNO
DS
F
MAN NUMBER

68670000
68880000
69090000
69300000
69510000
69720000
69930000
70140000
70350000
70560000
70770000
70980000
71190000
71400000
76440000
76650000
76860000
77070000
77280000
77490000
77910000
78120000
78330000
78540000
78750000
78960000
79170000
79380000
79590000
79800000
80010000
80220000
80430000
80640000
80850000
81060000
81270000
81480000
81690000
81900000
82110000
82320000
82530000
82740000
82950000
83160000
83370000
83580000
83790000
84000000
84630000
84840000
85260000
85470000
85680000
85890000
86100000
86310000
86520000
86730000

DS
*
CONN
CPU
BILNAME
BILWSQ
BILWSA
WSTRACKS

0D
ACCOUNTING INFORMATION

DS
F
DS
F
COMPUTE TIME IN SECONDS/300
DS
CL12
SIGN ON NAME
DS
H
WORKSPACE QUOTA
DS
H
ACTUAL NUMBER OF WS
DS
H
TOTAL TRACKS FOR ALL WS
DS
5H
RESERVED FOR BACKING STORE
BILINFO EQU CONN
BILINFOL EQU *-BILINFO
SAVREG1 DS
9D
DOSREGS DS
3F
SAVDIR DS
F
TIMES
DC
D'0'
WORK
DC
D'0'
BILNTX DC
C'USER NOT IN SYSTEM '
DC
X'10'
NUMB
DC
XL4'00'
DC
X'FF'
REJMSG DC
C'REJECTED BILLING INPUT '
REJCRD DS
CL80
DC
X'FF'
WRNMSG DC
C'REJECTED BILLING INPUT APPEARS ON SYSLST'
DC
X'FF'
NFMSG
DC
C'USER NUMBERS NOT IN SYSTEM APPEAR ON SYSLST'
DC
X'FF'
NOUIMSG DC
C'NO INSTALLATION ROUTINE - BILLING TERMINATED',X'FF'
BILBF1 DS
CL80
BILBF2 DS
CL80
DS
0D
BLANK
DC
80C' '
MONES
DC
(BILINFOL)X'FF'
LTORG
COPY DIRSECT
END
./ ADD
NAME=APLUDISK
DISK
TITLE 'APL UTILITY DISK I/O ROUTINES
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
DISKSECT CSECT
PRINT OFF
COPY APLDEFN ZSYMBOLS
EMPTYM EQU X'80'
5989
COPY APLDEFN
TITLE 'INITIALIZE WS POINTERS AND COMPUTE MAX/CFREDSK'
DISKSECT CSECT
COPY ZSYMBOLS
PRINT ON
C037
*
RE-INITIALIZE WS POINTERS AND COMPUTE CFREDSK
*
DIRSET PROLOG
ENTRY DIRSET
L
1,=A(KMANHASH)
L
1,0(1)
ST
1,MANHASH
INITIALIZE THE NUMBER OF DIRECTORIES
L
10,=A(WSLOC)
L
10,0(10)
DROP 11
USING M,10

86940000
87150000
87360000
87570000
87780000
87990000
88200000
88410000
88620000
88830000
89040000
89250000
89460000
89670000
91350000
91560000
91770000
91980000
92190000
92400000
92610000
92820000
93030000
93240000
93450000
93660000
93870000
94080000
94290000
94500000
94710000
94920000
95130000
95340000
95550000
95760000
00070000
00140000
00210000
00280000
00560000
00630000
00700000
00770000
00840000
00910000
00980000
01050000
01120000
01190000
01260000
01330000
01400000
01470000
01540000
01610000
01680000
01750000
01820000

SR
1,1
* CFREDSK FOR EACH EXTENT IS MAX / FREEDSK FOR EACH LIBRARY
DSET2
STH 1,DIRIN
ICALL DIRREAD
LM
0,2,CDCBXLE
USING CDCPARS,2
LA
3,FREEDSK
DIRLP3 CLC CFREDSK,0(3)
BH
DIRLP4
MVC CFREDSK,0(3)
DIRLP4 LA
3,4(3)
BXLE 2,0,DIRLP3
DROP 2
LH
1,DIRIN
LA
1,1(1)
C
1,MANHASH
BL
DSET2
*
CFREDSK IS INITIALIZED
IRETURN
DROP 10
LTORG
TITLE 'LIBRARY DISK USAGE SUMMARY'
*
*
PRINT LAST CYLINDER IN USE, ALL LIBRARY PACKS ON SYSLOG
*
LCYLOG PROLOG
ENTRY LCYLOG
LM
2,4,CDCBXLE
USING CDCPARS,4
SR
5,5
LCY1
LH
6,EXTLOW
LH
7,EXTUP
SR
7,6
LA
7,1(7)
ST
7,LCYDT
MVC DRMC+1(4),LCYDT
LH
7,CFREDSK
SR
7,6
ST
7,DRMSG+1
MVC DRMS3(44),DSLAB
ICALL OUTWRTL
DC
AL4(DRMSG)
LA
5,1(5)
BXLE 4,2,LCY1
*
PRINT +/ SALVHED, ALL DIRECTORIES.
L
9,=A(KMANHASH)
L
9,0(9)
ST
9,LCYHASH
SR
1,1
ST
1,LCYTRKS
LCY2
ICALL DIRREAD
USING M,10
LA
3,SALVHED
LA
4,4
LA
5,FREEDSK-1
USING PERSAVW,2
LCY3
L
2,0(3)
LCY4
LTR 2,2
BZ
LCYBXLE
AR
2,10

01890000
01960000
02030000
02100000
02170000
02240000
02310000
02380000
02450000
02520000
02590000
02660000
02730000
02800000
02870000
02940000
03010000
03080000
03150000
03220000
C059 03290000
03360000
03430000
03500000
03570000
03640000
03710000
03780000
03850000
03920000
03990000
04060000
04130000
04200000
04270000
04340000
04410000
04480000
04550000
04620000
04690000
04760000
04830000
04900000
04970000
05040000
05110000
05180000
05250000
05320000
05390000
05460000
05530000
05600000
05670000
05740000
05810000
05880000
05950000
06020000

SR
1,1
IC
1,PSLEN
A
1,LCYTRKS
ST
1,LCYTRKS
L
2,PSLINK
B
LCY4
LCYBXLE BXLE 3,4,LCY3
L
1,WFLMAN-M(10)
LA
1,1(1)
C
1,LCYHASH
BL
LCY2
MVC TRKS+1(4),LCYTRKS
ICALL OUTWRTL
DC
AL4(TRKS)
IRETURN
LCYDT
DC
D'0'
LCYHASH EQU LCYDT
LCYTRKS EQU LCYDT+4
TRKS
DC
X'1000000000'
DC
C' SALVAGED TRACKS'
DC
X'FF'
DC
0F'0',CL3' '
PUT ON 3RD BYTE OF FULLWORD
DRMSG
DC
X'100000'
DC
X'0000'
DC
C' OF '
DRMC
DC
X'100000'
DC
X'0000'
DC
C' CYLS, '
DRMS3
DC
CL44' ',X'FF'
*
DROP 2,10
DROP 4,12
*
*
LOG DAMAGED WORKSPACE NAMES
*
R0 = TIMESTAMP ADDRESS, OR 0
*
R1 = WSID ADDRESS
*
R2 = ACTION TEXT (9 BYTES)
A04
*
ENTRY DWSLOG
DWSLOG PROLOG
MVI DLTS-6,C' '
ASSUME NO TIMESTAMP
MVC DLTS-5(17),DLTS-6
MVC DLMACT(9),0(2)
MOVE ACTION INTO MSG
A04
LTR 2,0
BZ
DL2
MVC DLTS-6(6),=X'000000000013' MOVE IN TIMESTAMP STARTER
MVC DLTS(12),0(2)
AND TIMESTAMP
DL2
MVC DLID(16),0(1)
MVC DLSNAP(9),0(3)
MOVE SNAPID OR X'FF' TO MSG
NOP DL3
FIRST-TIME SWITCH
OI
*-3,X'F0'
ICALL OUTWRTL
DC
AL4(DLMSG1)
DL3
ICALL OUTWRT
DC
AL4(DLMSG2)
IRETURN
DLMSG1 DC
C'NAMES OF DAMAGED WORKSPACES APPEAR ON SYSLST',X'FF'
DLMSG2 DC
C'WORKSPACE DAMAGED '
A04
DLMACT DC
CL10'XXXXXXXXX '
A04
DC
XL6'00'

06090000
06160000
06230000
06300000
06370000
06440000
06510000
06580000
06650000
06720000
06790000
06860000
06930000
07000000
07070000
07140000
07210000
07280000
07350000
07420000
07490000
07560000
07630000
07700000
07770000
07840000
07910000
07980000
08050000
08120000
08190000
08260000
08330000
08400000
08470000
08540000
08610000
08680000
08750000
08820000
08890000
08960000
09030000
09100000
09170000
09240000
09310000
09380000
09520000
09660000
09730000
09800000
09870000
09940000
10010000
10080000
10150000
10220000
10290000
10360000

DLTS
DLID
DLSNAP
*
*
*
FMTDSK

DC
DC
DC
DC
DC
DC
TITLE

XL12'00'
X'11'
XL16'00'
C' '
CL9'XXXXXXXXX'
SNAPID FOR OS WSDUMP
X'FF'
'FORMAT AND VERIFY DISK ROUTINES'

FORMAT DISK DESIGNATED BY (PARAMS+4)

PROLOG
ENTRY FMTDSK
L
1,=A(PARAMS)
L
1,4(1)
MH
1,CDCBXLE+2
A
1,ADPAR
C
1,CDCBXLE+4
BNL FMTXXX
CHECK FOR PARAMETER OUT OF RANGE
ST
1,FMTPARS+4
LA
1,FMTPARS
ICALL DISKFMT
IRETURN
SPACE
FMTXXX ICALL OUTWRTL
PARAMETER OUT OF RANGE.
DC
AL4(XXXMSG)
ICALL CCREJ
RETURN, REQUEST INPUT FROM SYSLOG
SPACE
FMTPARS DC
F'0'
NONSWAP
DC
A(*-*)
DC
F'0'
DC
A(0,0)
SPACE 2
*
READ WITH SKIP ALL TRACKS IN EXTENT (UP TO CFREDSK)
VERIFY PROLOG
ENTRY VERIFY
L
4,=A(PARAMS)
L
4,4(4)
MH
4,CDCBXLE+2
A
4,ADPAR
3580
C
4,CDCBXLE+4
CHECK FOR PARAMETER IN RANGE
3580
BNL VERXXX
3580
USING CDCPARS,4
MVC VERSK+2(4),EXTLOW
MVC VERCWR+6(2),TLENF+2
MVI VERPSCCW,NOP
RESET TO NO-OP
DASD
TM
CDCFLAGS,RPS
WAS RPS SELECTED
DASD
BZ
VER4
NO
DASD
MVI VERPSCCW,SETSECTR MOVE IN SET SECTOR COMMAND
DASD
VER4
LA
2,10
ERROR RETRY COUNT
LA
3,IOB
USING IOBECB,3
LH
1,LOGAD
LOAD INDEX OF DCB
MH
1,=H'72'
MULTIPLY BY LENGTH
A
1,=A(APLSDCBS)
ADD BASE
ST
1,IOBDCB
STORE IN IOB
MVC IOBFLAG1(2),=X'C200' CC+DC+SYNCHRONOUS WAIT.
MVC IOBSTART(3),=AL3(VERCW) CCW CHAIN START ADDRESS.
MVC IOBERRCT(2),=H'0' ZERO ERROR COUNT.
MVC IOBSKPT(7),VERSK
MOVE SEEK ADDRESS TO IOB
VER1A
XC
EVNTCB(4),EVNTCB
ZERO OUT EVENT CONTROL BLOCK.

10430000
10500000
10570000
10710000
10780000
10920000
10990000
11060000
11130000
11200000
11270000
11340000
11410000
11480000
11550000
11620000
11690000
11760000
11830000
11900000
11970000
12040000
12110000
12180000
12250000
12320000
12390000
12460000
12530000
12600000
12670000
12740000
12810000
12880000
12950000
13020000
13090000
13160000
13230000
13300000
13370000
13440000
13790000
13860000
14000000
14070000
14140000
14210000
14350000
15190000
15260000
15330000
15400000
15470000
15540000
15610000
15680000
15750000
15820000
15890000

DROP 3
EXCP IOB
WAIT ECB=ECB
LA
1,IOB
USING IOBECB,1
CLI ECB,X'7F'
CHECK ENDING STATUS FOR ERRORS.
BNE VER3A
CLC IOBSTAT(2),=X'0C00' CHECK CSW STATUS FOR NORM END
BE
VER2
TRACK OK
VER3A
TM
IOBSENS1,NRF
NO RETRIES UNLESS
3581
BZ
VER3
IT'S NO RECORD FOUND
3581
NRF
EQU X'08'
NO RECORD FOUND
3581
DROP 1
BCT 2,VER1A
RETRY 10 TIMES
3581
VER3
MVC VERMCH,VERSK+2
MVC VERMSU(44),DSLAB
ICALL OUTWRTL
DC
AL4(VERMSG)
VER2
LA
1,1
A
1,VERSK+2
ST
1,VERSK+2
CLC VERSK+4(2),HMAX
BL
VER5
A
1,CCADJ
ST
1,VERSK+2
VER5
CL
1,EXTUP
BL
VER4
IRETURN
SPACE
VERXXX ICALL OUTWRTL
PARAMETER OUT OF RANGE
DC
AL4(XXXMSG)
ICALL CCREJ
RETURN, REQUEST INPUT FROM SYSLOG
SPACE
XXXMSG DC
C'LIBRARY EXTENT PARAMETER OUT OF RANGE'
DC
X'FF'
SPACE
VERCW
CCW X'07',VERSK,X'40',6
VERPSCCW CCW SETSECTR,ZERO,CC,1 WILL BE A NO-OP IF RPS NOT USED DASD
CCW X'31',VERSK+2,X'40',5
CCW X'08',*-8,0,0
VERCWR CCW X'06',*,X'10',0
CNOP 2,4
VERSK
DC
XL7'00000000000001'
VERMSG DC
C'BAD TRACK '
DC
X'04'
VERMCH DC
XL4'00'
DC
C', '
VERMSU DC
CL44' ',X'FF'
DROP 4
TITLE 'START A SEEK OPERATION (USED BY INCDUMP) '
*
*
SEEK TO CCHH IN R1 ON FILE NUMBER R2/CDCL
DASD
ENTRY DSEEK
DSEEK
PROLOG
STM 1,2,DSSKT
WAIT ECB=ECB
MVC DSSKAD+2(4),DSSKT
DASD
A
2,ADPAR
R2 WAS OFFSET INTO DISKPARS TABLE
USING CDCPARS,2
LA
3,IOB
VER1

15960000
16030000
16100000
16170000
16240000
16310000
16380000
16450000
16520000
16590000
16660000
16730000
16800000
16870000
17010000
17080000
17150000
17220000
17290000
17360000
17430000
17500000
17570000
17640000
17710000
17780000
17850000
17920000
17990000
18060000
18130000
18200000
18270000
18340000
18410000
18480000
18830000
18970000
19110000
19180000
19250000
19320000
19390000
19460000
19530000
19600000
19670000
19740000
19810000
19880000
19950000
20020000
20090000
20160000
20230000
20650000
20790000
20860000
21350000
21420000

USING IOBECB,3
LH
1,LOGAD
PUT DCB ADDR IN IOB
MH
1,=H'72'
MULTIPLY BY LENGTH
A
1,=A(APLSDCBS)
ADD BASE
ST
1,IOBDCB
MVC IOBFLAG1(2),=X'C200' CC+DC+SYNCHRONOUS WAIT
MVC IOBSTART(3),=AL3(DSSKCW) CCW CHAIN START ADDR
MVC IOBERRCT(2),=H'0'
ZERO ERROR COUNT
MVC IOBSKPT(6),DSSKAD MOVE SEEK ADDR TO IOB
XC
EVNTCB(4),EVNTCB
ZERO OUT ECB
DROP 3,2
EXCP IOB
LM
1,2,DSSKT
IRETURN
*
DSSKT
DSSKCW
DSSKAD
*
*
*
*
*
*
*
DRD

DC
CCW
DC
TITLE

2F'0'
TEMP STORAGE
X'07',DSSKAD,X'20',6
XL6'00'
'DISK READ ROUTINE'

READ WORKSPACE FROM CYLINDER, HEAD IN R1 TO CORE AREA DESIGNATED BY R11.

R2 IS FILE NUMBER * CDCL

PROLOG
ENTRY DRD
ICALL DRDR1
READ FIRST RECORD,
ICALL DRDREST
THEN WITH CDCOMP'S HELP, READ REST.
IRETURN
SPACE 2
ENTRY DRDR1
DRDR1
PROLOG
STM 1,6,DWRT
L
1,=A(WSLEN)
WORKSPACE LENGTH.
L
1,0(1)
ST
1,WLEN
A
2,ADPAR
ST
2,CDCBASE
ICALL DRDZ
LA 15,WLEN
ADDRESSIBILITY
5989
USING WLEN,15
5989
MVC PHYCYL,DWRT
SET UP PARAMETERS FOR CDCOMP
DASD
L
3,RD1ST
MVC 2(4,3),PHYCYL
DASD
DROP 15
5989
ST
11,DWRT
AND FOR RECORD 1 CCW CHAIN
MVC CDCAD+1(3),DWRT+1
LA
3,IOB
USING IOBECB,3
L
1,CDCBASE
MVI RPSCCW,NOP
RESET TO NO-OP
DASD
TM
CDCFLAGS-CDCPARS(1),RPS SHOULD RPS BE USED
DASD
BZ
DRNORPS
NO
DASD
MVI RPSCCW,SETSECTR
MOVE IN SET SECTOR COMMAND
DASD
DRNORPS EQU *
DASD
LH
1,LOGAD-CDCPARS(1)
MH
1,=H'72'
A
1,=A(APLSDCBS)

21490000
21560000
21630000
21700000
21770000
21840000
21910000
21980000
22050000
22120000
22190000
22260000
22400000
22470000
22540000
22610000
22960000
23030000
23100000
23170000
23240000
23310000
23380000
23450000
23520000
23590000
23660000
23730000
23800000
23870000
23940000
24010000
24080000
24150000
24220000
24290000
24360000
24430000
24500000
24570000
24920000
24990000
25060000
25130000
25690000
25760000
25830000
25900000
25970000
26460000
26530000
26600000
26670000
26740000
26810000
26880000
26950000
27020000
27090000
27160000

ST
1,IOBDCB
MVC IOBFLAG1(2),=X'C200'
MVC IOBSTART(3),=AL3(RD1ST)
MVC IOBERRCT(2),=H'0'
L
1,RD1ST
MVC IOBSKPT(7),0(1)
XC
EVNTCB(4),EVNTCB
EXCP IOB
WAIT ECB=ECB
DROP 3
MVI REJECT-M(11),0
BUFFER NOW TRULY OCCUPIED
ICALL DRDZ
LM
2,6,DWRT+4
IRETURN
SPACE 2
ENTRY DRDREST
DRDREST PROLOG
STM 2,6,DWRT+4
MUST BE CALLED AFTER DRDR1, EXCEPT
*
FOR INCDUMP WHICH MAY READ REC 1 AND
*
IGNORE IT.
MVI DOP+1,X'06'
TELL CDCOMP TO READ
LA
15,WLEN
USING WLEN,15
5989
BAL 6,CDCOMP
5989
CLI REJECT-M(11),0
IF REJECTED BY CDCOMP, DON'T ATTEMPT
BNZ DRD2
TO READ.
MVI DRDZFG,0
SET FIRST-TIME SWITCH FOR END OF REA
CLI ONETRK,0
IF WORKSPACE FITS ON ONE TRACK,
BE
DRD2
SKIP FURTHER DISK READING.
L
1,CDCBASE DISK POINTER TO DESIRED FILE
LA
3,IOB
USING IOBECB,3
LH
1,LOGAD-CDCPARS(1) LOAD INDEX OF DCB
MH
1,=H'72' MULTIPLY BY LENGTH OF DCB
A
1,=A(APLSDCBS) ADD BASE OF DCBS
ST
1,IOBDCB STORE IN OIB DCB ADDRESS
MVC IOBFLAG1(2),=X'C200'
MVC IOBSTART(3),=AL3(CCWAR+32)
MVC IOBERRCT(2),=H'0' ZERO ERROR COUNT
L
1,CCWAD
DROP 15
5989
L
1,32(1)
1ST HALF OF SECOND SEEK IN CHAIN
MVC IOBSKPT(7),0(1)
MV SEEK ADR TO IOB
XC
EVNTCB(4),EVNTCB
ZERO OUT EVENT CNTRL BLK
DROP 3
EXCP IOB
DRD2
LM
2,6,DWRT+4
IRETURN
*
*
DRDZ
PROLOG EDRS,EDRSZ
ENTRY DRDZ
STM 0,8,EDRS
SAVE CALLER'S REGISTERS
CLI ONETRK,0
WAS THIS A ONETRAK WS?
5989
BE
ENDDR1
YES, ALL DONE
5989
WAIT ECB=ECB
DRDZC
CLI ECB,X'7F'
BNE ENDDR2
CLC IOBSTAT-IOBECB+IOB(2),=X'0C00'
BE
ENDDR1
ALL DONE
5989

27230000
27300000
27370000
27440000
27510000
27580000
27650000
27720000
27790000
27860000
28000000
28070000
28140000
28210000
28280000
28350000
28420000
28490000
28560000
28630000
28700000
28770000
28840000
28910000
28980000
29050000
29120000
29190000
29260000
29750000
29820000
29890000
29960000
30030000
30100000
30170000
30240000
30310000
30380000
30450000
30520000
30590000
30660000
30730000
30800000
30870000
31010000
31080000
31150000
31220000
31290000
31360000
31430000
31500000
31570000
32480000
32550000
32620000
32690000
32760000

ENDDR2

ENDDR1

VW5

MVC
L
MVC
L
MVC
ICALL
DC
MVI
B
SPACE
TS
BNZ
LA
BAL
L
USING

DRDMST(2),IOBSTAT-IOBECB+IOB
1,CDCBXLE+8
DRDMLU(44),DSLAB-CDCPARS(1)
1,CDCAD
AND WSNAME
DRDMWF(16),WFLLIB-M(1)
OUTWRTL
AL4(DRDMSG)
REJECT-M(1),3
DISMISS THIS WS
C059
ENDDR3
BYPASS VALIDITY CHECKING
3
5989
DRDZFG
WORKSPACE VALIDITY CHECK.
ENDDR3
CHECK ONLY AFTER DRDREST CALL
15,WLEN
ADDRESSIBILITY
5989
8,RELOC
DO ANY NECESSARY INCORE MOVES
5989
8,CCPAR1
M,8
BYPASS ANY WORKSPACE WITH BAD
POINTERS, SYMBOL TABLE, OR M-ENTRIES
CLI WFLNAME,C'A'
IGNORE DIRECTORIES
BE
ENDDR3
L
1,=A(WSLEN)
CLC 0(4,1),QR13STK
QR13STK IS FAIRLY IMPORTANT PTR
BNH VWFAIL
CLC QSYMBOT(4),PARREL
BNH VWFAIL
CLC PARREL(4),MX
BNH VWFAIL
TM
QR13STK+3,3
BNZ VWFAIL
TM
QSYMBOT+3,3
BNZ VWFAIL
TM
PARREL+3,3
BNZ VWFAIL
TM
MX+3,3
BNZ VWFAIL
LM
1,2,QR13STK ,QSYMBOT
CLR 1,2
BOTTOM LOWER THAN TOP OF S.T.
BNH VWFAIL
LA
0,8
AR
1,8
ABS S.T. POINTERS
AR
2,8
BCTR 1,0
OC
0(8,2),0(2)
NO ENTRY
BZ
VW1A
TM
0(2),X'80'
KEYWORD
BO
VW2
NO BETS
L
3,0(2)
C
3,VWUNV
UNDEFINED VARIABLE
BE
VW2
TM
3(2),3
BNZ VWFAIL
LA
3,0(3)
CL
3,MX
POINTS BELOW MX
BNL VWFAIL
CL
3,=A(FREE-M)
BL
VWFAIL
AR
3,8
TM
0(3),X'80'
NOT GARBAGE
BO
VWFAIL
L
4,0(3)
LA
4,M(4)
POINTERS REFLECT

32830000
32970000
33040000
33110000
33180000
33250000
33320000
33390000
33460000
33530000
33600000
33670000
33740000
33810000
33880000
33950000
34020000
34090000
34160000
34230000
34300000
34370000
34440000
34510000
34580000
34650000
34720000
34790000
34860000
34930000
35000000
35070000
35140000
35210000
35280000
35350000
35420000
35490000
35560000
35630000
35700000
35770000
35840000
35910000
35980000
36050000
36120000
36190000
36260000
36330000
36400000
36470000
36540000
36610000
36680000
36750000
36820000
36890000
36960000
37030000

VW3
VW2

VW1

VW1A

VW10

CR
BNE
CLI
BNL
CLI
BL
TM
BZ
B
TM
BO
L
LTR
BZ
LA
CLI
BNH
TM
BNZ
LA
CL
BNL
CL
BL
AR
TM
BO
L
LA
S
CR
BNE
CLC
BNE
CLI
BH
SR
IC
LA
N
C
BNE
LA
SR
IC
LA
LA
CLI
BNL
BAL
BXLE
LA
L
AR
CLR
BL
BE
TM
BO
TM

2,4
VWFAIL
0(2),TERMSYM
VWFAIL
0(2),DFN
VW3
0(3),MLSTBIT
VWFAIL
VW2
0(3),MLSTBIT
VWFAIL
3,4(2)
3,3
VWFAIL
5,4(2)
4(2),3
VW1
7(2),3
VWFAIL
3,0(3)
3,MX
VWFAIL
3,=A(FREE-M)
VWFAIL
3,8
0(3),X'80'
VWFAIL
4,0(3)
4,M(4)
4,=F'4'
2,4
VWFAIL
4(1,2),8(3)
VWFAIL
8(3),77
VWFAIL
4,4
4,8(3)
4,MPNAME-M+4(4)
4,=F'-4'
4,MCOUNT-M(3)
VWFAIL
5,8(3)
6,6
6,0(5)
7,IDZT
5,1(5)
0(5),Z0
VWFAIL
LKR,VWZC
2,0,VW5
2,FREE
1,MX
1,8
1,2
VWFAIL
ENDDR3
0(2),X'80'
VWFAIL
3(2),3

37100000
37170000
VALID SYMBOL CLASS
37240000
37310000
37380000
NOT A LIST
37450000
37520000
37590000
37660000
MUST NOT BE LIST
37730000
37800000
LOOK AT PRINTNAME
37870000
37940000
MUST EXIST
38010000
38080000
38150000
SHORT PNAME
38220000
38290000
NOT MULT OF 4
38360000
38430000
MUST POINT INTO M-ENTRIES
38500000
38570000
38640000
38710000
38780000
NOT GARBAGE
38850000
38920000
38990000
39060000
39130000
POINTERS MUST REFLECT
39200000
39270000
COUNTS SHOULD MATCH
39340000
39410000
39480000
39550000
39620000
39690000
COMPARE CHAR COUNT TO BYTE COUNT
39760000
39830000
39900000
39970000
40040000
CHECK LEGALITY OF PRINTNAME ZSYMBOLS 40110000
40180000
40250000
40320000
FIRST CHARACTER MUST
40390000
BE ALPHABETIC
40460000
40530000
END OF SYMBOL TABLE LOOP
40600000
40670000
LOOK AT M-ENTRIES
40740000
40810000
40880000
40950000
EMPTY WORKSPACE
41020000
GARBAGE IS IMPOSSIBLE
41090000
41160000
41230000

VW15

VW16

MORE

BNZ
TM
BNZ
L
ALR
CLR
BH
L
LA
C
BNL
C
BNL
C
BNL
C
BL
LR
AR
L
LA
CR
BNE
S
BM
EX
BNZ
TM
BO
CLI
BE
CLI
BE
CLI
BNE
LH
LA
N
C
BNE
CLC
BNE
MVI
LA
AH
BCTR
TM
BZ

VWFAIL
MHEAD NOT MULT OF 4
7(2),3
VWFAIL
COUNT NOT MULT OF 4
3,4(2)
3,2
3,1
COUNT LESS THAN MX
VWFAIL
3,0(2)
3,0(3)
3,QR13STK
POINTS TO SYMBOL TABLE,
VWFAIL
3,PARREL
STACK,
VW15
3,MX
OR M-ENTRY
VWFAIL
3,=A(FREE-M)
VWFAIL
5,3
COPY OF REL S.T. POINTER
3,8
4,0(3)
4,M(4)
2,4
POINTERS REFLECT
VWFAIL
5,QSYMBOT
IF NOT A MULT OF 8 FROM SYMBOT,
VW16
AND INSIDE THE SYMBOL TABLE,
5,VWTM
VW6
IT'S A LONG PNAME, ALREADY CHECKED.
0(2),MLSTBIT
CHECK VARB, TEMP VALIDITY
VW11
LIST VALIDITY
0(3),VARB
VW7
0(3),CONST
VW7
TEMP
0(3),CDST
VW6
MYSTERY, MIGHT BE VALID
7,MCSCNT-M(2)
CODESTRING
7,MCSORG-M+3(7)
JUST CHECK SYL COUNT
7,=F'-4'
7,MCOUNT-M(2)
MUST BE LEQ COUNT
VWFAIL
MCSCNT-M(7,2),=AL1(0,5,1+2*ZREM,ZILG,0,1,1+2*ZCCONST) A04
*+8
A04
MCSORG+1-M(2),ZBLANK
REPLACE ZILG WITH BLANK
A04
4,MCSORG-M(2)
R2 PTS TO START OF M ENTRY
4,MCSCNT-M(2)
R4 PTS TO RIGHT END OF CODESTRING,
4,0
AND IS PTR REG ALONG STRING(R TO L)
0(4),X'01'
SHORT OR LONG SYLLABLE?
LSYLL
LONG

*
*
*

VW4

SHORT SYLLABLE
CLI
BL
CLI
BE
CLI
BNE
CLI
BNL
SR

0(4),1+2*ZFILL17
VW4
0(4),1+2*ZTDELTA
OK
0(4),1+2*ZSDELTA
VWFAIL
0(4),1+2*ZLBR
OK
6,6

41300000
41370000
41440000
41510000
41580000
41650000
41720000
41790000
41860000
41930000
42000000
42070000
42140000
42210000
42280000
42350000
42420000
42490000
42560000
42630000
42700000
42770000
42840000
42910000
42980000
43050000
43120000
43190000
43260000
43330000
43400000
43470000
43540000
43610000
43680000
43750000
43820000
43890000
43960000
44030000
44170000
44240000
44310000
44380000
44450000
44520000
44590000
44660000
44730000
44800000
44870000
44940000
45010000
45080000
45150000
45220000
45290000
45360000
45430000
45500000

X
XEOS
BAD
CON

BACK

*
*
*
LSYLL

LSYLL1

OK

VW7

SR
IC
SRA
IC
B
EQU
LA
CR
BNH
B
IC
SH
MVC
LH
SLA
BM
LA
SRA
CH
BH
STH
CLI
BNE
LR
SR
LA
BAL
SH
LA
CR
BNH
B

7,7
7,0(4)
7,1
6,TBL(7)
X(6)
*
7,MCSORG-M(2)
4,7
VW6
VWFAIL
7,STBL-ZBCONST(7)
4,=H'2'
TEMPH(2),0(4)
6,TEMPH
6,0(7)
VWFAIL
6,7(6)
6,3
6,MCSCNT-M(2)
VWFAIL
6,TEMPH
2(4),1+ZCCONST*2
BACK
5,4
5,6
7,GENZT
LKR,VWZC
4,TEMPH
7,MCSORG-M(2)
4,7
VWFAIL
OK

SET UP BRANCH TO PROPER

ROUTINE TO CHECK FOR
CONSTANTS.

WE HAVE EOS...
ARE WE AT THE END OF THE STRING.
R7 HAS SHIFT VALUE FOR CONSTANT
MOVE PTR TO ELEMENT CNT
HALFWD BDRY
COMPUTE BYTE LENGTH OF CONST
NEGATIVE COUNT
*
*
IS IT G.T. CODESTRING LENGTH.
YES, NO GOOD
IS THIS A CHAR CONSTANT
NO
YES, CHECK FOR LEGAL Z-SYMBOLS
PT TO START OF FIELD
*
*
MOVE PTR TO END OF CONSTANT
END OF CON COINCIDES WITH
END OF CODESTRING...INVALID
SINCE NO EOS OR REM
LONG SYLLABLE

BCTR
TM
BO
OC
BNZ
MVC
LH
SLA
A
C
BL
BCTR
LA
CR
BNL
LA
CLI
BE
CLI
BE
CLI
BE
B
LA
TM

4,0
0(4),X'80'
LSYLL1
0(2,4),0(4)
VWFAIL
TEMPH(2),0(4)
6,TEMPH
6,2
6,QR13STK
6,QSYMBOT
VWFAIL
4,0
7,MCSORG-M(2)
4,7
MORE
4,1(4)
0(4),1+2*ZEOS
VW6
0(4),1+2*ZLEOS
VW6
0(4),1+2*ZREM
VW6
VWFAIL
7,1
MRANK-M+1(2),3

PT TO START OF LONG SYLLABLE

NEGATIVE VALUE
YES
NO, IS IT ZERO.
NO, BAD SYLLABLE
HALFWD BDRY
COMPUTE NEGATIVE ST DISP
ADD DISP TO START OF ST
DOES IT PT WITHIN ST?
ADDRESS OF CODESTRING END
ARE WE THRU STRING?
NO
PT TO LAST SYLL IN STRING
CHECK FOR EOS OR LEOS
*

CHECK XRHO AND TYPE VS COUNT

MUST BE MULT OF 4

45570000
45640000
45710000
45780000
45850000
45920000
45990000
46060000
46130000
46200000
46270000
46340000
46410000
46480000
46550000
46620000
46690000
46760000
46830000
46900000
46970000
47040000
47110000
47180000
47250000
47320000
47390000
47460000
47530000
47600000
47670000
47740000
47810000
47880000
47950000
48020000
48090000
48160000
48230000
48300000
48370000
48440000
48510000
48580000
48650000
48720000
48790000
48860000
48930000
49000000
49070000
49140000
49210000
49280000
49350000
49420000
49490000
49560000
49630000
49700000

VW9

VW8

VW11

VW14

BNZ
LH
CL
BH
LA
LTR
BZ
M
LTR
BNZ
S
BP
IC
BCTR
CL
BNL
IC
CL
BH
LR
SLL
AL
SRL
AH
LA
C
BH
CLI
BNE
LA
BAL
B
LH
LH
TM
BNZ
LA
AR
AR
C
BNE
AR
LTR
BZ
CLI
BZ
TM
BNZ
L
LA
TM
BO
C
BNL
C
BL
L
LA
CR
BNE

VWFAIL
3,MRANK-M(2)
3,=F'256'
VWFAIL
5,MRHO-M(2,3)
3,3
VW8
6,MRHO-M-4(2,3)
6,6
VWFAIL
3,=F'4'
VW9
3,MTYPE-M(2)
3,0
3,=F'4'
VWFAIL
3,VWTS(3)
7,=A(X'FFFFFF')
VWFAIL
6,7
7,0(3)
7,=F'31'
7,5
7,MRANK-M(2)
7,MRHO-M(7)
7,MCOUNT-M(2)
VWFAIL
MTYPE-M(2),4
VW6
7,GENZT
LKR,VWZC
VW6
3,MLSOS-M(2)
4,MLSCT-M(2)
MLSOS-M+1(2),3
VWFAIL
6,0(4,4)
6,6
6,3
6,MCOUNT-M(2)
VWFAIL
3,2
4,4
VW6
0(3),0
VW13
3(3),3
VWFAIL
6,0(3)
6,0(6)
0(3),X'80'
VW12
6,MX
VWFAIL
6,=A(FREE-M)
VWFAIL
7,M(6)
7,M(7)
7,3
VWFAIL

49770000
49840000
49910000
UNREASONABLE RANK
49980000
DATA ADDR FOR CHAR TYPE CHECK
50050000
50120000
SCALAR
50190000
50260000
50330000
UNREASONABLE XRHO
50400000
50470000
50540000
50610000
50680000
50750000
UNREASONABLE TYPE
50820000
50890000
REASONABLE XRHO
50960000
51030000
51100000
51170000
ROUND TO WORD BDY
51240000
51310000
51380000
SHOULD EQUAL COUNT
51450000
51520000
TAKE THAT, BH0
51590000
ON CHARACTER TYPE,
51660000
51730000
CHECK FOR LEGAL ZSYMBOLS
51800000
51870000
51940000
52010000
52080000
52150000
OFFSET MUST BE MULT OF 4
52220000
CHECK LIST OFFSET AND ELEMENT COUNT 52290000
52360000
AGAINST BYTE COUNT
52430000
52500000
52570000
ABS ADDR OF FIRST LIST ELEMENT
52640000
52710000
EMPTY LIST
52780000
52850000
NOT A POINTER
52920000
52990000
NOT MULT OF 4
53060000
53130000
53200000
53270000
INDIRECT
53340000
MUST BE BELOW MX
53410000
53480000
53550000
53620000
53690000
53760000
POINTERS REFLECT
53830000
53900000

VW12

VW13
VW6

*
*
*
*
VWZC

VWZC2

VWZC1

VWZCTR
VWTM
VWFAIL

B
C
BL
C
BNL
LA
BCT
TM
BNZ
L
LTR
BNP
AR
CR
BH
B

LTR
BCR
BCTR
STM
S
BM
TRT
BNZ
LA
B
EX
BNZ
LM
BR
TRT
TM
MVC
STM
LA
L
TM
BZ
OC
BNZ
SR
L
LA
L
ST
BXLE
L
AR
LH
L
PRINT
SNAP
STC
LA
C
BL

VW13
6,PARREL
VWFAIL
6,QR13STK
VWFAIL
3,4(3)
4,VW14
MCOUNT-M(2),3
VWFAIL
7,MCOUNT-M(2)
7,7
VWFAIL
2,7
1,2
VW10
ENDDR3

53970000
54040000
54110000
OR SYMBOL TABLE
54180000
54250000
54320000
54390000
PROBABLY SUPERFLUOUS
54460000
54530000
54600000
54670000
54740000
54810000
54880000
54950000
ALL OK
55020000
R7 POINTS TO TRT TABLE
55090000
R6 HAS FIELD LENGTH, R5 PTS TO FIELD 55160000
BOTH R5 AND R6 ARE DESTROYED.
55230000
55300000
6,6
Z-SYMBOL CHECKER
55370000
8,LKR
EMPTY
55440000
6,0
55510000
1,2,VWZCT
55580000
6,=F'256'
55650000
VWZC1
55720000
0(256,5),0(7)
55790000
VWFAIL
55860000
5,256(5)
55930000
VWZC2
56000000
6,VWZCTR
56070000
VWFAIL
56140000
1,2,VWZCT
56210000
LKR
56280000
0(0,5),0(7)
56350000
=X'04',0
56420000
EDRSREG(16*4),0(8)
A04 56490000
0,15,0(8)
A04 56560000
3,=XL1'FF'
NO SNAPID FOR 'WS DAMAGED' MSG
58100000
1,=A(UTFLAGS)
ADDR OF OPTION FLAGS
58170000
0(1),UTWSDMP
WSDUMP OPTION SPECIFIED ?
58240000
NOWSDMP
BRANCH IF NO
58310000
WFLPASS,WFLPASS
IS WS PASSWORD PROTECTED ?
58380000
NOWSDMP
NO WSDUMP ALLOWED IF PASS PROT
58450000
0,0
CLEAR GARBAGE BETWEEN
58520000
1,MX
MX AND SVI.
58590000
2,4
58660000
3,SVI
58730000
0,M(1)
58800000
1,2,*-4
58870000
2,WLEN
PICK UP WS LENGTH
58940000
2,8
CALCULATE END OF WS
59010000
3,SNAPID
CURRENT SNAP ID
59080000
0,=A(WSDMPDCB)
ADDR OF WSDUMP DCB FOR SNAP
59150000
GEN
59220000
ID=(3),DCB=(0),STORAGE=((8),(2))
59290000
3,SNAPWRK1+8
STORE SNAPID IN MSG LINE WORKAR
59360000
3,1(3)
BUMP SNAPID
59430000
3,=F'256'
IF GREATER THAN 255,
59500000
*+6
RESET TO ZERO.
59570000
MUST POINT TO STACK

SR
3,3
STH 3,SNAPID
LA
3,SNAPWRK1
SNAPID FOR DWSLOG
NOWSDMP EQU *
LA
0,WFLDATE
LA
1,WFLLIB
LA
2,=CL9'IMPEACHED' ACTION TAKEN
ICALL DWSLOG
ENDDR4 MVC 0(16*4,8),EDRSREG RESTORE WS REGISTERS
DROP 8
ENDDR3 LM
0,8,EDRS
TS
ONETRK
SET FLAG SO THAT CALLS TO DRDZ IN RANDOM
*
SEQUENCE DO THE PROPER ERROR CHECKING ON THE IOB
IRETURN
VWUNV
DC
0F'0',AL1(VARB,0,0,0)
VWTS
DC
FL1'0,5,6,3'
DRDZFG DC
X'FF'
FIRST-TIME FLAG FOR DRDZ
DRDMSG DC
C'WORKSPACE'
DC
X'11'
DRDMWF DC
XL16'00'
WS NO, NAME
DC
C' DISK READ ERROR. STATUS=',X'02'
DRDMST DC
X'0000',C' '
DRDMLU DC
CL44' ',X'FF'
DRDZT
DS
F
EDRS
DSECT
DS
9F
VWZCT
DS
2F
EDRSREG DS
16F
SAVES WS REGISTERS
EDRSZ
EQU *
DISKSECT CSECT
TITLE 'DISK WRITE ROUTINE'
*
*
*
WRITE WORKSPACE DESIGNATED BY R11 TO DISK CCHH IN R1
*
R2 IS FILE NUMBER
*
DWR
PROLOG
ENTRY DWR
STM 1,6,DWRT
L
1,=A(WSLEN)
L
1,0(1)
ST
1,WLEN
MVI DOP+1,X'05'
A
2,ADPAR
ST
2,CDCBASE
DWR1
EQU *
ICALL DWRZ
MVC PHYCYL,DWRT
SET UP ARGUMENTS FOR CDCOMP
MVI CCFIRST,0
RESET FIRST WRITE PASS SWITCH
ST
11,DWRLAST
MVC CDCAD+1(3),DWRLAST+1
LA
15,WLEN
BAL 6,CDCOMP-WLEN(15)
MVI CDOP,0
RESET ALTERNATE DIRECTORY SWITCH
L
1,CDCBASE DISK POINTER TO DESIRED FILE
LA
3,IOB
USING IOBECB,3
LH
1,LOGAD-CDCPARS(1) LOAD INDEX OF DCB
MH
1,=H'72' MULTIPLY BY LENGTH OF DCB
A
1,=A(APLSDCBS) ADD BASE OF DCBS

A04
5989
5989

A04

DASD

DASD
DASD

5989

59640000
59710000
59780000
59850000
59920000
59990000
60060000
60130000
60270000
60340000
60410000
60480000
60550000
60620000
60690000
60760000
60830000
60900000
60970000
61040000
61110000
61180000
61250000
61320000
61390000
61460000
61530000
61600000
61670000
61740000
61810000
61880000
61950000
62020000
62090000
62160000
62230000
62300000
62370000
62440000
62510000
62580000
62650000
62720000
62790000
62860000
63210000
63280000
63420000
63560000
63630000
64120000
64190000
64260000
64680000
64750000
64820000
64890000
64960000
65030000

DWR2
*
*
DWFMSG
DWFMDT
DWFMID

ST
1,IOBDCB STORE IN OIB DCB ADDRESS
MVC IOBFLAG1(2),=X'C200'
MVC IOBSTART(3),=AL3(CCWAR)
MVC IOBERRCT(2),=H'0' ZERO ERROR COUNT
L
1,CCWAD
L
1,0(1)
LOAD 1ST HALF OF SEEK ADDRESS
MVC IOBSKPT(7),0(1)
MV SEEK ADR TO IOB
XC
EVNTCB(4),EVNTCB
ZERO OUT EVENT CNTRL BLK
DROP 3
EXCP IOB
L
2,=A(UTFLAGS)
LISTING OF ALL WS LABELS WRITTEN
TM
0(2),UTWSLST
MAY HAVE BEEN REQUESTED
BZ
DWR2
CLI WFLNAME-M(MR),C'A' DON'T LIST DIRECTORIES -- IT GETS
BE
DWR2
TEDIOUS
MVC DWFMID(16),WFLLIB-M(MR) MOVE IN WSID
MVC DWFMDT(12),WFLDATE-M(MR) LIKEWISE TIME STAMP
ICALL OUTWRT
DC
AL4(DWFMSG)
LM
2,6,DWRT+4
IRETURN
DC
DC
DC
DC
DC
DC

CL7'
X'13'
XL12'00'
X'11'
XL16'00'
X'FF'

'

SPACES TO BE CONSISTENT W/ MTSECT

DATE, TIME
LIB NO, WSNAME

*
SPACE
PROLOG
ENTRY DWRZ
ST
1,DWRZT
WAIT ECB=ECB
LA
1,IOB
USING IOBECB,1
CLI ECB,X'7F'
BNE DWRZ1
CLC IOBSTAT(2),=X'0C00' CHECK FOR NORMAL END
BE
DWRZ2
DWRZ1
MVC DWRMST(2),IOBSTAT
DROP 1
L
1,CDCBXLE+8
MVC DWRMLU(44),DSLAB-CDCPARS(1)
L
1,DWRLAST
MVC DWRMWF(16),WFLLIB-M(1) FILE LABEL OF UNFORTUNATE WS
ICALL OUTWRTL
DC
AL4(DWRMSG)
DWRZ2
L
1,DWRZT
IRETURN
SPACE
DWRMSG DC
C'WORKSPACE'
DC
X'11'
DWRMWF DC
XL16'00'
DC
C' DISK WRITE ERROR. STATUS=',X'02'
DWRMST DC
X'0000',C' '
DWRMLU DC
CL44' ',X'FF'
DWRZT
DS
F
DWRLAST DS
F
DWRZ

65100000
65170000
65240000
65310000
65380000
65450000
65520000
65590000
65660000
65730000
65870000
65940000
66010000
66080000
66150000
66220000
66290000
66360000
66430000
66500000
66570000
66640000
66710000
66780000
66850000
66920000
66990000
67060000
67130000
67200000
67270000
67340000
67410000
67480000
68250000
68320000
68390000
68460000
68530000
68600000
68670000
68740000
68810000
68950000
69020000
69090000
69160000
69230000
69300000
69370000
69440000
69510000
69580000
69650000
69720000
69790000
69860000
69930000
70000000
70070000

DWRT
*
*
*
*
*
DIRWRT
*
*

*
UPDFR1
UPDFR2

*
*
*
*
*

DS
6F
USED ALSO BY DISK READ
TITLE 'DIRECTORY READ AND WRITE ROUTINES'
WRITE TWO COPIES OF A DIRECTORY TO THE CORRECT DISK LOCATIONS.
R10 IS CORE LOCATION, R1 IS DIRECTORY NUMBER
NOPR 15

********** PROGRAM MODIFIED BY MAIN

********** TO INHIBIT DIRWRT FOR
********** TESTBILL COMMAND ********

PROLOG
ENTRY DIRWRT
ST
11,DIRT
LR
11,10
STM 0,3,DIRT+4
USING M,10
UPDATE FREEDSK TABLE IN THIS DIRECTORY
LM
0,2,CDCBXLE
LA
3,FREEDSK
MVC 0(4,3),CFREDSK-CDCPARS(2)
LA
3,4(3)
BXLE 2,0,UPDFR2
NEXT LIBRARY
L
1,DIRT+8
RESTORE R1
SLL 1,3
LR
2,1
L
1,=A(DIRTAB)
L
1,0(1,2)
SR
2,2
ICALL DWR
WRITE IT.
ICALL DWRZ
MVI CDOP,8
SET "ALTERNATE DIRECTORY" SWITCH,SO
THAT DIRECTORY DATA IS NOT MOVED A SECOND TIME.
L
2,DIRT+8
SLL 2,3
L
1,=A(DIRTAB)
L
1,4(1,2)
SR
2,2
ICALL DWR
ICALL DWRZ
THE ABOVE SHUFFLE WITH CDOP PREVENTED DOING THE INCORE
MOVE A SECOND TIME, BUT THE DATA HAS BEEN MOVED
(SEE CDCOMP FOR DESCRIPTION).
IF THE INCORE MOVE WAS DESTRUCTIVE, THEN WE HAVE TO
RESTORE THE DATA IN CORE.
LA
15,WLEN
ESTABLISH ADDRESSABILITY
USING WLEN,15
CLI ONETRK,INCORMV WAS THE DATA MOVED IN CORE ?
BNE UPDFR3
NO, WE DON'T HAVE TO MOVE IT BACK
L
1,CCPAR1
ADDRESS OF WORKSPACE
USING M,1
LM
2,3,MX
GET MX AND SVI
LA
2,7(,2)
ROUND MX TO A DOUBLE-WORD BOUNDARY
N
2,=F'-8'
N
3,=F'-8'
ROUND SVI TO A DOUBLE-WORD BOUNDARY
SR
3,2
GET THE LENGTH OF THE GARBAGE AREA
LH
2,MVCLNGTH
GET THE LENGTH OF THE MOVE
LPR 2,2
MAKE IT POSITIVE
CR
3,2
WAS THE MOVE DESTRUCTIVE ?
BNL UPDFR3
NO, MOVE BACK NOT NECESSARY

5989
5989
5989

5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989
5989

70140000
70210000
70280000
70350000
70420000
70490000
70560000
70630000
70700000
70770000
70840000
70910000
70980000
71050000
71120000
71190000
71260000
71330000
71400000
71470000
71540000
71610000
71680000
71750000
71820000
71890000
71960000
72030000
72100000
72170000
72240000
72310000
72380000
72450000
72520000
72590000
72660000
72730000
72800000
72870000
72940000
73010000
73080000
73150000
73220000
73290000
73360000
73430000
73500000
73570000
73640000
73710000
73780000
73850000
73920000
73990000
74060000
74130000
74200000
74270000

*
*
UPDFR3

FIX UP THE DAMAGED WS

BAL 0,MVCREV
DROP 1,15
EQU *
L
11,DIRT
LM
0,3,DIRT+4
IRETURN
DROP 10
EJECT

GO MOVE THE DATA BACK

5989
5989
5989
5989
5989

*
*
READ DIRECTORY SPECIFIED BY R1 INTO CORE SPECIFIED BY R10.
DIRREAD PROLOG
ENTRY DIRREAD
STM 1,2,DIRT
ST
11,DIRT+8
LR
11,10
SLL 1,3
L
2,=A(DIRTAB)
AR
1,2
ADDR OF CCHH, PRIMARY DIRECTORY
ST
1,DIRT2
MVI DIRRALT,0
ATTEMPTING TO READ PRIMARY
L
1,0(1)
DIRR2
SR
2,2
ICALL DRD
ICALL DRDZ
CLI REJECT-M(11),3
CHECK FOR HARD ERROR
C059
BE
DIRRX
DIR IS UNREADABLE
C059
SR
2,2
ERR CODE IF NOT A DIR
C059
CLC WFLNAME-M(12,11),=C'APLDIRECTORY'
BNE DIRERR
NOT A DIRECTORY
C059
LA
2,4
ERR CODE IF DIR FORMAT WRONG
C059
CLC VVMM-M(4,11),=C'V1M1' DIR WRITTEN BY V1M1 UTIL?
C059
BNE DIRERR
NO. INCOMPATIBLE DIR FORMATS C059
LA
2,8
ERR CODE IF DIRS OR WSLEN WRONG C059
L
LKR,=A(KMANHASH)
C059
L
LKR,0(LKR)
NO. DIRS FROM CONFIG
C059
LA
0,1000
C059
A
0,QR13STK-M(11)
ACTUAL WSLEN FROM LIB
C059
L
1,=A(WSLEN)
C059
C
0,0(1)
ACTUAL WSLEN VS. CONFIG WSLEN C059
BNE DIRERR
MISMATCH. LET'S QUIT
C059
C
LKR,NUMDIRS-M(11) CONFIG DIRS VS. ACTUAL DIRS
C059
BNE DIRERR
MISMATCH. LET'S QUIT
C059
CLI REJECT-M(11),0
JUST IN CASE MX & SVI BAD
C059
BNE DIRRX
SCRAMBLED INNARDS. REJECT
C059
LM
1,2,DIRT
L
11,DIRT+8
IRETURN
DIRRX
XI
DIRRALT,1
HAVE WE TRIED ALTERNATE YET -BZ
DIRR3
YES
ICALL OUTWRTL
NO. LOG PRIMARY FAILURE AND TRY ALT
DC
AL4(DIRRMSG)
L
1,DIRT2
L
1,4(1)
ALTERNATE DIRECTORY CCHH
B
DIRR2
DIRR3
ICALL OUTWRTL
DC
AL4(DIRRMSGA)
CANCEL
DIRRMSGA DC
C'ALTERNATE '

74340000
74410000
74480000
74550000
74620000
74690000
74760000
74830000
74900000
74970000
75040000
75110000
75180000
75250000
75320000
75390000
75460000
75530000
75600000
75670000
75740000
75810000
75880000
75950000
76020000
76370000
76440000
76510000
76580000
76650000
76720000
76790000
76860000
76930000
77000000
77070000
77140000
77210000
77280000
77350000
77420000
77490000
77560000
77630000
77700000
77770000
77840000
77910000
77980000
78050000
78120000
78190000
78260000
78330000
78400000
78470000
78540000
78610000
78680000
78750000

DIRRMSG DC
DC
DIRT
DS
DIRT2
DS
DIRRALT DS
TITLE
WLEN
DC
MANHASH DC
DIRIN
DC
CDCBASE DC
CDCBXLE DC
ADPAR
EQU
TOHEX
EQU
DC
SPACE
LTORG
SPACE
DIRERR DS
L
LR
LR
L
L
ICALL
DC
ABEND
DIRRMSGB DC
DC
DS
ZERO
DC
SNAPID DC
DS
IOB
DC
DC
DC
DC
DC
ECB
DC
SNAPWRK1 DC
DC
IDZT
DC
ORG
DC
ORG
GENZT
DC
ORG
DC
ORG
DC
ORG
DC
ORG
*
*
*
STBL
DC
TBL
DC
DC
DC
DC

C'DIRECTORY READ FAILURE '

X'FF'
3F
2F
XL1
'LITERALS AND USEFUL CONSTANTS'
A(0)
F'0'
H'0'
A(LIBPARS)
A(CDCL,LIBPZ,LIBPARS)
CDCBXLE+8
*-C'0'
C'0123456789ABCDEF'
3

5989
5989
3
5989
0H
C059
3,NUMDIRS-M(11)
ACTUAL NO. DIRS
C059
4,LKR
NO. DIRS FROM CONFIG
C059
5,0
WSLEN IN LIBRARY
C059
1,=A(WSLEN)
C059
6,0(1)
WSLEN FROM CONFIG
C059
OUTWRTL
'INCOMPATIBLE APL LIB FORMATS' C059
AL4(DIRRMSGB)
MUST FOLLOW ICALL
C059
1098,DUMP
BAD DIRECTORIES
C059
C'INCOMPATIBLE APL LIBRARY FORMAT'
C059
X'FF'
MUST FOLLOW DIRRMSGB
C059
0H
H'0'
H'0'
SNAP ID FOR WSDUMP
0F
F'0'
INITIALIZED FOR LEADING WAIT
A(ECB)
COMPLETE
4X'00'
X'0C000000'
6F'0'
X'7F000000'
C'SNAPID='
FOR 'WS DAMAGED' MSG WITH WSDUMP
X'1200'
MUST BE AFTER SNAPWRK1
256X'11'
IDZT+ZA
64X'00'
ALPHA, ALPHA, NUMERIC
256X'11'
GENZT+ZLBR
(ZFILL17-ZLBR)X'00'
GENZT+ZA
(ZEOB-ZA)X'00'
GENZT+ZBS
(ZLENGTH-ZBS)X'00'

AL1(0,5,6,3)
AL1(BAD-X)
AL1(XEOS-X)
AL1(XEOS-X)
AL1(OK-X)

IN THE FOLLOWING TABLES,ASSUMPTIONS

HAVE BEEN MADE AS TO THE ORDERING OF THE Z-SYMBOLS.
SHIFT VALUES FOR CONSTANTS CNTS

78820000
78890000
78960000
79030000
79100000
79170000
79240000
79310000
79380000
79450000
79520000
79590000
79660000
79730000
79800000
79870000
79940000
80010000
80080000
80150000
80220000
80290000
80360000
80430000
80500000
80640000
81060000
81130000
81200000
82390000
82460000
82530000
82600000
82670000
82740000
82810000
82880000
82950000
83020000
83090000
83230000
83300000
83370000
83440000
83510000
83580000
83650000
83720000
83790000
83860000
83930000
84000000
84070000
84140000
84210000
84280000
84350000
84420000
84490000
84560000

DC
AL1(BAD-X)
DC
AL1(BAD-X)
DC
AL1(BAD-X)
DC
AL1(OK-X)
DC
AL1(OK-X)
DC
AL1(OK-X)
DC
AL1(CON-X)
DC
AL1(CON-X)
DC
AL1(CON-X)
DC
AL1(CON-X)
TEMPH
DC
H'0'
EXTRN KMANHASH
EXTRN PARAMS
EXTRN CCREJ
EXTRN DISKFMT
EXTRN DIRTAB
EXTRN WSLEN
EXTRN LIBPARS
EXTRN LIBPZ
EXTRN OUTWRT
EXTRN OUTWRTL
EXTRN UTFLAGS
EXTRN WSLOC
ENTRY ADPAR
EXTRN APLSDCBS
EXTRN WSDMPDCB
IOBECBD
ENTRY CDCAD
ENTRY CDCBASE
ENTRY CDCBXLE
UTWSLST EQU X'80'
UTFLAGS MASK - WSLIST
UTWSDMP EQU X'20'
UTFLAGS MASK - DUMP REJECTED WSS
REJECT EQU M
TITLE 'DISK CCW COMPUTATION'
*
DROP 12
USING WLEN,15
SAME ADDRESSIBILITY AS CDCOMP
5989
RELOC
CLI ONETRK,INCORMV
5989
MVI ONETRK,NOT1TRK
5989
BCR 2,8
5989
L
1,CCPAR1
5989
LR
0,8
RETURN ADDRESS FOR FAKE BAL
5989
B
MVCREV
GO MOVE THE DATA BACK
5989
SPACE 3
5989
USING WLEN,15
5989
COPY CDINF
DASD
CDCOMP REMCDC ,
DASD
DROP 15
*
LTORG
*
COPY CDCPARS
COPY DIRSECT
END
./ ADD
NAME=APLUDUMP
DUMP
TITLE 'APL UTILITY DUMP ROUTINES
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*

84630000
84700000
84770000
84840000
84910000
84980000
85050000
85120000
85190000
85260000
85330000
85400000
85470000
85540000
85610000
85680000
85750000
85820000
85890000
85960000
86030000
86100000
86170000
86240000
86800000
86870000
86940000
87080000
87150000
87220000
87290000
87360000
87430000
87500000
87570000
87640000
87710000
87780000
87850000
87920000
87990000
88060000
88130000
88200000
88270000
88340000
88410000
88480000
88550000
88620000
88690000
88760000
88830000
88900000
00180000
00360000
00540000
00720000
01440000

EXTRN CCREJ
EXTRN DIRREAD
EXTRN DIRWRT
EXTRN DRD
EXTRN DRDR1
EXTRN DRDREST
EXTRN DRDZ
EXTRN DSEEK
EXTRN DWSLOG
EXTRN KMANHASH
EXTRN LCYLOG
EXTRN LOC8MAN
EXTRN MTWCLOSE
EXTRN MTWOPEN
EXTRN MTWR
EXTRN MTWRZ
EXTRN OUTWRTL
EXTRN PARAMS
EXTRN SELCARD
EXTRN TRECLEN
EXTRN UTDATE
EXTRN UTFLAGS
EXTRN VTOZ
EXTRN WSLEN
EXTRN WSLOC
PRINT OFF
COPY APLDEFN ZSYMBOLS
COPY APLDEFN
COPY ZSYMBOLS
TITLE 'APL UTILITY DUMP ROUTINE
05/11/70'
PRINT ON,NOGEN
DUMPSECT CSECT
*
*
*
DDUMP
PROLOG
ENTRY DDUMP
MVI IDFLAG,0
NOT INCREMENTAL DUMP
MVI IDNXPS,1
GUARANTEE NONZERO
B
DUMPCM
*
*
INCREMENTAL DUMP
*
ENTRY IDUMP
IDUMP
PROLOG
MVI IDFLAG,1
DOING AN INCREMENTAL DUMP
*
DUMPCM BALR 12,0
REESTABLISH ADDRESSING
USING *,12
L
1,=A(UTDATE)
LOCATE EBCDIC DATE
MVC RTS(8),0(1)
L
1,=A(VTOZ)
MAP TO ZSYMBOLS
TR
RTS(8),0(1)
MVI RTS+2,ZSLASH
VTOZ DOESN'T HOLD ZSLASH
MVI RTS+5,ZSLASH
GETIME TU
ST
1,RTS+8
ICALL DISUB
SET UP DUMP AND SELDUMP PARAMETERS
SR
2,2
ST
2,IWSCNT
INITIALIZE NO. OF INCDUMPED WSS
LR
11,10

01620000
01800000
01980000
02160000
03060000
03240000
03420000
03600000
03780000
03960000
04140000
04320000
04500000
04680000
04860000
05040000
05220000
05400000
05580000
05760000
05940000
06120000
06300000
06480000
06660000
06840000
07020000
07200000
07380000
07560000
07740000
07920000
08100000
08280000
08460000
08640000
08820000
09000000
09180000
09360000
09540000
09720000
09900000
10080000
10260000
10440000
10620000
10800000
10980000
11160000
11340000
11520000
11700000
11880000
12060000
12240000
12420000
12600000
12780000
12960000

*
DDUMPDR LR
ICALL
LTR
BNZ
MVC
CLI
BNE
MVC
DD2
MVC
DD1
ICALL
ICALL
LA
C
BL
XC
SR
DDCS
STH
MVI
L
*
ICALL
L
BAL
B
*
*
USING
CLI
BE
IDG
ST
MVC
MVC
TS
BZ
*
*
DDV
LR
*
DDM
L
TM
BNZ
ICALL
DDM2
CLI
BNZ
ICALL
ICALL
MVI
DDU
L
SR
IC
A
ST
L
C
BL
ST
L
A
ST

FIRST WRITE ALL (MANHASH) DIRECTORIES TO TAPE

1,2
DIRREAD
1,2
ON DIRECTORY 0 ONLY,
DD1
DIDTS-M(12,10),RTS WRITE INCREMENTAL-DUMP TIMESTAMP
IDFLAG,0
DD2
DFDTS-M(12,10),RTS ALSO FULL-DUMP TIMESTAMP IF NOT INCRTS2(12),DFDTS-M(10) DUMP.
MTWR
MTWRZ
2,1(2)
2,HASHVAL
DDUMPDR
WSTATS(12),WSTATS
1,1
START DUMPING WITH DIRECTORY 0.
1,CURDIR
IDAFLG,0
1ST-TIME-ONLY FLAG FOR INCDUMP
10,DIRWS
PREPARE TO DUMP FROM NEXT DIRECTORY
DIRREAD
11,CURWS
15,TABTRAC
DDB
REENTRY FROM TABTRAC WITH ANOTHER PERSAVW TO PROCESS
PERSAVW,7
IDFLAG,0
FOLLOWING CODE ONLY FOR INCDUMP
DDM
7,IDNXPS
SAVE NEW PERSAVW ADDR AS NEXT
LOSTPL,IDADPL
GLITCH FOR 'LOST WS' MESSAGES -IDADPL,TABTPSAV+4 MAKE SURE PERLIB ADDR LAGS BY ONE
IDAFLG
FIRST TIME THROUGH, SIMPLY COLLECT
IDA
A PERSAVW POINTER FOR PRESEEKING
AT THIS POINT, A POINTER TO PREVIOUS PERSAVW, LOADED
AT DDG, IS IN R8.
7,8
REST OF CODE KEEPS CURRENT PERSAVW
ADDR IN R7
1,=A(UTFLAGS)
IF SINGLE WS BUFFERRING IS IN EFFECT
0(1),UT3WSS
DDM2
WAIT FOR DISK END TO START TAPE.
DRDZ
REJECT-M(11),0
BYPASS TAPE WRITE IF WS IGNORED FOR
DDU
ANY REASON
MTWR
MTWRZ
REJECT-M(11),1
BUFFER IS EMPTY
1,PSCYL
DASD
0,0
DASD
0,PSLEN
DASD
0,WSTATS+4
0,WSTATS+4
0,PSCYL
DASD
0,WSTATS+8
*+8
0,WSTATS+8
0,WSTATS
0,=F'1'
0,WSTATS

13140000
13320000
13500000
13680000
13860000
14040000
14220000
14400000
14580000
14760000
14940000
15120000
15300000
15480000
15660000
15840000
16020000
16200000
16380000
16560000
16740000
16920000
17100000
17280000
17460000
17640000
17820000
18000000
18180000
18360000
18540000
18720000
18900000
19080000
19260000
19440000
19620000
21600000
21780000
21960000
22140000
22320000
23220000
23400000
23580000
23760000
23940000
24120000
24300000
24480000
24660000
24840000
25020000
25200000
25380000
25560000
25740000
25920000
26100000
26280000

IDB

DDE
*
*
DDJ
DDK
DDQ
DDP
IDA
DDG

DDB
DDH

DDD2

DDC

LH
CLI
BZ
ICALL
CLC
BNE
CLC
BH
BL
CLC
BH
ICALL
L
LA
ST
B
ICALL
CLC
BE
MVI
CLI
BE
ICALL
MVI
B
L
MVC
ST
EQU
L
LTR
BNZ
B
DROP
SR
CLI
BNE
LH
LA
C
BL
ICALL
CLI
BNE
ICALL
MVI
L
CLI
BNE
ICALL
MVI
ICALL
CLI
BNE
LR
SR
ICALL
MVC

2,PSFILE
FILE NUMBER
IDFLAG,0
DDE
FOLLOWING IS FOR INCREMENTAL DUMP
DRDR1
READ ONLY FIRST RECORD OF WS
WFLNAME-M(16,11),PSNAME SAME CHECK AS BELOW FOR FULL DM
DDJ
RTS2+6(2),WFLDATE-M+6(11) COMPARING YY FIRST IS EASIER
DDQ
IDB
THAN REARRANGING DATE TO YYMMDD
RTS2(12),WFLDATE-M(11) DUMP THIS WS ONLY IF SAVED LATER
DDQ
THAN TIME OF LAST FULL DUMP
DRDREST
IT WAS. INITIATE READING OF REST
1,IWSCNT
OF TRACKS.
1,1(1)
1,IWSCNT
UP COUNT OF DUMPED WORKSPACES
DDK
DRD
READ ENTIRE WORKSPACE FOR FULL DUMP
NOTE.. WE ARE GUARANTEED OF HAVING FIRST RECORD IN CORE
WHEN DRD RETURNS, SO TESTS HERE ON WFLLIB ETC ARE OK.
WFLNAME-M(16,11),PSNAME MAKE SURE WORKSPACE LABEL AGREES
DDK
WITH DIRECTORY -- LIBRARY PACK HAS
REJECT-M(11),1
BEEN OVERWRITTEN IF NOT.
REJECT-M(11),0
DDP
LOSTWS
WORKSPACE NOT READ CORRECTLY
REJECT-M(11),1
OLD WS, NO DUMP. REJECT QUIETLY.
DDG
11,ALTWS
SWAP WS ADDRESSES (NO EFFECT IF
ALTWS(4),CURWS
SINGLE BUFFERRING)
11,CURWS
*
END OF THIS DIR FOR INCDUMP
8,IDNXPS
FALL THROUGH IF PROCESSING
8,8
LAST WORKSPACE IN DIRECTORY
TABX
DURING INCDUMP
DDH
7
7,7
FOR INCDUMP,
IDFLAG,0
NOTE NONEXISTENCE OF NEXT PERSAVW
IDG
1,CURDIR
ADVANCE TO NEXT DIRECTORY
1,1(1)
1,HASHVAL
DDCS
DRDZ
UNBUFFER
REJECT-M(11),0
IF REJECTED, LOSE WS QUIETLY
DDD2
MTWR
REJECT-M(11),1
11,ALTWS
REJECT-M(11),0
NO EFFECT FOR SINGLE BUFFERRING
DDC
MTWR
WRITE LAST WS
REJECT-M(11),1
MTWCLOSE
CLOSE OUTPUT TAPE
IDFLAG,0
IF FULL-DUMP,
DDC2
11,10
REWRITE DIRECTORY 0
1,1
DIRREAD
WITH THE TIME OF THE FULL DUMP.
DFDTS(12),RTS

26460000
26640000
26820000
27000000
27180000
27360000
27540000
27720000
27900000
28080000
28260000
28440000
28620000
28800000
28980000
29160000
29340000
29520000
29700000
29880000
30060000
30240000
30420000
30600000
30780000
30960000
31140000
31320000
31500000
31680000
31860000
32040000
32220000
32400000
32580000
32760000
32940000
33120000
33300000
33480000
33660000
33840000
34020000
34920000
35100000
35280000
35460000
35640000
35820000
36000000
36180000
36360000
36540000
36720000
36900000
37080000
37260000
37440000
37620000
37800000

DDC2

DDL

DISUB

DISERR
*
DISB2

DISB3
IDFLAG
RTS
*
RTS2
IDNXPS
*
*
IDADPL
IWSCNT
IDAFLG
IDMSG

SR
1,1
ICALL DIRWRT
EQU *
MVC DMNOWS(4),WSTATS
PRINT DUMP STATISTICS
MVC DMNOTR(4),WSTATS+4
CLI IDFLAG,0
INCDUMP PRINTS COUNT OF WSS ACTUALLY
BZ
DDL
MVC DMNIWS(4),IWSCNT
ICALL OUTWRTL
DUMPED AS WELL AS NO. OF WORKSPACES
DC
AL4(IDMSG)
IN SYSTEM.
ICALL OUTWRTL
DC
AL4(DMSG)
ICALL LCYLOG
IRETURN
SPACE 2
PROLOG
, SET UP DUMP PARAMETERS
LM
1,2,=A(TRECLEN,PARAMS+4)
L
0,0(2)
PARAM 1 IS RECORD LENGTH
ST
0,0(1)
C
0,TRLOW
MUST BE BETWEEN 500
BL
DISERR
CL
0,TRHIGH
AND 32K
BH
DISERR
OBJECT TO EXCESSIVE TAPE RECORD LGTH
L
1,=A(TCCWARK-10)
COMPUTE (WITH A LITTLE SLOP) THE
MR
0,0
MAXIMUM WS SIZE THE SPECIFIED
BLOCK SIZE WILL PERMIT.
L
2,=A(WSLEN)
IF WE CANNOT HANDLE OUR WS SIZE
C
1,0(2)
WITH SPECIFIED BLOCK SIZE, REJECT.
BH
DISB2
ICALL OUTWRTL
INVALID RECORD LENGTH PARAMETER
DC
AL4(RLBMSG)
ICALL CCREJ
ABNORMAL RETURN TO MAIN PROG
ICALL MTWOPEN
L
1,=A(KMANHASH)
MVC HASHVAL(4),0(1)
L
1,=A(WSLOC)
MVC DIRWS(12),0(1)
L
10,DIRWS
L
11,CURWS
MVI REJECT-M(11),1
L
1,=A(UTFLAGS)
TM
0(1),UT3WSS
BZ
DISB3
L
11,ALTWS
MVI REJECT-M(11),1
ST
11,ALTWS
IRETURN
SPACE 2
DC
X'00'
DC
3F'0'
DC
DC

3F'0'
A(0)

DC
DC
DC
DC

A(0)
F'0'
FL1'0'
X'10'

OPEN OUTPUT TAPE FILE

NO. OF DIRECTORIES
ADDRS OF 2 OR 3 BUFFER AREAS
MARK BUFFERS EMPTY

SAME AS CURWS IF SINGLE BUFFERRING

INCREMENTAL-DUMP FLAG
OUR TIMESTAMP (WFLLIB FORMAT OF
CURRENT TIME)
TIMESTAMP OF PREV FULL DUMP
ADDR OF NEXT PERSAVW TO BE PROCESSED BY INCDUMP, OR 0 IF
FINISHED WITH THIS LIBRARY.
PERLIB ADDRESS FOR NEXT PERSAVW
NO. OF WORKSPACES ACTUALLY DUMPED
1-ST-TIME SWITCH FOR INCDUMP

37980000
38160000
38340000
38520000
38700000
38880000
39060000
39240000
39420000
39600000
39780000
39960000
40140000
40320000
40500000
40680000
40860000
41040000
41220000
41400000
41580000
41760000
41940000
42120000
42300000
42480000
42660000
42840000
43020000
43200000
43380000
43560000
43740000
43920000
44100000
44280000
44460000
44640000
44820000
45000000
45180000
45360000
45540000
45720000
45900000
46080000
46260000
46440000
46620000
46800000
46980000
47160000
47340000
47520000
47700000
47880000
48060000
48240000
48420000
48600000

DMNIWS
DMSG
DMNOWS
DMNOTR
WSTATS
TRHIGH
TRLOW
RLBMSG
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
* NOTE..
SELDUMP

SDB
SDA

DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
DC
TITLE

C'0000'
C' WORKSPACES DUMPED'
X'FF'
X'10'
'NNN WORKSPACES NNN TRACKS'
C'0000'
C' WORKSPACES '
X'10'
C'0000'
C' TRACKS '
X'FF'
3F'0'
F'32750'
A LITTLE SLOP
F'500'
C'INVALID RECORD LENGTH PARAMETER'
X'FF'
'SELECTIVE DUMP ROUTINE'

EXAMPLE OF UTILITY CARDS TO PREPARE A DISTRIBUTION TAPE:

*CARDS*
SELDUMP NNNN
DIST
(*) WSFNS
(*) NEWS
(*) ADVANCEDEX
. . .
OPLIB
(*) OPFNS
. . .
END

*TAPE*
WFLLIB WFLNAME
0
1
1
1

WFLMAN

*DIRECTORY*
0
WSFNS
314159
NEWS
314159
ADVANCEDEX 314159
. . .

314159 OPFNS
. . .

314159

(*) ABOVE MEANS ANY NUMBER MAY BE USED AS A LIBRARY NUMBER.

PROLOG
ENTRY SELDUMP
ICALL DISUB
MVI SDCRT+1,0
MVI SD4+1,X'F0'
L
11,CURWS
USING M,11
SR
0,0
NO ERROR PREVIOUS CARD
LA
1,SDWSN
GET A LIB NO AND WSNAME FROM CARD
ICALL SELCARD
TM
SDWSN,X'80'
LOOK FOR 'DIST' OR 'END'
BZ
SDESZ2
CLC SDWSN+WFLNAME-WFLLIB(4),=AL1(3,ZE,ZN,ZD)
BE
SD5
CLC SDWSN+WFLNAME-WFLLIB(4),=AL1(3,ZEU,ZNU,ZDU) LOWERCASE
BE
SD5
LA
0,1
ASSUME ERROR ON PREVIOUS CARD
CLC SDWSN+WFLNAME-WFLLIB(5),=AL1(4,ZD,ZI,ZS,ZT)
BE
SDCRT
CLC SDWSN+WFLNAME-WFLLIB(5),=AL1(4,ZDU,ZIU,ZSU,ZTU)
BE
SDCRT
CLC SDWSN+WFLNAME-WFLLIB(6),=AL1(5,ZO,ZP,ZL,ZI,ZB)
BE
SDISTX
CLC SDWSN+WFLNAME-WFLLIB(6),=AL1(5,ZOU,ZPU,ZLU,ZIU,ZBU)
BNE SDA
MUST BE ONE OF THE ABOVE
OPLIB CARD INDICATES SELECTIONS WHICH FOLLOW GO TO OPR LIB

48780000
48960000
49140000
49320000
49500000
49680000
49860000
50040000
50220000
50400000
50580000
50760000
50940000
51120000
51300000
51480000
51660000
51840000
52020000
52200000
52380000
52560000
52740000
52920000
53100000
53280000
53460000
53640000
53820000
54000000
54180000
54360000
54540000
54720000
54900000
55080000
55260000
55440000
55620000
55800000
55980000
56160000
56340000
56520000
56700000
56880000
57060000
57240000
57420000
57600000
57780000
57960000
58140000
58320000
58500000
58680000
58860000
59040000
59220000
59400000

SDISTX

SDCRT
SDCRT2
*
*
*

DIST1

SDESZ2

SD3

MVC
CLI
BE
EX
B
BC
MVC
MVI

DISTLIB,OPNUM
SD4+1,0
SDB
0,SDCRT
SDCRT2
0,SDA
DISTLIB,=F'1'
SD4+1,0

59580000
59760000
59940000
REJECT IF THIS IS NOT THE FIRST
60120000
SELECTION CARD.
60300000
**** PROG MODIFIED ****
60480000
PUT FOLLOWING SELECTIONS IN LIB 1
60660000
FLIP DISTRIBUTION SWITCH $$$$$ $$$$$ 60840000
61020000
INITIAL DIRECTORY FOR DISTRIBUTED LIBRARY.
61200000
61380000
DROP 11
61560000
USING M,10
61740000
SR
1,1
READ IN DIRECTORY.
61920000
ICALL DIRREAD
62100000
L
1,MANSTAR
62280000
AR
1,10
62460000
LA
2,MANENTL
62640000
B
DIST1+2
62820000
USING PERLIB,1
63000000
AR
1,2
63180000
CLC LIBNUM(4),=F'-1'
63360000
BNE DIST1
63540000
SR
1,2
63720000
XC
PERLIB(MANENTL),PERLIB
63900000
MVI SRALIM,X'80'
INFINITE TIME LIMIT
64080000
MVC LIBNUM,OPNUM
64260000
MVC HISNAME(12),OPNAME
64440000
MVC MANWSQ,=H'100'
64620000
SR
1,2
64800000
XC
PERLIB(MANENTL),PERLIB
64980000
MVC LIBNUM,=F'1'
65160000
SR
1,10
65340000
ST
1,MANSTAR
65520000
XC
DFDTS(12),DFDTS
MAKE THIS LOOK LIKE A VERY OLD
65700000
XC
DIDTS(12),DIDTS
FULL DUMP TAPE
65880000
AR
1,10
66060000
S
1,=F'256'
66240000
XC
PERLIB(256),PERLIB ZERO CONFIDENTIAL INFORMATION FROM 66420000
XC
FIRSTENT(256),FIRSTENT THE DIRECTORIES OF THIS SYSTEM 66600000
MVC DSNXTF,=A(FIRSTENT-M)
66780000
LR
11,10
66960000
ICALL MTWR
67140000
L
11,CURWS
67320000
DROP 1,10
67500000
B
SDB
67680000
USING M,11
67860000
EQU *
68040000
MVI SDCRT+1,X'F0'
ACCEPT NO 'DIST' CARDS
68220000
L
1,SDWSN
RETRIEVE LIB NUMBER
68400000
SR
0,0
68580000
D
0,HASHVAL
68760000
LR
1,0
68940000
ICALL DIRREAD
AND DIRECTORY
69120000
L
0,SDWSN
69300000
ICALL LOC8MAN
69480000
B
SDNM
NOT FOUND EXIT
69660000
LR
7,1
69840000
USING PERSAVW,7
SEARCH FOR WSNAME IN PERSAVWS
70020000
L
7,PSLINK
70200000
IF DIST CARD WAS ALREADY READ, OK.

LTR 7,7
BZ
SDNW
WORKSPACE NOT FOUND
AR
7,10
CLI SDWSN+4,0
NO CHECK ON WSNAME IF DUMPING ALL
BE
SD7
CLC PSNAME,SDWSN+4
BNE SD3
SD7
L
1,PSCYL
READ WS FROM DISK
DASD
LH
2,PSFILE
EXTENT NUMBER
ST
7,LOSTPL
SAVE PERSAVE ADDR FOR 'LOST' MSG
STM 6,9,SDTEMP
ICALL DRD
ICALL DRDZ
CLI REJECT-M(11),0
BNE SD7A
DRD REJECTED WORKSPACE
LM
6,9,SDTEMP
CLC WFLNAME(16),PSNAME THOROUGH CHECK FOR RIGHT WS
BE
SD4
MVI REJECT-M(11),1
SD7A
ICALL LOSTWS
LOG 'WS LOST' IF NOT ALREADY DONE
B
SD4B
SD4
B
SD4A
PROGRAM MODIFIED.
CLC WFLLIB(4),OPNUM
BE
SD4A
DON'T CHANGE OPERATOR'S WSS.
MVC WFLLIB,DISTLIB
MVC WFLMAN,OPNUM
SAVED BY OPERATOR.
SD4A
ICALL MTWR
ICALL MTWRZ
MVI REJECT-M(11),0
SD4B
CLI SDWSN+4,0
BE
SD3
B
SDB
SD5
ICALL MTWCLOSE
IRETURN
SPACE
SDNM
MVC SDMSG,=CL14'LIBRARY NUMBER'
B
SD8
SDNW
CLI SDWSN+4,0
NOT ERROR IF DUMPING ALL WSS,
BE
SDB
JUST FINISHED.
MVC SDMSG,=CL14'WORKSPACE NAME'
SD8
ICALL OUTWRTL
DC
AL4(SDMSG)
BAL 0,SDA
GET NEXT INPUT FROM SYSLOG
SDMSG
DC
CL14'**************'
DC
C' NOT FOUND'
DC
CL5' '
SLOP
DS
0F
ALIGNMENT
ORG *-5
RESOLUTION
DC
X'11'
INTRODUCTION
SDWSN
DS
4F
LIB NO, WSNAME FROM SELECTION CARD
DC
X'FF'
OPNUM
DC
F'314159'
DISTLIB DC
A(*-*)
DIST LIBRARY NUMBER
OPNAME DC
AL1(8,ZO,ZP,ZE,ZR,ZA,ZT,ZO,ZR,0,0,0)
SDTEMP DS
2D
DROP 7
DROP 11
TITLE 'LIBRARY TABLE TRACE ROUTINE'
*
*
TRACE DOWN MAN LIST AND LIBRARY LIST FOR WORKSPACES.

70380000
70560000
70740000
70920000
71100000
71280000
71460000
71640000
71820000
72000000
72180000
72360000
73260000
73440000
73620000
73800000
73980000
74160000
74340000
74520000
74700000
74880000
75060000
75240000
75420000
75600000
75780000
75960000
76140000
76320000
76500000
76680000
76860000
77040000
77220000
77400000
77580000
77760000
77940000
78120000
78300000
78480000
78660000
78840000
79020000
79200000
79380000
79560000
79740000
79920000
80100000
80280000
80460000
80640000
80820000
81000000
81180000
81360000
81540000
81720000

*
*
*
*

FOR EACH SAVED WORKSPACE, RETURN TO 4(15) WITH ADDRESS OF

WORKSPACE ENTRY (PERSAVW) IN R7. RETURN TO 0(15) WHEN DONE.
SAVES R15-R8. USES R9 AS BASE. R9 MUST NOT BE ALTERED BY
CODE AT 4(15).
USING M,10
TABTRAC BALR 9,0
USING *,9
STM 7,8,TABCRS
ST
15,TABCRS+8
L
8,MANSTAR
AR
8,10
USING PERLIB,8
TAB0
CLC LIBNUM(4),=F'-1'
BE
TAB2
LR
7,8
USING PERSAVW,7
TAB1
OC
PSLINK,PSLINK
LINK = 0 IS END OF LIST SIGNAL
BE
TAB3
L
7,PSLINK
AR
7,10
STM 7,8,TABTPSAV
SAVE OWN REGISTERS
ST
8,LOSTPL
L
8,TABCRS+4
RESTORE CALLER'S REGISTERS
L
15,TABCRS+8
B
4(15)
TABX
ST
8,TABCRS+4
4(15) CODE RETURNS HERE
LM
7,8,TABTPSAV
BY B TABX
B
TAB1
BY B TABX
TAB3
LA
8,MANENTL(8)
B
TAB0
TAB2
LM
7,8,TABCRS
L
15,TABCRS+8
BR
15
TABCRS DC
3F'0'
TABTRAC'S CALLER'S REGISTERS
TABTPSAV DC
2F'0'
DROP 10
DROP 9
DROP 8
DROP 7
TITLE 'PRINT LOST WORKSPACE MESSAGE'
*
R7 = PERSAVW ADDR
*
R11= WS ADDR
*
LOSTWS PROLOG
USING PERSAVW,7
CLI REJECT-M(11),2
NO MESSAGE IF REJECT=2
BE
LOSTWS2
INDICATING MESSAGE ALREADY PRINTED
L
1,LOSTPL
PERLIB ADDR FOR THIS PERSAVW CHAIN
MVC LWSD(4),LIBNUM-PERLIB(1)
MVC LWSD+4(12),PSNAME SET UP FOR OUTWRT
LA
1,LWSD
LOC OF WSID
SR
0,0
NO TIMESTAMP AVAILABLE
LA
2,=CL9'REJECTED ' ACTION TAKEN
A04
LA
3,=XL1'FF'
NO SNAP ID
ICALL DWSLOG
LOSTWS2 IRETURN
LWSD
DC
XL16'00'
LOSTPL DC
A(0)
ADDR OF PERLIB FOR CURRENT PERSAVW
DROP 7
EJECT

81900000
82080000
82260000
82440000
82620000
82800000
82980000
83160000
83340000
83520000
83700000
83880000
84060000
84240000
84420000
84600000
84780000
84960000
85140000
85320000
85500000
85680000
85860000
86040000
86220000
86400000
86580000
86760000
86940000
87120000
87300000
87480000
87660000
87840000
88020000
88200000
88380000
88560000
88740000
88920000
89100000
89280000
89460000
89640000
89820000
90000000
90180000
90360000
90540000
90720000
90900000
91080000
91260000
91440000
91620000
91800000
91980000
92160000
92340000
92520000

*
HASHVAL
DIRWS
CURWS
ALTWS
REJECT
*
*
CURDIR
UT3WSS
TCCWARK

DC
DC
EQU
EQU
EQU

F'0'
3A(0)
DIRWS+4
DIRWS+8
M

********** NOTE -- WE ASSUME THAT

********** BYTE 0 OF SAVED REG 0
********** IS IRRELEVANT

DC
H'0'
EQU X'40'
UTFLAGS MASK - DOUBLE BUFFERING
EQU 200
MAG TAPE CCW COUNT (FROM MTSECT)
LTORG
COPY DIRSECT
END
./ ADD
NAME=APLUMAIN
MAIN
TITLE 'A P L U T I L I T Y I N I T I A L I Z A T I O N '
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
MACRO
&L
CMD &TXT,&LOC,&PARS,&FLAGS
&L
DC
CL8'&TXT'
DC
AL1(&FLAGS)
DC
AL3(&LOC)
DC
F'&PARS'
MEND
*
*
PRINT OFF
COPY APLDEFN ZSYMBOLS
COPY APLDEFN
COPY ZSYMBOLS
TITLE 'A P L U T I L I T Y C O N T R O L
05/11/70'
PRINT ON
DROP 11
EXTRN ADPAR
ENTRY APLMODAD
EXTRN BILL
EXTRN CDCAD
ENTRY CMD
EXTRN CREATE
EXTRN DIRREAD
EXTRN DIRSET
EXTRN DDUMP
EXTRN DIRWRT
EXTRN DREST
EXTRN FMTDSK
EXTRN IDUMP
EXTRN KMANHASH
EXTRN OPLIB
OPEN ALL LIBRARY PACKS
EXTRN OUTWRT
EXTRN OUTWRTL
ENTRY PARAMS
EXTRN RETRIEVE
EXTRN SELDUMP
EXTRN SELREST
EXTRN TVERIFY
ENTRY UTDATE
EXTRN UTCARD
ENTRY UTFLAGS
EXTRN VERIFY

92700000
92880000
93060000
93240000
93420000
93600000
93780000
93960000
94140000
94320000
94500000
94680000
94860000
95040000
00090000
00180000
00270000
00360000
00450000
00540000
00630000
00720000
00810000
00900000
00990000
01080000
01530000
01620000
01710000
01800000
01890000
01980000
02070000
02160000
02250000
02340000
02430000
02520000
02610000
02700000
02790000
02880000
02970000
03060000
03150000
03240000
03330000
03420000
03510000
03600000
03690000
03780000
03870000
03960000
04050000
04140000
04230000
04320000
04410000

EXTRN WSLEN
EXTRN ZTOV
*
*
*
MAIN

INITIAL ENTRY TO APL UTILITIES

CSECT
SR
15,15
PROVIDE A ZERO RETURN CODE
2214
STM 14,12,12(13)
SAVE OS REGISTERS
BALR 12,0
ADDRESSABILITY
USING *,12
LA
10,4092(12)
SECOND BASE REGISTER.
USING *+4092-4,10
ST
13,OSLINK
SAVE OS SAVE AREA ADDRESS
LM
2,5,DCBADS
OPEN LST,RDR,PCH,WSDUMP
OPEN ((2),(OUTPUT),(3),,(4),(OUTPUT),(5),(OUTPUT))
USING IHADCB,2
TM
DCBOFLGS,X'10'
ENSURE THAT SYSLST WAS OPENED
BO
GETCORE
OPEN WAS SUCCESSFUL
2214
WTO 'APL
SYSPRINT DDCARD MISSING',ROUTCDE=(1,11)
K19
B
CANCEL
DROP 2
SPACE 2
2214
GETCORE EQU *
2214
SPACE 1
2214
L
1,=A(WSLEN)
GET WSLEN FROM CONFIG
2214
L
1,0(1)
2214
LA
1,7(1)
ROUND UP TO DOUBLE WORD
2214
N
1,=F'-8'
2214
ST
1,WLEN
2214
SPACE 2
2214
LA
2,1016+3*32(1,1)
CALCULATE MAXIMUM CORE THAT CAN 2214
AR
2,1
BE USED = 1000+3*WSLEN+32
2214
LA
1,1016+32(1) SET UP PROPER MINIMUM
2214
STM 1,2,SPACE
SAVE MIN AND MAX FOR GETMAIN
2214
GETMAIN VU,LA=SPACE,A=WSLOC GET AS MUCH SPACE AS IS USAB 2214
L
13,WSLOC
TEMP R13 FOR ERROR MESSAGES
2214
LR
14,13
DUMMY START OF STACK ENTRY
2214
USING IHADCB,3
TRYRDR TM
DCBOFLGS,X'10'
WAS RDR OPENED
BO
TRYPCH
CONTINUE IF YES
ICALL OUTWRT
DC
AL4(NORDRMSG)
B
CANCEL
DROP 3
USING IHADCB,4
TRYPCH TM
DCBOFLGS,X'10'
BO
GETTIME
UREC FILES ALL OPENED CORRECTLY
MVI NOBILL,X'FF'
NO PUNCH - PROHIBIT BILLING
*
*
CONVERT CURRENT DATE TO APL FORM AVOIDING THE USE OF
*
PACKED DECIMAL ARITHMETIC FOR THE SAKE OF THE MODEL 91
*
GETTIME TIME DEC
GET PACKED DATE
ST
1,DATE
AND
STH 1,DAY+6
SAVE IT
CVB 1,DAY
FORM BINARY DAY OF YEAR
LM
2,5,INDEX
INDICES FOR CALCULATING MONTH
TM
DATE+1,X'01'
CHECK FOR LEAP YEAR
BO
CMP
THIS IS AN ODD YEAR
TM
DATE+1,X'12'
FIND EVEN NON LEAP YEARS. THIS

04500000
04590000
04680000
04770000
04860000
04950000
05400000
05490000
05580000
05670000
05760000
05850000
08370000
08460000
08550000
08640000
08730000
08820000
08910000
09000000
09090000
09180000
09270000
09450000
09540000
09630000
09720000
09810000
09900000
09990000
10170000
10260000
10350000
10440000
10530000
10620000
10710000
10800000
10890000
10980000
11070000
11160000
11250000
11340000
11430000
11520000
11610000
11700000
11790000
11880000
11970000
12060000
12150000
12240000
12330000
12420000
12510000
12600000
12690000
12780000

BM
CMP
CODE IS VALID UNTIL THE YEAR 2100
CH
1,NUMTH+2(4)
A LEAP YEAR. IS THIS BEFORE FEB 29TH
BL
CMP
YES
BZ
PRT
NO, BUT IT IS FEB 29TH
BCTR 1,0
DATE AFTER 29TH FEB IS 1 DAY TOO HI
CMP
CH
1,NUMTH(4)
IS DAY IN THIS MONTH
BL
DEC
EXIT FROM SEARCH IF YES
BXLE 4,2,CMP
GO TEST NEXT MONTH IN LIST TO DEC.
DEC
SR
4,2
ADJUST MONTH
PRT
SH
1,NUMTH(4)
FORM DAY OF MONTH
AH
1,NUMTH
AR
2,4
FORM BINARY DATE
MR
4,2
(100*MONTH)+DAY
AR
1,5
CVD 1,DECDT
PACKED DECIMAL DATE IN FORM
MVC DECDT+4(1),DATE+1 YY0MMDDS
OI
DECDT+7,X'0F'
L
2,=A(UTDATE)
UNPK DATE(7),DECDT+4(4) WITH INTERSPERSED SLASHES
MVC 0(8,2),=AL1(3,4,7,5,6,7,0,1)
TR
0(8,2),DATE
SPACE 3
2214
* SUBALLOCATE THE CORE AVAILABLE TO THE APL UTILITY
2214
LM
2,3,WSLOC
GET LAST BYTE OF CORE PLUS ONE
AR
2,3
2214
ST
2,SPACE
2214
LA
2,0(2)
2214
S
2,=F'1000'
ALLOW LOTS OF ROOM FOR R13 STACK
L
1,WLEN
GET WORKSPACE SIZE
2214
*
ADD START OF WS1 PLUS
2214
LA
1,32(1,13)
TAPE IO OVERSHOOT AREA
2214
ST
1,WSLOC+4
START OF WS AREA 2
CR
2,1
MAKE SURE WE HAVE ENOUGH CORE TO
BH
MAINE
RUN THE UTILITY AT ALL
ICALL OUTWRTL
INSUFFICIENT CORE STORAGE
2214
DC
AL4(OVFMSG)
CANCEL CANCEL ,
THERE ARE NO REASONS TO CONTINUE.
MAINE
A
1,WLEN
ADD IN WS LENGTH
LA
1,32(1)
TAPE IO MAY OVERSHOOT BY 24
ST
1,WSLOC+8
START OF WS AREA 3
CR
2,1
EVEN IF WE HAVE ROOM FOR ONLY A
BH
MAINC
SINGLE WS AREA, SOME COMMANDS WILLGO
NI
UTFLAGS,255-UT2WSS TURN OFF 2 WSS SWITCH
L
1,WSLOC+4
OI
WSLOC+5,X'80' NO LONGER A VALID ADDRESS
2214
B
MAINC2
THERE WONT BE ENOUGH FOR 3 EITHER
2214
MAINC
A
1,WLEN
ADD IN WS LENGTH
LA
1,32(1)
TAPE IO MAY OVERSHOOT BY 24
CR
2,1
IF WE HAVE ENOUGH CORE LEFT, LET'S
BH
MAIND
USE IT TO DOUBLE BUFFER WSS
L
1,WSLOC+8
END OF SECOND SLOT
2214
MAINC2 EQU *
2214
OI
WSLOC+9,X'80' NO LONGER A VALID ADDRESS
2214
NI
UTFLAGS,255-UT3WSS TURN OFF 3 WSS SWITCH
MAIND
LR
13,1
ESTABLISH REAL R13 STACK
LA
14,16(13)
WITH DUMMY FIRST ENTRY
2214
MVC 0(12,13),=3A(X'800000')
DUMMY FIRST ENTRY
2214
LA
1,1000(14)
CHECK IF SPACE REQD BYT UTILITY
L
0,SPACE
IS LESS THAN THAT ASSIGNED BY GETMN
SR
0,1

12870000
12960000
13050000
13140000
13230000
13320000
13410000
13500000
13590000
13680000
13770000
13860000
13950000
14040000
14130000
14220000
14310000
14400000
14490000
14580000
14670000
14760000
14850000
14940000
15030000
15120000
15300000
15390000
16020000
16470000
16560000
16650000
16740000
16830000
16920000
17010000
17100000
17190000
17280000
17370000
17460000
17550000
17640000
17730000
17820000
17910000
18000000
18090000
18180000
18270000
18360000
18450000
18540000
18630000
18720000
18810000
18900000
19620000
19710000
19800000

BNH NOFREE
SKIP IF NOT
FREEMAIN R,LV=(0),A=(1) IS NOT REQUIRED
NOFREE EQU *
ICALL OUTWRT
PRINT A TIMESTAMP
DC
AL4(MATOD)
BAL 12,MA0
ESTABLISH NEW BASE, START RUN
2214
USING *,12
TELL ASSEMBLER THAT WE HAVE ADDRESS 2214
DROP 10
GET RID OF OLD SECOND BASE REG
2214
NOCORE ICALL OUTWRTL
INSUFFICIENT CORE STORAGE MESSAGE
2214
DC
AL4(OVFMSG)
2214
CANCEL ,
TERMINATE THIS RUN OF THE UTILITY
2214
SPACE 3
2214
APLMODAD DC
F'0'
2214
SPACE 3
2214
MA0
STM 12,14,MASRS SAVESTART OF STACK POINTERS FOR
2214
*
USE BY CCREJ IF CONTROL CARD REJECTED
2214
TITLE 'A P L U T I L I T Y C O N T R O L '
2214
MA1
EQU *
2214
SR
0,0
ASSUME NO ERROR, PREV CONTROL CARD.
MA8
EQU *
2214
L
1,=A(DIRWRT)
RE-ENABLE DIRECTORY WRITES
NI
1(1),X'0F'
IN CASE WE FOLLOW TESTBILL COMMAND
DEQ (QNAME,RNAME,,SYSTEM),RET=HAVE
*
ENSURE APLOS360.LIBRARIES IS NOT ASSIGNED TO APLUTIL
LA
1,CARD
ICALL UTCARD
B
EOJ
END-FILE RETURN
LA
6,CARD
SET UP FOR CARD SCAN
MVI 0(TLR),C' '
BUILD 80 CHARS OF BLANKS TO OR
MVC 1(79,TLR),0(TLR)
LOWERCASE EBCDIC ALPHAS INTO UPPER
OC
CARD(80),0(TLR)
MA2
CLI 0(6),C' '
SKIP TO FIRST NONBLANK COLUMN
BNE MA3
LA
6,1(6)
B
MA2
MA3
CLI 0(6),X'FF'
CHECK FOR END OF CARD
BE
MA1
TOTALLY BLANK
LM
0,2,CMDSCN
LR
7,6
SAVE COMMAND START COLUMN
MVC CMD(8),=XL8'0'
CLEAR COMMAND WORK AREA
2531
VS8
LA
7,1(7)
SCAN TO END OF COMMAND
CLI 0(7),C' '
BNE VS8
FIRST SKIP COMMAND,
LR
5,7
SR
5,6
COMMAND LENGTH
BCTR 5,0
SS
MA4
EX
5,MACLC
BE
MA5
MA13
BXLE 2,0,MA4
GO SCAN NEXT TABLE ENTRY
2531
EX
0,MA5
WERE THERE ANY MATCHES
2531
BNE MA12
BRANCH IF VALID COMMAND
2531
MBC
ICALL OUTWRTL
BAD COMMAND. NOTE ON SYSLOG
DC
AL4(MATX)
BAL 0,MA8
READ NEXT CARD FROM SYSLOG
EOJ
EOJ
MACLC
CLC 0(0,6),0(2)
MA5
CLC CMD(8),=XL8'0'
IS THIS THE FIRST MATCH
2531
BNE MBC
NO-- ABBREV COMMAND NOT UNIQUE 2531
MVC CMD(8),8(2)
MOVE TABLE ENTRY TO WORK
2531
B
MA13
FINISH TABLE SCAN
2531

19890000
19980000
20070000
20250000
20340000
20430000
20520000
20610000
20700000
20790000
20880000
20970000
21060000
21150000
21240000
21330000
21420000
21510000
21600000
21690000
21780000
21870000
22140000
22230000
22320000
22410000
22500000
22590000
22680000
22770000
22860000
22950000
23040000
23130000
23220000
23310000
23400000
23490000
23580000
23670000
23760000
23850000
23940000
24030000
24120000
24210000
24300000
24390000
24480000
24570000
24660000
24750000
24840000
24930000
25020000
25110000
25200000
25290000
25380000
25470000

MA12

VS9

VS11
VS10
VS1

VS3
VS4

VS6
VS5

VS2

EQU
L
LTR
BZ
LR
LA
CLI
BE
LA
XC
B
LA
CLC
BE
LR
CLI
BL
CLI
BE
LA
B
LA
LR
CLI
BE
CLI
BE
CLI
BNL
CLI
BH
CLI
BL
IC
LA
STC
LA
B
SR
CL
BH
EX
L
B
SR
BCTR
CL

*
6,CMD+4
6,6
MA7
6,7
6,1(6)
0(6),C' '
VS9
4,PARAMS+4
PARAMS(76),PARAMS
VS10
6,1(6)
0(2,6),=C'X'''
VS3
7,6
0(6),C'0'
VS2
0(6),X'FF'
VS2
6,1(6)
VS1
6,2(6)
7,6
0(6),C''''
VS5
0(6),X'FF'
MBC
0(6),C'0'
VS6
0(6),C'F'
MBC
0(6),C'A'
MBC
5,0(6)
5,X'FF'-C'F'(5)
5,0(6)
6,1(6)
VS4
6,7
6,=F'8'
MBC
6,VSHPK
0,VTEMP
VS7
6,7
6,0
6,=F'9'

BH
EX
CVB
ST
LA
LA
CLI
BE
CLI
BE
CLI
BNE

MBC
6,VSDPK
0,VTEMP
0,0(4)
4,4(4)
6,1(6,7)
0(6),C','
VS11
0(6),C' '
VS12
0(6),X'FF'
MBC

VS7

2531 25560000
25650000
25740000
ZERO PARAMETERS
25830000
25920000
26010000
SKIP BLANKS FOLLOWING COMMAND
26100000
26190000
26280000
26370000
26460000
SKIP OVER COMMA
26550000
IS NEXT OPERAND HEX -26640000
26730000
NO. RECORD START ADDRESS.
26820000
26910000
SKIP TO END OF DECIMAL NUMBER
27000000
ARE WE AT END OF BUFFER
27090000
YES, COLLECT LAST DIGIT
27180000
27270000
27360000
HEX CONVERSION. SKIP X'
27450000
27540000
HAVE WE REACHED END -27630000
YES.
27720000
ARE WE AT END OF CARD
27810000
YES, ERROR. HE FORGOT ENDING '
27900000
NO, IS NEXT CHAR NUMERIC
27990000
YES
28080000
IT HAD BETTER BE ABCDEF
28170000
28260000
28350000
28440000
MAKE LOW-ORDER 4 BITS
28530000
HEX ABCDEF
28620000
28710000
28800000
28890000
28980000
29070000
NO MORE THAN 8 DIGITS
29160000
PACK TO A 4-BYTE NUMBER WITH FIFTH 29250000
GARBAGE BYTE IGNORED
29340000
REJOIN COMMON CODE
29430000
GET CONSTANT LENGTH
29520000
SS FORMAT
29610000
NOTE CHECK HERE FOR NONEXISTENT CON 29700000
MAPPED INTO COUNT OF -1
29790000
29880000
PACK CONSTANT
29970000
AND CONVERT.
30060000
REENTRY FOR HEX CONSTANTS
30150000
BUMP TO NEXT OPERAND LOCATION
30240000
RESTORE CHARACTER POINTER
30330000
IS NEXT CHAR A COMMA -30420000
YES. CONVERT ANOTHER OPERAND.
30510000
IT HAD BETTER BE A BLANK
30600000
30690000
OR COLUMN 81
30780000
30870000

VS12

*
MA7
SKPOPN

*
*
MA9B

MA9
MA6

MA11
CHKPCH

EXECRT

MA10

WSLIST

WSDUMP

S
4,=A(PARAMS+4)
SRL 4,2
FIND NUMBER OF OPERANDS CONVERTED
L
1,=A(PARAMS)
ST
4,0(1)
CL
4,CMD+4
IS IT SUFFICIENT -BL
MBC
NO.
LOCATE APL LIBRARY USING VTOC
TS
OPFLAG
ARE LIBRARIES OPEN
BNZ SKPOPN
DO IT ONLY ONCE
ICALL OPLIB
OPEN ALL LIBRARIES
L
2,=A(CDCAD)
USING CDCAD,2
USING CDCPARS,8
L
8,=A(ADPAR)
L
8,0(8)
MVC CDCAD+4(4),TLENF
DROP 2,8
TM
CMD,CMWAPL
IF COMMAND IS ALLOWED WHILE APL
BO
MA9
IS RUNNING, OK.
ENQ (QNAME,RNAME,E,,SYSTEM),RET=USE
ASSIGN APLOS360.LIBRARIES TO APLUTIL IF POSSIBLE
LTR 15,15
WAS IT ASSIGNED
IF IT WAS NOT, THEN PRESUMABLY APL PROGRAM HAS IT
BE
MA9
BRANCH IF APL NOT RUNNING
MVC MATX,=C'INVALID -- APL RUNNING '
ICALL OUTWRTL
NOTE REJECTION ON SYSLOG.
DC
AL4(MATX)
MVC MATX,=C'INCORRECT CONTROL CARD '
BAL 0,MA8
GIVE OPERATOR A CHANCE TO FIX IT UP
TM
CMD,CMNORD
SHOULD WE SKIP DIRECTORY READ -BO
MA6
YES
ICALL DIRSET
TM
CMD,CM1WS
IF THIS COMMAND USES ONLY 1 WS, WE
BO
MA11
KNOW WE HAVE ENOUGH CORE.
TM
UTFLAGS,UT2WSS
ALL COMMANDS WILL WORK WITH 2 SLOTS
BZ
NOCORE
ONLY 1 SLOT, CANCEL WITH ERR MSG
L
1,CMD
CALL APPROPRIATE ROUTINE
TM
CMD,CMPCH
BZ
EXECRT
BRANCH IF NO PUNCH IS REQUIRED.
CLI NOBILL,0
PUNCH MUST BE AVAILABLE FOR BILLING
BE
EXECRT
OR TESTBILLING
ICALL OUTWRTL
DC
AL4(NOBILMSG)
B
MA1
EQU *
TM
CMD,CMMOD
BZ
MA10
CLC APLMODAD,=F'0'
BZ
MBC
BALR 15,1
B
MA1
SPACE 2
USING WSLIST,1
OI
UTFLAGS,UTWSLST
ASK MTSECT TO LOG WS FILE LABEL IN
BR
15
DUMP OR RESTORE OPERATIONS
DROP 1
SPACE 2
USING WSDUMP,1
USING IHADCB,6
L
6,=A(WSDMPDCB)
ADDR OF WSDUMP DCB

30960000
31050000
31140000
31230000
31320000
31410000
31500000
31590000
31680000
31770000
31860000
31950000
32040000
32130000
32220000
32310000
32400000
32490000
32580000
34830000
34920000
35010000
35100000
35190000
35370000
35460000
35550000
35640000
35730000
35820000
35910000
36000000
36090000
36180000
36270000
36360000
36450000
36630000
36720000
36810000
36900000
36990000
37080000
37170000
37260000
37350000
37440000
37530000
37620000
37710000
37800000
37890000
37980000
38070000
38160000
38250000
38340000
38430000
38970000
39060000

TM
BO
LR
ICALL
DC
BR
WSDUMPOK OI
*
BR
DROP
DROP
SPACE
ENTRY
CCREJ
BALR
*
USING
LM
DROP
BAL
*
*
USING
INHIB
ICALL
DC
L
OI
L
DROP
B
TBWARN DC
DC
*
CMDSCN DC
*
CMNORD EQU
CMWRD
EQU
CMRST
EQU
CMMOD
EQU
CMWAPL EQU
CMPCH
EQU
CM1WS
EQU
CMDT
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMD
CMDE
EQU
MASRS
DC
VSDPK
PACK
VSHPK
PACK

DCBOFLGS,X'10'
WSDUMPOK
6,15
OUTWRT
AL4(WSDMPERR)
6
UTFLAGS,UTWSDMP

WAS DCB OPENED SUCCESSFULLY?

BRANCH IF YES
SAVE RETURN REG THRU ICALL
NO, PUT NASTY MESSAGE ON SYSPRINT
AND CONTINUE WITHOUT WSDUMP.
RETURN TO CALLER
SET FLAGS TO CAUSE REJECTED WS
TO BE DUMPED IN HEX.
RETURN TO CALLER

39150000
39240000
39330000
39420000
39510000
39600000
39690000
39780000
15
39870000
6
39960000
1
40140000
2
40230000
CCREJ
RE-ENTRY AFTER CONTROL CARD REJECTED 40320000
1,0
BY ONE OF MAIN'S SUBROUTINES
40410000
E.G. DUMP DOESN'T LIKE RECORD LGTH 40500000
*,1
40590000
12,14,MASRS
RECALL R13 STACK POSITION
40680000
1
40770000
0,MA8
READ NEXT CARD FROM SYSLOG
40860000
40950000
41040000
INHIB,1
DO A TEST BILLING
41130000
OUTWRTL
DON'T LOSE OUR INTEGRITY WITHOUT
41220000
AL4(TBWARN)
A STRUGGLE
41310000
2,=A(DIRWRT)
41400000
1(2),X'F0'
INHIBIT DIRECTORY WRITES
41490000
1,=A(BILL)
THEN BEHAVE LIKE BILLING COMMAND
41580000
1
41670000
MA10
41760000
C'APL BILLING TEST -- USE OUTPUT ONLY FOR DEBUGGING'
41850000
X'FF'
41940000
42030000
A(16,CMDE,CMDT)
42120000
COMMAND BIT MEANINGS -42210000
X'80'
SKIP DISK DIRECTORY READ
42300000
X'40'
REWRITE DISK DIRECTORIES
42390000
X'20'
RESET ACCOUNTING INFORMATION
42480000
X'10'
ALTER EACH WORKSPACE DURING RESTORE 42570000
X'08'
ALLOW COMMAND WHILE APL IS RUNNING 42660000
X'04'
THIS OPERATION PUNCHES CARDS
42750000
X'02'
ONLY 1 WS SLOT NEEDED
42840000
DUMP,DDUMP,1,0
42930000
INCDUMP,IDUMP,1,0
43020000
RESTORE,DREST,0,CMNORD+CMWRD
43110000
ACCTG,ACCOUNT,1,CMWAPL
43200000
BILLING,BILL,0,CMWRD+CMRST+CMPCH
43290000
DISKFMT,FMTDSK,1,CMNORD
43380000
CREATE,CREATE,0,CMNORD+CMWRD
43470000
SELREST,SELREST,0,CMWRD
43560000
SELDUMP,SELDUMP,1,CMNORD+CMWAPL
43650000
RETRIEVE,RETRIEVE,0,CMWRD
43740000
TESTBILL,INHIB,0,CMWAPL+CMPCH
43830000
TVERIFY,TVERIFY,0,CMNORD+CMWAPL
2214 43920000
VERIFY,VERIFY,1,CMNORD+CMWAPL
44010000
WSLIST,WSLIST,0,CMNORD+CMWAPL+CM1WS
44100000
WSDUMP,WSDUMP,0,CMNORD+CMWAPL+CM1WS
44190000
*-1
44280000
3F'0'
SAVED R12, R13, R14 FOR MAIN
44370000
VTEMP(8),0(0,7)
44460000
VTEMP(5),0(0,7)
44550000

VTEMP
UTDATE
CMD
MATOD
UTFLAGS
UTWSLST
UT3WSS
UTWSDMP
UT2WSS
NOBILL
OPFLAG
*
ALIBPZ
ALIBPARS
AAPLSDCB
AMANHASH
AWSLEN
ADIRTAB
*
NORDRMSG
NOBILMSG
WSDMPERR
*
SPACE
DCBADS
QNAME
RNAME
OSLINK
DECDT
DAY
DATE
INDEX
NUMTH
MATX
CARD
OVFMSG
MAIN
*
*
ACCOUNT

DC
DC
DC
DC
DC
EQU
EQU
EQU
EQU
DC
DC
ENTRY
EXTRN
ENTRY
DC
DC
DC
DC
DC
DC
ERROR
DC
DC
DC
DC
DC

D'0'
44640000
CL8' '
MM/DD/YY IN EBCDIC FOR UTILITY
44730000
2F'0'
UTILITY COMMAND WORK AREA
2531 44820000
X'14FF'
'PAGE HEADING' IN MIDDLE OF PAGE
44910000
AL1(UT2WSS+UT3WSS) UTILITY FLAG BYTE
45000000
X'80'
WSLIST FLAG
45090000
X'40'
DOUBLE BUFFERING FLAG (3 WS SLOTS) 45180000
X'20'
DUMP REJECTED WSS TO SYSLST
45270000
X'10'
SINGLE BUFFERING FLAG (2 WS SLOTS) 45360000
X'00'
45450000
X'00'
45540000
POINTS REQUIRED UNDER OS FOR OPLIB,NOPEN,DSKFMT
47250000
LIBPZ,LIBPARS,APLSDCBS,DIRTAB
47340000
ALIBPZ,ALIBPARS,AAPLSDCB,AMANHASH,AWSLEN,ADIRTAB
47430000
A(LIBPZ)
47520000
A(LIBPARS)
47610000
A(APLSDCBS)
47700000
A(KMANHASH)
47790000
A(WSLEN)
47880000
A(DIRTAB)
47970000
MESSAGE FOR APL UNDER OS
48060000
C'SYSIN DD STATEMENT OMITTED'
48150000
X'FF'
48240000
C'NO BILLING - SYSPUNCH DD STATEMENT OMITTED'
48330000
X'FF'
48420000
C'UNABLE TO OPEN WSDUMP DATA SET -- WSDUMP CONTROL CARD X48510000
IGNORED'
48600000
DC
X'FF'
48690000
DATA REQD BY OS MAIN ONLY
48780000
DC
A(8,X'FFFFF8')
48870000
DC
A(PRTDCB,RDRDCB,PCHDCB,WSDMPDCB)
48960000
EXTRN PRTDCB,RDRDCB,PCHDCB,WSDMPDCB
49050000
DC
C'APLOS360'
49140000
DC
C'LIBRARIES'
49230000
DS
F
49320000
DS
D
49410000
DC
D'0'
49500000
DS
CL7
49590000
DC
C'/'
49680000
DC
A(2,22,2,50)
49770000
DC
H'1,32,60,91,121,152,182,213,244,274,305,335'
49860000
DC
C'INCORRECT CONTROL CARD ' MUST PRECEDE 'CARD'
50040000
DS
80C
50130000
DC
X'FF'
COL 81
50220000
DC
C'INSUFFICIENT CORE STORAGE'
50310000
DC
X'FF'
50400000
DCBD DSORG=PS,DEVD=DA
50670000
CSECT
50760000
TITLE 'APL UTILITY ACCOUNTING SUMMARY
05/11/70' 50940000
51030000
PRINT ACCOUNTING INFORMATION ON SYSLST.
51120000
USING M,11
51210000
PROLOG
51300000
L
1,=A(KMANHASH)
51390000
L
1,0(1)
51480000
ST
1,MANHASH
51570000
L
1,AWS1
51660000
A
1,ACTWL
51750000
S
1,=A(MANENTL)
51840000
ST
1,ACTSZ
51930000

LA

3,MANENTL+5*PSWL

M
S
SR
DR
ST
XC
XC
ICALL
ICALL
DC
USING
L
LR
SR
ST
MVC
L
LA
ST
L
LA
ST
SR
ST
ICALL
L
L
LA
B

2,MANHASH
1,AWS1
0,0
0,3
1,ACTDIV
TCUMCON(16),TCUMCON
TWSS(16),TWSS
DIRSET
OUTWRT
AL4(ACHD)
PERLIB,2
11,AWSD
10,11
1,1
1,ACNO
ACFIG,ACM1
1,AWS1
1,8(1)
1,ACWSPT
4,ACTSZ
1,MANENTL(4)
1,ACTBL
1,1
1,DIRNO
DIRREAD
0,ACNO
5,ACTDIV
5,1(5)
ACST1

ACST9
ACST13

ACST8

*
ACST2

ACST10

ACST11

GUESS THE APPROPRIATE NUMBER OF

ENTRIES TO EXTRACT FROM EACH DIR
5 WS PER MAN IS REASONABLE AVERAGE
EFFECTIVE WS LENGTH

CLEAR COUNTERS INITIALLY

PRINT HEADING

FIRST NO IGNORED IS STARTING POINT

BUILD MAN ENTRIES FROM TOP DOWN

TABLE INITIALLY EMPTY

BRING IN NEXT DIRECTORY

GUARANTEE POSITIVE
LOAD UP TO (R5)-1 ENTRIES FROM THIS
DIRECTORY INTO ACTBL
ST
4,ACTBL
NEW BOTTOM OF MAN TABLE
MVC 0(MANENTL,4),PERLIB MOVE THIS MAN INTO TABLE
L
1,ACWSPT
MOVE HIS WSS INTO WS1 AREA
LR
6,1
S
6,AWS1
CLC LIBLINK-PERLIB(4,4),ZEROA
ANY WORKSPACES SAVED Q
MVC LIBLINK-PERLIB(4,4),ZEROA
BE
ACST12
NO.
ST
6,LIBLINK-PERLIB(4) YES. POINT PERLIB AT WS1 AREA
LA
3,PSWL(1)
CHECK FOR MAN, PERSAVW TABLE OVERLAP
C
3,ACTBL
BL
ACST11
L
0,DIRNO
NOT ENOUGH SPACE. DECREASE THE
LTR 1,0
NUMBER OF EXTRACTIONS PER DIRECTORY
BNZ *+8
IN PROPORTION TO THE NUMBER OF
LA
0,1
DIRECTORIES NOT PROCESSED IN THIS
SRDA 0,1
PASS.
D
0,MANHASH
NOTE MIDPOINT SCALING
M
0,ACTDIV
SLDA 0,1
ST
0,ACTDIV
B
ACST13
CLC PSLINK-PERSAVW(4,2),ZEROA ANY MORE PERSAVWS TO BE MOVED
BE
ACST12
NO. LINK IS ZERO.
L
2,PSLINK-PERSAVW(2)
AR
2,MR
MVC 0(PSWL,1),0(2)
LA
1,PSWL(1)
ADVANCE WS1 AREA POINTER

52020000
52110000
52200000
52290000
52380000
52470000
52560000
52650000
52740000
52830000
52920000
53010000
53100000
53190000
53280000
53370000
53460000
53550000
53640000
53730000
53820000
53910000
54000000
54090000
54180000
54270000
54360000
54450000
54540000
54630000
54720000
54810000
54900000
54990000
55080000
55170000
55260000
55350000
55440000
55530000
55620000
55710000
55800000
55890000
55980000
56070000
56160000
56250000
56340000
56430000
56520000
56610000
56700000
56790000
56880000
56970000
57060000
57150000
57240000
57330000

ACST12
ACST1
*
ACST5
*
*
*

ACST4
ACST3

ACST6
ACST7

ACC5

ACC6

ACC7
ACC0

ACC4

ST
B
S
L
AR
LA

1,ACWSPT
ACST10
4,=A(MANENTL)
ADVANCE MAN TABLE POINTER
1,MANSTAR
1,11
ABSOLUTE
2,PERLIB-LIBNUM+ACM1
POINT R2 AT MAN NO. INFINITY (OR -1)
CLC LIBNUM-PERLIB(,1),ACM1
BE
ACST3
IF THIS IS NOT END MARKER (-1),
ACCEPT MAN ONLY IF REJECTED ON LAST
PASS AND SMALLER THAN SMALLEST NO
SO FAR ON THIS PASS.
C
0,LIBNUM-PERLIB(1) NOTE -1 COMPARES LOW
BNL ACST4
CLC LIBNUM-PERLIB(,1),LIBNUM
BH
ACST4
NOTE -1 COMPARES HIGH
LR
2,1
LA
1,MANENTL(1)
B
ACST5
L
0,LIBNUM
CL
0,ACM1
IF NO ENTRIES,
BE
ACST6
LOOK NO FARTHER.
BCT 5,ACST2
ENTER 1/MANHASH OF THE ENTRIES
CL
0,ACFIG
ACFIG IS LOWEST NO. REJECTED THIS
BH
ACST7
PASS (-1 IS HIGH)
ST
0,ACFIG
L
1,DIRNO
LA
1,1(1)
ADVANCE DIRECTORY NUMBER
C
1,MANHASH
BL
ACST8
DROP 2
L
8,ACTBL
USING PERLIB,8
LR
7,8
L
1,ACNO
PREVIOUS MAN NUMBER PROCESSED
L
2,=F'-1'
INFINITY
L
3,LIBNUM
SEARCH TABLE FOR MAN NUMBER NEXT LAR
C
8,ACTSZ
GER THAN THE ONE PREVIOUSLY PRINTED.
BH
ACC0
CLR 1,3
BNL ACC7
CLR 2,3
BL
ACC7
LR
2,3
LR
7,8
LA
8,MANENTL(8)
B
ACC6
MVC ACLINE,ACPAT
LR
8,7
L
1,ACFIG
CLR 2,1
BL
ACC4
NUMBER FOUND, LESS THAN LIMIT
CL
1,ACM1
EQUAL OR PAST LIMIT. IS LIMIT (1ST
BE
ACC8
NO. IGNORED) -1 -- IF SO, SUMMARIZE
BCT 1,ACST9
OTHERWISE, TAKE ANOTHER PASS
ST
2,ACNO
SAVE NUMBER BEING PRINTED
CLI PARAMS+3,2
IF LISTING OF ONLY A SELECTED DIR
BL
ACC3
WAS REQUESTED, MAKE SURE THIS USER
SR
0,0
BELONGS IN THAT DIRECTORY.
LR
1,2

57420000
57510000
57600000
57690000
57780000
57870000
57960000
58050000
58140000
58230000
58320000
58410000
58500000
58590000
58680000
58770000
58860000
58950000
59040000
59130000
59220000
59310000
59400000
59490000
59580000
59670000
59760000
59850000
59940000
60030000
60120000
60210000
60300000
60390000
60480000
60570000
60660000
60750000
60840000
60930000
61020000
61110000
61200000
61290000
61380000
61470000
61560000
61650000
61740000
61830000
61920000
62010000
62100000
62190000
62280000
62370000
62460000
62550000
62640000
62730000

ACC3

ACC1A

ACC1

ACC2

ACC1B

ACCW2

D
C
BNE
CVD
EDMK
CL
BNL
MVC
B
SR
IC
TM
BZ
MVI
BCTR
CL
BL
LA
EX
L
EX
L
AL
ST
BC
L
LA
ST
L
LA
BAL
L
AL
ST
BC
L
LA
ST
L
LA
BAL
LA
A
ST
L
LR
A
SR
SR
LTR
BZ
LA
MVC
A
CLC
BNE
MVC
L
LA
B

0,MANHASH
0,PARAMS+8
ACC5
2,ATEMP
ACMAN,ATEMP+2
2,=F'1000'
PUBLIC OR PRIVATE -ACC1A
ACCON(L'ACCON+L'ACCOM),ACCON-1 YES. ERASE ACCOUNTING.
ACC1B
1,1
1,HISNAME
PLMISC,LIBLOCK
IF USER IS CURRENTLY LOCKED OUT,
*+8
ACNAME-1,C'*'
NOTE EXCLUSION BY AN ASTERISK
1,0
1,=F'11'
MOVE MAX 11 CHARS
*+8
1,10
1,ACMV
2,=A(ZTOV)
1,ACTR
1,CUMCON
1,TCUMCON+4
1,TCUMCON+4
12,ACC1
1,TCUMCON
1,1(1)
1,TCUMCON
1,CUMCON
2,ACCON
15,ACRC
1,CUMCOM
1,TCUMCOM+4
1,TCUMCOM+4
12,ACC2
1,TCUMCOM
1,1(1)
1,TCUMCOM
1,CUMCOM
2,ACCOM
15,ACRC
0,1
BUMP THE COUNT OF USERS
0,TACCT
0,TACCT
3,LIBLINK
2,3
3,AWS1
0,0
1,1
2,2
ACCW1
END OF PERSAVW'S
1,1(1)
WS COUNT
ACW1+3(1),PSLEN-PERSAVW(3)
0,ACW1
TRACK COUNT
PSNAME-PERSAVW(9,3),QZCONT
*+10
ATTACH '+1' TO WS COUNT IF CONTINUE
ACWSCONT,=C'+1'
EXISTS. MANWSA DOESN'T INCLUDE IT.
2,PSLINK-PERSAVW(3)
3,PSWL(3)
BUMP TO NEXT PERSAVW
ACCW2

62820000
62910000
63000000
63090000
63180000
63270000
63360000
63450000
63540000
63630000
63720000
63810000
63900000
63990000
64080000
64170000
64260000
64350000
64440000
64530000
64620000
64710000
64800000
64890000
64980000
65070000
65160000
65250000
65340000
65430000
65520000
65610000
65700000
65790000
65880000
65970000
66060000
66150000
66240000
66330000
66420000
66510000
66600000
66690000
66780000
66870000
66960000
67050000
67140000
67230000
67320000
67410000
67500000
67590000
67680000
67770000
67860000
67950000
68040000
68130000

ACCW1

ACCW3

ACA2

ACA1

L
AR
ST
LH
CVD
EDMK
L
AR
ST
LH
CVD
EDMK
CLC
BH
CLI
BE
MVC
MVC
SR
CVD
EDMK
A
ST
ICALL
DC
CLI
BE
L
LTR
BZ
A
MVI
MVC
SR
IC
BCTR
CL
BL
LA
EX
L
EX
L
CL
BE
CVD
MVC
EDMK
LH
SR
D
MVC
STC
L
STC
SRL
STH
IC
STC
ICALL

2,TWSS
2,1
2,TWSS
CUMULATIVE WORKSPACES
1,MANWSA
1,ATEMP
ACWSS,ATEMP+5
2,TTRK
2,0
2,TTRK
3,MANWSQ
QUOTA
3,ATEMP
ACQUOT,ATEMP+5
ACNO,=F'1000'
ACCW3
PARAMS+7,0
ACC5
ACWSS,=CL7' '
ACQUOT,=CL7' '
3,3
0,ATEMP
ACTRK,ATEMP+4
3,TQUOT
3,TQUOT
OUTWRT
AL4(ACLINE)
PARAMS+7,0
PRINTING WSNAMES -ACC5
NO.
3,LIBLINK
YES.
3,3
ANY SAVED WORKSPACES -ACCP5
NO.
3,AWS1
ACLINE,C' '
ACLINE+1(L'ACLINE-1),ACLINE
2,2
2,PSNAME-PERSAVW(3)
2,0
2,=F'11'
*+8
MOVE MAX 11 CHARS
2,10
2,ACAMV
1,=A(ZTOV)
2,ACATR
2,PSMAN-PERSAVW(3)
2,ACNO
ACA1
2,ATEMP
ACAMPAT,ACPAT
ACAMPAT,ATEMP+2
1,PSFILE-PERSAVW(3)
0,0
SCALE TO FILE NUMBER TO BE USEFUL
0,=A(CDCL)
ACDISK,ACDKPAT
MOVE IN PATTERN
DASD
1,ACDFILE
FILE NUMBER
1,PSCYL-PERSAVW(3)
DASD
1,ACDTRK
TRACK NUMBER
1,16
1,ACDCYL
CYLINDER NUMBER
DASD
1,PSLEN-PERSAVW(3)
DASD
1,ACDLNGTH
WS LENGTH IN TRACKS
OUTWRT

68220000
68310000
68400000
68490000
68580000
68670000
68760000
68850000
68940000
69030000
69120000
69210000
69300000
69390000
69480000
69570000
69660000
69750000
69840000
69930000
70020000
70110000
70200000
70290000
70380000
70470000
70560000
70650000
70740000
70830000
70920000
71010000
71100000
71190000
71280000
71370000
71460000
71550000
71640000
71730000
71820000
71910000
72000000
72090000
72180000
72270000
72360000
72450000
72540000
72630000
72720000
72810000
72900000
72990000
73080000
73170000
73260000
73350000
73440000
73530000

ACCP5
ACC8

ACD1

DC
CLC
LA
BNE
ICALL
DC
B
MVC
LM
LA
BAL
LM
LA
BAL
L
CVD
EDMK
L
CVD
EDMK
L
CVD
EDMK
L
CVD
EDMK
ICALL
DC
ICALL
DC
ICALL
DC
SR
LR
ICALL
MVC
CVD
EDMK
L
LA
SR
LR
SR
D
CVD
EDMK
LR
L
L
S
LA
MR
DR
SR
DR
AR
CVD
EDMK
L
S

AL4(ACLINE)
PSLINK-PERSAVW(4,3),ZEROA TEST FOR END OF LIST
3,PSWL(3)
ADVANCE TO NEXT PERSAVW
ACA2
PRINT IT IF IT EXISTS
OUTWRT
PRINT A BLANK LINE BETWEEN USERS
AL4(ACJFUA)
ACC5
ACMAN,FUASRL
0,1,TCUMCON
PRINT TOTAL CONNECTED, COMPUTE
2,ACCON
15,ACRC+2
0,1,TCUMCOM
2,ACCOM
15,ACRC+2
1,TACCT
TOTAL NUMBER OF USERS
1,ATEMP
ACMAN+6(6),ATEMP+5
1,TWSS
1,ATEMP
TOTAL WORKSPACES
ACWSS,ATEMP+5
1,TTRK
1,ATEMP
ACTRK,ATEMP+4
TOTAL TRACKS
1,TQUOT
1,ATEMP
ACQUOT,ATEMP+5
TOTAL QUOTATA
OUTWRT
AL4(ACJFUA)
OUTWRT
AL4(ACLINE)
OUTWRT
PRINT REMAINING-SPACE INFORMATION
AL4(ACDHD)
FOR EACH DIRECTORY
5,5
1,5
NEXT DIRECTORY NUMBER
DIRREAD
ACLINE(L'ACDPAT),ACDPAT
5,ATEMP
ACDIRNO-ACDPAT+ACLINE,ATEMP+6 DIRECTORY NUMBER
1,DSNXTF
FIRST CALCULATE SPACE REQUIRED BY
0,FIRSTENT-M
1,0
THE 'TYPICAL USER'
LKR,1
AS TOTAL PERSAVW SPACE / MAN ENTRIES
0,0
0,=A(PSWL)
1,ATEMP
ACNWSS-ACDPAT+ACLINE,ATEMP+5 WSS NOW IN USE
1,LKR
3,PARREL
3,PARREL
AS TOTAL PERSAVW SPACE / MAN ENTRIES
3,MANSTAR
4,MANENTL
PLUS MANENTL
0,4
0,3
2,2
2,4
R3 IS NO. OF PERLIBS
4,1
NOW R4 IS TYPICAL SPACE REQUIREMENT
3,ATEMP
ACNUS-ACDPAT+ACLINE,ATEMP+5
3,MANSTAR
3,DSNXTF
ACTUAL REMAINING SPACE IN DIRECTORY

73620000
73710000
73800000
73890000
73980000
74070000
74160000
74250000
74340000
74430000
74520000
74610000
74700000
74790000
74880000
74970000
75060000
75150000
75240000
75330000
75420000
75510000
75600000
75690000
75780000
75870000
75960000
76050000
76140000
76230000
76320000
76410000
76500000
76590000
76680000
76770000
76860000
76950000
77040000
77130000
77220000
77310000
77400000
77490000
77580000
77670000
77760000
77850000
77940000
78030000
78120000
78210000
78300000
78390000
78480000
78570000
78660000
78750000
78840000
78930000

LR
SR
DR
CVD
EDMK
SRDA
D
CVD
EDMK
L
*
*
ACD2

ACD6

ACD5
ACD5A

ACD3

ACD4

ACMV
ACTR
ACRC

0,3
2,2
FIND HOW MANY ADDITIONAL TYPICAL
2,4
USERS WE COULD FIT HERE
3,ATEMP
ACDUS-ACDPAT+ACLINE,ATEMP+5
0,32
SAME CALCULATION FOR ADDITIONAL
0,=A(PSWL)
WORKSPACES BUT NO MORE USERS
1,ATEMP
ACDWS-ACDPAT+ACLINE,ATEMP+5
8,MANSTAR
REPEAT THESE CALCULATIONS,
ASSUMING THAT SPACE MUST BE RESERVED
FOR ALL WS QUOTA NOT IN USE.
SR
3,3
L
1,LIBNUM-PERLIB(8,MR)
LTR 1,1
END OF PERLIBS
BM
ACD5A
C
1,=F'1000'
BNH ACD5
AH
3,MANWSQ-PERLIB(8,MR)
SH
3,MANWSA-PERLIB(8,MR) QUOTA MINUS ACTUAL
L
9,LIBLINK-PERLIB(8,MR)
BXLE 9,MR,ACD5
LOOK FOR ABSENCE OF CONTINUE
CLC PSNAME-PERSAVW(9,9),QZCONT
BE
ACD5
L
9,PSLINK-PERSAVW(9)
BXH 9,MR,ACD6
LA
3,1(3)
LA
8,MANENTL(8)
B
ACD2
M
2,=A(0-PSWL)
A
3,MANSTAR
S
3,DSNXTF
R3 = UNBOOKED SPACE (MAYBE NEGATIVE)
LR
0,3
WE'LL NEED IT LATER
M
2,=F'1'
DR
2,4
CVD 3,ATEMP
EXTRA USERS TO ADD
LA
1,OBDUS+L'OBDUS-1-ACDPAT+ACLINE
EDMK OBDUS-ACDPAT+ACLINE,ATEMP+5
BNM ACD3
BCTR 1,0
MVI 0(1),C'-'
SRDA 0,32
SEE THE DIFFERENT TECHNIQUES
D
0,=A(PSWL)
ADDITIONAL WORKSPACES
CVD 1,ATEMP
LA
1,OBDWS+L'OBDWS-1-ACDPAT+ACLINE
EDMK OBDWS-ACDPAT+ACLINE,ATEMP+5
BNM ACD4
ALSO POSSIBLY NEGATIVE
BCTR 1,0
MVI 0(1),C'-'
ICALL OUTWRT
DC
AL4(ACLINE)
LA
5,1(5)
ADVANCE DIRECTORY NUMBER
C
5,MANHASH
BL
ACD1
ICALL OUTWRT
DC
AL4(ACHDND)
PAGE SKIP, NO HEADING
IRETURN
MVC ACNAME(0),HISNAME+1
TR
ACNAME(0),0(2)
ZTOV
SR
0,0

79020000
79110000
79200000
79290000
79380000
79470000
79560000
79650000
79740000
79830000
79920000
80010000
80100000
80190000
80280000
80370000
80460000
80550000
80640000
80730000
80820000
80910000
81000000
81090000
81180000
81270000
81360000
81450000
81540000
81630000
81720000
81810000
81900000
81990000
82080000
82170000
82260000
82350000
82440000
82530000
82620000
82710000
82800000
82890000
82980000
83070000
83160000
83250000
83340000
83430000
83520000
83610000
83700000
83790000
83880000
83970000
84060000
84150000
84240000
84330000

ACHD

AL
BC
A
D
SR
D
LR
SR
D
LR
M
AR
M
AR
CVD
EDMK
BR
DC

ACHDND
ACDHD

DC
DC

ACDPAT DS
ACDIRNO DC
DC
ACNUS
DC
ACNWSS DC
DC
ACDUS
DC
ACDWS
DC
DC
OBDUS
DC
OBDWS
DC
DC
FUASRL DC
DS
ACDKPAT DC
DC
DC
DC
DC
DC
DC
DC
DC
ACDZ
EQU
ACPAT
DC
DC
ACTIMPAT DC
DC
DC
DC
DC
DC
DC
ACLINE DS
DS
ACMAN
DS
DS
ACNAME DS

1,=F'150'
84420000
12,*+8
ROUND UP IN DOUBLE PRECISION
84510000
0,=F'1'
84600000
0,=F'300'
CONVERT TIME FROM 300THS OF SECS
84690000
0,0
TO DECIMAL HOURS , MINS, SECS
84780000
0,=F'60'
84870000
4,0
84960000
0,0
85050000
0,=F'60'
85140000
3,0
85230000
0,=F'100'
85320000
1,3
85410000
0,=F'100'
85500000
1,4
85590000
1,ATEMP
85680000
0(L'ACCON,2),ATEMP+3
85770000
15
85860000
C'
ACCOUNT NO.
NAME
CONNECT TIME
CPU.85950000
TIME
WSS
TRACKS QUOTA
'
86040000
X'14FE'
PAGE HEADING END TEXT
86130000
C'DIRECTORY NO. LIBS, WSS -- CURRENT
IN REMAINI.86220000
NG SPACE
IN UNBOOKED SPACE',X'14FE'
86310000
0CL(L'ACDHD+1)
86400000
X'40404040202120'
86490000
CL19' '
86580000
X'402020202120'
86670000
X'402020202120'
86760000
CL10' '
86850000
X'402020202120'
86940000
X'402020202120'
87030000
CL12' '
87120000
X'402020202120'
87210000
X'402020202120'
87300000
X'FF'
87390000
C' TOTAL ',X'2020202120'
87480000
0H
DASD 87570000
C'LIB '
DASD 87660000
X'120040'
FILE NUMBER
DASD 87750000
C'CYL '
DASD 87840000
X'10'
DASD 87930000
2H'0'
CYLINDER NUMBER
DASD 88020000
C' TRK '
DASD 88110000
X'120040'
TRACK NUMBER
DASD 88200000
C'LEN '
DASD 88290000
X'120040FF'
WS LENGTH IN TRACKS
DASD 88380000
*
DASD 88470000
X'404040404040402020202020202020202020'
88560000
X'40404040404040404040404040'
88650000
X'40404020202021204B20204B2020'
88740000
X'40404020202021204B20204B2020'
88830000
X'40402020202120'
88920000
X'4040'
89010000
X'4020202020202120'
89100000
X'40402020202120' QUOTA
89190000
X'FF'
89280000
0CL(L'ACDHD)
89370000
6C
89460000
CL12
89550000
2C
89640000
CL11
89730000

ACCON
ACCOM
ACWSS
ACWSCONT
ACTRK
ACQUOT

DS
DS
DS
DS
DS
DS
ORG
DS
DS
DS
DS
DS
DS
DS
EQU
EQU
EQU
EQU
ORG
DC
MVC
TR
DC
DC
DS
DS
DS

CL14
CL14
CL7
CL2
CL8
CL7
ACLINE
CL7
ACAMPAT
CL18
CL2
ACWNAME
CL11
CL5
0H
DASD
ACDISK
CL(ACDZ-ACDKPAT)
DASD
ACDFILE
ACDISK+5
FILE NUMBER
DASD
ACDCYL
ACDISK+14
CYLINDER NUMBER
DASD
ACDTRK
ACDISK+22
TRACK NUMBER
DASD
ACDLNGTH
ACDISK+29
WS LENGTH IN TRACKS
DASD
ACLINE+L'ACDHD+1
ACJFUA
X'FF'
ACAMV
ACWNAME(0),PSNAME+1-PERSAVW(3)
ACATR
ACWNAME(0),0(1)
ZTOV
QZCONT
AL1(8,ZC,ZO,ZN,ZT,ZI,ZN,ZU,ZE)
ACM1
F'-1'
ACFIG
F
NO. OF FIRST IGNORED MAN, THIS PASS
DIRNO
F
DIRECTORY PRESENTLY IN CORE
ACWSPT
A
NEXT ENTRY, PERSAVW'S FOR MEN IN ACT
*
BL
TCUMCON DS
2F
TCUMCOM DS
2F
ACNO
DS
F
NO. OF THIS MAN (OR 1ST IGNORED
*
MAN, THIS PASS)
TWSS
DS
F
TTRK
DS
F
TACCT
DS
F
TQUOT
DS
F
ACW1
DC
F'0'
ATEMP
DC
D'0'
ZEROA
DC
F'0'
ACTSZ
DC
A(0)
ACTBL
DC
F'0'
BASE OF EXTRACTED MAN ENTRY TABLE
ACTDIV DC
F'0'
NO. OF MAN ENTRIES TO EXTRACT
*
FROM EACH DIR
DROP 8
DROP 11
MANHASH DC
F'0'
LTORG
ENTRY WSLOC
WSLOC
DC
A(WSD,0,0)
AWSD
EQU WSLOC
AWS1
EQU WSLOC+4
AWS2
EQU WSLOC+8
WLEN
DC
A(*-*)
WSLEN
ACTWL
EQU WLEN
PARAMS DC
20F'0'
WSD
DS
0D
************** MAIN MUST BE LAST DECK IN LINK MODULE ****************
TITLE 'U S E F U L D S E C T S'
COPY CDCPARS
COPY DIRSECT

89820000
89910000
90000000
90090000
90180000
90270000
90360000
90450000
90540000
90630000
90720000
90810000
90900000
90990000
91080000
91170000
91260000
91350000
91440000
91530000
91620000
91710000
91800000
91890000
91980000
92070000
92160000
92250000
92340000
92430000
92520000
92610000
92700000
92790000
92880000
92970000
93060000
93150000
93240000
93330000
93420000
93510000
93600000
93690000
93780000
93870000
93960000
94050000
94140000
94230000
94320000
94410000
94500000
94590000
94680000
94770000
94860000
94950000
95040000
95130000

END MAIN
./ ADD
NAME=APLURSTR
RSTR
TITLE 'APL UTILITY RESTORE FUNCTIONS
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*
EXTRN ADPAR
EXTRN CCREJ
EXTRN CDCBASE
EXTRN CDCBXLE
EXTRN DIRWRT
EXTRN DIRREAD
EXTRN DIRTAB
EXTRN DISKFMT
EXTRN DWR
EXTRN DWRZ
EXTRN KMANHASH
EXTRN LCYLOG
EXTRN MTFLAGS
EXTRN MTRD
EXTRN MTRDZ
EXTRN MTROPEN
EXTRN MTRCLOSE
EXTRN OUTWRT
EXTRN OUTWRTL
EXTRN SELCARD
EXTRN UTDATE
EXTRN UTFLAGS
EXTRN VTOZ
EXTRN WSLEN
EXTRN WSLOC
PRINT OFF
COPY APLDEFN ZSYMBOLS
COPY APLDEFN
COPY ZSYMBOLS
TITLE 'LIBRARY TABLE SEARCH SUBROUTINE'
PRINT ON,NOGEN
RSTRSECT CSECT
*
*
FIND ENTRY IN MAN TABLE FOR NUMBER IN R0.
*
RETURNS ABS ADDRESS IN R1
*
WITH R0 UNCHANGED
DROP 11
USING M,10
LOC8MAN PROLOG
ENTRY LOC8MAN
L
1,MANSTAR
LOC8A
AR
1,10
LOC8C
C
0,0(1)
BE
LOC8B
CLC 0(4,1),=F'-1'
LA
1,MANENTL(1)
BNE LOC8C
IRETURN
NOT FOUND EXIT
LOC8B
LM
12,15,0(13)
B
4(15)
FOUND EXIT
DROP 10
TITLE 'APL UTILITY LIBRARY RESTORE'
*
*

95220000
00100000
00200000
00300000
00400000
00800000
00900000
01000000
01100000
01200000
01300000
01400000
01500000
01600000
01700000
02200000
02300000
02400000
02500000
02600000
02700000
02800000
02900000
03000000
03100000
03200000
03300000
03400000
03500000
03600000
03700000
03800000
03900000
04000000
04100000
04200000
04300000
04400000
04500000
04600000
04700000
04800000
04900000
05000000
05100000
05200000
05300000
05400000
05500000
05600000
05700000
05800000
05900000
06000000
06100000
06200000
06300000
06400000
06500000

*
*
MTEOF
MTREJ
UTWSLST
UT3WSS
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
DREST

RESTORE LIBRARY TO DISK FROM SYS004, SYS005 MAG TAPE

EQU X'10'
EQU X'04'
EQU X'80'
UTFLAGS MASK - WSLIST
EQU X'40'
UTFLAGS MASK - DOUBLE BUFFERING
USING M,10
RESTORE STARTS OUT BY CHECKING FULL-DUMP VS INCREMENTAL-DUMP
TIMES GIVEN BY THE FIRST TAPE DIRECTORY. IF THEY ARE EQUAL,
THE TAPE IS A FULL-DUMP TAPE AND RESTORE TAKES PLACE IN ONE
PASS. OTHERWISE TAPE MUST HAVE BEEN WRITTEN BY INCDUMP. THE
INCREMENTAL RESTORE TAKES TWO PASSES. THE FIRST PASS READS AN
INCREMENTAL-DUMP TAPE, WRITES DIRECTORIES TO DISK AFTER ERASING PSLEN, PSCYL FROM PERSAVW AND MANWSA FROM PERLIB, AND THEN
FUNCTIONS LIKE A FULL RESTORE. WSSAVE SUBROUTINE DOES NOT
NEED TO CREATE PERSAVWS, SINCE THEY ALREADY EXIST, BUT IT DOES
GET FREE DISK SPACE. AT THE END OF THE FIRST PASS THE LIBRARY
HAS BEEN RESTORED, EXCEPT FOR WORKSPACES SAVED BEFORE THE FULL
DUMP WHICH PRECEDED THE INCREMENTAL DUMP.
ON THE SECOND PASS, THE TAPE DIRECTORIES ARE IGNORED (EXCEPT
TO CHECK FULL- VS INCREMENTAL-DUMP DATES), AND WORKSPACES ARE
READ FROM TAPE. FOR EACH WORKSPACE WHERE NO PERLIB EXISTS,
ONE OF THREE SITUATIONS EXSISTS.
1) A PERSAVW EXISTS AND PSLEN, PSCYL ARE ZERO. THIS
WORKSPACE EXISTED AT THE TIME OF THE INCDUMP, BUT
HAD NOT BEEN SAVED RECENTLY. FILL IN THE PERSAVW
AND WRITE THE WORKSPACE TO DISK.
2) A PERSAVW EXISTS AND PSLEN, PSCYL ARE NONZERO. THIS
WORKSPACE HAD BEEN SAVED BETWEEN THE FULL DUMP
AND THE INCREMENTAL DUMP, AND A NEWER VERSION IS
ALREADY ON DISK. IGNORE THIS WORKSPACE.
3) NO PERSAVW EXISTS. THIS WORKSPACE WAS DROPPED BETWEEN THE FULL DUMP AND THE INCREMENTAL DUMP. IGNORE THIS WORKSPACE.
FOR EACH WORKSPACE WHERE NO PERLIB EXISTS, THE LIBRARY WAS
DELETED BETWEEN THE FULL DUMP AND THE INCREMENTAL DUMP.
IGNORE THIS WORKSPACE.
AT THE END OF THE SECOND PASS THE LIBRARY HAS BEEN RESTORED
TO THE TIME OF THE INCREMENTAL DUMP.

PROLOG
ENTRY DREST
MVI RTFLG,0
ORDINARY FULL RESTORE
*
REENTRY FOR INCREMENTAL RESTORE, PASS 2
RESCOM2 ICALL MTROPEN
OPEN TAPE INPUT FILE
ICALL SETCON
L
9,HASHVAL
L
11,DIRWS
DRRDIR ST
9,DIRCT
DRRDIR2 ICALL MTRD
READ NEXT DIRECTORY
ICALL MTRDZ
L
1,=A(MTFLAGS)
TM
0(1),MTREJ
ACCEPT REJECTED READ QUIETLY -BO
DRRDIR2
LATER CHECKS WILL TAKE CARE OF IT
LA
2,RFTAPE
DIFFERENT MESSAGES FOR DIFF CASES
CLI RTFLG,2
FULL REST, INC REST PASS 1 SAY
BNH *+8
'INCORRECT NUMBER OF DIRECTORIES'
LA
2,IRCE
INC REST-2 SAYS 'NOT A FULL-DUMP'
TM
0(1),MTEOF
BCR 1,2 BO
MIGHTY SHORT DUMP TAPE

06600000
06700000
06800000
06900000
07000000
07100000
07200000
07300000
07400000
07500000
07600000
07700000
07800000
07900000
08000000
08100000
08200000
08300000
08400000
08500000
08600000
08700000
08800000
08900000
09000000
09100000
09200000
09300000
09400000
09500000
09600000
09700000
09800000
09900000
10000000
10100000
10200000
10300000
10400000
10500000
10600000
10700000
10800000
10900000
11000000
11100000
11200000
11300000
11400000
11500000
11600000
11700000
11800000
11900000
12000000
12100000
12200000
12300000
12400000
12500000

LR
CLC
BCR
TM
BNZ
L
STH
ST
*
A
C
BNE
S
MVC
MVC
XC
XC
CLI
BH
*
*
*

DREST2

BXH
MVC
ICALL
DC
L
LM
USING
MVC
BXLE
L
L
SLA
A
MVC
DROP
CLC
BE
MVI

*
MVC
*
IRA

IRB

IRG
IRE

CLI
BL
LA
SR
C
BNL
ST
STC
LA
B
L
L
CL
BE
STH
LA
B

10,11
WFLNAME(12),DIRTNAME
7,2
NOT A DIRECTORY AT ALL
CREATING,1
DRCRT
CREATE HANDLES DIRECTORIES ODDLY
1,WFLMAN
1,DIRIN
1,WFLLIB
AVOID HISTORICAL ACCIDENT OF
MEANINGLESS WFLLIB IN DIRECTORY
1,DIRCT
CHECK DIRECTORY NUMBER
1,HASHVAL
RFTAPE
1,DIRCT
WE NEED TRUE DIRECTORY NUMBER
VVMM(4),=C'V1M1'
DIR HAS V1,M1 FORMAT
C059
NUMDIRS(4),HASHVAL NO. DIRECTORIES
C059
SALVHED(256),SALVHED ERASE SALVAGED-TRACK LISTS
SALVHED+256(FIRSTENT-SALVHED-256),SALVHED+256
RTFLG,2
IF JUST STARTING A FULL RESTORE,
IRC
(INCREMENTAL RESTORE, PASS 2)
CHECK DATES. NOTE BECAUSE OF
FOLLOWING BXH, NO NEED TO CHECK
RTFLG=2. RTFLG=1 DOES NOT OCCUR HERE
1,1,IRA
CHECK DATE ON DIRECTORY ZERO ONLY
IRMSTS,DIDTS-M(10) LOG TIME OF DUMP OR INCDUMP
OUTWRTL
AL4(IRMSG1)
3,=A(CDCBXLE)
SET ALL CFREDSK'S TO EXTLOW
0,2,0(3)
NOT NECESSARY UNLESS SOME OTHER
CDCPARS,2
CFREDSK,EXTLOW
UTILITY OPERATION PRECEDED THIS ONE
2,0,DREST2
2,8(3)
NEED EXT 0 AGAIN
1,HASHVAL
RESET EXTENT 0 CFREDSK
1,3
TO 1ST TRACK PAST LAST DIR
1,=A(DIRTAB)
CFREDSK,0(1)
2
DFDTS(12),DIDTS
WHAT KIND OF TAPE IS THIS -DRES2B
FULL-DUMP TAPE. SINGLE-PASS RESTORE
RTFLG,2
INC-DUMP TAPE. THIS IS PASS 1 OF 2
INCREST PASS 1 -- USING INCREMENTAL-DUMP TAPE
FDTS,DFDTS
SAVE TIME, DATE OF FULL DUMP FOR
LATER CHECK IN PASS 2
RTFLG,2
DRES2B
ANOTHER CHECK FOR FULL-DUMP TAPES
1,FIRSTENT-M
PREPARE TO ZERO PSLEN,PSCYL
0,0
1,DSNXTF
END OF PERSAVWS
IRG
0,PSCYL-PERSAVW(1,10)
DASD
0,PSLEN-PERSAVW(1,10)
DASD
1,PSWL(1)
ADVANCE TO NEXT PERSAVW
IRB
1,MANSTAR
PREPARE TO ZERO EVERYONE'S SAVED
2,LIBNUM-PERLIB(1,10) WORKSPACE COUNT
2,=F'-1'
STOPPER
IRF
0,MANWSA-PERLIB(1,10)
1,MANENTL(1)
IRE

12600000
12700000
12800000
12900000
13000000
13100000
13200000
13300000
13400000
13500000
13600000
13700000
13800000
13900000
14000000
14100000
14200000
14300000
14400000
14500000
14600000
14700000
14800000
14900000
15000000
15100000
15200000
15300000
15400000
15500000
15600000
15700000
15800000
15900000
16000000
16100000
16200000
16300000
16400000
16500000
16600000
16700000
16800000
16900000
17000000
17100000
17200000
17300000
17400000
17500000
17600000
17700000
17800000
17900000
18000000
18100000
18200000
18300000
18400000
18500000

*
*
IRC

18600000
18700000
18800000
18900000
19000000
*
19100000
IRCE
19200000
19300000
19400000
IRD
19500000
19600000
19700000
19800000
19900000
*
20000000
*
FULL RESTORE WITH SINGLE SET OF TAPES
20100000
DRES2B L
1,MANSTAR
20200000
SR
0,0
CLEAR ALL LINKS TO SAVED WORKSPACES 20300000
DRES3
L
2,LIBNUM-PERLIB(1,10) IN MAN AND COMMON LIB TABLE
20400000
CL
2,=F'-1'
20500000
BE
DRES4
20600000
ST
0,LIBLINK-PERLIB(1,10)
20700000
STH 0,MANWSA-PERLIB(1,10)
20800000
LA
1,MANENTL(1)
20900000
B
DRES3
21000000
DRES4
LA
1,FIRSTENT-M
21100000
ST
1,DSNXTF
ENTRIES
21200000
IRF
LH
1,DIRIN
21300000
ICALL DIRWRT
21400000
IRH
MVI DIRIN+1,255
NO DIRECTORY IN CORE
21500000
L
9,DIRCT
ADVANCE TO NEXT DIRECTORY, IF ANY
21600000
BCT 9,DRRDIR
21700000
DRRDIRZ EQU *
21800000
DROP 10
21900000
DRES1
L
11,CURWS
ALTERNATE CORE SPACES
22000000
ICALL MTRD
READ IN NEXT WORKSPACE
22100000
ICALL MTRDZ
22200000
L
1,=A(UTFLAGS)
IF DOUBLE BUFFERING IS IN EFFECT,
22300000
TM
0(1),UT3WSS
22400000
BZ
DRES1A
22500000
ICALL DWRZ
DISK WRITE.
23000000
DRES1A L
1,=A(MTFLAGS)
CHECK FOR TAPE END-OF-FILE
23100000
TM
0(1),MTEOF
23200000
BO
DRES2
IT'S ON. TAPE IS COPIED.
23300000
TM
0(1),MTREJ
23400000
BO
DRES1
BRANCH IF WS REJECTED BY MTREAD
23500000
USING M,11
23600000
CLC WFLNAME(12),DIRTNAME
23700000
BE
DRNEWDIR
WE COULD FIND A DIRECTORY.
23800000
L
1,WFLLIB
23900000
ICALL GETDIR
24000000
L
0,WFLLIB
24100000
ICALL LOC8MAN
24200000
B
DRNOMAN
NOT FOUND.
24300000
ICALL WSSAVE
24400000
DROP 11
24500000
L
1,=A(UTFLAGS)
IF DOUBLE BUFFERING IS IN EFFECT,
24600000
TM
0(1),UT3WSS
24700000
BZ
DRES1B
24800000
L
11,ALTWS
SWAP BUFFERS AND GO GET NEXT WS
24900000
INCREST PASS 2 -- USING FULL-DUMP TAPE
BXH 1,1,IRH
CHECK ON DIRECTORY ZERO ONLY -CLC DFDTS(12),DIDTS
FULL-DUMP TIMESTAMP WILL AGREE WITH
BE
IRD
INCDUMP TIMESTAMP IF IT IS TRULY A
FULL-DUMP TAPE
ICALL OUTWRTL
DC
AL4(IRMSG4)
B
IRM
GIVE HIM ANOTHER TRY WITH NEW TAPES
CLC FDTS(12),DFDTS
FULL-DUMP DATE CONTROLLING THE
BE
IRH
INCDUMP TAPE CREATION MUST MATCH
ICALL OUTWRTL
DATE ON THIS FULL-DUMP TAPE
DC
AL4(IRMSG3)
(WHICH IT ASSUREDLY DOES NOT)
B
IRM

MVC
ST
B
EQU
ICALL
B
CLI
BE
LH
ICALL
CLI
BE
BL

ALTWS(4),CURWS
11,CURWS
DRES1
*
DWRZ
DRES1
DIRIN+1,255
DRESTZ
1,DIRIN
DIRWRT
RTFLG,2
IRM
DRESTZ2

FROM TAPE,

25000000
25100000
25200000
DRES1B
25300000
TO DISK, THEN GO GET NEXT WS
25800000
FROM TAPE.
25900000
DRES2
26000000
26100000
26200000
26300000
DRESTZ
IF END OF INCREST PASS 1,
26400000
THERE IS MORE TO DO.
26500000
IF END OF INCREST PASS 2,
26600000
*
TAKE A FINAL PASS THROUGH THE
26700000
*
DIRECTORIES TO LOOK FOR LONELY
26800000
*
PERSAVWS WITH PSLEN=0 -- WE FOUND
26900000
*
NO WORKSPACE ON EITHER SET OF TAPES 27000000
L
9,HASHVAL
27100000
IRC0
L
1,HASHVAL
27200000
SR
1,9
NEXT DIRECTORY NUMBER
27300000
ICALL DIRREAD
27400000
USING M,10
27500000
USING PERLIB,4
27600000
USING PERSAVW,5
27700000
L
4,MANSTAR
27800000
AR
4,10
ABS PERLIB POINTER
27900000
IRC6
CLC LIBNUM(4),=F'-1'
LIB TABLE STOPPER
28000000
BE
IRC2
END OF DIRECTORY
28100000
L
5,LIBLINK
PTR TO FIRST (IF ANY) PERSAVW
28200000
LA
6,0(4,10)
LAGGING PERSAVW POINTER
28300000
LR
6,4
LAGGING PERSAVW POINTER.
28400000
IRC4
LTR 5,5
28500000
BZ
IRC1
END OF PERSAVW CHAIN
28600000
AR
5,10
ABS PERSAVW POINTER
28700000
CLI PSLEN,0
PSLEN NONZERO MEANS A WS IS REALLY 28800000
BNZ IRC3
SAVED ON DISK
28900000
MVC IRCMWS(4),PSMAN
LOG MISSING WORKSPACE
29000000
MVC IRCMWS+4(12),PSNAME
29100000
ICALL OUTWRTL
29200000
DC
AL4(IRCMS)
29300000
MVC PSLINK-PERSAVW(4,6),PSLINK LINK AROUND THIS PERSAVW
29400000
*
PERWSAVW IS NOW IN LIMBO AND WILL
29500000
*
NOT BE RECLAIMED UNTIL THE NEXT
29600000
*
FULL DUMP AND RESTORE
29700000
B
IRC5
29800000
IRC3
LR
6,5
GOOD PERSAVW. ADVANCE LAGGING PTR 29900000
IRC5
L
5,PSLINK
ADVANCE PERSAVW POINTER
30000000
B
IRC4
30100000
IRC1
LA
4,MANENTL(4)
ADVANCE TO NEXT MAN TABLE ENTRY
30200000
B
IRC6
30300000
IRC2
L
1,HASHVAL
END OF DIRECTORY
30400000
SR
1,9
30500000
ICALL DIRWRT
30600000
BCT 9,IRC0
ADVANCE TO NEXT DIRECTORY
30700000
DROP 10
30800000
DROP 4
30900000
DROP 5
31000000
*
31100000
DRESTZ2 ICALL LCYLOG
31200000
IRETURN
31300000

IRM

ICALL MTRCLOSE
CLOSED ALREADY UNLESS WE GET HERE
MVI RTFLG,3
FROM PASS 2 ERROR
ICALL OUTWRTL
DC
AL4(IRMSG2)
HINT TO OPERATOR
B
RESCOM2
SPACE 2
DRCRT
L
10,CURWS
MAKE TAPE DIRECTORY RESIDE IN CURWS
ST
11,CURWS
ST
10,DIRWS
SINCE DISK DIRS READ/WRITE INTO DIRW
DRNEWDIR TM
CREATING,1
BZ
RSTXXX
ICALL DIRHASH
B
DRRDIRZ
RFTAPE EQU *
RSTXXX ICALL OUTWRTL
DC
AL4(NOOKMSG)
CANCEL
DRNOMAN MVC NOMWS,WFLLIB-M(11)
CLI RTFLG,3
IF THIS IS PASS 2 OF AN INCR REST,
BE
DRES1
THE OWNER OF THIS WS WAS DELETED.
ICALL OUTWRTL
DC
AL4(NOMS)
B
DRES1
TITLE 'SELECTIVE RESTORE ROUTINE'
*
RETRIEVE SELECTED WORKSPACES FROM TAPE
*
AND WRITE THEM TO LIBRARY DISK.
*
ENTRY RETRIEVE
RETRIEVE PROLOG
LM
1,3,=A(WSNBUF,16,WSNBUF+1599) MAX 100 SELECTIONS
SR
0,0
RT1
ICALL SELCARD
CLC 0(8,1),RTEND
BE
RT2
BXLE 1,2,RT1
BUILD TABLE OF WSNAMES FOR SEARCH
ICALL OUTWRTL
TABLE OVERFLOWED -- NOTIFY OPERATOR
DC
AL4(RTMSG)
RT3
ICALL SELCARD
LET SELCARD DO ACTUAL LISTING
CLC 0(8,1),RTEND
BNE RT3
SR
1,2
BACK TABLE INDEX OFF BY 1 ENTRY
RT2
BCTR 1,0
ST
1,WSNBLIM
FOR BXH END TEST
MVI RTFLG,1
DOING RETRIEVE, NOT SELREST
B
SELST
RTMSG
DC
C'SELECTION TABLE OVERFLOW -- CARDS BELOW IGNORED'
DC
X'FF'
RTEND
DC
X'80000000'
DC
AL1(3,ZE,ZN,ZD)
*
*
*
VERIFY DUMP, INCDUMP, OR SELDUMP TAPE(S)
*
*
ONLY ONE WS SLOT IS NEEDED BY THE TVERIFY OPERATION
*
ENTRY TVERIFY
TVERIFY PROLOG
MVI RTFLG,X'FF'
NO DISK ACTION AT ALL
B
SELST
EJECT

31400000
31500000
31600000
31700000
31800000
31900000
32000000
32100000
32200000
32300000
32400000
32500000
32600000
32700000
32800000
32900000
33000000
33100000
33200000
33300000
33400000
33500000
33600000
33700000
33800000
33900000
34000000
34100000
34200000
34300000
34400000
34500000
34600000
34700000
34800000
34900000
35000000
35100000
35200000
35300000
35400000
35500000
35600000
35700000
35800000
35900000
36000000
36100000
36200000
36300000
36400000
36500000
36600000
36700000
36800000
36900000
37000000
37100000
37200000
37300000

*
*
*
*
*
*
*
*
*
SELREST
SELST

SEL0
SEL1

SEL6
SEL3
*

*
*

37400000
37500000
37600000
WORKSPACES RETRIEVED OR SELECTIVELY RESTORED ARE GIVEN A
37700000
TIMESTAMP OF THE PRESENT TIME. IF THEY RETAINED THEIR TRUE
37800000
SAVE TIME, THEY MIGHT SHOW UP IN NEITHER THE PREVIOUS FULL
37900000
DUMP NOR IN A FOLLOWING INCREMENTAL DUMP, AND SO THEY WOULD BE 38000000
IGNORED IN A RESTORE OPERATION. SUCH IS THE PRICE OF PROGRESS 38100000
38200000
PROLOG
38300000
ENTRY SELREST
38400000
MVI RTFLG,0
DOING SELREST, NOT RETRIEVE
38500000
BALR 12,0
ENTRY FOR RETRIEVE
38600000
USING *,12
38700000
L
1,=A(UTDATE)
38800000
MVC RTS(8),0(1)
EBCDIC DATE
38900000
L
1,=A(VTOZ)
39000000
TR
RTS(8),0(1)
ZSYMBOL DATE
39100000
MVI RTS+2,ZSLASH
39200000
MVI RTS+5,ZSLASH
39300000
GETIME TU
TIME IN 300THS
39400000
ST
1,RTS+8
39500000
ICALL SETCON
39600000
ICALL MTROPEN
39700000
L
10,DIRWS
39800000
L
11,CURWS
39900000
ICALL MTRD
40000000
ICALL MTRDZ
40100000
L
1,=A(MTFLAGS)
40200000
TM
0(1),MTEOF
40300000
BO
SELRESTZ
40400000
TM
0(1),MTREJ
40500000
BO
SEL1
FORGET IT IF REJECTED BY MTREAD.
40600000
USING M,11
40700000
CLC WFLNAME,DIRTNAME
IGNORE DIRECTORIES
40800000
BE
SEL1
40900000
TM
RTFLG,X'FF'
IS THIS OPERATION A RETRIEVE -41000000
BZ
SEL2
NO, SELREST. ACCEPT ALL TAPE WSS. 41100000
BM
SEL6
YES. PREPARE TO SEARCH WSNAME TABLE 41200000
L
2,=A(UTFLAGS)
TVERIFY. IF WS LISTING REQUESTED
41300000
TM
0(2),UTWSLST
41400000
BZ
SEL1
(WHICH IT'S NOT)
41500000
MVC TVMID(16),WFLLIB
MOVE IN WSID
41600000
MVC TVMTS(12),WFLDATE LIKEWISE TIME STAMP
41700000
ICALL OUTWRT
AND LIST THIS WS
41800000
DC
AL4(TVMSG)
41900000
B
SEL1
42000000
LM
1,2,=A(WSNBUF-16,16)
42100000
L
3,WSNBLIM
END OF WS NAME TABLE
42200000
MVI RTEFLG,1
ASSUME RETRIEVE OPERATION ENDED
42300000
BXH 1,2,SEL5
COMPARE TAPE WS AGAINST ALL
42400000
SELECTED WS LIBS AND NAMES
42500000
CLI WFLNAME-WFLLIB(1),X'80' FLAG FOR WS ALREADY RETRIEVED
42600000
BH
SEL3
IGNORE
42700000
MVI RTEFLG,0
RESET ASSUMPTION OF ALL DONE
42800000
TM
WFLNAME-WFLLIB(1),X'7F'
42900000
BNZ SEL3B
X'80' MEANS WE HAVE STARTED
43000000
RETRIEVING AN ENTIRE LIBRARY BUT
43100000
HAVEN'T FINISHED IT
43200000
CLC WFLLIB-WFLLIB(4,1),WFLLIB RETRIEVE IF RIGHT LIBRARY
43300000
SELECTIVE RESTORE.

BE
TM

SEL3A
(WHICH IT IS)
WFLNAME-WFLLIB(1),X'80' IF NEW LIB NO. AND WE HAVE BEEN
*
RESTORING A FULL LIBRARY, WE'RE
*
FINISHED WITH THIS LIBRARY.
BZ
SEL3
NO, UNRETRIEVED LIBRARY.
MVI WFLNAME-WFLLIB(1),X'FF' YES. MARK IT UTTERLY RETRIEVED.
B
SEL3
SEL3B
CLC WFLLIB(16),WFLLIB-WFLLIB(1)
BNE SEL3
NO MATCH, BACK FOR NEXT TEST
SEL3A
OI
WFLNAME-WFLLIB(1),X'80' MARK WS AS RETRIEVED
SEL2
EQU *
ICALL DWRZ
ENSURE DISK OPERATION FINISHED
L
1,WFLLIB
ICALL GETDIR
L
0,WFLLIB
ICALL LOC8MAN
B
SELNOLIB
MVC WFLDATE(12),RTS
ICALL WSSAVE
SEL4
L
1,=A(UTFLAGS)
IF DOUBLE WS BUFFERING IS IN EFFECT,
TM
0(1),UT3WSS
BZ
SEL4A
L
11,ALTWS
SWAP BUFFERS AND GO GET NEXT WS
MVC ALTWS(4),CURWS
ST
11,CURWS
B
SEL0
SEL4A
EQU *
ICALL DWRZ
TO DISK, THEN GO GET NEXT WS
B
SEL0
FROM TAPE.
*
END UNSUCCESSFUL TABLE SEARCH IN RETRIEVE OPERATION
SEL5
CLI RTEFLG,0
IF NO WSNAMES REMAINING IN TABLE,
BZ
SEL1
QUIT. ELSE READ NEXT TAPE WS.
ICALL MTRCLOSE
SELRESTZ CLI RTFLG,X'FF'
IF ENDING A VERIFY OPERATION,
BE
SELRZZZ
NO POST-RESTORE CLEANUP.
CLI DIRIN+1,255
SKIP DIR REWRITE IF NO DIR IN CORE
BE
SELRZZ
LH
1,DIRIN
ICALL DIRWRT
SELRZZ ICALL LCYLOG
CLI RTFLG,0
IF RETRIEVE OPERATION,
BE
SELRZZZ
LM
1,2,=A(WSNBUF-16,16) WE MUST LOG THE UNRETRIEVED WSS.
L
3,WSNBLIM
SELRZC BXH 1,2,SELRZZZ
CLI WFLNAME-WFLLIB(1),X'80'
BNL SELRZC
MVC IRCMWS,WFLLIB-WFLLIB(1)
ICALL OUTWRTL
DC
AL4(IRCMS)
B
SELRZC
SELRZZZ IRETURN
SELNOLIB MVC NOMWS,WFLLIB-M(11)
ICALL OUTWRTL
DC
AL4(NOMS)
B
SEL1
RTS
DC
3F'0'
TIMESTAMP INFORMATION
TVMSG
DC
CL7'
'
SPACES TO BE CONSISTENT W/ MTSECT
DC
X'13'
TVMTS
DC
XL12'00'
DATE, TIME

43400000
43500000
43600000
43700000
43800000
43900000
44000000
44100000
44200000
44300000
44400000
44900000
45000000
45100000
45200000
45300000
45400000
45500000
45600000
45700000
45800000
45900000
46000000
46100000
46200000
46300000
46400000
46900000
47000000
47100000
47200000
47300000
47400000
47500000
47600000
47700000
47800000
47900000
48000000
48100000
48200000
48300000
48400000
48500000
48600000
48700000
48800000
48900000
49000000
49100000
49200000
49300000
49400000
49500000
49600000
49700000
49800000
49900000
50000000
50100000

TVMID

*
*
*
*
*
*
WSSAVE

DC
DC
DC
DROP
TITLE

X'11'
XL16'00'
WSID
X'FF'
11
'SAVE A WORKSPACE ON THE LIBRARY DISK'

SAVE A WORKSPACE
REPRODUCE AS MUCH AS POSSIBLE, )SAVE
***** ASSUMES THAT A PRECEDING CALL OF DWRZ HAS ENDED ANY
***** PREVIOUS WORKSPACE WRITE OPERATION *****

PROLOG WSAR,WSARZ
USING M,11
STM 0,9,WSAR
MVI ADJQ+1,0
PROG MODIFICATION.
CLI RTFLG,2
IF INCREST (EITHER PASS),
BL
TRCOMPS
2221
LA
7,ADJQZ
LOCATE THE PERSAVW FOR THIS WS
BAL 8,LOC8WS
(WE MAY DISCARD IT ANYWAY)
CLI PSLEN-PERSAVW(3),0 WSNAME FOUND, ERGO NOT DROPPED
BCR 7,7
ALREADY SAVED -- IGNORE THIS COPY
SR
3,10
NAME EXISTS BUT NOT WORKSPACE -ST
3,WSPERSAV
REMEMBER LOCATION OF PERSAVW
TRCOMPS L
4,=A(CDCBASE)
2221
L
4,0(4)
2221
COPY TRCOMP
DROP 11
USING M,10
ST
1,TRCNT
*
*
CHECK SALVHED FOR A SALVAGED BLOCK OF THE RIGHT SIZE.
CLI RTFLG,2
IF INCREST (EITHER PASS),
BNL EWS3
WE NEED NO MORE PERSAVWS.
BCTR 1,0
SLL 1,2
L
3,SALVHED(1)
LTR 3,3
BZ
EWS2
NO SALVAGED BLOCKS THIS SIZE
AR
3,10
USING PERSAVW,3
L
2,PSLINK
ST
2,SALVHED(1)
L
2,PSCYL
DASD
ST
2,WSCHH
MVC WSFILE(2),PSFILE
SR
3,10
ST
3,WSPERSAV
B
EWS10
DROP 3
*
*
NO PERSAVW AVAILABLE FROM SALVAGED TRACK LIST.
*
CREATE A PERSAVW FROM FREE-SPACE AREA ABOVE MX.
EWS2
L
3,DSNXTF
GET PERSAV FROM FREE AREA.
LA
2,PSWL(3)
C
2,MANSTAR
CHECK FOR DIRECTORY OVERFLOW
BNL EWS6
TOO MANY NAMES
ST
2,DSNXTF
ST
3,WSPERSAV
*
*
SELECT A FILE TO SAVE THIS WORKSPACE ON

50200000
50300000
50400000
50500000
50600000
50700000
50800000
50900000
51000000
51100000
51200000
51300000
51400000
51500000
51600000
51700000
51800000
51900000
52000000
52100000
52200000
52300000
52400000
52500000
52600000
52700000
52800000
52900000
53000000
53100000
53200000
53300000
53400000
53500000
53600000
53700000
53800000
53900000
54000000
54100000
54200000
54300000
54400000
54500000
54600000
54700000
54800000
54900000
55000000
55100000
55200000
55300000
55400000
55500000
55600000
55700000
55800000
55900000
56000000
56100000

*
*
*
*
EWS3
MAXS1

MAXS3
MAXS4

MAXS2
*
EWS1

EWS9

*
*
EWS10
*
*
LOC8WS

WSS1

LIB EXTENT IS FULL IF CFREDSK IS LARGER THAN EXTUP.

5981
R3
IS MAX NUMBER OF FREE TRACKS SO FAR.
5981
R4 IS ((EXTUP-CFREDSK) IOTA MAX/EXTUP-CFREDSK) (/1/)
R5
IS NUMBER OF FREE TRACKS IN EXTENT R2.
5981
L
1,=A(CDCBXLE)
LM
0,2,0(1)
SR
3,3
SR
5,5
IF END-CYL MINUS FR-CYL IS MINUS5981
LH
8,EXTUP-CDCPARS(2) END-CYL MINUS FREE-CYL
5981
SH
8,CFREDSK-CDCPARS(2)
5981
BM
MAXS4
ONLY IF EXTENT IS FULL
5981
LH
5,2+EXTUP-CDCPARS(2) END-HEAD MINUS FREE-HEAD
5981
SH
5,2+CFREDSK-CDCPARS(2)
5981
BNM MAXS3
BRANCH IF HEAD DIFF NOT MINUS 5981
LTR 8,8
5981
BZ
MAXS4
BR IF EXTENT IS FULL
5981
BCTR 8,0
IF MINUS, DECR CYL DIFF
5981
AH
5,HMAX-CDCPARS(2) AND GET NO. TRKS MINUS 1
5981
MH
8,CCADJ-CDCPARS+2(2) MULT CYL BY MINUS TRKS/CYL
5981
LPR 8,8
5981
LA
5,1(8,5)
GET TOTAL FREE TRACKS
5981
CR
3,5
BH
MAXS2
LR
3,5
NEW MAX FREE TRACKS
5981
LR
4,2
BXLE 2,0,MAXS1
L
2,TRCNT
TRACK COUNT THIS WS
A
2,CFREDSK
FREEDSK IS IN FORM CCHH
DASD
EX
2,EWS5
CHECK FOR HEAD GTR LIMIT
BH
EWS9
A
2,CCADJ
B
EWS1
C
3,TRCNT
TRKS AVAILABLE VS.TRKS NEEDED 5981
BL
EWS4
NO ROOM IN FREE AREA
5981
L
0,CFREDSK
ST
2,CFREDSK
RESERVE TRACKS
ST
0,WSCHH
L
1,=A(ADPAR)
S
4,0(1)
STH 4,WSFILE
CLI RTFLG,2
IF SELREST (EITHER PASS), NO NEED TO
BNL WSS3
LOCATE PERSAVW AGAIN
LA
LA

REENTRY WHEN PERSAVW WAS FOUND ON SALVAGED-TRACK LIST

8,WSS2
FOUND EXIT
7,WSS3
NOT FOUND EXIT

L
ICALL
B
ST
ST
USING
L
LTR
BCR
AR
SR

LOCATE-WS PSEUDO-SUBROUTINE
0,WFLLIB-M(11)
LOC8MAN
ADJQZ
MAN NOT FOUND -- IGNORE QUIETLY
1,WSSMAN
1,WSSLINK
PERSAVW,3
3,LIBLINK-PERLIB(1)
3,3
8,7
NO WS OF SAME NAME
3,10
1,1

56200000
56300000
56400000
56500000
56600000
56700000
56800000
56900000
57000000
57100000
57200000
57300000
57400000
57500000
57600000
57700000
57800000
57900000
58000000
58100000
58200000
58300000
58400000
58500000
58600000
58700000
58800000
58900000
59000000
59100000
59200000
59300000
59400000
59500000
59600000
59700000
59800000
59900000
60000000
60100000
60200000
60300000
60400000
60500000
60600000
60700000
60800000
60900000
61000000
61100000
61200000
61300000
61400000
61500000
61600000
61700000
61800000
61900000
62000000
62100000

WSCLC
*
*
WSS2

*
*
*
WSS3

WSS4
*
ADJQ

ADJQ1

IC
EX
BCR
ST
L
B
CLC

1,PSNAME
1,WSCLC
8,8
SAME-NAME WS FOUND
3,WSSLINK
3,PSLINK
WSS1
PSNAME(0),WFLNAME-M(11)

L
L
ST
SR
IC
BCTR
SLL
L
ST
SR
ST
MVI

SAME-NAME WS FOUND IN THIS LIBRARY. PURGE IT.

2,PSLINK
REMOVE FROM LIBRARY.
1,WSSLINK
2,PSLINK-PERSAVW(1)
1,1
1,PSLEN
1,0
1,2
2,SALVHED(1)
2,PSLINK
3,10
3,SALVHED(1)
ADJQ+1,X'F0'
DON'T ADJUST QUOTA FOR THIS.

PUT WS INFO INTO NEW PERSAVW ON LIBRARY LIST.

MOST OF THIS IS IRRELEVANT FOR INCREMENTAL RESTORE.
L
3,WSPERSAV
AR
3,10
USING PERSAVW,3
MVC PSCYL,WSCHH
CYLINDER, HEAD
DASD
MVC PSLEN,TRCNT+3
TRACK COUNT
MVC PSFILE(2),WSFILE
CLC WFLNAME-M(9,11),CONTINUE NO QUOTA BUMPING IF WS IS CONT
BNE *+8
MVI ADJQ+1,X'F0'
CLI RTFLG,2
ON SELREST (EITHER PASS), PERSAVW IS
BNL WSS4
ALREADY LINKED INTO LIST
MVC PSMAN,WFLMAN-M(11) REMEMBER SAVER
MVC PSNAME,WFLNAME-M(11) AND WSNAME
MVC PSPASS,WFLPASS-M(11) AND PASSWORD
L
1,WSSMAN
L
0,LIBLINK-PERLIB(1)
ST
0,PSLINK
ADD THIS WS TO TOP OF LIST OF SAVED
SR
3,10
WORKSPACES IN THIS LIBRARY
ST
3,LIBLINK-PERLIB(1)
L
1,WSCHH
LH
2,WSFILE
ICALL DWR
WRITE WORKSPACE TO DISK
ADJUST MANWSA
BC
0,ADJQZ
PROGRAM MODIFIED.
L
1,WSSMAN
L
0,WFLLIB-M(11)
C
0,=F'1000'
COMMON VS PRIVATE LIBRARY
BNL ADJQ1
L
1,WFLMAN-M(11)
ICALL GETDIR
L
0,WFLMAN-M(11)
ICALL LOC8MAN
B
ADJQZ
COMMON LIBRARY WS WITH NO SAVER.
LH
2,MANWSA-PERLIB(1)
LA
2,1(2)
STH 2,MANWSA-PERLIB(1)

62200000
62300000
62400000
62500000
62600000
62700000
62800000
62900000
63000000
63100000
63200000
63300000
63400000
63500000
63600000
63700000
63800000
63900000
64000000
64100000
64200000
64300000
64400000
64500000
64600000
64700000
64800000
64900000
65000000
65100000
65200000
65300000
65400000
65500000
65600000
65700000
65800000
65900000
66000000
66100000
66200000
66300000
66400000
66500000
66600000
66700000
66800000
66900000
67000000
67100000
67200000
67300000
67400000
67500000
67600000
67700000
67800000
67900000
68000000
68100000

ADJQZ
EWS5
EWS4
EWS6
EWS7
CONTINUE
WSAR
TRCNT
WSSMAN
WSCHH
WSSLINK
WSPERSAV
WSFILE
WSARZ
RSTRSECT
GETDIR

RDONLY
GETDIRZ
GETS
GETSZ
RSTRSECT
SETCON

CH
2,MANWSQ-PERLIB(1)
BNH *+8
STH 2,MANWSQ-PERLIB(1)
LM
0,9,WSAR
IRETURN
CLI HMAX+1,0
ICALL OUTWRTL
DISK FULL
DC
AL4(DFTX)
B
EWS7
ICALL OUTWRTL
DIRECTORY FULL
DC
AL4(DHFMS)
LH
1,DIRIN
AT LEAST ASSURE THAT DIRECTORIES
ICALL DIRWRT
REFLECT LIBRARY STATE
CANCEL
DC
AL1(8,ZC,ZO,ZN,ZT,ZI,ZN,ZU,ZE)
DROP 3,4
DROP 10
DSECT
DC
F'0'
DC
F'0'
DC
F'0'
DC
F'0'
DC
F'0'
DC
H'0'
EQU *
CSECT
TITLE 'SUBROUTINES'
SPACE
PROLOG GETS,GETSZ
STM 0,10,GETS
SR
0,0
D
0,HASHVAL
LR
1,0
CLI DIRIN+1,255
BE
RDONLY
CH
1,DIRIN
BE
GETDIRZ
STH 1,NXTDIR
LH
1,DIRIN
ICALL DIRWRT
LH
1,NXTDIR
STH 1,DIRIN
ICALL DIRREAD
LM
0,10,GETS
IRETURN
DSECT
DS
11F
EQU *
CSECT
SPACE 3
PROLOG
L
1,=A(WSLEN)
PICK UP INSTALLATION DEPENDENT VALUE
L
1,0(1)
ST
1,WLEN
WORKSPACE LENGTH.
L
1,=A(KMANHASH)
NUMBER OF DIRECTORIES.
L
1,0(1)
ST
1,HASHVAL
L
1,=A(WSLOC)
MVC DIRWS(12),0(1)
MVI DIRIN+1,255

68200000
68300000
68400000
68500000
68600000
68700000
68800000
68900000
69000000
69100000
69200000
69300000
69400000
69500000
69600000
69700000
69800000
69900000
70000000
70100000
70200000
70300000
70400000
70500000
70600000
70700000
70800000
70900000
71000000
71100000
71200000
71300000
71400000
71500000
71600000
71700000
71800000
71900000
72000000
72100000
72200000
72300000
72400000
72500000
72600000
72700000
72800000
72900000
73000000
73100000
73200000
73300000
73400000
73500000
73600000
73700000
73800000
73900000
74000000
74100000

IRETURN
SPACE
DIRCT
DC
F'0'
NOMS
DC
C'LIBRARY NUMBER NOT FOUND'
DC
X'11'
NOMWS
DC
XL16'00'
DC
X'FF'
NOOKMSG DC
C'INCORRECT NUMBER OF DIRECTORIES ON TAPE'
DC
X'FF'
IRMSG1 DC
C'LIBRARY RESTORE TO '
DC
X'13'
IRMSTS DC
XL12'00'
DC
X'FF'
IRMSG2 DC
C'MOUNT '
DC
X'13'
FDTS
DC
XL12'00'
DC
C' FULL-DUMP TAPE FILE',X'FF'
IRMSG3 DC
C'MISMATCH OF DUMP DATES.'
DC
X'FF'
IRMSG4 DC
C'NOT A FULL-DUMP TAPE',X'FF'
IRCMS
DC
C'NOT FOUND ON TAPE'
DC
X'11'
IRCMWS DC
XL16'00'
DC
X'FF'
TITLE 'APL UTILITY CREATE FUNCTION'
*
*
*
CREATE A NEW SET OF DIRECTORIES AND RESTORE FROM TAPE.
*
*
FIRST, WRITE MANHASH EMPTY DIRECTORIES.
*
THEN, PERFORM ''ADDS'' TO THEM FROM MAN TABLE FROM TAPE.
*
WHEN THIS HAS BEEN DONE, CARRY ON LIKE A RESTORE.
*
SPACE
CREATE PROLOG
ENTRY CREATE
MVI CREATING,1
ICALL SETCON
CREATE2 ICALL MTROPEN
OPEN INPUT TAPE FILE.
L
11,CURWS
ICALL MTRD
READ IN A DIRECTORY.
ICALL MTRDZ
L
1,=A(MTFLAGS)
ARTIFICIALLY CLOSE.
TM
0(1),MTREJ
IF DIRECTORY WAS NOT READ
BO
CREATE0
SUCESSFULLY, REJECT IT.
MVI 0(1),0
FORCE REWIND ON NEXT TAPE OPEN
USING M,11
CLC WFLNAME,DIRTNAME
BNE CREATE0
NOT A DIRECTORY
CLC DFDTS(12),DIDTS
MAKE SURE IT'S NOT AN INCDUMP TAPE
BE
CREATE1
FULL DUMP OR DISTRIBUTION SELDUMP
CREATE0 ICALL OUTWRTL
DC
AL4(IRMSG4)
ICALL MTRCLOSE
REWIND UNLOAD ALIEN TAPE
B
CREATE2
TRY AGAIN
*
FORMAT ALL LIBRARY DISKS.
CREATE1 L
3,=A(CDCBXLE)
LM
4,5,0(3)
L
3,8(3)
CRFMT
ST
3,FMTPARS+4

74200000
74300000
74400000
74500000
74600000
74700000
74800000
74900000
75000000
75100000
75200000
75300000
75400000
75500000
75600000
75700000
75800000
75900000
76000000
76100000
76200000
76300000
76400000
76500000
76600000
76700000
76800000
76900000
77000000
77100000
77200000
77300000
77400000
77500000
77600000
77700000
77800000
77900000
78000000
78100000
78200000
78300000
78400000
78500000
78600000
78700000
78800000
78900000
79000000
79100000
79200000
79300000
79400000
79500000
79600000
79700000
79800000
79900000
80000000
80100000

STM
LA
ICALL
LM
BXLE
*
*
*

3,5,CRTS35
1,FMTPARS
DISKFMT
3,5,CRTS35
3,4,CRFMT

WRITE MANHASH EMPTY DIRECTORIES.

L
11,CURWS
L
1,QSYMBOT
S
1,=A(STPARAM+8-STFREG)
S
1,=A(MANENTL)
ST
1,MANSTAR
L
0,=F'-1'
ST
0,M(1)
XC
SALVHED(256),SALVHED
XC
SALVHED+256(FIRSTENT-SALVHED-256),SALVHED+256
MVC VVMM(4),=C'V1M1'
DIRECTORY IS FOR V1, M1
MVC NUMDIRS(4),HASHVAL NO. DIRECTORIES
LA
2,FIRSTENT-M
ST
2,DSNXTF
LR
10,11
SR
1,1
SET DIRECTORY NUMBER TO ZERO.
WRITEMP ST
1,WFLMAN
ST
1,WFLLIB
WFLLIB = WFLMAN FOR NEATNESS,
ICALL DIRWRT
WRITE A DIRECTORY.
L
1,WFLMAN
LA
1,1(1)
INCREMENT DIRECTORY NUMBER.
C
1,HASHVAL
SEE IF WE'RE DONE.
BL
WRITEMP
WRITE ANOTHER IF NOT.
ICALL INIT,*
INITIALIZE CFREDSK
ICALL DREST
NOW DO A RESTORE, SORT OF.
MVI CREATING,0
IRETURN
CRTS35 DC
3F'0'
DROP 11
INIT
PROLOG ,
L
3,=A(CDCBXLE)
SET ALL CREFDSK'S TO EXLOW.
LM
0,2,0(3)
NOT NECESSARY UNLESS SOME OTHER
USING CDCPARS,2
INIT2
MVC CFREDSK,EXTLOW
UTILITY OPERATION PROCEEDED
BXLE 2,0,INIT2
THIS ONE.
L
2,8(3)
NEED EXTENT 0 AGAIN.
L
1,HASHVAL
RESET EXTENT 0 CREFDSK TO
SLA 1,3
1ST TRACK PAST LAST DIR.
A
1,=A(DIRTAB)
MVC CFREDSK,0(1)
DROP 2
IRETURN
EJECT
*
*
*
ADD USERS TO DIRECTORIES.
*
CURWS=R11=DIRECTORY JUST READ FROM TAPE
*
DIRHASH PROLOG
USING M,10
LM
10,11,DIRWS ,CURWS
SR
1,1
HASH1
STH 1,DIRIN

C059
C059

ETC.

3579

3579
3579
3579
3579
3579
3579
3579
3579
3579
3579
3579
3579
3579

80200000
80300000
80400000
80500000
80600000
80700000
80800000
80900000
81000000
81100000
81200000
81300000
81400000
81500000
81600000
81700000
81800000
81900000
82000000
82100000
82200000
82300000
82400000
82500000
82600000
82700000
82800000
82900000
83000000
83100000
83200000
83300000
83400000
83500000
83600000
83700000
83800000
83900000
84000000
84100000
84200000
84300000
84400000
84500000
84600000
84700000
84800000
84900000
85000000
85100000
85200000
85300000
85400000
85500000
85600000
85700000
85800000
85900000
86000000
86100000

HASH1A

HASH2
ODIRZ

DHFUL

DHFMS
ZEROD
*
DFTX

ICALL DIRREAD
L
5,MANSTAR-M(11)
AR
5,11
L
4,MANSTAR
SR
2,2
L
3,0(5)
C
3,=F'-1'
BE
ODIRZ
D
2,HASHVAL
CH
2,DIRIN
BNE HASH2
S
4,=A(MANENTL)
C
4,DSNXTF
BNH DHFUL
LA
6,0(4,10)
USING PERLIB,6
MVC PERLIB(MANENTL),0(5)
MVC LIBLINK,ZEROD
ELIMINATE LINK
MVC MANWSA(2),ZEROD
INITIALIZE WS COUNT.
LA
5,MANENTL(5)
B
HASH1A
ST
4,MANSTAR
LH
1,DIRIN
ICALL DIRWRT
LH
1,DIRIN
LA
1,1(1)
C
1,HASHVAL
BL
HASH1
IRETURN
ICALL OUTWRTL
DC
AL4(DHFMS)
CANCEL
DROP 10
DROP 6
DC
C'DIRECTORIES FULL -- UTILITY CANCELLED'
DC
X'FF'
DC
F'0'
LTORG
EJECT
DC
DC
DC
EQU
EQU
DC
DC
DC
DC
DC
DC
DC
DC
DC

DIRWS
CURWS
ALTWS
DIRIN
NXTDIR
HASHVAL
WLEN
FMTPARS
DIRTNAME
SELECTV
CREATING
RTFLG
*
*
*
*
RTEFLG DC
WSNBLIM DS

10-04-68

C'LIBRARY PACKS FULL -- UTILITY CANCELLED'

X'FF'
3A(0)
DIRWS+4
DIRWS+8
H'0'
H'0'
A(0)
F'0'
5A(0)
C'APLDIRECTORY'
X'00'
FL1'0'
X'00'
= 0 ORDINARY FULL RESTORE OR SELECTIVE RESTORE
= 1 RETRIEVE
= 2 INCREMENTAL RESTORE, PASS 1
= 3 INCREMENTAL RESTORE, PASS 2
X'00'
RETRIEVE OPERATION ENDED
A
LIMIT ON WSNBUF

86200000
86300000
86400000
86500000
86600000
86700000
86800000
86900000
87000000
87100000
87200000
87300000
87400000
87500000
87600000
87700000
87800000
87900000
88000000
88100000
88200000
88300000
88400000
88500000
88600000
88700000
88800000
88900000
89000000
89100000
89200000
89300000
89400000
89500000
89600000
89700000
89800000
89900000
90000000
90100000
90200000
90300000
90400000
90500000
90600000
90700000
90800000
90900000
91000000
91100000
91200000
91300000
91400000
91500000
91600000
91700000
91800000
91900000
92000000
92100000

WSNBUF
*

DS

404F

16-BYTE WS LIB, NAME ENTRIES FOR

RETRIEVE

COPY CDCPARS
DSECT
DS
8F
EMWSVE EQU *
COPY DIRSECT
END
./ ADD
NAME=APLUTAPE
TAPE
TITLE 'APL UTILITY MAGNETIC TAPE ROUTINES
05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
MACRO
&NAME
EXCP &CCB
AIF ('&CCB' EQ '').L6
AIF ('&CCB'(1,1) EQ '(').L1
&NAME
L
1,=A(&CCB)
AGO .L4
.L1
AIF ('&CCB'(2,2) EQ '1)').L5
&NAME
LR
1,&CCB(1)
.L4
AGO .A1
.A1
ANOP
ICALL OSMTEXCP
MEXIT
.L6
MNOTE 5,'NO CCB SPECIFIED - MACRO IGNORED.'
MEXIT
.L5
ANOP
&NAME
ICALL OSMTEXCP
MEND
SPACE
MACRO
&NAME
WAIT &CCB
GBLA &WCNT
AIF (T'&CCB NE 'O').L1
MNOTE 5,'CCB OMITTED - MACRO IGNORED.'
MEXIT
.L1
AIF ('&CCB'(1,1) EQ '(').L2
&NAME
L
1,=A(&CCB)
AGO .L3
.L2
AIF ('&CCB'(2,2) EQ '1)').L4
&NAME
LR
1,&CCB(1)
AGO .L3
.L4
ANOP
&NAME
TM
2(1),X'80'
AGO .L5
.L3
TM
2(1),X'80'
.L5
ANOP
BO
WAIT&WCNT
ICALL OSMTWAIT
WAIT&WCNT EQU *
&WCNT
SETA &WCNT+1
MEND
SPACE
MACRO
&L
SYSDATE &T,&S
AIF (T'&S EQ 'O').S2
&L
TIME DEC
ST
1,&S
EMWSV

92200000
92300000
92400000
92500000
92600000
92700000
92800000
92900000
00060000
00120000
00180000
00240000
00300000
00360000
00420000
00540000
00600000
00660000
00720000
00780000
00840000
00900000
01140000
01200000
01260000
01320000
01380000
01440000
01740000
01800000
01860000
01920000
01980000
02100000
02160000
02220000
02280000
02340000
02400000
02460000
02520000
02580000
02640000
02700000
02760000
02820000
02880000
02940000
03300000
03360000
03420000
03480000
03540000
03600000
03660000
03720000
04260000
04380000
04440000

.S2

&L
&L

&L
&L

MTSECT
*
*
*

UNPK &T.(6),&S+1(3)
OI
&T+5,X'F0'
MVI &T,C' '
MEXIT
MNOTE 5,'SCRATCH WORD REQUIRED FOR OS. MACRO IGNORED'
MEND
SPACE
MACRO
SWITCH
XI
MTDCCB+7,1
MVC CTLCCB+6(2),MTDCCB+6
L
1,DCBCUR
MVC DCBCUR(4),DCBALT
ST
1,DCBALT
MEND
SPACE
MACRO
SETLU
MVI MTDCCB+7,5
MVC CTLCCB+6(2),MTDCCB+6
MVC DCBCUR(8),=A(MTDCB5,MTDCB4)
MEXIT
MEND
PRINT ON,GEN
EXTRN APLMODAD
EXTRN CMD
EXTRN DWSLOG
EXTRN OUTWRT
EXTRN OUTWRTL
SUPER-DUPER MESSAGE-WRITER
EXTRN UTFLAGS
EXTRN WSLEN
PRINT OFF
COPY APLDEFN
COPY APLDEFN
CSECT
PRINT ON,GEN
TITLE 'APL UTILITY MAGNETIC TAPE OUTPUT OPEN
05/11/70'
OPEN - SET UP AND WRITE HEADER LABEL.

SPACE
ENTRY MTWOPEN
MTWOPEN PROLOG MTSAVAR,MTSAVR2Z
STM 1,2,MTSAVR1
MVI MTWOR+1,0
PROGRAM MODIFICATION.
LA
2,MTLABAR
LABEL AREA.
USING TFLAB,2
TM
MTFLAGS,FILOPEN
CHECK FOR FIRST REEL.
BO
MTWO1
BRANCH IF NOT.
MVC MTVOLSEQ(2),=C'00' OTHERWISE, INITIALIZE REEL NUMBER.
SETLU
MTWO1
SWITCH
MTWO2
ICALL MTLABCK
CHECK LABELS.
SPACE
*
SET UP HEADER LABEL.
SPACE
MVC TFTYPE(TFCDAT-TFLAB),APLHDR FIRST PART.
SYSDATE TFCDAT,SAVETEMP CREATION DATE
MVC TFEDAT(TFLABZ-TFEDAT),APLLR REMAINDER OF ALBEL.
SPACE
*

04500000
04560000
04620000
04680000
04740000
04800000
04860000
04920000
04980000
05100000
05160000
05340000
05400000
05460000
05520000
05580000
05640000
05700000
05820000
05880000
06060000
06120000
06480000
06540000
06780000
06840000
06900000
06960000
07020000
07080000
07140000
07200000
07260000
07320000
07380000
07440000
07500000
07560000
07620000
07680000
07740000
07800000
07860000
07920000
07980000
08040000
08100000
08160000
08220000
08280000
08340000
08400000
08460000
08520000
08580000
08640000
08700000
08760000
08820000
08880000

*
*

OPEN NEW FILE.

08940000
09000000
SPACE
09060000
MTWOR
BC
0,MTWOZ1
PROGRAM MODIFIED.
09120000
*
TO PREVENT MULTIPLE INCREASE OF
09180000
*
VOL NUMBER.
09240000
TR
MTVOLSEQ+1(1),EBCDEC INCREMENT REEL NUMBER.
09300000
CLI MTVOLSEQ+1,C'0'
CHECK FOR OVERFLOW.
09360000
BNE MTWOZ1
09420000
TR
MTVOLSEQ(1),EBCDEC 99 REELS IS ENOUGH FOR ANYONE.
09480000
*
LABEL CHECKING ROUTINE LEAVES THE TAPE POSITIONED FOR THE
09540000
*
HEADER LABEL.
09600000
MTWOZ1 MVC TFVSEQ+2(2),MTVOLSEQ MOVE IN REEL NUMBER.
09660000
MVC TFBLKCT(4),TRECLEN WRITE BLOCK LENGTH IN LABEL.
09720000
MVI RETRIES,0
09780000
MTWOZ2 MVI CTLCCW,TWRITE
WRITE HEADER LABEL.
09840000
EXCP CTLCCB
ASSUME DCB'S HAVE BEEN OPENED.
12060000
WAIT (1)
12120000
* THIS CODE RETRIES WRITE IF UNIT EXCEPTION OCCURRED ON PREVIOUS
12180000
* BACKSPACE-RECORD (THIS CAN OCCUR IF BSR SENSES FOIL STRIP OR
12240000
* A TAPE-MARK). THE CONDITION CAUSED HDR1 TO BE OMITTED
12300000
* BECAUSE SUCCEEDING WRITE-TAPE-MARK RESETS THE ERROR CONDITION.
12360000
*
12420000
DCBIFLGS EQU X'2C'
OFFSET TO DCBIFLGS
12480000
DCBOFLGS EQU X'30'
OFFSET TO DCBOFLGS
6020 12540000
DCBIOBAD EQU X'1C'
OFFSET TO DCBIOBAD
12600000
EVNTCB EQU X'28'
OFFSET TO ECB (FROM IOB)
12660000
L
LKR,=A(DCBCUR)
PTR TO CURRENT DCB
12720000
L
LKR,0(LKR)
ADDR OF OPENED DCB
12780000
NI
DCBIFLGS(LKR),X'3F' TURN OFF ERROR BITS IN DCBIFLGS
12840000
L
LKR,DCBIOBAD(LKR) ADDR OF IOB
12900000
CLI EVNTCB(LKR),X'44' CHECK FOR INTERCEPT ON BSR
12960000
BE
MTWOZ2
BRANCH IF INT, RETRY WRITE
13020000
MTWO3
ICALL LOGMTLAB
LOG HEADER LABEL
13140000
MVI CTLCCW,WEF
TAPE MARK MUST FOLLOW LAST HDR
13200000
EXCP (1)
13260000
WAIT (1)
13320000
OI
MTFLAGS,FILOPEN
MARK FILE OPEN.
13380000
LM
1,2,MTSAVR1
13440000
IRETURN
13500000
DROP 2
13560000
SPACE
13620000
MTVOLSEQ DC
C'00'
13680000
RETRIES DC
X'00'
13740000
RETRYTR DC
X'0102030405060708090A0B00'
13800000
COMREJ EQU X'80'
13860000
FILPROT EQU X'02'
13920000
CTLSENSE DC
XL2'00'
13980000
TITLE 'APL UTILITY MAGNETIC TAPE OUTPUT CLOSE
05/11/70' 14040000
*
14100000
*
CLOSE LAST OUTPUT FILE.
14160000
*
14220000
ENTRY MTWCLOSE
14280000
MTWCLOSE PROLOG MTSAVAR,MTSAVR5Z
14340000
STM 0,4,MTSAVR1
14400000
OI
MTFLAGS,CLOSING
MAKE SURE MTWRZ DOESN'T WRITE EOV. 14460000
ICALL MTWRZ
MAKE SURE ALL WRITES ARE COMPLETE. 14520000
MVC MTLABAR(3),=C'EOF' END OF FILE TRAILER.
14580000
LA
4,MTTRLBL
WRITE TRAILER LABEL & SHOW OPERATOR 14640000
BALR 3,4
14700000

MTLABCK

MTNEWTAP

RDLBL

*
MTLABC1
MTLABSW

MTCKM1

*
*
*
VOLLBL

MVI MTFLAGS,0
RESET ALL FLAGS.
LM
0,4,MTSAVR1
IRETURN
TITLE 'APL UTILITY MAGNETIC TAPE OUTPUT LABEL CHECKING'
PROLOG MTSAVAR,MTREPZ
STM 1,2,MTSAVR1
XC
MTLABAR(80),MTLABAR ZERO LABEL AREA.
MVC VOLID(6),=C'*NOLBL' VOLID FOR UNLABELED TAPES
L
2,DCBCUR
OPEN ((2),(OUTPUT))
TM
DCBOFLGS(2),X'10' WAS OPEN SUCCESSFUL ?
6020
BO
MTNEWTAP
YES IT WAS
6020
ABEND 1550,DUMP
6020
MVI CTLCCW,REW
REWIND THE TAPE.
EXCP CTLCCB
WAIT (1)
MVI CTLCCW,TREAD
READ THE LABEL, IF ANY.
EXCP (1)
WAIT (1)
LA
2,MTLABAR
BEGIN LABEL CHECK
USING TFLAB,2
CLC TFTYPE(3),=C'VOL' CHECK FOR A VOL LABEL.
BE
VOLLBL
PRESERVE IT IF FOUND
CLC TFTYPE(4),=C'HDR1' SEE IF TAPE IS LABELLED.
BNE MTLABOK
WRITE ON IT IF NOT.
TM
MTFLAGS,FILOPEN
CHECK FOR FIRST REEL.
BZ
MTLABC1
CHECK EXPIRY IF NOT.
CLC TFLAB(TFVSEQ-TFLAB),PREVLAB OTHERWISE, SEE IF SAME AS
BNE MTLABC1
PREVIOUS. EXPIRY CHECK IF NOT.
CLC TFCDAT(6),PREVDAT CHECK CREATION DATE FOR AGREEMENT.
BE
MTLABOK
IF AGREES, ANOTHER VOLUME OF ACCEPTE
SPACE
EXPIRATION CHECK.
SPACE
MVC PREVLAB(TFVSEQ-TFLAB),TFLAB SAVE FOR FUTURE CHECKS.
MVC PREVDAT(6),TFCDAT
BC
0,MTLABOK
SWITCH FOR IGNORE RESPONSE $$$$$
SYSDATE TODAYDAT,SAVETEMP TODAY'S DATE
CLC TFEDAT(6),TODAYDAT
BL
MTLABOK
BRANCH IF EXPIRED.
ICALL LOGMTLAB
PRINT PART OF THE LABEL.
ICALL OUTWRTL
WRITE NOT EXPIRED MESSAGE
DC
AL4(EXPMSG)
LA
1,MTREP
POINT TO REPLY AREA
LR
0,1
ICALL OUTWRTL
DC
AL4(REPMSG)
OC
MTREP(7),=CL7' '
FOLD TO UPPER CASE
CLC MTREP(7),=C'NEWTAPE'
BE
MTNEWTAP
NEWTAPE MEANS HE MOUNTED ANOTHER
CLC MTREP(6),=C'IGNORE' IGNORE MEANS OKAY TO WRITE
BNE MTCKM1
MVI MTLABSW+1,X'F0'
SET IGNORE SWITCH $$$$$ $$$$$
B
MTNEWTAP
MAKE SURE TAPE HAS BEEN CHANGED
REMEMBER VOLID FROM VOL1 LABEL FOR INSERTION INTO HDR1
CLI
BNE
MVC

TFNUM,C'1'
RDLBL
VOLID(6),TFFID

IGNORE ALL BUT VOL1 LABELS

SAVE VOLID

14760000
14820000
14880000
14940000
15000000
15060000
15120000
15180000
15360000
15420000
15480000
15540000
15600000
15720000
15780000
15840000
15900000
15960000
16020000
16080000
16140000
16200000
16260000
16320000
16380000
16440000
16500000
16560000
16620000
16680000
16740000
16800000
16860000
16920000
16980000
17040000
17100000
17160000
17220000
17280000
17340000
17400000
17460000
17520000
17580000
17640000
17700000
17760000
17820000
17880000
17940000
18000000
18060000
18120000
18180000
18240000
18300000
18360000
18420000
18480000

B
RDLBL
*
*
TAPE MAY BE WRITTEN ON
*
MTLABOK MVI CTLCCW,BSR
BACKSPACE TO POSITION.
EXCP CTLCCB
WAIT (1)
MVI MTLABSW+1,X'00'
RESET IGNORE SWITCH $$$$$ $$$$$
LM
1,2,MTSAVR1
IRETURN
SPACE
PREVLAB DC
CL27' '
PREVDAT DC
CL6' '
TODAYDAT DC
CL6' '
TITLE 'APL UTILITY MAGNETIC TAPE WRITE
05/11/70'
SPACE
*
*
WRITE WORKSPACE SPECIFIED BY R 11 TO MAG TAPE.
*
TWRITE EQU 1
SPACE
ENTRY MTWR
MTWR
PROLOG MTSAVAR,MTSAVR1Z
ST
1,MTSAVR1
MVC MTWSLIB(16),WFLLIB SAVE WSID FOR THIS RECORD
MVC MTWSDATE(12),WFLDATE SAVE TIME STAMP FOR THIS RECORD
L
1,=A(UTFLAGS)
MAKE SURE HE WANTS ALL WSID
TM
0(1),UTWSLST
LISTED BEFORE DOING SO.
BZ
MTWRX
MVC DISWSID(6),=CL6'
' BLANK OUT POSSIBLE ERROR PFX
ICALL OUTWRT
LIST WSID & TIME STAMP
DC
AL4(MTWSID)
MTWRX
ICALL MTWRZ
CLEAN UP ANY PREVIOUS WRITE
MVI TOP,TWRITE
OPERATION FOR CTCOMP
ICALL CTCOMP
SET UP TAPE CCW CHAIN.
TM
MTFLAGS,MTREJ
THIS TEST SHOULD BE UNNECESSARY
BO
MTWRXX
SINCE MX, SVI WERE CHECKED BY CDCOMP
*
WHEN WS WAS READ FROM DISK.
MVC MTDCCB+8(4),=A(TCCWAR) CCB CCW ADDRESS
EXCP MTDCCB
START THE WRITE.
OI
MTFLAGS,CCWAIU
MARK I/O PENDING.
MTWRXX NI
MTFLAGS,255-MTREJ TURN OFF REJECT FLAGS
L
1,MTSAVR1
IRETURN
TITLE 'APL UTILITY MAGNETIC TAPE END OF WRITE
05/11/70'
*
*
END OF WRITE AND END OF VOLUME ROUTINE.
*
ENTRY MTWRZ
MTWRZ
PROLOG MTSAVAR,MTSAVR5Z
STM 0,4,MTSAVR1
TM
MTFLAGS,CCWAIU
CHECK FOR PENDING I/O.
BZ
MTWRZZ
BRANCH IF NONE.
MTWRZ2 WAIT MTDCCB
WAIT FOR COMPLETION
TM
MTDCCB+4,UE
CHECK FOR END OF VOLUME.
BO
MTWEOV
BRANCH IF SO.
CLC MTDCCB+13(3),EXPCSWA+1 CHECK FINAL CSW ADDRESS.
BE
MTWRZZ
OK
3066
MVC TAPEUNIT(3),LOGUN TAPE ADDRESS TO MSG
3066
ICALL OUTWRTL
PERMANENT I/O ERROR- WRITE MSG 3066

18540000
18600000
18660000
18720000
18780000
18840000
18900000
18960000
19020000
19080000
19140000
19200000
19260000
19320000
19380000
19440000
19500000
19560000
19620000
19680000
19740000
19800000
19860000
19920000
19980000
20040000
20100000
20160000
20220000
20280000
20340000
20400000
20460000
20520000
20580000
20640000
20700000
20760000
20820000
20880000
20940000
21000000
21060000
21120000
21180000
21240000
21300000
21360000
21420000
21480000
21540000
21600000
21660000
21720000
21780000
21840000
21900000
21960000
22020000
22080000

DC
AL4(TAPERROR)
CANCEL ,
ABEND
NI
MTFLAGS,255-CCWAIU
LM
0,4,MTSAVR1
IRETURN

3066 22140000
3066 22200000
MTWRZZ
22260000
22320000
22380000
*
22440000
*
END OF VOLUME
22500000
*
22560000
*
TO AVOID WRITING OFF THE END OF A REEL OF TAPE, WE OPEN A
22620000
*
NEW REEL AND WRITE THE ENTIRE WS THERE. MTRDZ WILL REJECT
22680000
*
THE INCOMPLETE COPY WHICH CONTAINS THE TAPE MARK.
22740000
*
22800000
MTWEOV TM
MTFLAGS,CLOSING
SEE IF CALL WAS FROM MTCLOSE
22860000
BO
MTWRZZ
22920000
MVC MTLABAR(3),=C'EOV' SET UP EOV LABEL.
22980000
LA
4,MTTRLBL
WRITE EOV LABEL & SHOW OPERATOR
23040000
BALR 3,4
23100000
ICALL MTWOPEN
OPEN NEW VOLUME.
23160000
CLC MTDCCB+13(3),EXPCSWA+1 CHECK FOR COMPLETION
23220000
BE
MTWRZZ
23280000
MVC MTDCCB+8(4),=A(TCCWAR) MOVE CCW START ADDR TO CCB
23340000
EXCP MTDCCB
WRITE THE WS AGAIN
23400000
B
MTWRZ2
GO ACT AS IF NOTHING HAPPENED
23460000
DROP PR
23520000
*
23580000
*
WRITE EOF OR EOV LABEL & SHOW OPERATOR
23640000
*
23700000
USING *,4
23760000
MTTRLBL LA
2,=AL1(WEF,NOP,TWRITE,WEF,WEF) COMMANDS
24180000
LA
0,5
SET COMMAND COUNT
24300000
LA
1,CTLCCB
24360000
MTTRLBL1 MVC CTLCCW(1),0(2)
PLANT CCW COMMAND
24420000
EXCP (1)
24480000
WAIT (1)
24540000
LA
2,1(2)
NEXT COMMAND PLEASE
24600000
BCT 0,MTTRLBL1
24660000
ICALL LOGMTLAB
24720000
L
2,DCBCUR
24900000
CLOSE ((2))
CLOSE TAPE DCB AT EOF OR EOV
24960000
BR
3
RETURN
25020000
DROP 4
25080000
TITLE 'APL UTILITY MAGNETIC TAPE INPUT OPEN
05/11/70' 25140000
*
25200000
*
INPUT TAPE LABEL CHECKING
25260000
*
25320000
ENTRY MTROPEN
25380000
MTROPEN PROLOG MTSAVAR,MTREPZ
25440000
STM 1,2,MTSAVR1
25500000
NI
MTFLAGS,255-MTEOF
25560000
XC
MTLABAR(80),MTLABAR
25620000
TM
MTFLAGS,FILOPEN
CHECK FOR FIRST REEL.
25680000
BO
MTRO1
BRANCH IF NOT.
25740000
MVI CTCOMP2+1,0
SET FIRST TIME SWITCH (SIGH) $$$$$ 25800000
MVI MTRDZ6+1,0
SET FIRST TIME SWITCH (SIGH) $$$$$ 25860000
MVI MTRDZ5+1,X'F0'
SAME
25920000
SETLU
INITIALIZE LOGICAL UNITS.
25980000
MTRO1
SWITCH
,SWITCH LOGICAL UNITS.
26040000
MVC VOLID(6),=C'*NOLBL'
VOLID FOR UNLABELED TAPE
26100000
L
2,DCBCUR
26280000
OPEN ((2),(INPUT))
26340000

TM
DCBOFLGS(2),X'10'
BO
MTRO3
YES
ABEND 1550,DUMP
MVI CTLCCW,REW
EXCP CTLCCB
WAIT (1)
MVI CTLCCW,TREAD
EXCP (1)
WAIT (1)
LA
2,MTLABAR
USING TFLAB,2
CLC TFTYPE(3),=C'VOL'
BE
MTRVOL
CLC TFTYPE(4),=C'HDR1'
BNE MTROXXX
TM
MTFLAGS,FILOPEN
BO
MTROC
CLC TFVSEQ+2(2),=C'01'
BNE MTRVSER
MVC MTROCD(6),TFCDAT
MVC MTRPVS(2),TFVSEQ+2
TR
MTRPVS+1(1),EBCDEC
CLI MTRPVS+1,C'0'
BNE MTR04
TR
MTRPVS(1),EBCDEC
CLC TFFID,APLMTID
BNE MTROXXY
MVC TRECLEN(4),TFBLKCT
EXCP CTLCCB
WAIT (1)
TM
CTLCCB+4,UE
BZ
MTROXXX
OI
MTFLAGS,FILOPEN
ICALL LOGMTLAB
LM
1,2,MTSAVR1
IRETURN

WAS OPEN SUCCESSFUL ?

IT WAS

6020 26400000
6020 26460000
6020 26520000
MTRO3
REWIND INPUT TAPE.
26640000
26700000
26760000
READ HEADER LABEL.
26820000
MTRO2
26880000
26940000
LABEL AREA.
27000000
27060000
SKIP OVER ANY VOL LABELS.
27120000
27180000
MUST BE HEADER 1 LABEL
27240000
BRANCH IF NOT.
27300000
CHECK FOR FIRST REEL
27360000
BRANCH IF NOT
27420000
REALLY VOL 1
27480000
NO, ERROR
27540000
MTROCI
SAVE CREATION DATE &
27600000
VOLUME SEQUENCE NUMBER
27660000
MTROVI
ADD ONE TO VOL SEQ NUMBER
27720000
CHECK FOR OVERFLOW
27780000
27840000
99 ENOUGH FOR ANYBODY
27900000
MTR04
CHECK FOR APL DUMP ID
27960000
REFUSE IT IF NOT OURS
28020000
PICK UP RECORD LENGTH FROM LABEL.
28080000
POSITION OVER TAPE MARK
28140000
28200000
IF WE DIDN'T SKIP OVER TAPE MARK,
28260000
TAPE NOT TO OUR STANDARDS,REJECT. 28320000
MARK FILE AS OPEN.
28380000
LOG HEADER LABEL
28440000
28500000
28560000
*
28620000
MTRVOL CLI TFNUM,C'1'
IGNORE ALL BUT VOL1 LABELS
28680000
BNE MTRO2
28740000
MVC VOLID(6),TFFID
SAVE VOLID
28800000
B
MTRO2
28860000
*
28920000
MTROC
CLC MTROCD(6),TFCDAT
CHECK FOR CONSISTENT CREATION DATE 28980000
BNE MTRVSER
IF NOT, ERROR
29040000
CLC MTRPVS(2),TFVSEQ+2 ERROR IF SEQUENCE NUMBER IS NOT
29100000
BE
MTROVI
ONE MORE THAN PREVIOUS
29160000
*
VOLUME SEQUENCE ERROR MESSAGE & OPERATOR COMMUNICATION 29220000
MTRVSER ICALL LOGMTLAB
SHOW THE LABEL TO THE OPERATOR
29280000
ICALL OUTWRTL
WRITE VOL SEQ ERR MESSAGE TO OPR
29340000
DC
AL4(SEQMSG)
29400000
MTRVSERX LA
1,MTREP
POINT TO REPLY AREA
29460000
LR
0,1
R0 NOT = 0 MEANS SYSLOG
29520000
ICALL OUTWRTL
29580000
DC
AL4(REPMSG)
29640000
OC
MTREP(7),=CL7' '
FOLD TO UPPER CASE
29700000
CLC MTREP(6),=C'IGNORE' DOES HE REALLY WANT THIS TAPE
29760000
BE
MTROCI
YES, HE'S THE BOSS
29820000
CLC MTREP(7),=C'NEWTAPE' DID HE PUT UP THE WRONG TAPE
29880000
BE
MTRO3
YES, PROCESS LABEL.
29940000
B
MTRVSERX
30000000

*
MTROXXY ICALL LOGMTLAB
MTROXXX ICALL OUTWRTL
COMPLAIN TO THE OPERATOR
DC
AL4(XXXMSG)
MVI CTLCCW,RUN
UNLOAD THE REJECTED TAPE.
EXCP CTLCCB
WAIT (1)
B
MTRO3
DROP 2
TITLE 'APL UTILITY MAGNETIC TAPE READ
05/11/70'
*
*
READ A WORKSPACE FROM TAPE TO THE AREA SPECIFIED BY R 11.
*
TREAD
EQU 2
ENTRY MTRD
MTRD
PROLOG MTSAVAR,MTSAVR2Z
STM 1,2,MTSAVR1
ICALL MTRDZ
OTHERWISE, COMPLETE.
MTR1
MVI MTRRTCT,0
SET READ RETRY COUNT TO 0
MVI MTR6+1,0
SET RETRY SWITCH. (PROG MOD)
L
1,=A(TCCWAR)
SET UP READ OF FIRST RECORD.
ST
11,0(1)
DATA ADDRESS.
MVI 0(1),TREAD
COMMAND.
MVC 4(4,1),=A(SVI-M+4) ZERO FLAGS, COUNT.
MVC MTDCCB+8(4),=A(TCCWAR)
MTR1A
EXCP MTDCCB
READ FIRST RECORD.
WAIT (1)
NI
MTFLAGS,255-MTREJ-SIZEMOD RESET FLAGS
TM
MTDCCB+4,UE
CHECK FOR EOF.
BZ
MTR1B
ICALL MTREOF
PROCESS END OF VOLUME
TM
MTFLAGS,MTEOF
IF NOT EOF, REREAD WS FROM NEXT TAPE
BO
MTR5
B
MTR1
MTR1B
TM
MTDCCB+5,IL
CHECK FOR INCORRECT LENGTH
BNZ MTR6
TM
MTDCCB+2,UNERR
LOOK FOR UNRECOVERABLE DATA CHECK
BZ
MTR3
NO ERRORS
B
MTR6A
*
*
INCORRECT LENGTH ON FIRST RECORD.
*
MTR6
BC
0,MTR1A
PROGRAM MODIFIED $$$$$$$$$$$
MVI CTLCCW,BSR
OTHERWISE, RETRY.
EXCP CTLCCB
BACKSPACE RECORD.
WAIT (1)
TR
MTRRTCT,MTRRTR
COUNT RETRIES.
CLI MTRRTCT,0
SEE IF WE'VE EXHAUSTED LIMIT.
BNE MTR1A
NO, WE CAN RETRY THE READ.
*
AFTER 4 RETRIES, STILL GET INCORRECT LENGTH.
MTR6A
BAL 2,SHOWDIS
TELL OPR WE MAY HAVE LOST A WS
MVI MTR6+1,X'F0'
FLIP RETRY SWITCH SO WE'LL FORWARD
*
SPACE.
B
MTR1A
AND GO PROCEED TO SPACE TAPE.
*
*
FIRST RECORD WAS READ SUCESSFUL. PROCEED TO READ REST OF WS.
*
MTR3
MVI TOP,TREAD
OPERATION FOR CTCOMP.
ICALL CTCOMP
COMPUTE CCW CHAIN.
OI
MTFLAGS,CCWAIU
MARK CCW AREA IN USE

30060000
30120000
30180000
30240000
30300000
30360000
30420000
30480000
30540000
30600000
30660000
30720000
30780000
30840000
30900000
30960000
31020000
31080000
31140000
31200000
31260000
31320000
31380000
31440000
31500000
31560000
31620000
31680000
31740000
31800000
31860000
31920000
31980000
32040000
32100000
32160000
32220000
32280000
32340000
32400000
32460000
32520000
32580000
32640000
32700000
32760000
32820000
32880000
32940000
33000000
33060000
33120000
33180000
33240000
33300000
33360000
33420000
33480000
33540000
33600000

TM
BZ
TM
BO
BAL
B
MVC
L
NI

MTFLAGS,MTREJ
AVOID MESSAGE IF CTCOMP OK'ED THE WS 33660000
MTR4
33720000
MTFLAGS,SIZEMOD
IF WS SIZE IS BEING CONVERTED,
33780000
MTR4
WE'LL WORRY ABOUT ERROR AT MTRDZ.
33840000
2,SHOWDIS
TELL OPR THINGS DON'T LOOK GOOD
33900000
MTR5
33960000
MTR4
MTDCCB+8(4),=A(TCCWAR+8) IGNORE THE FIRST CCW
34020000
1,=A(TCCWAR+8)
RESET SKIP BIT IN SECOND CCW,
34080000
4(1),255-SKIP
WHICH IS SET WHEN WS TOO BIG.
34140000
*
(WE NEED 2ND RECORD FOR WSID)
34200000
EXCP MTDCCB
START THE I/O.
34260000
MTR5
LM
1,2,MTSAVR1
34320000
IRETURN
34380000
TITLE 'APL UTILITY MAGNETIC TAPE END OF READ'
34440000
*
34500000
*
COMPLETION OF MAG TAPE READ OPERATION.
34560000
*
34620000
ENTRY MTRDZ
34680000
MTRDZ
PROLOG MTSAVAR,MTSAVRBZ
34740000
STM 1,2,MTSAVR1
34800000
ST
11,MTSAVRB
34860000
TM
MTFLAGS,CCWAIU
CHECK FOR ANYTHING PENDING.
34920000
BZ
MTRDZZ
BRANCH IF NONE.
34980000
TM
MTFLAGS,SIZEMOD
IF MTREJ BUT NOT SIZEMOD BY CTCOMP, 35040000
BO
MTRDZ1
(SEE NOTE IN CTCOMP) WE SHOULD
35100000
TM
MTFLAGS,MTREJ
RETURN WITH MTREJ SET, AND NEXT
35160000
BO
MTRDZZ
READ SHOULD BE SUCESSFUL.
35220000
MTRDZ1 WAIT MTDCCB
WAIT FOR COMPLETION.
35280000
L
11,=A(TCCWAR)
GET ADDRESS OF WS
35340000
L
11,0(11)
35400000
LA
11,0(11)
35460000
TM
MTDCCB+4,UE
IF TAPE MARK WAS READ BEFORE END
35520000
BZ
MTRDZNE
OF WS, QUIETLY IGNORE THIS COPY,
35580000
ICALL MTREOF
SINCE THE COMPLETE COPY OF THIS WS 35640000
OI
MTFLAGS,MTREJ
IS ON THE NEXT REEL.
35700000
B
MTRDZZ
35760000
MTRDZNE TM
MTDCCB+2,UNERR
35820000
BO
MTRDIS
UNRECOVERABLE READ ERROR
35880000
TM
MTDCCB+5,IL
INCORRECT LENGTH HAS SPECIAL CASES 35940000
BZ
MTRDZ2
BRANCH IF NOT.
36000000
MVC MTTEMP(4),MTDCCB+12 OTHERWISE, CHECK FOR A DC CCW.
36060000
L
1,MTTEMP
36120000
S
1,=F'16'
36180000
TM
4(1),DC
36240000
BZ
MTRDZ4
36300000
LA
1,8(1)
OTHERWISE,
36360000
CLC MTDCCB(2),6(1)
RESIDUAL COUNT MUST EQUAL COUNT OF 36420000
BNE MTRDZ4
CCW AFTER DC CCW, ELSE TAPE ERROR
36480000
MVI 0(1),TREAD
FORCE COMMAND TO A READ.
36540000
ST
1,MTTEMP
36600000
MVC MTDCCB+9(3),MTTEMP+1 RESUME CHAIN BACK 1 CCW
36660000
EXCP MTDCCB
36720000
B
MTRDZ1
WAIT FOR COMPLETION.
36780000
MTRDZ2 CLC MTDCCB+13(3),EXPCSWA+1 CHECK CSW ADDRESS.
36840000
BNE MTRDIS
BRANCH IF NOT THE EXPECTED.
36900000
*
36960000
*
PERFORM WORKSPACE SIZE RELOCATION IF REQUIRED
37020000
*
37080000
TM
MTFLAGS,MTREJ+SIZEMOD IF WS TOO LARGE, REJECT
37140000
BO
MTRDZ6
37200000

TM
BZ
ICALL
TM
BO

MTFLAGS,SIZEMOD
MTRDZ8
RELOCWS
MTFLAGS,MTREJ
MTRDZZ

IF WS SIZE RELOCATION REQUIRED,

37260000
37320000
GO RELOCATE WS
37380000
IF WS WAS REJECTED, WE'RE DONE
37440000
37500000
*
37560000
*
PERFORM WORKSPACE MODIFICATION IF REQUESTED (APLMOD)
37620000
*
37680000
MTRDZ8 L
1,=A(CMD)
SEE IF WSS ARE BEING MODIFIED
37740000
TM
0(1),CMMOD
37800000
CMMOD
EQU X'10'
CMD MASK - CALL APLMOD ROUTINE
37860000
BZ
MTRDZX
BRANCH IF NO MODIFICATIONS
37920000
L
1,=A(APLMODAD)
MODIFICATION PROGRAM ADDRESS.
37980000
L
1,0(1)
38040000
BALR LKR,1
38100000
MTRDZX MVC MTWSLIB(16),WFLLIB SAVE WSID FOR THIS RECORD
38160000
MVC MTWSDATE(12),WFLDATE SAVE TIME STAMP FOR THIS RECORD
38220000
MTRDZ5 BC
15,MTRDZY
PROGRAM MODIFIED $$$$$$$$$$$$$$$$$$ 38280000
MVC DISWSID(6),=CL6'BEFORE' SHOW WHERE WE RECOVERED FROM
38340000
ICALL OUTWRT
THE LAST READ ERROR
38400000
DC
AL4(DISWSID)
38460000
MVI MTRDZ5+1,X'F0'
RESTORE TO NORMAL (NO PRIOR ERROR) 38520000
MTRDZY L
11,MTSAVRB
38580000
MTRDZZ NI
MTFLAGS,255-CCWAIU TURN OFF PENDING FLAG.
38640000
LM
1,2,MTSAVR1
38700000
IRETURN
38760000
*
38820000
*
REJECT A WS WHICH IS TOO BIG FOR THIS SYSTEM
38880000
*
38940000
MTRDZ6 BC
0,MTRDZ7
FIRST PASS SWITCH (MODIFIED) $$$$$$ 39000000
ICALL OUTWRTL
TELL THE OPERATOR WE ARE REJECTING 39060000
DC
AL4(SIZEMSG2)
WS(S) AS BEING TOO BIG.
39120000
MVI MTRDZ6+1,X'F0'
RESET 1ST PASS SWITCH $$$$$$$$$$$$ 39180000
MTRDZ7 MVC SIZEWSID(16),WFLLIB LOG TO SYSLST THE TIME STAMP AND
39240000
MVC SIZEDATE(12),WFLDATE WSID OF EACH WS WE ARE REJECTING 39300000
ICALL OUTWRT
AS TOO BIG.
39360000
DC
AL4(SIZEMSG3)
39420000
B
MTRDZY
39480000
*
39540000
*
INCORRECT LENGTH ERROR ON CCW NOT DATA-CHAINED
39600000
*
39660000
MTRDZ4 MVI CTLCCW,BSR
BACKUP AND ASSUME NOISE CAUSED
39720000
EXCP CTLCCB
US TO READ INTO NEXT WS.
39780000
*
39840000
*
CAN'T MAKE SENSE OUT OF THIS SPOT ON TAPE.
39900000
*
TELL THE OPERATOR WE THINK WE'VE LOST A WORKSPACE, AND
39960000
*
THEN TRY TO POSITION TO THE NEXT GOOD WORKSPACE ON TAPE.
40020000
*
40080000
MTRDIS BAL 2,SHOWDIS
TELL THE OPERATOR WE ARE GIVING UP 40140000
MVC DISWSID(6),=CL6'ERROR ' WE MIGHT AS WELL TRY TO SHOW
40200000
*
HIM THE WSID FOR THIS WS.
40260000
MVC MTWSLIB(16),WFLLIB SAVE WSID FOR THIS RECORD
40320000
MVC MTWSDATE(12),WFLDATE SAVE TIME STAMP FOR THIS RECORD
40380000
ICALL OUTWRT
40440000
DC
AL4(DISWSID)
40500000
OI
MTFLAGS,MTREJ
40560000
MVC MTDCCB+8(4),=A(TCCWAR)
40620000
L
1,=A(TCCWAR)
SET UP A READ WITH SKIP.
40680000
MVC 0(8,1),MTS1CW
SKIP CCW.
40740000
MTRDIS1 EXCP MTDCCB
READ WITH SKIP.
40800000

WAIT (1)
TM
MTDCCB+4,UE
SEE IF WE HIT AN END FILE.
BO
MTRDISZ
QUIT IF SO.
TM
MTDCCB+5,IL
CHECK FOR INCORRECT LENGTH.
BO
MTRDIS1
SKIP ANOTHER RECORD IF SO.
MTRDISZ MVI CTLCCW,BSR
SET UP BACKSPACE RECORD.
EXCP CTLCCB
BACKSPACE OVER LAST RECORD.
B
MTRDZY
MTRRTCT DC
X'00'
MTRRTR DC
X'0102030400'
TITLE 'APL UTILITY MAGNETIC TAPE INPUT CLOSE
05/11/70'
*
*
INPUT TAPE CLOSE ROUTINE.
ENTRY MTRCLOSE
MTRCLOSE PROLOG MTSAVAR,MTSAVR1Z
ST
1,MTSAVR1
L
5,DCBCUR
CLOSE ((5))
MVI MTFLAGS,MTEOF
CLEAR FLAGS
L
1,MTSAVR1
IRETURN
*
*
END OF FILE ON INPUT TAPE
*
MTREOF PROLOG
MVI CTLCCW,TREAD
READ TRAILER LABEL
EXCP CTLCCB
WAIT (1)
CLC MTLABAR(3),=C'EOF' CHECK FOR LAST REEL
BNE MTREOF1
MTREOF0 MVI MTFLAGS,MTEOF
SET END-OF-FILE, RESETTING ALL ELSE
ICALL LOGMTLAB
B
MTREOFZ
MTREOF1 CLC MTLABAR(3),=C'EOV' VERIFY END OF VOLUME
BE
MTREOF2
MVC MTLABAR(21),=C'****NO TRAILER LABEL '
B
MTREOF0
TREAT LIKE AN EOF ANYWAY
MTREOF2 ICALL LOGMTLAB
ICALL MTROPEN
OPEN NEXT FILE
MTREOFZ IRETURN ,
RETURN
DROP 12
*
*
SHOWDIS TELLS THE OPERATOR WE ARE REJECTING A WS & THE WSID
*
OF THE PRIOR WS. IT THEN INDICATES THAT THE NEXT SUCESSFUL
*
WS READ SHOULD ALSO BE LOGGED.
*
SHOWDIS BALR 1,0
USING *,1
L
1,=A(MTRDZ)
USING MTRDZ,1
ICALL OUTWRTL
TELL THE OPERATOR
DC
AL4(DISMSG)
MVC DISWSID(6),=CL6'AFTER ' SHOW LAST WSID
ICALL OUTWRT
DC
AL4(DISWSID)
MVI MTRDZ5+1,X'00'
REMEMBER TO SHOW NEXT WSID $$$$$$$
BR
2
RETURN
DROP 1
TITLE 'APL UTILITY MAGNETIC TAPE CCW GENERATION
05/11/70'
*

40860000
40920000
40980000
41040000
41100000
41160000
41220000
41280000
41340000
41400000
41460000
41520000
41580000
41640000
41700000
41760000
42180000
42240000
42300000
42360000
42420000
42480000
42540000
42600000
42660000
42720000
42780000
42840000
43200000
43260000
43320000
43380000
43440000
43500000
43560000
43620000
43680000
43740000
43800000
43860000
43920000
43980000
44040000
44100000
44160000
44220000
44280000
44340000
44400000
44460000
44520000
44580000
44640000
44700000
44760000
44820000
44880000
44940000
45000000
45060000

*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
*
DC
CC
SLI
SKIP
*
CTCOMP

MAGNETIC TAPE CCW GENERATION

EACH WS ON TAPE CONSISTS OF 3 OR MORE PHYSICAL RECORDS LE
RECLEN. THE WS IS WRITTEN AS TWO AREAS, FROM START OF WS
THRU MX, AND FROM SVI THRU END OF WS, WITH A LITTLE SLACK
AT EACH END. THIS FORMAT MINIMIZES THE AMOUNT OF TAPE
REQUIRED FOR EACH WS.
RECORD 1 IS FROM THE START OF WS THRU INCLUSIVE THE LOCATIONS
QR13STK, MX & SVI. FROM THESE THREE LOCATIONS WE CAN
COMPUTE THE WSLEN ON TAPE TO DETERMINE IF RELOCATION IS
REQUIRED, AND ALSO GENERATE THE APPROPRIATE CCW CHAIN.
AREA 1 CONTINUES THRU MX, AREA 2 STARTS AT SVI THRU THE END
OF THE WS.
THE TAPE ERROR RETRY LOGIC AT MTRDIS INTRODUCES THE VERY
SLIGHT POSSIBILITY THAT THE RECORD WE CURRENTLY THINK IS THE
FIRST RECORD OF THIS BLOCK IS REALLY THE LAST RECORD OF THE
DISCARDED WS. TO PROTECT OURSELVES FROM DISASTER, WE MAKE
EFFECTIVELY THE SAME TESTS ON MX & SVI WHICH ARE MADE IN
CDCOMP (& A FEW OTHERS FOR GOOD MEASURE). WE CANNOT DO THINGS
EXACTLY THE SAME WAY CDCOMP DOES, BECAUSE WE MUST ALSO
RECOGNIZE AND HANDLE WS SIZE ADJUSTMENT.
NOTE: IT WOULD BE DESIRABLE TO DATA CHAIN BETWEEN MX & SVI,
AND THE CCW'S ARE GENERATED TO ALLOW FOR THIS POSSIBILITY.
IN OS WE CANNOT SAFELY DO THIS FOR EITHER TAPE READS
OR WRITES. THEREFORE WE ARE UNABLE TO PROCESS ANY TAPES
WRITTEN WITH DATA CHAINING
TO IMPLEMENT DATA CHAINING OF WRITES ON A SYSTEM WHICH
SUPPORTS CCW RETRY CORRECTLY, CHANGE THE INSTRUCTION AT
CTCOMP0 TO MVI DCF,SLI+DC
R
R
R
R
R
R

11
10
9
7
8
6

EQU
EQU
EQU
EQU

- MR.
-- CURRENT WS POINTER
- CCW POINTER
- MX
- SVI
- RECORD LENGTH
X'80'
X'40'
X'20'
X'10'

PROLOG CTSAVAR,CTSAVARZ
STM 0,10,CTREGSV
SPACE
MVI CCF,CC
MVI DCF,CC
CLI TOP,TWRITE
BNE CTCOMP1
MVI CCF,SLI+CC
CTCOMP0 MVI DCF,SLI+CC
*
CTCOMP1 LR
10,MR
L
9,=A(TCCWAR)
*
*
R5
R6

SET UP CCW FLAGS.

CC FOR OS ON READ
SEE IF THIS IS A WRITE.
BRANCH IF NOT.
OTHERWISE, SUPRESS INCORRECT LENGTH
WHICH WILL ALWAYS OCCUR ON WRITE.
WE DON'T DARE DATA CHAIN (SEE NOTE)
MOVE WS POINTER TO R10.
GET ADDRESS OF CCW AREA.
R7 R8

45120000
45180000
45240000
45300000
45360000
45420000
45480000
45540000
45600000
45660000
45720000
45780000
45840000
45900000
45960000
46020000
46080000
46140000
46200000
46260000
46320000
46380000
46440000
46500000
46560000
46620000
47280000
47340000
47400000
47520000
47580000
47640000
47700000
47760000
47820000
47880000
47940000
48000000
48060000
48120000
48180000
48240000
48300000
48360000
48420000
48480000
48540000
48600000
48660000
48720000
49020000
49140000
49200000
49260000
49320000
49380000
49440000
49500000
49560000
49620000

LM
CR
BH
LTR
BNH
CR
BH
L
L
ST
S
SR
BZ
*
*
*
CTCOMP2

CTCOMP3

CTCOMP4
CTCOMP5
*
*
*
*

*
*
*
CTCA1

5,8,QR13STK ,QSYMBOT,MX,SVI
7,8
IF MX IS GREATER THAN SVI, EVIL
CTCOMPXX
7,7
IF MX IS NEGATIVE, EVIL
CTCOMPXX
8,6
IF SVI GREATER THAN QSYMBOT, EVIL
CTCOMPXX
2,=A(WSLEN)
PICK UP WS LENGTH (CORE)
2,0(2)
2,WLEN
SAVE IN CASE NEEDED
2,=A(LR13STK)
SUBTRACT R13 STACK LENGTH
2,5
COMPUTE DIFFERENCE BETWEEN CORE
CTCOMP4
& TAPE WS LENGTH. IF SAME, EASY.

49680000
49740000
49800000
49860000
49920000
49980000
50040000
50100000
50160000
50220000
50280000
50340000
50400000
50460000
WS SIZE RELOCATION IS REQUIRED
50520000
50580000
CLI TOP,TWRITE
IF WE ARE DOING A WRITE & WSLEN
50640000
BE
CTCOMPXX
INCORRECT, THINGS LOOK VERY BAD
50700000
BC
0,CTCOMP3
NOTIFY OPR 1ST TIME (PROG MOD) $$$$ 50760000
LA
3,LR13STK(5)
COMPUTE TAPE WS LENGTH
50820000
ST
3,SIZETAPE
50880000
ICALL OUTWRTL
TELL OPERATOR WS SIZE ADJUSTMENTS IN 50940000
DC
AL4(SIZEMSG1)
PROGRESS
51000000
MVI CTCOMP2+1,X'F0'
ONLY 1ST TIME (PROG MODIF) $$$$$$$ 51060000
OI
MTFLAGS,SIZEMOD
INDICATE WS SIZE ADJ FOR THIS WS
51120000
ST
2,RELFACT
SAVE RELOCATION FACTOR FOR LATER
51180000
AR
5,2
ADJUST QR13STK
51240000
AR
6,2
ADJUST QSYMBOT
51300000
AR
8,2
ADJUST SVI
51360000
S
8,=F'80'
INSIST ON SLOP
51420000
CR
7,8
IF MX IS NOW GT SVI, WS IS TOO BIG 51480000
LA
8,80(8)
51540000
BNH CTCOMP4
AND WILL BE READ USING OLD SIZE
51600000
OI
CCF,SKIP
& SKIP FLAG ON IN CCW
51660000
OI
DCF,SKIP
51720000
OI
MTFLAGS,MTREJ
INDICATE WS REJECTED
51780000
B
CTCOMP5
51840000
STM 5,8,QR13STK & ASSOCIATES
51900000
LA
7,7(7)
ROUND MX
51960000
N
7,=F'-8'
TO DOUBLE WORD BOUNDARY.
52020000
L
6,TRECLEN
GET RECORD LENGTH
52080000
52140000
SET UP CCW FOR FIRST RECORD
52200000
START OF WORKSPACE TO 4 + ADDRESS OF SVI
52260000
52320000
ST
10,0(9)
DATA ADDRESS.
52380000
MVC 0(1,9),TOP
OPERATION.
52440000
MVC 4(4,9),=A(SVI-M+4) COUNT.
52500000
A
10,4(9)
NEW WS POINTER.
52560000
S
7,4(9)
REMAINING TO MX.
52620000
MVC 4(1,9),CCF
FLAGS - COMMAND CHAIN.
52680000
LA
9,8(9)
9 POINTS TO NEXT CCW.
52740000
52800000
AREA 1 - 4 + ADDRESS SVI THRU MX
52860000
52920000
ST
10,0(9)
DATA ADDRESS.
52980000
MVC 0(1,9),TOP
OPERATION.
53040000
CR
7,6
MX VS RECORD LENGTH.
53100000
BL
CTCA2
FINISHED THIS AREA IF LESS.
53160000
ST
6,4(9)
COUNT= RECORD LENGTH.
53220000

MVC
AR
SR
LA
B
*
*
*
CTCA2

*
*
*

CTCA3

CTCA4

*
CTCB

*
CTCZ

CTCZ2

4(1,9),CCF
10,6
7,6
9,8(9)
CTCA1

FLAGS - COMMAND CHAIN.

INCREASE WS POINTER BY REC LENGTH.
DECREMENT MXR BY REC LENGTH.
POINT TO NEXT CCW.
ANOTHER CCW IN THIS AREA.

53280000
53340000
53400000
53460000
53520000
53580000
MXR LE RECLEN, BEGIN SECOND AREA - SVI TO END OF WS
53640000
53700000
LR
10,MR
WS ORIGIN TO R 10.
53760000
A
10,SVI
NEXT CCW DATA ADDRESS.
53820000
LA
8,LR13STK
53880000
A
8,QR13STK
TAPE WS LENGTH LESS SVI
53940000
S
8,SVI
EQUALS REMAINING COUNT.
54000000
LTR 7,7
CHECK FOR MXR = 0
54060000
BZ
CTCB
54120000
54180000
DATA CHAIN BETWEEN MX & SVI. (SEE NOTE ABOVE)
54240000
54300000
ST
7,4(9)
COUNT FROM MXR.
54360000
C
7,MINREC
CHECK FOR LESS THAN MINIMUM.
54420000
BNL CTCA3
RBANCH IF NOT LESS.
54480000
MVC 4(4,9),MINREC
OTHERWISE, USE MINIMUM COUNT.
54540000
MVC 4(1,9),DCF
FLAGS - DATA CHAIN (SEE NOTE ABOVE) 54600000
LA
9,8(9)
NEXT CCW.
54660000
ST
10,0(9)
DATA ADDRESS.
54720000
MVC 0(1,9),TOP
MAKE SURE CCW HAS COMMAND CODE.
54780000
SR
6,7
REC LENGTH - MXR = COUNT FOR
54840000
CR
8,6
CHECK SVIR VS THIS COUNT.
54900000
BNH CTCZ
CHAIN IS COMPLETE IF LESS OR EQUAL. 54960000
ST
6,4(9)
DATA CHAINED CCW.
55020000
C
6,MINREC
55080000
BNL CTCA4
55140000
MVC 4(4,9),MINREC
MINIMUM LENGTH.
55200000
S
8,4(9)
DECREMENT SVIR.
55260000
A
10,4(9)
INCREMENT DATA ADDRESS.
55320000
MVC 4(1,9),CCF
FLAGS - COMMAND CHAIN.
55380000
LA
9,8(9)
NEXT CCW.
55440000
L
6,TRECLEN
RELOAD RECORD LENGTH.
55500000
SPACE
55560000
(SVI) TO END OF WORKSPACE.
55620000
SPACE
55680000
ST
10,0(9)
DATA ADDRESS.
55740000
MVC 0(1,9),TOP
OPERATION.
55800000
CR
8,6
SVIR VS REC LENGTH.
55860000
BNH CTCZ
BRANCH IF REMAINING COUNT LESS OR EQ 55920000
ST
6,4(9)
COUNT = REC LENGTH.
55980000
SR
8,6
DECREMENT REMAINING COUNT.
56040000
AR
10,6
INCREMENT DATA ADDRESS.
56100000
MVC 4(1,9),CCF
FLAGS - COMMAND CHAIN.
56160000
LA
9,8(9)
INCREMENT CCW POINTER.
56220000
B
CTCB
ANOTHER CCW, THIS AREA.
56280000
SPACE
56340000
FINAL CCW.
56400000
SPACE
56460000
ST
8,4(9)
FINAL COUNT, NO FLAGS.
56520000
C
8,MINREC
56580000
BNL CTCZ2
56640000
MVC 4(4,9),MINREC
56700000
MVC 4(1,9),CCF
SET FLAGS FOR POSSIBLE SLI & SKIP
56760000
LTR 8,8
SEE IF LAST CCW EXHAUSTED COUNT.
56820000

BP
CTCZ1
BRANCH IF NOT.
S
9,=F'8'
OTHERWISE, BACK UP ONE.
CTCZ1
NI
4(9),SLI+SKIP
TURN OFF COMMAND CHAIN FLAG.
LA
9,8(9)
EXPECTED CSW ADDRESS.
ST
9,EXPCSWA
SAVE FOR INTERRUPT.
LM
0,10,CTREGSV
RESTORE ALL REGISTERS.
IRETURN
CTCOMPXX OI
MTFLAGS,MTREJ
MX AND/OR SVI INCORRECT
B
CTCZ1
RETURN
*
MINREC DC
F'24'
MINIMUM RECORD LENGTH.
CCF
DC
X'00'
COMMAND CHAIN FLAG BYTE.
DCF
DC
X'00'
DATA CHAINING FLAG BYTE.
TITLE 'APL UTILITY MAGNETIC TAPE LABEL DISPLAY
05/11/70'
LOGMTLAB PROLOG MTSAVAR,MTSAVR5Z
STM 1,5,MTSAVR1
LA
2,MTLABAR
LABEL AREA.
USING TFLAB,2
MVC LOGLAB(4),TFTYPE
FILE TYPE.
MVI LOGLAB+4,C' '
MVC LOGLAB+5(17),TFFID FILE ID.
MVC LOGVOL(6),VOLID
VOLUME ID
MVC LOGREEL(2),TFVSEQ+2 REEL NUMBER.
MVC LOGCDAT(7),=AL1(0,1,2,0,3,4,5)
TR
LOGCDAT(7),TFCDAT CREATION DATE.
MVI LOGCDAT+3,C'.'
L
1,DCBCUR
L
1,44(1)
GET DEB ADDRESS
L
1,32(1)
GET UCB ADDRESS
MVC LOGUN(3),13(1)
PUT DEVICE ADDR INTO MESSAGE
CLI LOGLAB,C'E'
ONLY HEADER AND GARBAGE TO SYSLOG
BNE LOGMTLB1
ICALL OUTWRT
OUTPUT LABEL TO SYSLST
DC
AL4(LOGLAB)
B
LOGMTLB2
LOGMTLB1 ICALL OUTWRTL
OUTPUT LABEL TO SYSLOG & SYSLST
DC
AL4(LOGLAB)
LOGMTLB2 LM
1,5,MTSAVR1
IRETURN
DROP 2
SPACE
TITLE 'CONSTANTS AND EQUATES'
CTLCCB CCB SYS004,CTLCCW,X'8000',CTLSENSE
ORG CTLCCB+12
FIX THE HIDDEN FLAG
DC
X'00'
USER MUST NOT MODIFY THIS BYTE.
ORG ,
BUNCH OF GRUMBLE.
MTDCCB CCB SYS004,TCCWAR,X'8001' ,FLAGS MUST NOT BE CHANGED.
CTLCCW CCW 1,MTLABAR,X'20',80
MTS1CW CCW TREAD,TCCWAR,SKIP,SVI-M+4 SPACING CCW.
*
DCBCUR DC
2A(0)
ACTIVE DCB.
SAVETEMP DS
F
DCBALT EQU DCBCUR+4
ENTRY DCBCUR
EXTRN MTDCB4,MTDCB5,OSMTEXCP,OSMTWAIT
SPACE 5
NOP
EQU X'03'
NO-OP
*
MAGNETIC TAPE COMMANDS.
SENSE
EQU 4
REW
EQU 7

56880000
56940000
57000000
57060000
57120000
57180000
57240000
57300000
57360000
57420000
57480000
57540000
57600000
57660000
57720000
57780000
57840000
57900000
57960000
58020000
58080000
58140000
58200000
58260000
58320000
58380000
59580000
59640000
59700000
59760000
59820000
59880000
59940000
60000000
60060000
60120000
60180000
60240000
60300000
60360000
63120000
63180000
63240000
63300000
63360000
63420000
63480000
63540000
63600000
63720000
63840000
63900000
63960000
64020000
64080000
64200000
64260000
64320000
64380000
64440000

RUN
ERG
WEF
BSR
BSF
FSR
FSF
UE
UC
IL
READY
RWDING
DOSHS
UNERR
UTWSLST
UTWSDMP
TRECLEN
EXPCSWA
MTTEMP
*
MTFLAGS
*
CCWAIU
FILOPEN
CLOSING
MTEOF
MTREJ
SIZEMOD
*
TOP
MTLABAR
EBCDEC
APLHDR
APLMTID
VOLID
APLLR

MTRPVS
MTROCD
*
*
*
*
*
TAPERROR
TAPEUNIT
MTWSID
DISWSID

EQU 15
EQU 23
EQU 31
EQU 39
EQU 47
EQU 55
EQU 63
SPACE
EQU X'01'
EQU X'02'
EQU X'40'
EQU X'20'
EQU X'40'
EQU X'20'
EQU X'20'
EQU X'80'
EQU X'20'
DC
F'10000'
ENTRY TRECLEN
DC
A(0)
DC
F'0'
SPACE
FLAG BYTE.
ENTRY MTFLAGS
DC
X'00'
SETTINGS..
EQU X'80'
EQU X'40'
EQU X'20'
EQU X'10'
EQU X'04'
EQU X'01'

64500000
64560000
64620000
64680000
64740000
64800000
64860000
64920000
64980000
UNIT CHECK.
65040000
65100000
65160000
65220000
65280000
65340000
UTFLAGS MASK - WSLIST
65400000
UTFLAGS MASK - DUMP REJECTED WSS
65460000
65520000
65580000
65640000
65700000
65760000
65820000
65880000
65940000
66000000
66060000
66120000
66180000
66240000
66300000
66360000
66420000
DC
X'00'
MAG TAPE OPERATION.
66480000
SPACE 2
66900000
DC
80C' '
66960000
SPACE
67020000
EQU *-C'0'
67080000
DC
C'1234567890'
67140000
SPACE
67200000
DC
C'HDR1'
67260000
DC
CL17'APL LIBRARY DUMP'
67320000
DC
C'APL36000000000000301'
67380000
DC
C' 993650000000'
67440000
DC
CL13'APL OS VER 0'
67680000
DC
CL7' '
67740000
LTORG
67800000
SPACE
67860000
DC
C'00'
INPUT VOL SEQ NUMBER
67920000
DC
C'000000'
INPUT CREATION DATE
67980000
68040000
OUTPUT MESSAGES.
68100000
FOR A DESCRIPTION OF THE CONTROL CODES USED, SEE OUTWRT &
68160000
OUTWRTL COMMENTS.
68220000
68280000
DC
CL30'PERMANENT WRITE ERROR ON UNIT'
3066 68340000
DC C'XXX-UTILITY ABORTED'
3066 68400000
DC
X'FF'
3066 68460000
EQU *
WS TIME STAMP & WSID
68520000
DC
C'AFTER '
PREFIX FOR DISASTER MESSAGE
68580000

DC
X'13'
WS TIME STAMP & WSID
MTWSDATE DC
12X'00'
DC
X'11'
MTWSLIB DC
16X'00'
DC
X'FF'
NOHMSG DC
C'UNABLE TO WRITE TAPE HEADER LABEL, SYS'
NOHUN
DC
X'1200FF'
DS
0H
LOGLAB DC
CL23' '
LOGCDAT DC
C' YY/DDD VOLID='
LOGVOL DC
C'XXXXXX '
DC
C'REEL='
LOGREEL DC
C'XX UNIT='
LOGUN
DC
X'02FFFFFF'
XXXMSG DC
C'NOT AN APL DUMP TAPE'
DC
X'FF'
DISMSG DC
C'TAPE ERROR, WORKSPACE MAY HAVE BEEN LOST'
DC
X'FF'
EXPMSG DC
C'UNEXPIRED FILE'
DC
X'FF'
REPMSG EQU *
DC
C'REPLY NEWTAPE, IGNORE OR CANCEL'
DC
X'FD'
SEQMSG DC
C'VOLUME SEQUENCE ERROR'
DC
X'FF'
RELFACT DS
F
RELOCATION FACTOR FOR WS SIZE RELOC
SIZEMSG1 DC
C'WORKSPACE SIZE CONVERTED FROM
'
DS
0F
ORG *-5
DC
X'10'
SIZETAPE DC
F'0'
WS SIZE ON TAPE
DC
C' BYTES TO '
DC
X'10'
WLEN
DC
F'0'
WS SIZE IN CORE & DISK
DC
X'FF'
SIZEMSG2 DC
C'NAMES OF OVERSIZE WORKSPACES APPEAR ON SYSLST',X'FF'
SIZEMSG3 DC
C'WORKSPACE TOO LARGE, REJECTED '
DC
X'13'
SIZEDATE DC
12X'00'
DC
X'11'
SIZEWSID DC
16X'00'
DC
X'FF'
TITLE 'APL UTILITY MAGNETIC TAPE WS SIZE RELOCATION 05/11/70'
*
*
WS SIZE RELOCATION.
*
*
CTCOMP HAS RELOCATED QR13STK,QSYMBOT, AND SVI, AND HAS
*
SAVED THE RELOCATION FACTOR IN RELFACT. THE WS WAS READ USING
*
THE RELOCATED VALUES. WE MUST NOW RELOCATE ALL POINTERS
*
TO THE SYMBOL TABLE AND STACK.
*
RELOCWS PROLOG CTSAVAR,CTSAVARZ
STM 0,10,CTREGSV
SAVE REGISTERS
L
10,=A(RELFACT)
PRE-LOAD RELOCATION FACTOR
L
10,0(10)
*
*
RELOCATE PARREL
*
L
1,PARREL
WE COULDN'T RELOCATE PARREL WHEN
AR
1,10
WE RELOCATED ITS FRIENDS, BECAUSE

68640000
68700000
68760000
68820000
68880000
68940000
69000000
69060000
69120000
69180000
69240000
69300000
69360000
69420000
69720000
69780000
69840000
69900000
69960000
70020000
70080000
70140000
70200000
70260000
70320000
70740000
70800000
70860000
70920000
70980000
71040000
71100000
71160000
71220000
71280000
71340000
71400000
71460000
71520000
71580000
71640000
71700000
71760000
71820000
71880000
71940000
72000000
72060000
72120000
72180000
72240000
72300000
72360000
72420000
72480000
72540000
72600000
72660000
72720000
72780000

ST
*
*
*
*
*
*
*
*
*

RELO20

RELO22

RELO28
*
*
*

RELO30

RELO35

RELO31

RELO32

1,PARREL

PARREL IS IN RECORD 2 OF WS.

72840000
72900000
ENABLE PROGRAM CHECK ON CONDITION
72960000
73020000
SPIE RELOCPC,((1,15))
73500000
73620000
IF WE HAVE A DIRECTORY, RELOCATION IS VERY SIMPLE
73680000
73740000
CLC WFLNAME,=C'APLDIRECTORY' IF DIRECTORY, WE'RE DONE
73800000
BE
RELO80
73860000
73920000
RELOCATE ALL M-ENTRY POINTERS TO THE SYMBOL TABLE
73980000
74040000
LA
4,8
74100000
LM
5,6,QR13STK ,QSYMBOT
74160000
AR
5,MR
MAKE QR13STK & QSYMBOT ABSOLUTE
74220000
AR
6,MR
74280000
LM
2,3,0(6)
LOAD M-POINTER, PRINTNAME
74340000
CLI 4(6),3
IF SHORT PRINT NAME OR NONE,
74400000
BNH RELO22
LEAVE ALONE
74460000
L
0,M(3)
RELOCATE ST-POINTER IN PRINTNAME
74520000
AR
0,10
74580000
ST
0,M(3)
74640000
CLC 1(3,6),=F'0'
IF MHEAD ADDR = 0, NO SYMBOL
74700000
BE
RELO28
74760000
TM
0(6),X'80'
IF KEYWORD, DON'T RELOCATE
74820000
BO
RELO28
74880000
L
0,M(2)
74940000
AR
0,10
RELOCATE M-ENTRY POINTER TO S.T.
75000000
ST
0,M(2)
75060000
BXLE 6,4,RELO20
ADVANCE TO NEXT S.T. ENTRY
75120000
75180000
RELOCATE STACK ENTRIES
75240000
75300000
L
7,=A(X'FFFFFF')
75360000
L
4,PARREL
75420000
B
RELO35
SKIP THE FIRST STCODE
75480000
LA
1,0(4,MR)
BOTH STCODE TESTS MAY NOT BE NEEDED 75540000
CLI STCODE(1),0
CODESTRING POINTER
75600000
BE
RELO35
75660000
L
1,STCODE(4,MR)
CODESTRING POINTER
75720000
LTR 1,1
75780000
BZ
RELO35
FREQUENTLY = 0
75840000
L
0,M(1)
RELOCATE MHEAD
75900000
AR
0,10
75960000
ST
0,M(1)
76020000
L
1,STFNSPTR(4,MR)
FN NAME BST ENTRY POINTER
76080000
LTR 1,1
76140000
BZ
RELO31
NON-ZERO IS S.T. POINTER
76200000
AR
1,10
RELOCATE STFNSPTR
76260000
ST
1,STFNSPTR(4,MR)
76320000
L
5,STFREG(4,MR)
LOAD NEXT SAVED F-REG
76380000
LTR 5,5
76440000
BZ
RELO40
ZERO F-REG MARKS END OF CHAIN
76500000
AR
5,10
RELOCATE F-REG
76560000
LA
6,0(5)
76620000
ST
5,STFREG(4,MR)
76680000
LA
4,STSHADOW(4)
76740000
CR
4,6
RELOCATE IN UNIFORM FASHION
76800000
BE
RELO30
EVERYTHING UP TO NEXT F-REG SETTING 76860000

RELO33

L
LTR
BM
CR
BNH
NR
BZ
L
AR
ST
B
LA
CLI
BH

1,M(4)
1,1
RELO33
1,7
RELO34
1,7
RELO34
0,M(1)
0,10
0,M(1)
RELO34
2,M(4)
0(2),X'81'
RELO34

LR
NR
BZ
AR
ST
LA
B

0,1
0,7
RELO34
1,10
1,M(4)
4,4(4)
RELO32

RELO34
*
*
*
RELO40
*
RELO42

RELO44

RELO46
RELO48

INDIRECT POINTER
ZERO 1ST BYTE MEANS NON-POINTER
IF ADDR = ZERO, DON'T RELOCATE
RELOCATE MHEAD

DON'T RELOCATE KEYWORDS

RELOCATE ONLY ENTRIES WITH BYTE 0
X'80' OR X'81' -- OTHERS ARE
(NON-POINTER) KEYWORDS
IF ADDR = ZERO, DON'T RELOCATE
RELOCATE TO SYMBOL TABLE

RELOCATE POINTERS WITHIN LISTS

LA
LA
TM
BZ
LH
LTR
BNP
AH
CLI
BL
CLI
BH
L
AR
ST
LA
BCT
LR
A
CR
BNL
C
BL

4,FREE-M

START WITH FIRST M-ENTRY, IF ITS A

LIST, RELOCATE, ELSE GO TO NEXT.
5,M(4)
MAKE M-POINTER ABSOLUTE
MLIST-M(5),MLSTBIT IF NOT A LIST, LEAVE ALONE
RELO48
3,MLSCT(4)
PICK UP NUMBER OF ENTRIES IN LIST
3,3
IF NULL LIST, LEAVE ALONE
RELO48
5,MLSOS(4)
ADD IN OVERHEAD
0(5),X'80'
RELOCATE ONLY ENTRIES WITH BYTE 0
RELO46
X'80' OR X'81' -- OTHERS ARE
0(5),X'81'
(NON-POINTER) KEYWORDS
RELO46
2,0(5)
2,10
RELOCATE ENTRY
2,0(5)
5,4(5)
3,RELO44
CONTINUE LOOPING UNTIL DONE
5,4
SAVE CURR MENTRY PTR
2216
4,MCOUNT(4)
JUMP TO NEXT M-ENTRY
2216
5,4
DID WE REALLY JUMP FORWARD ?
2216
RELOCERR
IF NOT, REJECT DAMAGED WS
2216
4,MX
WHEN WE REACH MX, WE ARE DONE
RELO42

*
*
*
RELO80

RELOCATE SAVED VALUES OF REGISTERS 12 AND 13

*
*
*

DISABLE PROGRAM CHECK ON CONDITION

LM
AR
AR
STM

SPIE

2,3,M+13*4
2,10
3,10
2,3,M+13*4

RELOCATE SAVED VALUES OF R13 & R14

76920000
76980000
77040000
77100000
77160000
77220000
77280000
77340000
77400000
77460000
77520000
77580000
77640000
77700000
77760000
77820000
77880000
77940000
78000000
78060000
78120000
78180000
78240000
78300000
78360000
78420000
78480000
78540000
78600000
78660000
78720000
78780000
78840000
78900000
78960000
79020000
79080000
79140000
79200000
79260000
79320000
79380000
79440000
79500000
79560000
79620000
79680000
79740000
79800000
79860000
79920000
79980000
80040000
80100000
80160000
80220000
80280000
80340000
80400000
80760000

RELOCWSY LM
0,10,CTREGSV
IRETURN ,
RETURN TO CALLER
*
*
REJECT A WORKSPACE AFTER A PROGRAM CHECK WHILE RELOCATING
*
RELOCERR LA
1,WFLLIB
LA
0,WFLDATE
USE COMMON MESSAGE PRINTER
LA
2,=CL9'REJECTED ' ACTION TAKEN
A04
LA
3,=XL1'FF'
NO SNAP ID
ICALL DWSLOG
L
1,=A(MTFLAGS)
INDICATE THAT THIS WS WAS REJECTED
OI
0(1),MTREJ
B
RELOCWSY
RETURN
*
*
PROGRAM CHECK ON-CONDITION ROUTINE
*
USING *,15
2216
RELOCPC MVC 9(3,1),=AL3(RELOCERR) EXIT ROUTINE ADDR TO PIE
2216
BR
14
DROP 15
2216
*
LTORG
TITLE 'CONSTANTS AND EQUATES'
*
*
MAGNETIC TAPE CCW GENERATION AREA
*
TCCWARK EQU 200
NUMBER OF MAGNETIC TAPE CCW'S.
*
MUST EQUAL TCCWARK IN DUMPSECT.
TCCWAR DS
(TCCWARK)D
*
*
MAGNETIC TAPE LABEL DSECT
*
TFLAB
DSECT
TFTYPE DS
CL3
HDR, EOV, EOF, OR VOL.
TFNUM
DC
CL1'1'
FILE LABEL NUMBER, EBCDIC, ALWAYS 1.
TFFID
DS
CL17
FILE IDENTIFIER.
TFSER
DS
CL6
FILE SERIAL NUMBER.
TFVSEQ DS
CL4
VOLUME SEQUENCE NUMBER.
TFFSEQ DS
CL4
FILE SEQUENCE NUMBER.
TFGEN
DS
CL4
GENERATION NUMBER.
TFVER
DS
CL2
VERSION NUMBER OF GENERATION.
TFCDAT DS
CL6
CREATION DATE.
TFEDAT DS
CL6
EXPIRATION DATE.
TFSEQ
DS
CL1
FILE SECURITY, 0 = NONE.
TFBLKCT DS
CL6
BLOCK COUNT. (TRAILERS ONLY)
TFSYSCOD DC
CL13' '
SYSTEM CODE.
TFRES
DC
CL7' '
RESERVED, SHOULD BE BLANK.
TFLABZ EQU *
*
*
*
CTCOMP SAVE AREA DSECT
*
CTSAVAR DSECT
CTREGSV DS
11F
CTSAVARZ EQU *
*
*
*
GENERAL SAVE AREA DSECT
*
MTSAVAR DSECT ,

80880000
80940000
81000000
81060000
81120000
81180000
81240000
81300000
81360000
81420000
81480000
81540000
82680000
82740000
82800000
82860000
83520000
83580000
83640000
83700000
83820000
83880000
83940000
84000000
84060000
84120000
84180000
84240000
84300000
84360000
84420000
84480000
84540000
84600000
84660000
84720000
84780000
84840000
84900000
84960000
85020000
85080000
85140000
85200000
85260000
85320000
85380000
85440000
85500000
85560000
85620000
85680000
85740000
85800000
85860000
85920000
85980000
86040000
86100000
86160000

MTSAVR1
MTSAVR1Z
MTSAVR2
MTSAVR2Z
MTSAVR3
MTSAVR3Z
MTSAVR4
MTSAVR4Z
MTSAVR5
MTSAVR5Z

DS
F
EQU *
DS
F
EQU *
DS
F
EQU *
DS
F
EQU *
DS
F
EQU *
ORG MTSAVR3
MTSAVRB DS
F
R11 SAVE AREA FOR MTRDZ
MTSAVRBZ EQU *
ORG MTSAVR3
MTREP
DS
CL80
OPERATOR REPLY AREA
MTREPZ EQU *
END
./ ADD
NAME=APLUUREC
UREC
TITLE 'UNIT RECORD COMMUNICATION -- OUTWRT, SELCARD 05/11/70'
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
5736-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
PRINT OFF
COPY APLDEFN ZSYMBOLS
COPY APLDEFN
COPY ZSYMBOLS
TITLE 'UNIT RECORD COMMUNICATION -- OUTWRT, SELCARD 05/11/70'
URSECT CSECT
PRINT ON,NOGEN
ENTRY OUTWRT
ENTRY OUTWRTL
ENTRY SELCARD
ENTRY UTCARD
ENTRY UTCARDNL
ENTRY VTOZ
ENTRY ZTOV
EXTRN UTDATE
ENTRY PRTDCB,RDRDCB,PCHDCB,WSDMPDCB
*
*
OUTPUT MESSAGE WRITER
*
CALL ... BAL LKR,OUTWRT OR BAL LKR,OUTWRTL
*
DC AL4(TEXT)
*
TEXT CONSISTS OF EBCDIC TO BE PRINTED, INCLUDING
*
CONTROL CHARACTERS ..
*
X'00' - X'0F'
PRINT FOLLOWING N BYTES IN HEX
*
X'10'
PRINT NEXT 4 BYTES AS DECIMAL INT
*
WITH NO LEADING BLANKS
*
X'11'
PRINT NEXT 16 BYTES AS WORKSPACE
*
NUMBER AND NAME
*
X'12'
PRINT NEXT BYTE AS 3-CHAR DEC INT
*
X'13'
PRINT NEXT 12 BYTES AS TIME STAMP
*
(8 BYTES ZSYMBOL DATE, 4 BYTES OF
*
300THS OF SECONDS)
*
X'14'
FILL LINE WITH BLANKS TO COLUMN 102,
*
AND INSERT 18 BYTES OF TIME OF DAY
*
X'FD'
REPLY FROM OPERATOR EXPECTED
*
AFTER MESSAGE. IF A WTOR
*
REPLY IS EXPECTED THE ADDRESS
*
FOR THE RESPONSE IS PASSED
*
IN REGISTER 1.
*
X'FE'
END OF TEXT, USE AS PAGE HEADING

86220000
86280000
86340000
86400000
86460000
86520000
86580000
86640000
86700000
86760000
86820000
86880000
86940000
87000000
87060000
87120000
87180000
00170000
00340000
00510000
00680000
01360000
01530000
01700000
01870000
02040000
02210000
02380000
02550000
02720000
02890000
03060000
03230000
03400000
03570000
04080000
05100000
05270000
05440000
05610000
05780000
05950000
06120000
06290000
06460000
06630000
06800000
06970000
07140000
07310000
07480000
07650000
07820000
07990000
08160000
08330000
08500000
08670000
08840000

*
*
*
*
*
OUTWRTL
*
OUTWRT

OWA

OWA1

OWB
OWD
OWC

OWL

X'FF'
END OF TEXT
OUTWRT SENDS LINE TO SYSLST
OUTWRTL SENDS LINE TO SYSLST AND SYSLOG
ALL REGISTERS PRESERVED
MVI

0(LKR),1
SET SYSLOG FLAG IN CALLING SEQUENCE
ALL REGISTERS PRESERVED
PROLOG OUTLOC,OUTLOCND
STM 0,10,OUTLOC
MVC OWAD(4),0(LKR)
TEXT ADDRESS AND SYSLOG FLAG
NI
OWAD,255-REPMASK
RESET REPLY FLAG
MVC OWBUF-8(8),OWPFX
UTCARD MAY PREFIX WITH 'SYSLOG'
MVC OWPFX(8),=CL8' '
OR 'SYSIPT'
L
5,OWAD
TEXT ADDR
LA
2,1
LA
3,OWBUF+123
END TEST FOR BXLE
LA
4,OWBUF
CLI 0(5),X'FE'
LOOK FOR CONTROL CHARS IN TEXT
BH
OWC
END OF TEXT
BE
OWPH
END OF TEXT, MAKE PAGE HEADING
CLI 0(5),X'FD'
IS THIS WTOR
BNE OWA1
NOT END OF TEXT
OI
OWAD,REPMASK
REPLY WANTED
B
OWC
SR
0,0
IC
0,0(5)
CLI 0(5),X'10'
CHECK FOR HEX
BL
OWHEX
BE
OWDEC
OR DECIMAL FULLWORD
CLI 0(5),X'12'
BL
OWWSN
PRINT WSNAME
BE
OWDEC1
PRINT NNN FROM FOLLOWING BYTE
CLI 0(5),X'14'
BL
OWTS
PRINT TIMESTAMP
BE
OWTOD
PRINT TIME OF DAY
STC 0,0(4)
NOT CONTROL CHAR -- STORE DATA
LA
5,1(5)
ADVANCE TEXT POINTER
BXLE 4,2,OWA
AND OUTPUT BUFFER POINTER
LR
4,3
LA
1,OWBUF
OFF END OF BUFFER TREATED LIKE FF
MVI 0(4),C' '
BCTR 4,0
DELETE TRAILING BLANKS (FOR SYSLOG)
CLI 0(4),C' '
BE
*-6
LA
4,1(4)
TRUE COUNT
SR
4,1
BP
*+8
LA
4,1
EMPTY LINE -- PRINT 1 BLANK
LA
4,13(4)
ALLOW FOR LENGTH FIELD AND PREFIX
K14
STH 4,OWBUF-13
LENGTH IF NORMAL LINE
K14
BCTR 4,0
K14
STH 4,LENGTH
LENGTH FOR WTO
K14
CLI SWITCH,X'01'
IS NEW PAGE SWITCH SET
BE
OWHEAD
PRINT HEADER LINE
L
7,LNECNT
TEST FOR END OF PAGE
LA
7,1(7)
ST
7,LNECNT
CLI LNECNT+3,PAGLEN
BH
OWHEAD
STM 13,14,R13SAVE

09010000
09180000
09350000
09520000
09690000
09860000
10030000
10200000
10370000
10540000
10710000
11730000
11900000
12070000
12240000
12410000
12580000
12750000
12920000
13090000
13260000
13430000
13600000
13770000
13940000
14110000
14280000
14450000
14620000
14790000
14960000
15130000
15300000
15470000
15640000
15810000
15980000
16150000
16320000
16490000
16660000
16830000
17000000
17170000
17340000
17510000
17680000
17850000
21930000
22100000
22270000
22440000
22610000
22780000
22950000
23120000
23290000
23460000
23630000
23800000

Q
*

*
OWHEAD

*
OWE
OWZ
*

*
OWDEC

OWPAT
*
OWDEC1

*
OWHEX

LA
PUT
LM
CLI

13,OSSAVE
PRTDCB,OWBUF-13
13,14,R13SAVE
OWAD,1

23970000
24140000
24310000
24480000
REPMASK NOT SPECIFICALLY TESTED.
24650000
MVC MSG(150),OWBUF
24820000
BL
OWZ
NO WRITE TO OPR
24990000
LA
1,LENGTH
PICK UP PARAMETER LIST FOR WTO
25160000
BE
OWE
WTO WITH NO REPLY EXPECTED
25330000
THIS IS A FAKE ICALL
25500000
L
15,=A(UTLOG)
25670000
L
12,=A(UTCARD+6)
NOTE ASSMPT ABOUT PROLOG MACRO 25840000
BR
15
EXIT WILL BE FROM UTCARD
26010000
NEW PAGE WITH HEADER
26180000
LA
7,1(0)
26350000
ST
7,LNECNT
RESET LINE COUNT
26520000
STM 13,14,R13SAVE
26690000
LA
13,OSSAVE
26860000
PUT PRTDCB,OWSKBF-5
WRITE HEADING TO SYSPRINT
27030000
PUT PRTDCB,BLANK
PRINT BLANK LINE AFTER HEADING
27200000
LM
13,14,R13SAVE
27370000
MVI SWITCH,X'00'
RESET NEW PAGE SWITCH
27540000
B
OWL
27710000
WRITE TO LOG, NO REPLY
27880000
WTO MF=(E,(1))
28050000
LM
0,10,OUTLOC
28390000
IRETURN
WE MUST RETURN TO 4(LKR)
28560000
LM
PR,LKR,0(LR)
28730000
MVI 0(LKR),0
RESET SYSLOG FLAG IN CALL
28900000
B
4(LKR)
29070000
29240000
MVC OWTM(4),1(5)
29410000
L
0,OWTM
CONVERT FULLWORD INT TO DECIMAL
29580000
CVD 0,OWTD
29750000
MVC OWTM(12),OWPAT
29920000
LA
1,OWTM+11
PREPARE TO ELIMINATE LEADING BLANKS 30090000
EDMK OWTM(12),OWTD+2
30260000
MVC 0(11,4),0(1)
LEFT-JUSTIFIED CONST TO BUFFER
30430000
LA
4,OWTM+11(4)
30600000
SR
4,1
30770000
LA
5,4(5)
ADVANCE OVER CONSTANT IN TEXT
30940000
B
OWB
COMPLETE POINTER UPDATING
31110000
DC
X'40202020202020202020212040'
31280000
31450000
IC
0,1(5)
CONVERT 1 BYTE TO DECIMAL FOR THINGS 31620000
CVD 0,OWTD
31790000
UNPK 0(3,4),OWTD
LIKE SYSNNN
31960000
OI
2(4),C'0'
32130000
LA
4,2(4)
32300000
LA
5,1(5)
32470000
B
OWB
32640000
32810000
UNPK 0(7,4),1(4,5)
UNPACK POSSIBLY LONG STRING
32980000
TR
0(15,4),HTOV
33150000
LA
4,6(4)
BY A SERIES OF SHORT UNPACKS
33320000
LA
5,3(5)
33490000
S
0,=F'3'
33660000
BH
OWHEX
33830000
AR
5,0
34000000
AR
4,0
RESIDUAL BYTES OF LAST UNPACK
34170000
WRITE LINE TO SYSPRINT

AR
BCT
*
*
OWWSN

MVC
LA
L
CVD
MVC
EDMK
CLI
BNH

*
CLC
BE
*

OWW3
OWW1

OWMV
OWTR
OWTS

OWTS2

MVC
LA
LA
SR
B
MVC
LA
B
SR
IC
LA
CLI
BCTR
BE
EX
EX
LA
B
MVC
TR
SPACE
MVC
TR
MVI
MVI
MVC
LA
L
SR
A
D
SR
D
LR
SR
D
LR
M
AR
M
AR
CVD
MVC
EDMK

4,0
4,OWB

34340000
34510000
34680000
PRINT LIBRARY NUMBER AND WORKSPACE NAME
34850000
OWTD(16),1(5)
MOVE WSNO, WSNAME TO OUR STORAGE
35020000
5,16(5)
ADVANCE TEXT POINTER
35190000
0,OWTD
35360000
0,OWTD2
35530000
0(13,4),OWPAT
35700000
0(12,4),OWTD2+2
35870000
OWTD+WFLNAME-WFLLIB,11 NOW SOME VALIDITY CHECKING ON THE 36040000
OWW1
WORKSPACE NAME. 1ST BYTE MUST BE
36210000
COUNT OR NAME MUST BE APLDIRECTORY 36380000
OWTD+WFLNAME-WFLLIB(12),=C'APLDIRECTORY'
36550000
OWW3
36720000
IF NEITHER, WORKSPACE IS PROBABLY
36890000
0(12,4),=C'(ILLEGIBLE) ' IN BAD SHAPE
37060000
4,12(4)
ADVANCE OUTPUT POINTER
37230000
0,16
AND PRINT FILE LABEL IN HEX
37400000
5,0
37570000
OWHEX
37740000
13(11,4),=C'*DIRECTORY*'
37910000
4,23(4)
ADVANCE OUTPUT POINTER
38080000
OWB
38250000
1,1
PREPARE TO MOVE AND TRANSLATE WSNAME 38420000
1,OWTD+WFLNAME-WFLLIB
38590000
4,12(4)
38760000
OWTD+WFLNAME-WFLLIB,0 IF COUNT IS 0, PRINT NO NAME
38930000
1,0
39100000
OWB
39270000
1,OWMV
39440000
1,OWTR
39610000
4,1(4,1)
LIBRARY NO PLUS WSNAME LENGTH, -1
39780000
OWB
39950000
1(0,4),OWTD+WFLNAME-WFLLIB+1
40120000
1(0,4),ZTOV
40290000
2
40460000
0(8,4),1(5)
PRINT DATE AND TIME OF DAY
40630000
0(8,4),ZTOV
GET EBCDIC FROM ZSYMBOLS
40800000
2(4),C'/'
ZSLASH NOT IN ZTOV TRANSLATE TABLE 40970000
5(4),C'/'
41140000
OWTD(4),9(5)
PREPARE TO FORMAT TIME
41310000
5,12(5)
41480000
1,OWTD
AS HHH.MM.SS
41650000
0,0
(7 RHO 10) REP 100 BASE
41820000
1,=F'150'
41990000
0,=F'300'
0 60 60 REP FLOOR TIME DIV 300
42160000
0,0
42330000
0,=F'60'
SPLIT OFF SECONDS
42500000
6,0
42670000
0,0
42840000
0,=F'60'
THEN MINUTES
43010000
7,0
43180000
0,=F'100'
43350000
1,7
43520000
0,=F'100'
43690000
1,6
43860000
1,OWTD
44030000
8(10,4),OWTSPAT
44200000
8(10,4),OWTD+4
44370000

LA
4,17(4)
AND AS FORMATTED IN BUFFER
B
OWB
OWTSPAT DC
X'402021204B20204B2020' TO GET HHH.MM.SS
SPACE 2
OWPH
MVI SWITCH,X'01'
INDICATE PAGE HEADING REQUIRED
LA
1,OWBUF-12
CALCULATE
K14
SR
4,1
LENGTH OF
K14
STH 4,OWSKBF-5
HEADING
K14
MVC OWSKBF,OWBUF-8
HEADING HAS SEPARATE BUFFER
B
OWZ
*
OWTOD
LA
1,OWBUF+93
FILL WITH BLANKS AND PRINT DATE,TIME
LA
0,1
MVI 0(4),C' '
BXLE 4,0,*-4
LA
4,OWBUF+94
MIGHT HAVE TO TRUNCATE
L
1,=A(UTDATE)
NOW IN EBCDIC
MVC 0(8,4),0(1)
GETIME TU
NOW IN 300THS
B
OWTS2
TITLE 'SELCARD -- READ A WORKSPACE SELECTION CARD'
*
*
ON ENTRY, R1 = ADDRESS TO STORE 4 WORDS OF LIB NO, NAME
*
R0 NONZERO MEANS LOG ERROR MESSAGE FOR PREV CARD
*
IF NO LIB NUMBER ON CARD, STORED NO. IS X'80000000'
*
IF NO WSNAME ON CARD, CHAR COUNT OF NAME IS 0
*
LOWERCASE EBCDIC IS MAPPED INTO UNDERBARRED APL ALPHAS
*
BLANK CARDS ARE IGNORED
*
OTHER CARDS ARE FLAGGED
*
ALL REGISTERS PRESERVED
*
SELCARD PROLOG SELLOC,SELLOCND
STM 0,6,SELLOC
LR
6,1
RETAIN SINK ADDRESS
XC
0(16,6),0(6)
CLEAR SINK AREA
LTR 0,0
BNZ SELBAD
COMPLAIN ABOUT PREV CARD, THEN READ
CLI SELEOF,0
IF END OF FILE PENDING,
BE
SELA
SELE
MVI 0(6),X'80'
FAKE AN 'END' CARD AND COMPLAIN
MVC WFLNAME-WFLLIB(4,6),=AL1(3,ZE,ZN,ZD)
ICALL OUTWRTL
'END' CARD AND COMPLAIN
DC
AL4(SELEMSG)
MVI SELEOF,1
B
SELZ
SELA
SR
0,0
ASSUME NO ERROR, PREV CARD
SELR
LA
1,BUF
READ NEXT CARD
ICALL UTCARD
B
SELE
END FILE RETURN
LA
3,BUF+79
ELSE PREPARE TO SCAN CARD
LA
2,1
LA
4,BUF
SELC
CLI 0(4),C' '
SKIP LEADING BLANKS
BNE SELB
BXLE 4,2,SELC
B
SELA
THOROUGHLY BLANK
SELB
CLI 0(4),C'0'
BNL SELD
NUMERIC FIELD
MVI 0(6),X'80'
NO LIBRARY NUMBER
B
SELF

44540000
44710000
44880000
45050000
46750000
46920000
47090000
47260000
47600000
47770000
47940000
48110000
48280000
48450000
48620000
48790000
48960000
49130000
49300000
49470000
49640000
49810000
49980000
50150000
50320000
50490000
50660000
50830000
51000000
51170000
51340000
51510000
51680000
51850000
52020000
52190000
52360000
52530000
52700000
52870000
53040000
53210000
53380000
53550000
53720000
53890000
54060000
54230000
54400000
54570000
54740000
54910000
55080000
55250000
55420000
55590000
55760000
55930000
56100000
56270000

SELD
SELH
SELM

SELF

SELPK
SELI
SELN

SELL
SELP

SELZ
SELMV
SELTR
SELBAD
SELEOF

LR
5,4
PREPARE TO CONVERT NUMBER
LCR 1,4
CLI 1(4),C'0'
BL
*+8
BXLE 4,2,SELH
AR
1,4
C
1,=F'11'
BNL SELBAD
EX
1,SELPK
REASONABLE SIZED INTEGER
CVB 1,DTEMP
ST
1,0(6)
STASH IT AWAY
LA
4,1(4)
CLI 0(4),C' '
RESUME BLANK-SKIPPING
BNE SELI
BXLE 4,2,SELF
B
SELZ
NO WSNAME
PACK DTEMP(8),0(0,5)
LCR 1,4
PREPARE TO SCAN WSNAME
LR
5,4
CLI 0(4),C' '
BE
SELP
CLI 0(4),C'-'
VALIDATE NONBLANKS
BE
SELL
CLI 0(4),C'='
BE
SELL
CLI 0(4),C'a'
LOWERCASE A
BL
SELBAD
BXLE 4,2,SELN
AR
1,4
STC 1,4(6)
CLI 4(6),11
MAX 11 CHARS
BH
SELBAD
BCTR 1,0
EX
1,SELMV
MOVE NAME TO SINK
EX
1,SELTR
TRANSLATE TO Z-SYMBOLS
LM
0,6,SELLOC
IRETURN
MVC 5(0,6),0(5)
TR
5(0,6),VTOZ
ICALL OUTWRTL
DC
AL4(SELMSG)
BAL 0,SELR
GUARANTEE R0 NONZERO FOR ERROR
DC
FL1'0'
END-FILE FLAG
TITLE 'UTCARD -- READ SYSIPT OR SYSLOG'

*
*
ON ENTRY, R0 = 0 IF READING FROM SYSIPT
*
IF NONZERO, TAKE NEXT INPUT (OR 'CANCEL' REQUEST)
*
FROM SYSLOG
*
R1 = BUFFER ADDRESS
*
RETURN TO 4(LKR) NORMALLY
*
RETURN TO 0(LKR) ON END FILE, /*, /&
*
SAVES ALL REGISTERS
*
UTCARDNL PROLOG UTT,UTTL
MVI NOLIST,1
LA
12,UTCARD+6
USING UTCARD+6,12
B
UTC1
UTCARD PROLOG UTT,UTTL
MVI NOLIST,0
LOG IT TO SYSLST

56440000
56610000
56780000
56950000
57120000
57290000
57460000
57630000
57800000
57970000
58140000
58310000
58480000
58650000
58820000
58990000
59160000
59330000
59500000
59670000
59840000
60010000
60180000
60350000
60520000
60690000
60860000
61030000
61200000
61370000
61540000
61710000
61880000
62050000
62220000
62390000
62560000
62730000
62900000
63070000
63240000
63410000
63580000
63750000
63920000
64090000
64260000
64430000
64600000
64770000
64940000
65110000
65280000
65450000
65620000
65790000
65960000
66130000
66300000
66470000

UTC1

STM 0,10,UTT
66640000
LA
4,92
PUT LENGTH IN WTOR LIST IN CASE
K14 67150000
STH 4,LENGTH
IT IS CLOBBERED BY A PREVIOUS COMND 67320000
LTR 0,0
DETERMINE SYSIPT OR SYSLOG
67660000
BNZ UTLOG
67830000
MVC OWPFX(8),SYSIPT
K15 68000000
CLI EOFSW,1
PREVIOUS END-OF-FILE ?
P051 68170000
BE
UTC2
BRANCH IF YES, TAKE EOF EXIT
P051 68340000
MVI EOFSW,1
SET EOF CONDITION AS DEFAULT
P051 68510000
STM 13,15,R13SAVE
70550000
LA
13,OSSAVE
70720000
GET RDRDCB,UTBUF
70890000
MVI EOFSW,0
SET SWITCH --- NO END OF FILE P051 71060000
LM
13,14,R13SAVE
NO POINT IN RESTORING R15
71230000
UTCA
L
LKR,12(LR)
RESTORE EXIT
71400000
LA
LKR,4(LKR)
STEP PAST EOF RETURN
71570000
ST
LKR,12(LR)
**** NOTE LINKAGE CONVENTION ASSUMPT 71910000
UTC3
CLI NOLIST,0
IS CARD TO BE LOGGED TO SYSLST
72080000
BNE UTC2
SKIP IF NOT
72250000
ICALL OUTWRT
72420000
DC
AL4(UTBUF)
72590000
B
UTC2
SKIP ROUND REGISTER RESTORE
73100000
UTCOM
LM
13,15,R13SAVE
RESTORE REGISTERS BEFORE READ
73270000
UTC2
LM
0,10,UTT
RESTORE ALL REGISTERS
73610000
MVC 0(80,1),UTBUF
INPUT TO CALLER'S BUFFER
73780000
IRETURN
73950000
UTLOG
MVC OWPFX(8),SYSLOG
K15 74120000
MVI UTBUF,C' '
74290000
MVC UTBUF+1(79),UTBUF
74460000
ST
14,R13SAVE
WTOR USES REGISTER 14
75990000
WTOR ,UTBUF,,,MF=(E,WTORLIST) MSG HAS BEEN LOADED BY CALLER 76160000
WAIT ECB=ECBAD
76330000
L
14,R13SAVE
76500000
XC
ECBAD(4),ECBAD
RESET ECBAD TO 0
76670000
CLI UTBUF,C'/'
ASSUME ANYTHING BEGINNING WITH /
77010000
BE
UTC2
IS END OF FILE SIGNAL
77180000
MVC UTCAN,UTBUF
CHECK FOR CANCEL
77350000
OC
UTCAN,=CL7' '
77520000
CLC UTCAN,=C'CANCEL '
77690000
BNE UTCA
PLOW ONWARDS UNLESS 'CANCEL' REQUEST 77860000
UTCC
CANCEL
78030000
SYSIPT DC
CL8'SYSIN'
K15 81430000
SYSLOG DC
CL8'CONSOLE'
K15 81600000
RDRDCB DCB DDNAME=SYSIN,MACRF=(GM),DSORG=PS,LRECL=80,EODAD=UTCOM, X81770000
RECFM=FB,DEVD=DA
81940000
PRTDCB DCB DDNAME=SYSPRINT,MACRF=(PM),DSORG=PS,RECFM=VBA,LRECL=137,X82110000
BLKSIZE=3325,DEVD=DA
82280000
PCHDCB DCB RECFM=FB,DDNAME=SYSPUNCH,DSORG=PS,LRECL=80,MACRF=(PM), X82450000
BLKSIZE=3200,DEVD=DA
82620000
WSDMPDCB DCB DDNAME=WSDUMP,MACRF=(W),DSORG=PS,LRECL=125,BLKSIZE=882, X82790000
RECFM=VBA
82960000
LNECNT DC
A(55)
83130000
PAGLEN EQU 55
83300000
R13SAVE DC
3F'0'
83470000
OSSAVE DS
18F
83640000
WTORLIST DS
0F
ORDER OF THIS PARM LIST IS MANDATORY 83810000
DC
AL1(80)
REPLY LENGTH
83980000
DC
AL3(UTBUF) REPLY ADDRESS
84150000
DC
A(ECBAD)
&ECB
84320000
LENGTH DC
AL2(80)
MESSAGE LENGTH
84490000

DC
DC
MSG
DC
ECBAD
DC
BLANK
DS
DC
SWITCH DC
NOLIST DC
UTCAN
DS
REPMASK EQU
SELEMSG DC
DC
SELMSG DC
BUF
DC
DC
UTBUF
DS
DC
DS
DC
DC
DC
OWSKBF DC
OWPFX
DC
EOFSW
DC
DC
DC
DC
OWBUF
DS
ZTOV
EQU
DC
DC
*
HTOV
EQU
DC
DC
VTOZ
EQU
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
DC
ORG
LTORG
OUTLOC DSECT
DS
OWAD
DS
OWTM
DS

AL2(0)
84660000
CL8'APL'
CONSOLE MESSAGE HEADER
K19 84830000
150C' '
MESSAGE
85000000
F'0'
85170000
0F
85340000
X'000600004040'
85510000
X'00'
85680000
X'00'
86020000
CL7
86190000
X'08'
86360000
C'EOF -- END CARD PROVIDED'
86530000
X'FF'
86700000
C'INCORRECT SELECTION CARD '
86870000
80X'FF'
MUST FOLLOW SELMSG
87040000
X'40FF'
87210000
CL80
87380000
X'FF'
87550000
0F
LENGTH
87720000
H'6'
COUNT OF
87890000
H'0'
HEADING.
88060000
C'1'
NEW PAGE ASA CONTROL CHAR
88230000
CL132' '
PAGE HEADING BUFFER
88400000
CL8' '
MESSAGE ORIGINATOR
88570000
X'00'
END-OF-FILE SWITCH FOR CONTROL P051 88740000
F'0'
LENGTH COUNT OF MESSAGE
88910000
C' '
NEXT LINE ASA CONTROL CHAR
89080000
CL8' '
MUST PRECEDE OWBUF
89250000
150C
89420000
*-ZA
89590000
C'ABCDEFGHIJKLMNOPQRSTUVWXYZ-'
89760000
C'abcdefghijklmnopqrstuvwxyz='
89930000
ABOVE LINE IS LOWERCASE EBCDIC
90100000
*-C'0'
90270000
C'0123456789'
90440000
C'ABCDEF'
90610000
*-C' '
FOR SAFETY
90780000
VTOZ+C'-'
90950000
AL1(ZDELTA)
91120000
VTOZ+C'='
91290000
AL1(ZDELTAU)
91460000
VTOZ+C'a'
LOWERCASE A
91630000
AL1(ZAU,ZBU,ZCU,ZDU,ZEU,ZFU,ZGU,ZHU,ZIU)
91800000
VTOZ+C'j'
LOWERCASE J
91970000
AL1(ZJU,ZKU,ZLU,ZMU,ZNU,ZOU,ZPU,ZQU,ZRU)
92140000
VTOZ+C's'
LOWERCASE S
92310000
AL1(ZSU,ZTU,ZUU,ZVU,ZWU,ZXU,ZY,ZZU)
92480000
VTOZ+C'A'
UPPERCASE A
92650000
AL1(ZA,ZB,ZC,ZD,ZE,ZF,ZG,ZH,ZI)
92820000
VTOZ+C'J'
UPPERCASE J
92990000
AL1(ZJ,ZK,ZL,ZM,ZN,ZO,ZP,ZQ,ZR)
93160000
VTOZ+C'S'
UPPERCASE S
93330000
AL1(ZS,ZT,ZU,ZV,ZW,ZX,ZY,ZZ)
93500000
VTOZ+C'0'
93670000
AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9)
93840000
94010000
94180000
94350000
11F
94520000
A
94690000
4F
94860000

OWTD
OWTD2
OUTLOCND
SELLOC

DS
2D
DS
D
EQU *
DSECT
DS
7F
DTEMP
DS
D
SELLOCND EQU *
UTT
DSECT
DS
11F
UTTL
EQU *
END
./ ADD
NAME=TAPEOS
TITLE 'INTERFACE BETWEEN DOS CONTROL BLOCKS AND OS EXCP'
PRINT NOGEN
*
5734-XM6 COPYRIGHT IBM CORP. 1969, 1970
*
REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083
*
*
TAPEOS...INTERPRETER BETWEEN DOS..COMMAND CONTROL BLOCK
*
AND OS..I O BLOCK
*
*
*
AT ENTRY TO OSMTEXCP/OSMTWAIT,R1 CONTAINS THE ADDRESS
*
OF THE DOS CCB.
*
BEFORE ISSUEING EXCP UNDER OS , INFORMATION MUST BE
*
TRANSFERED FROM THE CCB TO THE IOB.
*
THE IOB MUST CONTAIN THE ADDRESS OF AN EVENT CONTROL BLOCK
*
WHICH WILL CONTAIN THE COMPLETION CODE AFTER THE IO
*
COMPLETES. OSMTWAIT RETURNS CONTROL WITH INFORMATION
*
FROM THE IOB TRANSFERED TO THE CCB.
*
*
TAPEOS CSECT
TAPE EXCP AND WAIT ROUTINES
EXTRN DCBCUR
POINTER TO CURRENT DCB
ENTRY MTDCB4
ENTRY MTDCB5
TITLE 'OS EXCP INTERPRETER'
OSMTEXCP PROLOG SAVE,SAVEZ
ENTRY LINKAGE
ENTRY OSMTEXCP
OS EXCP ROUTINE
STM 0,9,SAVE1
SAVE CALLERS REGISTERS
LR
9,1
TO REFERENCE CCB
USING CCB,9
CCB ADDRESS IN R9
TM
CCBTI,X'80'
IS EXCP NEEDED
BO
EXCP1
YES
ICALL OSMTWAIT
NO,WAIT ON EVENT
EXCP1
NC
CCBCT(3),=X'00007F' ZERO OUT RES COUNT AND TRAFFIC BIT
MVC CCBSTAT(2),=X'0000' ZERO STATUS IN CCB
L
2,=A(DCBCUR)
POINTER TO CURRENT DCB
L
2,0(2)
OPENED DCB ADDRESS
USING IHADCB,2
REFERENCE DCB
L
1,DCBIOBAD
IOBADDRESS FROM DCB
USING IOBECB,1
ST
2,IOBDCB
STORE DCB ADDRESS IN IOB
MVC IOBSTART(3),CCBCCWA ADDRESS OF CHANNEL PROGRAM
NI
IOBFLAG1,X'3F'
TURN OFF CHAINING FLAGS IN IOB
MVC TEMP+1(3),IOBSTART FIND FIRST CCW AND TEST FOR
L
5,TEMP
DATA / COMMAND CHAINING
LA
5,0(5)
TM
4(5),X'C0'
BZ
NOCHAIN
OI
IOBFLAG1,X'42'
TURN ON CMND CHN & UNRELATED FLAGS

95030000
95200000
95370000
95540000
95710000
95880000
96050000
96220000
96390000
96560000
96730000
00860000
01720000
02580000
03440000
04300000
05160000
06020000
06880000
07740000
08600000
09460000
10320000
11180000
12040000
12900000
13760000
14620000
15480000
16340000
17200000
18060000
18920000
19780000
20640000
21500000
22360000
23220000
24080000
24940000
25800000
26660000
27520000
28380000
29240000
30100000
30960000
31820000
32680000
33540000
34400000
35260000
36120000
36980000
37840000
38700000
39560000
40420000
41280000

NOCHAIN XC
EVNTCB(4),EVNTCB
ZERO OUT ECB
EXCP (1)
LM
0,9,SAVE1
RELOAD REGS
IRETURN
RETURN TO CALLER
TITLE 'OS WAIT INTERPRETER'
OSMTWAIT PROLOG SAVE,SAVEZ
STM 0,9,SAVE1
ENTRY OSMTWAIT
LR
9,1
USING CCB,9
CCB ADDRESS IN R9
L
8,=A(DCBCUR)
POINTER TO CURRENT DCB
L
8,0(8)
ADDRESS OF OPENED DCB
USING IHADCB,8
L
6,DCBIOBAD
USING IOBECB,6
IOB ADDRESS IN REG 6
LA
7,EVNTCB
ECB ADDRESS FOR WAIT
TM
EVNTCB,B'01000000' IS COMPLETE BIT ON
BC
1,POSTCCB
YES,POST CCB COMPLETE
WAIT ECB=(7)
ISSUE OS WAIT ON ECB
POSTCCB MVC CCBCT(2),IOBCSW+5 CSW COUNT
MVC CCBSTAT(2),IOBCSW+3
STATUS FROM CSW
MVC CCBCSWA(3),IOBCSW
LAST COMMAND
OI
CCBTI,X'80'
POST CCB COMPLETE
WAITZ LM
0,9,SAVE1
IRETURN
RETURN TO CALLER
UE
EQU 1
DS
0F
IOB4
DC
X'02'
UNRELATED FLAG ON
DC
3X'00'
DC
XL1'00'
DC
AL3(ECB4)
DC
8F'0'
ECB4
DC
F'0'
IOB5
DC
X'02'
UNRELATED FLAG ON
DC
3X'00'
DC
XL1'00'
DC
AL3(ECB5)
DC
8F'0'
ECB5
DC
F'0'
DS
0F
TEMP
DS
F
MTDCB4 DCB DSORG=PS,MACRF=(E),DDNAME=TAPE1,IOBAD=IOB4
MTDCB5 DCB DSORG=PS,MACRF=(E),DDNAME=TAPE2,IOBAD=IOB5
LTORG
PRINT OFF
APLDEFN
COPY APLDEFN
PRINT ON
SAVE
DSECT
SAVE1
DS
10F
SAVEZ
EQU *
SAVE2
DSECT
SAVE22 DS
10F
SAVE2Z EQU *
CCB
DSECT
CCBCT
DS
H
CCBTI
DS
H
CCBSTAT DS
H
CCBLU
DS
H
DS
1C
CCBCCWA DS
AL3

42140000
43000000
43860000
44720000
45580000
46440000
47300000
48160000
49020000
49880000
50740000
51600000
52460000
53320000
54180000
55040000
55900000
56760000
57620000
58480000
59340000
60200000
61060000
61920000
62780000
63640000
64500000
65360000
66220000
67080000
67940000
68800000
69660000
70520000
71380000
72240000
73100000
73960000
74820000
75680000
76540000
77400000
78260000
79120000
79980000
80840000
81700000
82560000
83420000
84280000
85140000
86000000
86860000
87720000
88580000
89440000
90300000
91160000
92020000
92880000

DS
1C
CCBCSWA DS
AL3
DS
F
DCBD DSORG=(PS)
TAPEOS CSECT ,
IOBECBD
END

NO COMMENT

93740000
94600000
95460000
96320000
97180000
98040000
98900000