!*
! IDLES at IPL
! ***** ** ***
!
! If certain errors occurr before an OPER has been found
! CHOPSUPE can not tell the Operator. Insteads it halts with an
! Idle instruction. These signify as follows:-
!
! {(S) indicates S series only, (P) indicates P series only.}
!
! A) Idles during Booting (from Disc or Tape)
!
! F001 (P) CRESP0 zero on entry
! F002 (P) Abnormal termination
! F003 (P) SAC interrupt flags, which give trunk, zero on entry
! F004 (P) First 4 decks on IPL stream inoperable
! F005 (P) GPC microprogram load failed
! F006 (P) Connect IPL stream fails
! F007 (P) Controller detected error when reading tape
! F008 (P) More than 10 attempts to read block
! F009 (P) Backspace failed when retrying read block
! F010 (P) Rewind fails
! F011 (P) Sense fails
! F012 (P) MARK < -1
! F013 (P) Non attention response rcvd when attn expected
! 1111 System errror on entry to CHOPSUPE
!
!
! B) Errors detected during GROPEing for devices
!
!
!
! B00B (P) OCP not 2960,2970,2980,2972 or 2976
! B00B (S) OCP not 2950,2956 or 2966
! 00DD (P) No operable GPC found in configuration
! 00DD (S) No operable DCU found in configuration
! 0DDD No Controllers found at all
! FF00 (P) Too many GPCs (>8)
! FF00 (S) Too many DCUs (>8)
! FF01 Too many SLOTS (>256) or supplied table too small
! FF02 Too many entries in 'RESPONSE' array
! FF03 Too many MAGTAPE streams (>32) (in 'FORM TABLES')
! FF04 Too many OPER streams (>7) (in 'FORM TABLES')
! FF05 Supplied table too small (in 'CHECKLIM')
!
! C) Errors detected after GROPE completed
!
! AAAA Normal CHOPSUPE idle (Awaiting Command from OPER)
! 3333 Imp %STOP executed (Software error)
! E00E Dump to tape completed successfully
! 12121 Dump to tape failed(Deck not known or faulty)
! CCCC Attempt to return from Procedure invoked by Activate
!
!
! D) Unexpected interrupts in CHOPSUPE
!
! 00F0 Sytem error interupt occurred (Probable OCP fault)
! 00F1 External interupt occurred (none ever expected)
! 00F2 Multi-processor interupt occurred (none ever expected)
! 00F4 Virtual Store interupt occurred (none ever expected)
! 00F6 Program error interupt occurred (S-ware or h-ware fault)
! 00F7 System Call interupt occurred (no System Calls ever made!)
! 00F8 Out interupt occurred (no Outs in code!)
! 00F9 Extracode interupt occurred (none ever expected)
! 00FA Event pending interupt occurred (none ever expected)
! 00FB Instruction Counter interupt occurred (Always masked)
!
!
CONSTSTRING (3) VSN="22B"
CONSTSTRING (8) VDATE="11/6/84"
RECORDFORMAT PARMF(INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
STRING (8)FNSPEC STRHEX(INTEGER N)
STRING (15) FNSPEC STRINT(INTEGER N)
STRINGFNSPEC HTOS(INTEGER VALUE,PLACES)
ROUTINESPEC MONITOR(STRING (63) S)
INTEGERFNSPEC HANDKEYS
ROUTINESPEC DUMPTABLE(INTEGER T, A, L)
INTEGERFNSPEC REALISE(INTEGER AD)
ROUTINESPEC PKMONREC(STRING (20)TEXT,RECORD (PARMF)NAME P)
ROUTINESPEC PTREC(RECORD (PARMF)NAME P)
ROUTINESPEC PRHEX(INTEGER N)
EXTERNALROUTINESPEC OPER(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC GDC(RECORD (PARMF)NAME P)
ROUTINESPEC PRINTER(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC TAPE(RECORD (PARMF)NAME P)
ROUTINESPEC OPMESS2(INTEGER OPER,STRING (63)MESS)
ROUTINESPEC OPERRELAY(RECORD (PARMF)NAME P)
ROUTINESPEC OPMESS(STRING (63) S)
ROUTINESPEC WAIT(INTEGER MILLESECS)
ROUTINESPEC COMREP(RECORD (PARMF)NAME P)
ROUTINESPEC SLAVESONOFF(INTEGER MASK)
ROUTINESPEC ONOFF(INTEGER OFFSET,MASK)
ROUTINESPEC PARSE COM(INTEGER SRCE,STRINGNAME S)
ROUTINESPEC TIMEEVAL(INTEGER FLAG)
IF SSERIES=YES START
ROUTINESPEC LIGHTS(INTEGER PATTERN)
FINISH
INTEGERFNSPEC STOI(STRINGNAME S)
!-----------------------------------------------------------------------
! PON & POFF etc. declarations
RECORDFORMAT PARMXF(INTEGER DEST, SRCE, P1, P2, P3, P4, P5, C
P6, LINK)
INTEGERFNSPEC PP INIT(RECORD (PARMXF)ARRAYNAME SPACE,INTEGER SIZE)
ROUTINESPEC MORE PP SPACE
ROUTINESPEC RETURN PPCELL(INTEGER CELL)
ROUTINESPEC PON(RECORD (PARMF)NAME P)
ROUTINESPEC POFF(RECORD (PARMF)NAME P)
ROUTINESPEC INHIBIT(INTEGER SERVICE)
ROUTINESPEC UNINHIBIT(INTEGER SERVICE)
! 64 services & 80 sets of parms
CONSTINTEGER MAXSERV=64
CONSTINTEGER PARMCELLS=80
IF SSERIES=YES START
!
!* image store addresses for S1,S2 & S3 processors
!* ordered:- LSTL,LSTB,PSTL,PSTB,HKEYS,HOOTER,SIR,
!* CLOCK X,Y,Z,HBIT,SLAVES,INH REPS,INH PHOTO,IT INT,IRATE,TSLICE
!
CONSTINTEGER ISAS ESIZE=17
OWNINTEGERARRAY ISAS(0:ISAS ESIZE*4-1)=C
X'6000',X'6001',X'6002',X'6003',X'6006',0,0,
X'600C',X'600D',X'600E',0,X'00086011',0,X'00016011',2,150,X'40000',
X'6000',X'6001',X'6002',X'6003',X'6006',0,6007,
X'600C',X'600D',X'600E',0,X'00086011',0,0,2,300,X'30000',
X'6000',X'6001',X'6002',X'6003',X'6006',0,0,
X'600C',X'600D',X'600E',0,X'01C86011',X'00106011',X'00026011',
2,900,X'20000',
X'6000',X'6001',X'6002',X'6003',X'6006',0,0,
X'600C',X'600D',X'600E',0,X'01C86011',X'00106011',X'00026011',
2,1000,X'20000'
!*** see PSD 2.5.1 & processor specs - amend when OCP types stable
CONSTBYTEINTEGERARRAY ISASP(1:3,0:6)=C
0,255, 255,
255,ISAS ESIZE,2*ISAS ESIZE,
255,255, 3*ISAS ESIZE,
255,255, 255,
255,255, 255,
255,255, 255,
255,255, 3*ISAS ESIZE
CONSTHALFINTEGERARRAY OCP NAME(1:4)=X'2950',X'2956',X'2966',X'2988'
CONSTINTEGER VAR88=6
OWNINTEGER ISAS PTR
CONSTINTEGER LSTL OFFSET=0
CONSTINTEGER LSTB OFFSET=1
CONSTINTEGER HK OFFSET=4
CONSTINTEGER SLAVES OFFSET=11
CONSTINTEGER INH REPS OFFSET=12
CONSTINTEGER INH PHOTO OFFSET=13
CONSTINTEGER ITIMER OFFSET=14
CONSTINTEGER IRATE OFFSET=15
CONSTINTEGER TSLICE OFFSET=16
CONSTINTEGER ISAS COML=12
!
FINISH ELSE START
!
! this array has the vital image store addrsess for P2,P3&P4s
! ordered as LST LIMIT,LST BASE, PST LIMIT, PST BASE,HKEYS,HOOTER, SIR,
! CLOCK X,Y,Z REGS,HOOTER BIT,SLAVES,INH REPORTS,INH PHOTO,IT INTERVAL,SMACINF RECORD,
! IRATE,TSLICE
! (SMACINF RECORD:- CONFIG REG,SMACPOS,BLOCK0 BIT,BLKSHIFT,
! BLKSPERSEG,BLKSIZE,SMACMAX,INTERLEAVE,SMAC DIAG REGS(3),SMAC ES REG,HAMMING OFF BIT
!
CONSTINTEGER ISAS ESIZE=30; !ENTRY SIZE IN WORDS
OWNINTEGERARRAY ISAS(0:4*ISAS ESIZE-1)=C
X'6000',X'6001',X'6002',X'6003',X'6006',X'6008',
X'600A',X'600C',X'600D',X'600E',1,X'00086011',
X'00806011',X'00016011',2,
X'4C006A20',16,X'100',1,2,X'20000',1,
0,X'4C006004',X'4C006100',X'4C006A00',X'4C006A10',
X'20000000',290,X'30000',
X'6000',X'6001',X'6002',X'6003',X'6006',X'6008',
X'600A',X'600C',X'600D',X'600E',1,X'00086011',
X'00906011',X'00016011',8,
X'4C006A20',16,X'100',1,2,X'20000',15,
0,X'4C006004',X'4C006100',X'4C006A00',X'4C006A10',
X'20000000',624,X'20000',
X'402C',X'402A',X'402B',X'4029',X'4205',X'4013',
X'4014',X'44004000',X'44004100',X'44004200',X'1000',
X'08084013',X'01004013',X'01004012',8,
X'4C004A20',20,X'01000000',-1,1,X'40000',
15,X'10000000',X'4C004004',X'4C004100',X'4C004A00',
X'4C004A10',X'40000000',2128,X'10000',
X'402C',X'402A',X'402B',X'4029',X'4205',X'4013',
X'4014',X'44004000',X'44004100',X'44004200',X'1000',
X'08084013',X'01004013',X'01004012',8,
X'4C006A20',20,X'100',1,2,X'20000',15,
0,X'4C006004',X'4C006100',X'4C006A00',X'4C006A10',
X'20000000',1400,X'10000';
!
! THIS ARRAY HAS POINTERS TO ISAS FOR P1-P4 AND P1/1-P4/1
! 255 MEANS THIS MACHINE NOT CATERED FOR
!
CONSTBYTEINTEGERARRAY ISASP(1:4,0:1)=C
255,0,ISAS ESIZE,2*ISAS ESIZE,
255,255,255,3*ISAS ESIZE;
OWNINTEGER ISAS PTR
CONSTINTEGER SMACINF OFFSET=15
CONSTINTEGER ITIMER OFFSET=14
CONSTINTEGER HK OFFSET=4
CONSTINTEGER SLAVES OFFSET=11
CONSTINTEGER LSTL OFFSET=0
CONSTINTEGER LSTB OFFSET=1
CONSTINTEGER ISAS COML=12
CONSTINTEGER INH REPS OFFSET=12
CONSTINTEGER INH PHOTO OFFSET=13
CONSTINTEGER IRATE OFFSET=28
CONSTINTEGER TSLICE OFFSET=29
CONSTINTEGER IRATE2972=1050; ! different for 2972
RECORDFORMAT SMACF(INTEGER CONFREG,SMACPOS,BLOCK0,BLKSHIFT, C
BLKSPERSEG,BLKSIZE,SMACMAX,INTERLEAVE,SDR1,SDR2,SDR3, C
SESR,HOFFBIT)
FINISH
!*
!* Communications record format - extant from CHOPSUPE 22B onwards *
!*
RECORDFORMAT COMF(INTEGER OCPTYPE,SLIPL,SBLKS,SEPGS,NDISCS,DLVNADDR, C
(INTEGER GPCTABSIZE,GPCA OR INTEGER DCUTABSIZE,DCUA), C
INTEGER SFCTABSIZE,SFCA,SFCK,DIRSITE, C
DCODEDA,SUPLVN,TOJDAY,DATE0,DATE1,DATE2, C
TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,SERVAAD, C
BYTEINTEGER NSACS,RESV1, C
(BYTEINTEGER SACPORT1,SACPORT0 OR BYTEINTEGER C
OCP1 SCU PORT,OCP0 SCU PORT), BYTEINTEGER C
NOCPS,SYSTYPE,OCPPORT1,OCPPORT0,INTEGER ITINT, C
(INTEGER CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA OR C
INTEGER DCU2HWNA,DCUCONFA,MIBA,SP0), C
INTEGER BLKADDR,RATION, C
(INTEGER SMACS OR INTEGER SCUS), C
INTEGER TRANS,LONGINTEGER KMON, C
INTEGER DITADDR,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, C
COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,TSLICE,FEPS, C
MAXCBT,PERFORMAD,BYTEINTEGER DAPNO,DAPBLKS,DAPUSER,DAPSTATE, C
INTEGER DAP1,DAPBMASK,SP1,SP2,SP3, C
LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ, C
HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3, C
SDR4,SESR,HOFFBIT,BLOCKZBIT,BLKSHIFT,BLKSIZE,END)
!
! This format describes "The Communication Record" which is kept
! locked in store at Public address X'80C00000'. It is readable at
! all ACR levels but writeable at ACR 1 only. Its purpose is to describe
! the hardware on which the EMAS System is running. Each entry is now
! described in more detail:-
!
! OCPTYPE The 2900 Processor on this configuration as follows
! 1 = 2950 (S1)
! 2 = 2960 (P2) or 2956 (S2)
! 3 = 2970 (P3) or 2966 (S3)
! 4 = 2980 (P4)
! 5 = 2972 or non-interleaved 2976 (P4/1)
! 6 = Interleaved 2976 (P4/1)
!
! SLIPL bit 0 is set to 1 to force an AUTO IPL from RESTART.
! bits 1-15 are the SLOAD lvn & site >>4.
! (equivalent to the handkey settings for AUTO IPL).
! bits 16-31 are thehe port/trunk/stream(or DCU/stream) of the
! device used at IPL time.
! SBLKS The no of 128k blocks of main store present
! SEPGS The no of extended pages for paging(ie not including
! any pages occupied by resident code & data).
! NDISCS Then number of EDS drives avaliable
! DLVNADDR The address of an array which maps disc lvns to
! their ddt slots.
! GPCTABSIZE The size in bytes of the GPC (or DCU) table
! GPCA The address of the GPC (or DCU) table
! SFCTABSIZE The size of the SFC(ie DRUM) table
! SFCA The address of the SFC table
! SFCK The number of (useable) 1K page frames of Drum store
! available for paging.(0 = No drum configuration)
! DIRSITE The Director site address(eg X200) no longer reqd?
! DCODEDA The Disc Address of the Director (expressed as
! SUPLVN<<24!DIRSITE)
! SUPLVN The logical volume no of the disc from which the
! Sytem was "SLOADED". Various System components (eg
! DIRECT, VOLUMS will page from here
!
! TOJDAY Todays (Julien) day number.
! DATE0} These three integers define the current date(updated at
! DATE1} at 2400) as a character string such that
! DATE2} the length byte is in the bottom of DATE0
!
! TIME0} These three integers define the clock time as a string
! TIME1} in the same format as for DATE. The time is updated
! TIME2} about every 2 seconds
!
! EPAGESIZE The number of 1K pages combined together to make up
! the logical "Extended Page" used in Emas.Currently=4
! USERS The number of user processes (foreground+background)
! currently in existence.Includes DIRECT,VOLUMS&SPOOLR
! CATTAD Address of maxcat followed by category table.
! SERVAAD The address of the service array SERVA.
! NSACS The number of sacs found at grope time
! SACPORT1} Holds the Port no of the Store Access Controller(s)
! SACPORT0} found at grope time. SACPORT0 was used to IPL system.
! NOCPS The number of OCPS found at grope time.
! SYSTYPE System infrastructure:
! 0 = SMAC based
! 1 = SCU based (SCU1)
! 2 = SCU based (SCU2)
! OCPPORT1} Hold the Port no of the OCPs found at grope time.
! OCPPORT0} OCPPORT0 was used to IPL the system.
! ITINT The Interval Timer interval in microsecs. Varies
! between different members of the range
! CONTYPEA The address of a 31 byte area containing the codes
! of the controllers in port-trunk order. Codes are:-
! 0 = Not relevant to EMAS
! 1 = SFC1
! 2 = FPC2
! 3 = GPC1
!
! GPCCONFA} These three variables each point to a word array
! FPCCONFA} containing controller data. The first word in each
! SFCCONFA} case says how many controllers on the system. The
! remainder have Port&Trunk in top byte and Public
! segment no of comms segment in bottom byte. For GPCS
! the Public Seg no is apparently omitted!
! BLKADDR The address of first element of a word array bounds
! (1:SBLKS) containing the real address of each 128K
! block of main store. Real addresses are in the form
! RSN/SMAC NO/Address in SMAC
! RATION Information maintained by DIRECT concerning access
! rationing. Bytes from left indicate scarcity,
! pre-empt point, zero and interactive users
! respectively
! SMACS Bits 0-15 are a map of SMACS in use by the system.
! 2**16 bit set if SMAC0 in use etc.
! Bits 16-31 are a map of SMACS found at grope time.
! 2**0 bit set if SMAC0 found etc.
! TRANS The address of a 768 byte area containing 3 translate
! tables. The first is ISO to EBCDIC, the second the
! exact converse & the third is ISO to ISO with
! lower to upper case conversion.
! KMON A 64 bit bitmask controlling monitoring of Kernel
! services. Bit 2**n means monitor service n. Bits can
! be set by Operator command KMON.
! DITADDR Disc index table address. The address of first
! element of an array(0:NDISCS-1) containing the address
! of the disc device entries.
! SMACPOS The no of places that the Smac no must be left
! shifted to be in the right position to access
! a Smac image store location. Incredibly this varies
! between the 2980 and others!!
! SUPVSN The Supervisor id no as a three char string eg 22A
! PSTVA The virtual address of the Public Segment table which
! is itself a Public segment. All other information
! about PST can be found by looking at its own PST entry
! SECSFRMN The no of Seconds since midnight. Updated as for TIME
! SECSTOCD The number of seconds to System closedown if positive
! If zero or negative no close down time has yet been
! notified. Updated as for TIME
! SYNC1DEST} These are the service nos N2,N3 & N4 for process
! SYNC2DEST} parameter passing described in Supervisor Note 1
! ASYNCDEST}
! MAXPROCS The maximum number of paged processes that the
! Supervisor is configured to run. Also the size
! of the Process array.
! INSPERSECS The number of instructions the OCP executes in 1
! second divided by 1000(Approx average for EMAS)
! ELAPHEAD The head of a linked list of param cells holding
! service with an elapsed interval interrupt request
! outstanding
! COMMSRECA The address of an area containing details of the
! Communication streams.(private to COMMS Control)
! STOREAAD The address of first element of the store record array
! bounds (0:SEPGS-1)
! PROCAAD The address of first element of the process record
! array bounds(0:MAXPROCS)
! SFCCTAB} The addresses of two private tables provided by grope
! DRUMTAD} for use by the routine DRUM. They give details of
! the SFCS and DRUMS found on the system
! TSLICE Time slice in microsecs. Supervisor has to allow for
! differences in interval timer speeds accross the range
! FEPS Bits 0-15 are a map of FEPs found at grope time.
! 2**16 bit set if FE0 found etc.
! Bits 16-31 are a map of currently available FEPs.
! 2**0 bit set if FE0 available etc.
! MAXCBT Maximum cbt entry
! PERFORMAD Address of record holding timing information and counts
! for performance analysis.
! DAPNO SMAC number for the DAP
! DAPBLKS The number of 128K blocks in DAP
! DAPUSER The PROCESS currently holding the DAP
! DAPSTATE The state of the DAP
! DAP1 DAP control fields
! DAPBMASK Bit map of currently allocated DAP blocks
! SP1->SP3 Spare locations
! LSTL}
! LSTB}
! PSTL}
! PSTB} These are the image store addresses for the following
! HKEYS} control registers:-
! HOOT} Local Segment Table Limit & Base
! SIM } Public Segment Table Limit & Base
! CLKX} Handkeys,Hooter System Interrupt Mask Register
! CLKY} and the clock X,Y & Z Registers
! CLKZ}
! HBIT A bit pattern that when ORed into Control Register
! "HOOT" operates the Hooter.(0=Hooterless machine)
! SLAVEOFF A bit pattern (top 16 bits) and Image store address
! in bottom 16 bits. ORing the top 16 bits(after
! shifting) into the image store will stop all slaving of
! operands but not instructions
! INHSSR A bit pattern and image location as for SLAVEOFF.
! ORing the bits into the location will switch off
! reporting of successful system retry
! SDR1}
! SDR2} The image store addresses of SMAC internal registers
! SDR3} needed by the Engineers after Smac errors have
! SDR4} occurred
! SESR}
! HOFFBIT A bit pattern that when ORed into a Smac Engineers
! status register will stop reporting of error
! from that Smac
!
! BLOCKZBIT A bit pattern indicating the position of
! the block zero bit in the SMAC config register.
!
! BLKSHIFT Indicates which way to shift the BLOCKZBIT mask
! to correspond with subsequent store blocks.
!
! BLKSIZE Store block size.
!
CONSTRECORD (COMF)NAME COM=X'80000000'!48<<18
RECORDFORMAT PARMAF(INTEGER DEST, SRCE, INTEGERARRAY P(1:6))
CONSTINTEGER PCELLSIZE=36; ! PARM cell size
EXTERNALINTEGER FEP MAP
EXTERNALLONGINTEGER PARMDES
EXTERNALINTEGER PARMASL,PARMAD
RECORDFORMAT SERVF(INTEGER P, L)
OWNRECORD (SERVF)ARRAY SERVA(0:MAXSERV)
OWNRECORD (PARMXF)ARRAYNAME PARM
OWNINTEGER KERNELQ, SERVICE
OWNINTEGER OCPTYPE
OWNINTEGER OCPVAR
CONSTINTEGER EPAGESPERBLOCK=32,EPBYTES=EPAGESIZE*1024
CONSTINTEGER DITSIZE=4,MAIN LP SIZE=X'4000'
IF SSERIES=NO START
CONSTINTEGER DDTSIZE=128,DCONSIZE=672
FINISH
CONSTLONGINTEGER SUPACR=1,DIRACR=2,ALLACR=15,PRIVACR=5
CONSTLONGINTEGER WSUPRDIR=SUPACR<<56!DIRACR<<52
CONSTLONGINTEGER WSUPRSUP=SUPACR<<56!SUPACR<<52
CONSTLONGINTEGER WDIRRDIR=DIRACR<<56!DIRACR<<52
CONSTLONGINTEGER WDIRRPRIV=DIRACR<<56!PRIVACR<<52
CONSTLONGINTEGER WDIRRALL=DIRACR<<56!ALLACR<<52
CONSTLONGINTEGER WSUPRPRIV=SUPACR<<56!PRIVACR<<52
CONSTLONGINTEGER NONSLAVED=X'2000000000000000'
OWNINTEGER IST VA
CONSTINTEGER REAL0ADDR=X'80000000'!64<<18
CONSTINTEGER UNDUMPSEG=X'80000000'!10<<18
CONSTINTEGER GROPESEG=UNDUMPSEG
EXTERNALLONGINTEGER KMON=0
OWNINTEGER POFFMON=0
OWNINTEGER STORE BLOCKS, STORE EPAGES
EXTERNALINTEGER NDISCS,HI STRM
CONSTINTEGER BA SIZE=128; ! ALLOW 16 MEG
OWNINTEGERARRAY BLOCK ADDR(0:BA SIZE-1)
IF SSERIES=YES START
OWNINTEGERARRAY DCUCONF(0:7)
CONSTINTEGER CONF LENGTH=32
CONSTINTEGER DCU2HWNL=64
OWNBYTEINTEGERARRAY DCU2HWN(0:DCU2HWNL-1)
OWNINTEGER FOOTPRINT
FINISH ELSE START
OWNINTEGERARRAY GPCCONF(0:7)
OWNINTEGERARRAY FPCCONF(0:7)
OWNINTEGERARRAY SFCCONF(0:7)
CONSTINTEGER CONF LENGTH=96
CONSTINTEGER CONTYPEL=32
OWNBYTEINTEGERARRAY CONTYPE(0:CONTYPEL-1)
FINISH
CONSTINTEGER DLVN SIZE=100
IF SSERIES=YES START
RECORDFORMAT ENTFORM(INTEGER C
SER, PTSM, PROPADDR, SECS SINCE, CAA, GRCB AD, C
BYTE INTEGER LAST ATTN, DACTAD, HALF INTEGER HALFSPARE, C
INTEGER LAST TCB ADDR, C
STATE, PAW, RESP1, SENSE1, SENSE2, SENSE3, SENSE4, C
REPSNO, BASE, ID, DLVN, MNEMONIC, C
STRING (6) LABEL, BYTE INTEGER HWCODE, C
INTEGER ENTSIZE, URCB AD, SENSDAT AD, LOGMASK, TRTAB AD, C
UA SIZE, UA AD, TIMEOUT,PROPS0,PROPS1)
FINISH ELSE START
RECORDFORMAT DDTFORM(INTEGER SER, PTS, PROPADDR, STICK, CCA, RQA, C
LBA, ALA, STATE, IW1, CONCOUNT, SENSE1, SENSE2, SENSE3, C
SENSE4, REPSNO, BASE, ID, DLVN, MNEMONIC, C
STRING (6) LAB, BYTEINTEGER MECH, C
INTEGER PROPS,STATS1,STATS2, C
BYTEINTEGER QSTATE,PRIO,SP1,SP2, C
INTEGER LQLINK,UQLINK,CURCYL,SEMA,TRLINK,CHFISA)
RECORDFORMAT ENTFORM(INTEGER C
SER, PTSM, PROPADDR, SECS SINCE, CAA, GRCB AD, LBA, ALA, C
STATE, RESP0, RESP1, SENSE1, SENSE2, SENSE3, SENSE4, C
REPSNO, BASE, ID, DLVN, MNEMONIC, C
ENTSIZE, PAW, USAW0, URCB AD, SENSDAT AD, LOGMASK, TRTAB AD, C
UA SIZE, UA AD, TIMEOUT,PROPS0,PROPS1)
FINISH
CONSTINTEGER PROP LENGTH=5*40
OWNINTEGERARRAY PROPERTIES(0:PROP LENGTH//4-1)=C
19,404,3,4096,23028,40,256,344,4,20, C { EDS100 }
19,808,3,4096,46056,40,256,344,4,20, C { EDS200 }
5,808,4,4096,16160,40,256,344,4,6, C { EDS80 }
10,816,9,4096,36720,40,256,344,4,4, C { FDS160 }
40,830,9,4096,149400,40,256,344,4,4 { FDS640 }
!*
!* FDS devices have 4.5 pages per track formatted thus:-
!*
!* Even numbered tracks - 4K 4K 4K 4K 2K
!* Odd numbered - 2K 4K 4K 4K 4K
!*
!* So that _PPERTRK (currently 9) is the number of pages in an even/odd
!* track pair
!*
CONSTBYTEINTEGERARRAY HEXDS(0:15)='0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F'
CONSTBYTEINTEGERARRAY SERV TAB(1:64)= C
0,0,0,4,5,6,0(3),10,0(6), C
0(15),32, C
33,34,35,36,37,38,0(8),47,48, C
49,50,51,0,0,54,0(3),58,59,0,0,62,0,0
!
! MASTER RESIDENT TRANSLATE TABLES FOR EMAS2900
!
CONSTINTEGER TRTAB SIZE=256
CONSTBYTEINTEGERARRAY ITOETAB(0 : 255) = C
X'00',X'01',X'02',X'03', X'37',X'2D',X'2E',X'2F',
X'16',X'05',X'25',X'0B', X'0C',X'0D',X'0E',X'0F',
X'10',X'11',X'12',X'13', X'3C',X'3D',X'32',X'26',
X'18',X'19',X'3F',X'27', X'1C',X'1D',X'1E',X'1F',
X'40',X'4F',X'7F',X'7B', X'5B',X'6C',X'50',X'7D',
X'4D',X'5D',X'5C',X'4E', X'6B',X'60',X'4B',X'61',
X'F0',X'F1',X'F2',X'F3', X'F4',X'F5',X'F6',X'F7',
X'F8',X'F9',X'7A',X'5E', X'4C',X'7E',X'6E',X'6F',
X'7C',X'C1',X'C2',X'C3', X'C4',X'C5',X'C6',X'C7',
X'C8',X'C9',X'D1',X'D2', X'D3',X'D4',X'D5',X'D6',
X'D7',X'D8',X'D9',X'E2', X'E3',X'E4',X'E5',X'E6',
X'E7',X'E8',X'E9',X'4A', X'E0',X'5A',X'5F',X'6D',
X'79',X'81',X'82',X'83', X'84',X'85',X'86',X'87',
X'88',X'89',X'91',X'92', X'93',X'94',X'95',X'96',
X'97',X'98',X'99',X'A2', X'A3',X'A4',X'A5',X'A6',
X'A7',X'A8',X'A9',X'C0', X'6A',X'D0',X'A1',X'07',
X'20',X'21',X'22',X'23', X'24',X'15',X'06',X'17',
X'28',X'29',X'2A',X'2B', X'2C',X'09',X'0A',X'1B',
X'30',X'31',X'1A',X'33', X'34',X'35',X'36',X'08',
X'38',X'39',X'3A',X'3B', X'04',X'14',X'3E',X'E1',
X'41',X'42',X'43',X'44', X'45',X'46',X'47',X'48',
X'49',X'51',X'52',X'53', X'54',X'55',X'56',X'57',
X'58',X'59',X'62',X'63', X'64',X'65',X'66',X'67',
X'68',X'69',X'70',X'71', X'72',X'73',X'74',X'75',
X'76',X'77',X'78',X'80', X'8A',X'8B',X'8C',X'8D',
X'8E',X'8F',X'90',X'9A', X'9B',X'9C',X'9D',X'9E',
X'9F',X'A0',X'AA',X'AB', X'AC',X'AD',X'AE',X'AF',
X'B0',X'B1',X'B2',X'B3', X'B4',X'B5',X'B6',X'B7',
X'B8',X'B9',X'BA',X'BB', X'BC',X'BD',X'BE',X'BF',
X'CA',X'CB',X'CC',X'CD', X'CE',X'CF',X'DA',X'DB',
X'DC',X'DD',X'DE',X'DF', X'EA',X'EB',X'EC',X'ED',
X'EE',X'EF',X'FA',X'FB', X'FC',X'FD',X'FE',X'FF'
CONSTBYTEINTEGERARRAY ETOITAB(0 : 255) = 0,
1, 2, 3, 156, 9, 134, 127, 151, 141, 142,
11, 12, 13, 14, 15, 16, 17, 18, 19, 157,
133, 8, 135, 24, 25, 146, 143, 28, 29, 30,
31, 128, 129, 130, 131, 132, 10, 23, 27, 136,
137, 138, 139, 140, 5, 6, 7, 144, 145, 22,
147, 148, 149, 150, 4, 152, 153, 154, 155, 20,
21, 158, 26, 32, 160, 161, 162, 163, 164, 165,
166, 167, 168, 91, 46, 60, 40, 43, 33, 38,
169, 170, 171, 172, 173, 174, 175, 176, 177, 93,
36, 42, 41, 59, 94, 45, 47, 178, 179, 180,
181, 182, 183, 184, 185, 124, 44, 37, 95, 62,
63, 186, 187, 188, 189, 190, 191, 192, 193, 194,
96, 58, 35, 64, 39, 61, 34, 195, 97, 98,
99, 100, 101, 102, 103, 104, 105, 196, 197, 198,
199, 200, 201, 202, 106, 107, 108, 109, 110, 111,
112, 113, 114, 203, 204, 205, 206, 207, 208, 209,
126, 115, 116, 117, 118, 119, 120, 121, 122, 210,
211, 212, 213, 214, 215, 216, 217, 218, 219, 220,
221, 222, 223, 224, 225, 226, 227, 228, 229, 230,
231, 123, 65, 66, 67, 68, 69, 70, 71, 72,
73, 232, 233, 234, 235, 236, 237, 125, 74, 75,
76, 77, 78, 79, 80, 81, 82, 238, 239, 240,
241, 242, 243, 92, 159, 83, 84, 85, 86, 87,
88, 89, 90, 244, 245, 246, 247, 248, 249, 48,
49, 50, 51, 52, 53, 54, 55, 56, 57, 250,
251, 252, 253, 254, 255;
CONSTBYTEINTEGERARRAY UPPER CASE ISO(0 : 255) = C
0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, C
16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, C
32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, C
48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, C
64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, C
80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, C
96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, C
80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127, C
128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,C
144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,C
160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,C
176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,C
192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,C
208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,C
224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,C
240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255
!-----------------------------------------------------------------------
RECORDFORMAT CATTABF(BYTEINTEGER PRIORITY,EPLIM,RTLIM,MOREP,MORET, C
LESSP,SP0,SUSP,RQTS1,RQTS2,STROBEI,SP2)
CONSTINTEGER MAXCAT=20
OWNBYTEINTEGERARRAY CATDATA(0:12*MAXCAT+11)= C
1, 0, 0, 0, 0, 0,'F', 0, 1,1, 0,0,
1,90, 8, 15,16, 0,'F',10, 1,1, 0,1,
1,90, 8, 18,18, 0,'B',14, 1,1, 0,2,
1,20, 4, 6, 4, 0,'F', 3, 1,1, 0,3,
4,20,48, 8, 4, 0,'F', 3, 1,2, 0,4,
5,20,64, 9, 5, 0,'B',13, 2,2, 0,5,
2,32, 4, 10, 7, 3,'F', 6, 1,1, 0,6,
3,32,48, 11, 8, 4,'F', 6, 1,2, 0,7,
4,32,64, 12, 8, 4,'F', 6, 2,2, 8,8,
5,32,80, 14, 9, 5,'B',13, 2,2, 10,9,
2,64, 4, 15,11, 6,'F',10, 1,1, 0,10,
3,64,48, 16,12, 7,'F',10, 1,2, 0,11,
4,64,48, 17,12, 8,'F',10, 2,2, 4,12,
2,64, 8, 18,14, 5,'B',13, 1,2, 0,13,
5,64,64, 18,14, 9,'B',13, 2,2, 8,14,
3,128,4, 19,16,10,'F',15, 1,1, 0,15,
3,128,48, 19,17,11,'F',15, 1,2, 0,16,
4,128,24, 19,17,12,'F',15, 2,2, 3,17,
5,128,32, 20,18,14,'B',13, 2,2, 4,18,
3,128,8, 19,19,16,'F',15, 1,1, 1,19,
5,128,32, 20,20,18,'B',13, 1,2, 4,20;
ROUTINE CHOP29
IF SSERIES=YES START
INTEGER DCU TAB SIZE,SCU MAP
INTEGER CONFIG TABLE,CONFIG LENGTH
INTEGER OCP0 SCU PORT,OCP1 SCU PORT,MIBA
CONSTINTEGER CONFIG SEG=49
FINISH ELSE START
INTEGER GPC TAB SIZE,SMAC MAP
INTEGER SFC TAB SIZE,SFCK,IPL SAC PORT,OTHER SAC PORT,NSACS,SFCA
FINISH
INTEGER COM SEG SIZE,NOCPS,IPL OCP PORT,REMOTE OCP PORT,CLOCK PORT,NJ
INTEGER I,J,K,IPLDEV,LAST REAL BYTE,TOP BLOCK,NEXT COM SEG,AUTO SLOAD,SYSPARM
INTEGER SYSTEM STORE BLOCKS
LONGINTEGER L,ACT1,ACT2
!-----------------------------------------------------------------------
! IST entry format etc.
RECORDFORMAT ISTF(INTEGER LNB, PSR, PC, SSR, SF, IT, IC, SP)
RECORD (ISTF)NAME IST
RECORD (ISTF) SAVE IST
CONSTLONGINTEGERARRAYNAME PST=PST VA
!-----------------------------------------------------------------------
SWITCH SERVROUT(1:64); ! services>64 are user processes
IF SSERIES=NO START
SWITCH CONROUT(0:3); ! controller type
FINISH
RECORD (PARMF) P
RECORD (PARMAF) PA
! interrupt routine specs
ROUTINESPEC ITIMER
!-----------------------------------------------------------------------
! service routine specs
IF SSERIES=YES START
EXTERNALROUTINESPEC DCU GROPE(RECORD (PARMF)NAME P)
FINISH ELSE START
EXTERNALROUTINESPEC GPC GROPE(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC DISC GROPE(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC DRUM GROPE(RECORD (PARMF)NAME P)
FINISH
EXTERNALROUTINESPEC DISC(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC DLABEL(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC FORMAT(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC RANDREAD(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC MOVE(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC PDISC(RECORD (PARMF)NAME P)
ROUTINESPEC GET EPAGE(RECORD (PARMF)NAME P)
ROUTINESPEC RETURN EPAGE(RECORD (PARMF)NAME P)
ROUTINESPEC CONFIG
ROUTINESPEC GET REAL CORE(INTEGERNAME BYTE)
ROUTINESPEC LOAD SUP(RECORD (PARMF)NAME P)
ROUTINESPEC ACTIVATE SUP
ROUTINESPEC NULL SERVICE(RECORD (PARMF)NAME P)
INTEGERFNSPEC FIND GAP(INTEGER N)
!-----------------------------------------------------------------------
! process inormation array decs etc.
RECORD (PARMXF)ARRAY PARMSPACE(0:PARMCELLS)
INTEGERARRAY GROPE SPACE(0:1023)
IF SSERIES=YES START
RECORD (ENTFORM)NAME DDT
FINISH ELSE START
RECORD (DDTFORM)NAME DDT
RECORD (SMACF)NAME SMACINF
INTEGERARRAY ONLINE(0:15)
FINISH
INTEGERARRAY DDT SPACE,SPEC PAGE(0:1023)
!-----------------------------------------------------------------------
! initialise IST (after decs LNB & SF valid)
*LSS_(3); ! current(ie IPL) OCP in SSR
*USH_-26
*AND_3; *ST_IPL OCP PORT
IST VA=X'80000000'!IPL OCP PORT<<18
IF SSERIES=YES THEN LIGHTS(X'2900FACE')
IST==RECORD(IST VA); ! IST base
*STLN_I
IST_LNB=I
IST_PSR=X'00140001'; ! ACR=1, PRIV=1, PM=0, ACS=1
IST_SSR=X'0180382E'; ! IM=382E (synch. ints. unmasked)
!DIG & ISR added 14/09/78
*STSF_I
IST_SF=I
IST_IT=0
IST_IC=0
IST_SP=0
FOR I=IST VA+X'20',X'20',IST VA+X'1A0' CYCLE
RECORD(I)<-IST
REPEAT
IST_SF=IST_SF+X'1000'; ! syserr SF beyond current frames
! insert PCs
*LXN_IST VA
*JLK_<IST1I>
*LSS_TOS
*ST_(XNB +2)
*JLK_<IST2I>
*LSS_TOS
*ST_(XNB +10)
*JLK_<IST3I>
*LSS_TOS
*ST_(XNB +18)
*JLK_<IST4I>
*LSS_TOS
*ST_(XNB +26)
*JLK_<IST5I>
*LSS_TOS
*ST_(XNB +34)
*JLK_<IST6I>
*LSS_TOS
*ST_(XNB +42)
*JLK_<IST7I>
*LSS_TOS
*ST_(XNB +50)
*JLK_<IST8I>
*LSS_TOS
*ST_(XNB +58)
*JLK_<IST9I>
*LSS_TOS
*ST_(XNB +66)
*JLK_<IST10I>
*LSS_TOS
*ST_(XNB +74)
*JLK_<IST11I>
*LSS_TOS
*ST_(XNB +82)
*JLK_<IST12I>
*LSS_TOS
*ST_(XNB +90)
*JLK_<IST13I>
*LSS_TOS
*ST_(XNB +98)
*JLK_<IST14I>
*LSS_TOS
*ST_(XNB +106)
!-----------------------------------------------------------------------
! initialise PON & POFF etc.
*LSS_(16)
*ST_J
OCPTYPE=J>>4&15
OCPVAR=J&15
ISAS PTR=ISASP(OCPTYPE,OCPVAR)
IF ISAS PTR=255 THEN START
*IDLE_X'B00B'
FINISH
IF SSERIES=YES START
OCP0 SCU PORT=J>>24
I=OCP0 SCU PORT<<22
*LB_X'601D'; *LSS_I; *ST_(0+B ); ! report errors to this OCP
*LB_X'602B'; *LSS_0; *ST_(0+B ); ! unset selective masks
*LB_X'6011'; *LSS_(0+B ); *OR_1; *ST_(0+B ); ! mini photos only
I=OCPVAR
IF I=VAR88 THEN I=4
FOOTPRINT=OCPNAME(I)<<16
LIGHTS(FOOTPRINT!X'FACE')
FINISH
ONOFF(INH REPS OFFSET,0); !turn off retry reporting
IF SSERIES=NO AND OCPTYPE=4 START ; ! turn off hamming reporting in SMAC0
SMACINF==RECORD(ADDR(ISAS(ISAS PTR+SMACINF OFFSET)))
J=SMACINF_SESR
K=SMACINF_HOFFBIT
*LB_J; *LSS_(0+B ); *OR_K; *ST_(0+B )
FINISH
SYSPARM=0
SAVE IST=IST; ! take any masked syserrs
IST_SSR=X'0180FFFE'
*JLK_<HOFF>
*LSS_TOS
*ST_I
IST_PC=I
*LSS_X'0180FFFE'
*ST_(3)
->NOMSE; ! none outstanding
HOFF: *JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_SYSPARM
NOMSE:
IST=SAVE IST
PARMAD=PP INIT(PARMSPACE,PARMCELLS)
FOR I=0,1,1023 CYCLE
SPEC PAGE(I)=0; GROPE SPACE(I)=0
REPEAT
KERNELQ=0
REMOTE OCP PORT=0
NOCPS=1; ! default is nothing dualled
IF SSERIES=YES START
OCP1 SCU PORT=0
MIBA=0
FINISH ELSE START
OTHER SAC PORT=0
NSACS=1
FINISH
P=0
PA=0; ACT1=0; ACT2=0
!-----------------------------------------------------------------------
! initialise control OPER
INHIBIT(47); ! hold OPER messages
OPMESS("CHOPSUPE ".VSN." ".VDATE)
UNLESS SYSPARM=0 THEN OPMESS("SYSERR parm=".STRHEX(SYSPARM))
IF SSERIES=YES START
IPLDEV=INTEGER(8)
OPMESS("S".HTOS(OCPTYPE,1)."/".HTOS(OCPVAR,1). C
" IPLed from ".HTOS(IPLDEV,3))
FINISH ELSE START
IPLDEV=INTEGER(8)
OPMESS("P".HTOS(OCPTYPE,1)."/".HTOS(OCPVAR,1). C
" IPLed from ".HTOS(IPLDEV,3))
IPL SAC PORT=IPLDEV>>8
FINISH
AUTO SLOAD=INTEGER(12); ! zero or AUTO SLOAD parms
!
! turn off slaving for grope as PST and IST being changed
!
SLAVESONOFF(0)
IF SSERIES=NO AND OCPTYPE=2 START
! inhibit stops & photos on 2960
*LSS_X'11001'; *ST_(X'6011')
FINISH
!-----------------------------------------------------------------------
!
CONFIG; ! grope store,controllers, etc.
J=MAIN LP SIZE; ! set up main LP buffer
IF SSERIES=NO AND OCPTYPE=3 START ; ! 2970
GET REAL CORE(J)
I=LAST REAL BYTE
FINISH ELSE START ; ! use overlay area
J=J-128
I=X'4000'
FINISH
PST(63)=WSUPRSUP!X'080000001'+I+LENGTHENI(J)<<32
BYTEINTEGER(X'80FC0000')=12
! perform the GPC/DCU grope
GROPE SPACE(0)=0
IF SSERIES=YES THEN J=DCU CONF(0) ELSE J=GPC CONF(0)
IF J=0 START ; ! no GPCs/DCUs - we are snookered!
*IDLE_X'0DDD'
FINISH
FOR I=1,1,J CYCLE
P_DEST=1
P_P2=ADDR(GROPE SPACE(0))
P_P3=GROPESEG
P_P4=1023; ! grope space limit
IF SSERIES=YES START
P_P1=DCU CONF(I)
P_P5=CONFIG TABLE
DCU GROPE(P)
FINISH ELSE START
P_P1=GPC CONF(I)>>24
GPC GROPE(P)
FINISH
REPEAT ; ! for all attached GPCs/DCUs
P_DEST=3
P_P2=ADDR(GROPE SPACE(0))
P_P4=1023; ! grope space limit
! form the tables
IF SSERIES=YES START
DCU GROPE(P)
DCU TAB SIZE=4*GROPE SPACE(0)+4
NJ=DCU CONF(0)
K=NJ
FINISH ELSE START
GPC GROPE(P)
GPC TAB SIZE=4*GROPE SPACE(0)+4
NJ=GPC CONF(0)
K=NJ
FINISH
FOR I=1,1,K CYCLE
J=GROPE SPACE(I+23); ! required comm area size
GET REAL CORE(J)
PST(NEXT COM SEG)=X'080000001'!WDIRRPRIV!NONSLAVED+ C
LENGTHENI(J)<<32+LAST REAL BYTE
P_DEST=2
P_P2=ADDR(GROPE SPACE(0))
P_P3=GROPESEG
P_P4=X'80000000'+NEXT COM SEG<<18
IF SSERIES=YES START
P_P1=DCU CONF(I)
P_P5=CONFIG TABLE
P_P6=ADDR(DDT SPACE(0))
DCU GROPE(P)
DCU CONF(I)=DCU CONF(I)!NEXT COM SEG<<16
IF P_P1#0 THEN OPMESS("DCU ".HTOS(DCU CONF(I)>>8&15,2). C
" flag=".HTOS(P_P1,8)) AND NJ=NJ-1
FINISH ELSE START
J=GPC CONF(I)>>24
P_P1=J
GPC GROPE(P)
IF P_P1#0 THEN OPMESS("GPC ".HTOS(J,2)." RI res=". C
HTOS(P_P1,8)) AND NJ=NJ-1
FINISH
NEXT COM SEG=NEXT COM SEG+1
REPEAT
IF NJ=0 START ; ! no operable GPCs/DCUs
*IDLE_X'0DD'
FINISH
IF SSERIES=NO START
NJ=FPCCONF(0)
IF NJ=0 THEN ->SKDISC
FOR I=1,1,NJ CYCLE
P_DEST=0
P_P1=FPCCONF(I)>>24
P_P2=ADDR(DDT SPACE(0))
J=NDISCS
DISC GROPE(P)
J=(NDISCS-J)*DCONSIZE+(32+16*(HI STRM+1))
J=(J+255)&X'FFFFFF00'; ! commcn area size
J=512 IF J<512
GET REAL CORE(J)
PST(NEXT COM SEG)=X'080000001'!WDIRRDIR!NONSLAVED+ C
LENGTHENI(J)<<32+LAST REAL BYTE
FPCCONF(I)=FPCCONF(I)!HI STRM<<16+NEXT COM SEG
NEXT COM SEG=NEXT COM SEG+1
REPEAT
SKDISC:
! perform the drum grope
K=GROPE SPACE(0)+4
SFC TAB SIZE=0; SFCK=0
GROPE SPACE(K)=0
NJ=SFC CONF(0)
->SKSFC IF NJ=0; ! no drum configuration
FOR I=1,1,NJ CYCLE
P_DEST=1; P_P1=SFC CONF(I)>>24; ! SFC port&trunk
P_P2=ADDR(GROPE SPACE(K))
P_P3=GROPESEG
DRUM GROPE(P)
J=P_P6
CONTINUE IF J=0; ! no drums on SFC
GET REAL CORE(J)
PST(NEXT COM SEG)=X'080000001'!WDIRRDIR!NONSLAVED+ C
LENGTHENI(J)<<32+LAST REAL BYTE
SFC CONF(I)=SFC CONF(I)+NEXT COM SEG
NEXT COM SEG=NEXT COM SEG+1
REPEAT
SFCK=P_P5; ! drum size in kilobytes
FOR I=1,1,SFC CONF(0) CYCLE
CONTINUE IF SFC CONF(I)&X'FFFF' = 0
P_DEST=2; P_P1=SFC CONF(I)>>24
P_P2=ADDR(GROPE SPACE(K))
P_P3=GROPESEG
P_P4=(SFC CONF(I)&X'FFFF')<<18!X'80000000'
DRUM GROPE(P)
REPEAT
SFC TAB SIZE=4*GROPE SPACE(K)+4
SFCA=ADDR(GROPE SPACE(K))
SKSFC:
FINISH
! calculate comm area size & fill it
J=((ADDR(COM_END)-ADDR(COM_OCPTYPE))+ C
PROP LENGTH+ C
(NDISCS*DITSIZE+31))&(-32) +C
(BA SIZE*4+ C
12*(MAXCAT+1)+4+ C
DLVN SIZE+ C
(TRTAB SIZE*3+31))&(-32)
IF SSERIES=YES START
J=J+ C
(DCU TAB SIZE+31)&(-32)+ C
CONF LENGTH+DCU2HWNL
FINISH ELSE START
J=J+ C
(NDISCS*DDTSIZE+31)&(-32)+ C
(GPC TAB SIZE+31)&(-32)+ C
(SFC TAB SIZE+31)&(-32)+ C
CONF LENGTH+CONTYPEL
FINISH
COM SEG SIZE=J
GET REAL CORE(J)
PST(48)=WDIRRALL!X'080000001'+LAST REAL BYTE+LENGTHENI(J)<<32
PST(48)=PST(48)!NONSLAVED IF NOCPS>1
COM=0
IF SSERIES=NO AND OCPTYPE=4 AND OCPVAR=1 START ; ! 2972 or 2976
*LSS_(X'4469'); ! inspect interleaved state
*ST_I
IF I>>28=0 START
OCPTYPE=5; ! 2972 or non-interleaved 2976
ISAS(ISAS PTR+IRATE OFFSET)=IRATE2972
FINISH ELSE OCPTYPE=6; ! interleaved 2976
FINISH
IF SSERIES=YES AND OCPVAR=VAR88 THEN OCPTYPE=4
COM_OCPTYPE=OCPTYPE
COM_SLIPL=IPLDEV
COM_SBLKS=STORE BLOCKS
COM_SEPGS=STORE EPAGES
COM_NDISCS=NDISCS
COM_NOCPS=NOCPS
*LSS_(16); *USH_-16; *AND_255; *ST_J
COM_SYSTYPE=J
COM_OCPPORT0=IPL OCP PORT
COM_OCPPORT1=REMOTE OCP PORT
COM_DIRSITE=X'200'
COM_EPAGESIZE=EPAGESIZE
COM_FEPS=FEP MAP<<16; ! set by GPC/DCU grope
STRING(ADDR(COM_SUPVSN))=VSN; ! for compatability check
COM_PSTVA=PST VA
COM_INSPERSEC=ISAS(ISAS PTR+IRATE OFFSET)
COM_TSLICE=ISAS(ISAS PTR+TSLICE OFFSET)
COM_ITINT=ISAS(ISAS PTR+ITIMER OFFSET); ! interval timer interval
FOR I=0,1,ISAS COML CYCLE ; ! copy in image store addrs
INTEGER(ADDR(COM_LSTL)+4*I)=ISAS(ISAS PTR+LSTL OFFSET+I)
REPEAT
IF SSERIES=YES START
COM_DCU TAB SIZE=DCU TAB SIZE
COM_SCUS=SCU MAP
COM_OCP0 SCU PORT=OCP0 SCU PORT
COM_OCP1 SCU PORT=OCP1 SCU PORT
COM_MIBA=MIBA
FINISH ELSE START
COM_GPC TAB SIZE=GPC TAB SIZE
COM_NSACS=NSACS
COM_SACPORT0=IPL SAC PORT
COM_SACPORT1=OTHER SAC PORT
COM_SMACS=SMAC MAP
SMACINF==RECORD(ADDR(ISAS(ISAS PTR+SMACINF OFFSET)))
COM_SMACPOS=SMACINF_SMACPOS
COM_SDR1=SMACINF_SDR1
COM_SDR2=SMACINF_SDR2
COM_SDR3=SMACINF_SDR3
COM_SDR4=SMACINF_CONFREG
COM_SESR=SMACINF_SESR
COM_HOFFBIT=SMACINF_HOFFBIT
COM_BLOCKZBIT=SMACINF_BLOCK0
COM_BLKSHIFT=SMACINF_BLKSHIFT
COM_BLKSIZE=SMACINF_BLKSIZE
FINISH
!
! P4 clocks set clock port no in image store address and also unmask
! external interupts for that port. note SSR mask still prevents
! any RTC interrupts till main sup activated
!
IF SSERIES=NO AND OCPTYPE>3 START
K=CLOCK PORT<<20
COM_CLKX=COM_CLKX!K
COM_CLKY=COM_CLKY!K
COM_CLKZ=COM_CLKZ!K
I=X'80000000'>>CLOCK PORT
*LSS_(X'4012')
*OR_I
*ST_(X'4012')
FINISH
K=ADDR(COM_END)
FOR I=0,1,PROP LENGTH//4-1 CYCLE
INTEGER(K)=PROPERTIES(I)
K=K+4
REPEAT
IF SSERIES=NO START
I=0
J=K
WHILE I<(DDTSIZE//4)*NDISCS CYCLE
INTEGER(K)=DDTSPACE(I)
K=K+4
I=I+1
REPEAT
FINISH
COM_DITADDR=K
I=0
WHILE I<NDISCS CYCLE
IF SSERIES=YES THEN INTEGER(K)=DDT SPACE(I) ELSE INTEGER(K)=J+I*DDTSIZE
K=K+4; I=I+1
REPEAT
K=(K+31)&(-32)
I=0
WHILE I<NDISCS CYCLE
DDT==RECORD(INTEGER(COM_DITADDR+4*I))
DDT_PROPADDR=DDT_PROPADDR+ADDR(COM_END)
I=I+1
REPEAT
! copy in the GPC/DCU table
IF SSERIES=YES THEN COM_DCUA=K ELSE COM_GPCA=K
FOR I=0,1,GROPE SPACE(0) CYCLE
INTEGER(K)=GROPE SPACE(I)
K=K+4
REPEAT
K=(K+31)&(-32)
IF SSERIES=YES START
COM_DCUCONFA=K
FOR I=0,1,7 CYCLE
INTEGER(K)=DCU CONF(I)
K=K+4
REPEAT
COM_DCU2HWNA=K
FOR I=0,1,DCU2HWNL-1 CYCLE
BYTEINTEGER(K)=DCU2HWN(I)
K=K+1
REPEAT
FINISH ELSE START
COM_SFC TAB SIZE=SFC TAB SIZE
COM_SFCA=K; COM_SFCK=SFCK
IF SFCK>0 THEN START
FOR I=0,1,INTEGER(SFCA) CYCLE
INTEGER(K)=INTEGER(SFCA)
K=K+4; SFCA=SFCA+4
REPEAT
K=(K+31)&(-32)
FINISH
COM_GPCCONFA=K
FOR I=0,1,7 CYCLE
INTEGER(K)=GPCCONF(I)
K=K+4
REPEAT
COM_FPCCONFA=K
FOR I=0,1,7 CYCLE
INTEGER(K)=FPCCONF(I)
K=K+4
REPEAT
COM_SFCCONFA=K
FOR I=0,1,7 CYCLE
INTEGER(K)=SFCCONF(I)
K=K+4
REPEAT
COM_CONTYPEA=K
FOR I=0,1,CONTYPEL-1 CYCLE
BYTEINTEGER(K)=CONTYPE(I)
K=K+1
REPEAT
FINISH
COM_BLKADDR=K
FOR I=0,1,BA SIZE-1 CYCLE ; ! leave room for 16 meg.
INTEGER(K)=BLOCK ADDR(I)
K=K+4
REPEAT
COM_TRANS=K
J=ADDR(ITOETAB(0))
FOR NJ=0,1,2 CYCLE
FOR I=0,1,TRTAB SIZE//4-1 CYCLE
INTEGER(K)=INTEGER(J)
J=J+4
K=K+4
REPEAT
J=ADDR(ETOITAB(0))
IF NJ=1 THEN J=ADDR(UPPER CASE ISO(0))
REPEAT
!
! amend category table now core size is known and copy it in to com seg
!
INTEGER(K)=MAXCAT
COM_CATTAD=K
K=K+4
J=CAT DATA(12*MAXCAT+1); ! core size for thrashing
IF STORE BLOCKS>16 THEN J=J+STORE BLOCKS-16
J=200 IF J>200; ! for enormous machines
CATDATA(12*MAXCAT+1)=J
CATDATA(12*(MAXCAT-1)+1)=J
FOR J=0,1,12*MAXCAT+11 CYCLE
BYTEINTEGER(K)=CAT DATA(J)
K=K+1
REPEAT
!
COM_DLVNADDR=K
FOR I=0,1,DLVN SIZE-1 CYCLE
BYTEINTEGER(K)=254
K=K+1
REPEAT
!
! set up public 19 as a readonly zero epage using top 1k of restart
! stack 4 times over.
!
J=PST(6)&X'3FF80'!X'C00'
FOR I=0,1,EPAGESIZE-1 CYCLE
INTEGER(X'81000000'-16+J+4*I)=X'80000001'!J
REPEAT
PST(19)=X'40F00F8080000001'!(J-16)
*LDTB_X'18000400'
*LDA_X'81000000'
*INCA_J
*MVL_L =DR ,0,0; ! clear it
INTEGER(UNDUMPSEG)=-1; ! initialise
P_P2=0; ! no process picture space
P_DEST=X'300002'
IF SSERIES=YES THEN P_P1=COM_DCUA ELSE P_P1=COM_GPCA
GDC(P)
IF SSERIES=NO START
UNLESS NDISCS=0 START
P_DEST=1
P_P2=COM_FPCCONFA
P_P3=COM_DITADDR
P_P4=NDISCS
DISC GROPE(P)
P_DEST=0
DISC(P)
FINISH
IF INTEGER(COM_SFCCONFA)>1 START ; ! tidy drum table
P_DEST=3
P_P2=COM_SFCA
DRUM GROPE(P)
FINISH
FINISH
P_DEST=X'360000'
PRINTER(P)
!-----------------------------------------------------------------------
! initialise RTC and timing scalars
I=COM_CLKZ
*LSS_0; *LB_I; *ST_(0+B ); ! clear clock Z reg
COM_DATE0=8; COM_TIME0=8
COM_DATE1=M'00/0'
COM_DATE2=M'0/00'
COM_TIME1=M'00.0'
COM_TIME2=M'0.00'
TIMEEVAL(1); ! evaluate time&date
*LSS_X'140001' ; ! allow prog errors
*ST_(1)
IF AUTO SLOAD=0 THEN AUTO SLOAD=HANDKEYS>>16&X'7FFF'; ! lvn/site of Supervisor
IF SSERIES=YES THEN LIGHTS(FOOTPRINT!X'C0DA')
SERVE:
*LSS_X'382E' ; ! allow synch. interrupts
*ST_(3)
!-----------------------------------------------------------------------
! supervisor service loop
CYCLE
IF KERNELQ=0 THEN EXIT ; ! go to do useful work
SERVICE=SERVA(KERNELQ)_L
NEXT: IF SERVA(SERVICE)_P>0 START ; ! if service is unihibited
! pass all params on list
P_DEST=SERVICE<<16
POFF(P)
IF POFFMON#0 THEN C
PKMONREC("Service ".STRINT(SERVICE)." called",P)
IF SERVICE>64 OR SERV TAB(SERVICE)=0 C
THEN NULL SERVICE(P) AND ->NEXT
->SERVROUT(SERVICE)
FINISH
! remove this service from Q
IF SERVICE=KERNELQ THEN KERNELQ=0 C
ELSE SERVA(KERNELQ)_L=SERVA(SERVICE)_L
SERVA(SERVICE)_L=0
REPEAT
!-----------------------------------------------------------------------
*LSS_X'826'; ! allow synch. & peripheral interrupts
*ST_(3)
*LSS_X'382E'; ! mask IC,IT,PERI,M-P&EXTRN
*ST_(3)
UNINHIBIT(47); ! let OPER messages go
*LSS_X'826'; ! peri int back in
*ST_(3)
I=1000000//COM_ITINT; ! wait a second
*LSS_I
*ST_(5)
*LSS_X'806'
*ST_(3); ! allow IT interupts
*IDLE_X'AAAA'
->SERVE
!-----------------------------------------------------------------------
! service routine calls
SERVROUT(4):
NULL SERVICE(P); ->NEXT
SERVROUT(5):
GET EPAGE(P); ->NEXT
SERVROUT(6):
RETURN EPAGE(P); ->NEXT
SERVROUT(10):
->NEXT
SERVROUT(32):
DISC(P)
->NEXT
SERVROUT(33):
PDISC(P); ->NEXT
SERVROUT(34):
RANDREAD(P); ->NEXT
SERVROUT(35):
DLABEL(P); ->NEXT
SERVROUT(36):
SERVROUT(37):
MOVE(P); ->NEXT
SERVROUT(38):
FORMAT(P); ->NEXT
SERVROUT(47):
OPER RELAY(P); ->NEXT
SERVROUT(48):
GDC(P)
->NEXT
SERVROUT(49):
TAPE(P); ->NEXT
SERVROUT(50):
SERVROUT(51):
OPER(P); ->NEXT
SERVROUT(54):
PRINTER(P); ->NEXT
SERVROUT(58):
ACTIVATE SUP; ->NEXT
SERVROUT(59):
LOAD SUP(P); ->NEXT
SERVROUT(62):
COMREP(P); ->NEXT
!-----------------------------------------------------------------------
! interrupt entry points
! system error
IST1I:*JLK_TOS ; ! entry point is link PC i.e. next instr
*LSS_TOS ; *LSS_TOS ; *ST_I
*JLK_<UNDUMP>; ! set up SSN+1 seg for tape dump
*IDLE_X'F0'
->SERVE
!-----------------------------------------------------------------------
! external
IST2I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'F1'
!-----------------------------------------------------------------------
! multiprocessor
IST3I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'F2'
->SERVE
!-----------------------------------------------------------------------
! peripheral
IST4I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
IF SSERIES=YES START
P_DEST=X'300003'
P_P1=I
GDC(P)
FINISH ELSE START
*LB_X'44000000'; *ADB_I;
*LSS_(0+B ); ! IS #44P00000 int flags
*ST_J
P_SRCE=0
FOR K=0,1,15 CYCLE
IF J&(X'80000000'>>K)#0 THEN START
P_P1=I>>16+K; ! port trunk
->CONROUT(CONTYPE(P_P1))
CONROUT(2): ! discs
P_DEST=X'200003'; DISC(P)
->CONTINUE
CONROUT(3): ! GPCs
P_DEST=X'300003'; GDC(P)
->CONTINUE
CONROUT(1): ! SFC
CONROUT(0): ! not valid
OPMESS("INT on port trunk ".HTOS(P_P1,2)."??")
FINISH
CONTINUE:
REPEAT
FINISH
->SERVE
!-----------------------------------------------------------------------
! virtual store
IST5I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'F4'
->SERVE
!-----------------------------------------------------------------------
! interval timer
IST6I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; ! parameter undefined
ITIMER
->SERVE
!-----------------------------------------------------------------------
! program error
IST7I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'F6'
->SERVE
!-----------------------------------------------------------------------
! system call
IST8I:*JLK_TOS
*STD_L
I=0
*JLK_<UNDUMP>
*IDLE_X'F7'
->SERVE
!-----------------------------------------------------------------------
! OUT
IST9I:*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'F8'
->SERVE
!-----------------------------------------------------------------------
! extracode
IST10I:
*JLK_TOS
*LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'F9'
->SERVE
!-----------------------------------------------------------------------
! event pending
IST11I:
*JLK_TOS
*LSS_TOS ; *LSS_TOS ; ! parameter undefined
I=0
*JLK_<UNDUMP>
*IDLE_X'FA'
->SERVE
!-----------------------------------------------------------------------
! instruction counter
IST12I:
*JLK_TOS
*LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'FB'
->SERVE
!-----------------------------------------------------------------------
! primitive
IST13I:
*JLK_TOS
*LSS_TOS ; *ST_I
*JLK_<UNDUMP>
*IDLE_X'FC'
->SERVE
!-----------------------------------------------------------------------
! UNIT
IST14I:
*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
IF SSERIES=YES START
K=UT VA+(I&X'FFFF')*64; ! unit table entry
J=DCU2HWN(INTEGER(K+8)>>24)<<24!(INTEGER(K+8)>>8&255)
! h/w no./00/00/strm
K=I>>16&15; ! int. sub-class
IF K=1 THEN J=J!X'400' ELSE C
IF K=4 THEN J=J!X'00204000' C
ELSE IF K#0 THEN ->SERVE
P_DEST=X'300003'
P_P1=J
P_P2=I
GDC(P)
FINISH ELSE START
*JLK_<UNDUMP>
*IDLE_X'FD'
FINISH
->SERVE
!-----------------------------------------------------------------------
!%ROUTINE UNDUMP
!%INTEGER J,K
UNDUMP:
IF SSERIES=YES START
!LIGHTS(FOOTPRINT!X'D1ED!)
J=FOOTPRINT!X'D1ED'; ! avoid disturbing stack frame
*LB_X'6016'; *LSS_J; *ST_(0+B )
FINISH
INTEGER(UNDUMPSEG)=I
INTEGER(UNDUMPSEG+4)=X'80B80000'
J=ISAS(ISAS PTR+LSTL OFFSET)
*LB_J
*LSS_(0+B )
*ST_K
INTEGER(UNDUMPSEG+8)=K
J=ISAS(ISAS PTR+LSTB OFFSET)
*LB_J
*LSS_(0+B )
*ST_K
INTEGER(UNDUMPSEG+12)=K
*J_TOS
!%END
!*
!********************************************************************
!-----------------------------------------------------------------------
ROUTINE GET EPAGE(RECORD (PARMF)NAME P)
!***********************************************************************
!* Gets an extended (4k) page. Frigged version for CHOPSUPE *
!***********************************************************************
CONSTINTEGER GESNO=X'50000'
P_P2=999; ! frigged index no
P_P4=ADDR(SPEC PAGE(0)); ! virtual address
INHIBIT(GESNO>>16); ! CHOPSUPE has only 1 page
P_DEST=P_SRCE
P_SRCE=GESNO
IF P_DEST#0 THEN PON(P)
END
ROUTINE RETURN EPAGE(RECORD (PARMF)NAME P)
!***********************************************************************
!* Returns a 4k page. Frigged for CHOPSUPE which only has 1 page *
!***********************************************************************
CONSTINTEGER GESNO=X'50000'
IF P_P2#999 THEN OPMESS("Bum page returned")
UNINHIBIT(GESNO>>16)
END
ROUTINE GET REAL CORE(INTEGERNAME BYTES)
!***********************************************************************
!* Allocates real core from top of store updating epage count *
!* rounding to next 256 byte boundary if not a multiple of 256 *
!* and resetting 'BYTES' to bound for segment table *
!***********************************************************************
INTEGER I
TOP BLOCK=TOP BLOCK-1 C
WHILE LAST REAL BYTE<BLOCK ADDR(TOP BLOCK); !align on relevant block
BYTES=(BYTES+255)&X'FFFFFF00'
REGET:
I=LAST REAL BYTE
LAST REAL BYTE=I-BYTES
IF LAST REAL BYTE>=BLOCK ADDR(TOP BLOCK) OR C
BLOCK ADDR(TOP BLOCK)-X'20000'=BLOCK ADDR(TOP BLOCK-1) START
STORE EPAGES=STORE EPAGES-(I//(EPAGESIZE*1024)- C
LAST REAL BYTE//(EPAGESIZE*1024))
BYTES=BYTES-128
RETURN
FINISH
STORE EPAGES=STORE EPAGES-(I//(EPAGESIZE*1024)- C
BLOCK ADDR(TOP BLOCK)//(EPAGESIZE*1024)); !discard useless chunk
TOP BLOCK=TOP BLOCK-1
LAST REAL BYTE=BLOCK ADDR(TOP BLOCK)+X'20000'
->REGET
END
INTEGERFN FIND GAP(INTEGER GAP)
!***********************************************************************
!* Used by routine 'LOAD SUP' to see if there is a contiguous *
!* area at the top of store for the supervisor GLA or code *
!* (Only called if OCP is not a P3) *
!***********************************************************************
INTEGER STORE BLOCK
STORE BLOCK=TOP BLOCK
LOOK:
IF LAST REAL BYTE-BLOCK ADDR(STORE BLOCK)>=GAP C
THEN RESULT =0; !gap found
IF BLOCK ADDR(STORE BLOCK-1)>>18&X'3F'=0 C
THEN RESULT =1; !next block is SMAC/SCU 0 block 0/1
IF BLOCK ADDR(STORE BLOCK)-X'20000'#BLOCK ADDR(STORE BLOCK-1) C
THEN RESULT =1; !next block discontiguous
!or in next SMAC/SCU
STORE BLOCK=STORE BLOCK-1
->LOOK
END
CONSTINTEGER CODESEG=8,GLASEG=9
CONSTINTEGER CODEAD=X'80000000'!CODESEG<<18,GLAAD=X'80000000'!GLASEG<<18
ROUTINE LOAD SUP(RECORD (PARMF)NAME P)
!***********************************************************************
!* Reads down a supervisor from the disc to top of store *
!* P_P1=lvn
!* P_P2=start page on disc *
!***********************************************************************
CONSTINTEGER PDISCSNO=X'210000', LSNO=X'3B0000'
SWITCH INACT(0:3)
STRING (23) LOADMSG
INTEGER SIZE
INTEGER ACT
INTEGER I
OWNINTEGER DEV, PAGE, COUNT, CODESIZE, GLASIZE, DONT ENTER
OWNINTEGER J,BASE PAGE,PT REALAD
OWNLONGINTEGER PAGIT
ACT=P_DEST&255
->INACT(ACT)
INACT(0): ! request
DEV=P_P1
IF DEV<0 THEN OPMESS("Give disc lvn") AND RETURN
PAGIT=0
COM_SUPLVN=DEV
COM_DCODEDA=COM_DIRSITE&X'FFFF'!DEV<<24
BASE PAGE=P_P2
PAGE=P_P2
DONT ENTER=P_P3
P_P2=DEV<<24!PAGE
P_P3=ADDR(SPEC PAGE(0))
P_SRCE=LSNO!1
PONIT:P_DEST=PDISCSNO+1
PON(P)
RETURN
INACT(1): ! header page read
IF P_P2#0 THEN ->TRANS FAIL
CODESIZE=(SPEC PAGE(6)-SPEC PAGE(1)+4095)&X'7FFFF000'
GLA SIZE=(SPEC PAGE(0)-SPEC PAGE(6)+4095)&X'7FFFF000'
UNLESS 0<CODESIZE<256*1024 C
THEN OPMESS("Bad header") AND RETURN
!
! Deal with GLA first then code. If not continuous space or we
! have a P3 with funny address translation h-w have a paged segment
! otherwise unpaged
!
IF (SSERIES=NO AND OCPTYPE=3) OR FIND GAP(GLA SIZE)#0 START
PAGIT=4
SIZE=GLASIZE//1024*4; !page table size
FINISH ELSE SIZE=GLA SIZE
GET REAL CORE(SIZE)
PT REALAD=LAST REAL BYTE
PST(GLASEG)=WSUPRDIR!X'080000001'!PAGIT<<60+LAST REAL BYTE+ C
LENGTHENI(GLASIZE-128)<<32
IF NOCPS>1 THEN PST(GLASEG)=PST(GLASEG)!NONSLAVED
COUNT=0
PAGE=PAGE+(CODESIZE+(1024*EPAGESIZE-1))//(1024*EPAGESIZE) C
+(GLASIZE+(1024*EPAGESIZE-1))//(1024*EPAGESIZE)-1
! round to 1K boundary if paged
IF PAGIT#0 THEN C
LAST REAL BYTE=LAST REAL BYTE&X'FFFFFC00' AND C
J=(X'81000000'+PT REALAD)!(GLASIZE+(1024*EPAGESIZE-1)) C
//(1024*EPAGESIZE)*EPAGESIZE*4
! GLA to be contiguous
GPAG:
IF PAGIT#0 START ; ! fill in page table
I=EPAGESIZE*1024
GET REAL CORE(I)
J=J-EPAGESIZE*4
FOR I=0,4,EPAGESIZE*4-4 CYCLE
INTEGER(J+I)=X'80000001'!LAST REAL BYTE+I*256
REPEAT
FINISH
P_SRCE=LSNO!3
P_P1=COUNT
P_P2=DEV<<24!(PAGE-COUNT)
P_P3=GLAAD+(GLASIZE-EPAGESIZE*1024)-1024*EPAGESIZE*COUNT
P_P6=J
->PONIT
INACT(3): ! GLA page read
IF P_P2#0 THEN ->TRANS FAIL
COUNT=COUNT+1
IF COUNT*(EPAGESIZE*1024)<GLASIZE THEN ->GPAG
!
! Have read all the GLA pages. Now start on the code
!
IF (SSERIES=NO AND OCPTYPE=3) OR FIND GAP(CODESIZE)#0 START
PAGIT=4
SIZE=CODESIZE//1024*4; !page table size
FINISH ELSE SIZE=CODESIZE AND PAGIT=0
! P3 or insufficient contiguous core
!
! Set up code segment table entry (public 8)
!
GET REAL CORE(SIZE)
PT REALAD=LAST REAL BYTE
PST(CODESEG)=WSUPRDIR!X'080000001'!PAGIT<<60 C
+LAST REAL BYTE+LENGTHENI(CODESIZE-128)<<32
PAGE=BASE PAGE
COUNT=0
IF PAGIT#0 THEN LAST REAL BYTE=LAST REAL BYTE&X'FFFFFC00'
CPAG:
IF PAGIT#0 START ; ! code is paged
I=EPAGESIZE*1024
GET REAL CORE(I); !for code page
J=(X'81000000'+PT REALAD)+COUNT*EPAGESIZE*4
FOR I=0,4,EPAGESIZE*4-4 CYCLE
INTEGER(J+I)=X'80000001'!LAST REAL BYTE+I*256
REPEAT
FINISH
P_SRCE=LSNO!2
P_P2=DEV<<24!(PAGE+COUNT)
P_P3=CODEAD+EPAGESIZE*1024*COUNT
->PONIT
INACT(2): ! code page read
IF P_P2#0 THEN ->TRANS FAIL
COUNT=COUNT+1
IF COUNT*(EPAGESIZE*1024)<CODESIZE THEN ->CPAG
PST(CODESEG)=PST(CODESEG)!!LENGTHENI(X'11')<<56;! flip ex/wr permit bits
!
! Having changed permission bits must clear address trans slave
! easiest done by reloading PSTB
!
I=COM_PSTB; *LB_I
*LSS_(0+B ); *ST_(0+B )
COM_SLIPL=COM_SLIPL!DEV<<24!BASEPAGE>>4<<16; ! remember SLOAD lvn/site
LOADMSG="Supervisor loaded"
UNLESS SSERIES=YES OR SYSTEM STORE BLOCKS=STORE BLOCKS THEN C
LOADMSG=LOADMSG."-SMAC0"
OPMESS(LOADMSG)
IF DONT ENTER=0 THEN P_DEST=X'3A0000' AND PON(P)
!activate sup
RETURN
TRANSFAIL:
OPMESS("Load failed")
END
ROUTINE ACTIVATE SUP
!***********************************************************************
!* Create the store array in segment 23 then activate the *
!* supervisor in code segment 8. *
!***********************************************************************
CONSTINTEGER MAX EPAGES=EPAGES PER BLOCK*8*16; ! 16 megabytes
CONSTINTEGER STOREFSIZE=12; ! store array recsize
CONSTINTEGER MAX PT SIZE=(MAX EPAGES*STOREFSIZE+1023)//1024*4; ! max store array page table size
CONSTINTEGER SASEG=23; ! PST 23
RECORDFORMAT STOREF(BYTEINTEGER FLAGS,USERS, C
HALFINTEGER LINK,BLINK,FLINK,INTEGER REALAD)
RECORD (STOREF)ARRAYFORMAT STOREAF(0:MAX EPAGES)
CONSTRECORD (STOREF)ARRAYNAME STORE=X'80000000'!SASEG<<18+MAX PT SIZE
RECORDFORMAT REGF(INTEGER LNB,PSR,PC,SSR,SF,IT,IC,LTB,XNB,B,C
DR0,DR1,LONGLONGREAL ACC)
CONSTINTEGER SSN=4
CONSTRECORD (REGF)NAME REGS=X'80000000'!(SSN+1)<<18
INTEGER I,J,K,REAL AD,EPDISP,FSTASL,BSTASL,SSNB,TOTAL EPAGES
*STSF_I
I=(I<<1)>>19+1; ! current SSN+1
REAL AD=PST(I)&X'FFFFF80'; ! and its real address
REAL AD=REAL AD+128; ! in case this rt craps!!
PST(SSN+1)=WSUPRSUP!X'00080000001'+REAL AD
REAL AD=REAL AD+256; ! room for 2 SSN+1s for duals
SSNB=(X'3FC00'+REAL AD)&(-EPBYTES)-REAL AD; ! TOS on epage boundary
PST(SSN)=WSUPRPRIV!X'080000001'!LENGTHENI(SSNB-128)<<32+REAL AD
IF NOCPS>1 THEN PST(SSN)=PST(SSN)!NONSLAVED
!
! Set up the registers in (SSN+1)
!
REGS=0
REGS_LNB=X'80000000'+SSN<<18+4; !align stack frame
REGS_SF=REGS_LNB+28; ! five words +2 1word params
REGS_PSR=X'0014FF01'; ! PRIV=1,ACS=1,ACR=1
REGS_SSR=X'0180FFFF'; ! all masked, VA mode
EPDISP=INTEGER(CODEAD+28)
REGS_DR0=X'B0000001'
REGS_DR1=GLAAD+EPDISP
REGS_PC=INTEGER(REGS_DR1+4)
UNLESS REGS_PC&X'FFFC0000'=CODEAD THEN C
OPMESS("SUP has a bad EP") AND RETURN
! Set up the 4word activate parameter in two long integers
ACT1=X'01FC000000008080'; ! 127<<(18+32)+LST REAL ADDR
ACT2=X'80000000'!SSN<<18
TOTAL EPAGES=STORE BLOCKS*EPAGES PER BLOCK
I=((TOTAL EPAGES- C
((TOTAL EPAGES*STOREFSIZE+MAX PT SIZE+EPBYTES-1)//EPBYTES))* C
STOREFSIZE+MAX PT SIZE+1023)&(-1024); ! pt + store array
GET REAL CORE(I)
LAST REAL BYTE=LAST REAL BYTE&(-EPBYTES); ! to page boundary
PST(SASEG)=WSUPRPRIV!X'4000000080000001'+LAST REAL BYTE+ C
LENGTHENI(I)<<32
PST(SASEG)=PST(SASEG)!NONSLAVED IF NOCPS>1
J=X'81000000'+LAST REAL BYTE
FOR I=0,4,(I+128+1023)//1024*4-4 CYCLE ; ! fill in page table
INTEGER(J+I)=X'80000001'!LAST REAL BYTE+I*256
REPEAT
COM_SEPGS=TOTAL EPAGES
FOR I=0,1,TOTAL EPAGES-1 CYCLE ; ! set real addresses into store array
STORE(I)=0
STORE(I)_USERS=255; ! system store
J=I//EPAGES PER BLOCK
STORE(I)_REALAD=BLOCK ADDR(J)! C
(EPAGESIZE*(I-J*EPAGES PER BLOCK))<<10
REPEAT
FSTASL=(SSNB+REAL AD)//EPBYTES; ! first free epage
J=FSTASL
BSTASL=TOTAL EPAGES-1
K=BLOCK ADDR(SYSTEM STORE BLOCKS-1)+X'20000'; ! end of supervisor store
FOR I=FSTASL+1,1,BSTASL CYCLE ; ! forward links
IF LAST REAL BYTE<=STORE(I)_REALAD<K THEN CONTINUE ; ! supvsr store
IF SSERIES=NO AND OCPTYPE>=4 START ; ! preserve SMAC1 photo area if P4
IF STORE(I)_REALAD=X'400000' OR C
(STORE(I)_REALAD=X'401000' AND NOCPS>1) C
THEN CONTINUE
FINISH
STORE(J)_FLINK=I
J=I
REPEAT
UNLESS J=I THEN BSTASL=J; ! supvsr at end of store
STORE(BSTASL)_FLINK=0
STORE(FSTASL)_BLINK=0
I=FSTASL; ! set up blinks
K=1; ! free epages
UNTIL I=BSTASL CYCLE
J=I
STORE(I)_USERS=0; ! not system store
I=STORE(I)_FLINK
STORE(I)_BLINK=J
K=K+1
REPEAT
STORE(I)_USERS=0
STORE(0)_LINK=K; ! free epages
STORE(0)_FLINK=FSTASL; ! for supervisor
STORE(0)_BLINK=BSTASL
COM_STOREAAD=ADDR(STORE(0))
END
ROUTINE CONFIG
IF SSERIES=YES START
RECORDFORMAT TCBF(INTEGER CMD,STE,LEN,DATAD,NTCB,RESP, C
INTEGERARRAY PR,PO(0:3))
RECORDFORMAT UTEF(INTEGER PD,PP,BYTEINTEGER FMN,SP,STRM,FLAGS, C
INTEGER TCBA,A1,A2,A3,A4,IDEST,I1,I2,I3,S1,S2,L1,L2)
RECORD (TCBF)NAME TCB
RECORD (UTEF)NAME UT
LONGINTEGER TCB DESC,UT DESC
INTEGER I,J,K,R
INTEGER DCU2S,INIT WAITS
CONSTINTEGER MAX INIT WAITS=2
LONGINTEGER BLOCKS
LONGINTEGER L
STRING (23)MSG
CONFIG LENGTH=INTEGER(16)&X'FFFF'; !table length
INTEGER(16)=(CONFIG LENGTH+127)&(-128)-X'80'; !PST bound
L=LONGINTEGER(16); !real address & bound
PST(CONFIG SEG)=X'01F0000080000001'!L
CONFIG TABLE=X'80000000'+CONFIG SEG<<18
DCU2S=0
SCU MAP=0
I=8
I=I+8 WHILE INTEGER(CONFIG TABLE+I)>>24#X'E2'; ! find store entry
SCU MAP=SCU MAP!1<<(I//8-1); !one SCU protem
I=I+CONFIG TABLE+4
BLOCKS=LENGTHENI(INTEGER(I))<<32; ! 1st 4 meg of store map
BLOCKS=BLOCKS!LENGTHENI(INTEGER(I+8)) IF INTEGER(I+4)>>24=X'E2'; ! 2nd 4 meg
STORE BLOCKS=0
FOR I=0,1,63 CYCLE ; ! 8 meg/SCU
EXIT IF BLOCKS>>(63-I)&1=0
BLOCK ADDR(I)=X'20000'*I
STORE BLOCKS=STORE BLOCKS+1
REPEAT
I=I+1 IF BLOCKS=-1
OPMESS("SCU 0 has ".STRINT((I)*128)."K bytes")
FOR I=0,1,STORE BLOCKS-1 CYCLE
PST(64+I>>1)=WDIRRDIR!NONSLAVED!X'3FF8080000001'+I<<17&X'0FFC0000'
REPEAT
STORE EPAGES=STORE BLOCKS*EPAGES PER BLOCK
SYSTEM STORE BLOCKS=STORE BLOCKS; ! supervisor to top of store
LAST REAL BYTE=BLOCK ADDR(SYSTEM STORE BLOCKS-1)+128*1024
TOP BLOCK=SYSTEM STORE BLOCKS-1
NEXT COM SEG=CONFIG SEG+1
I=CONFIG LENGTH
GET REAL CORE(I); ! save config table
! (always at top of store?)
I=8; ! set up OCP/DCU configs
WHILE I<CONFIG LENGTH CYCLE
J=INTEGER(CONFIG TABLE+I)
IF J>>24=X'C3' START
J=DCU CONF(0)+1
DCU CONF(0)=J
K=CONFIG TABLE+INTEGER(CONFIG TABLE+I+4)&X'FFFF'; !addr(stream tables)
K=INTEGER(K+4)>>8&X'FF'; !no. of streams
K=K<<24!(I//8-1); !& SCU port
K=K!(INTEGER(CONFIG TABLE+I+4)>>16&X'FF')<<8; !& DCU unit no.
DCU CONF(J)=K
OPMESS("DCU ".HTOS(K>>8&255,2)." on port ".STRINT(K&255))
FINISH ELSE IF J>>24=X'C2' START ; ! DCU2
DCU2S=DCU2S+1
J=DCU CONF(0)+1
DCU CONF(0)=J
K=(I//8-1)
! h/w no. inserted later
DCU CONF(J)=K
J=X'20000010'!K<<22
*LB_J; *LSS_X'00180000'; *ST_(0+B ); ! initialise DCU
I=I+24; ! takes 4 entries
FINISH ELSE IF J>>24=X'D7' START
UNLESS I//8-1=OCP0 SCU PORT START ; ! not IPL OCP
NOCPS=2; ! 2 only for now (dual 2988 has 4)
OCP1 SCU PORT=I//8-1
REMOTE OCP PORT=IPL OCP PORT!!1
PST(REMOTE OCP PORT)=PST(IPL OCP PORT)-X'200'
FINISH
FINISH
I=I+8
REPEAT
!* clear store from store block 2 to base of config table
J=2
WHILE J<STORE BLOCKS-1 CYCLE
I=X'80000000'+(64<<18)+BLOCK ADDR(J)
! K=0
! %WHILE K<128*1024 %CYCLE
! LONGLONGREAL(I+K)=0
! K=K+16
! %REPEAT
*LDTB_X'38002000'; *LDA_I; *LB_0; *LSQ_0
AGN: *ST_(DR +B ); *CPIB_X'1FFF'
*JCC_4,<AGN>
J=J+1
REPEAT
I=X'80000000'+(64<<18)+BLOCKADDR(J)
R=REALISE(CONFIG TABLE)!X'81000000'
K=0
WHILE I+K<R CYCLE
LONGLONGREAL(I+K)=0
K=K+16
IF K>=X'20000' START
OPMESS("CFGT outwith store!!!")
EXIT
FINISH
REPEAT
IF DCU2S>0 START
I=16*4*256*DCU2S; ! UT size
GET REAL CORE(I)
PST(UT SEG)=X'080000001'!WDIRRDIR!NONSLAVED+ C
LENGTHENI(I)<<32+LAST REAL BYTE
I=X'28000000'!(16*256*DCU2S); ! bound
*LB_X'6005'; *LSS_UT VA; *ST_(0+B ); ! UTBA
*LB_X'6004'; *LSS_I; *ST_(0+B ); ! UTBL
NEXT COM SEG=UT SEG+1
! set up interrupt buffer
I=4096*NOCPS; ! at 3 words/int & 2 ints/stream
! enough room for 170 streams
GET REAL CORE(I)
I=I+128
I=I>>(NOCPS-1)
MIBA=LAST REAL BYTE!I>>8
J=MIBA
IF NOCPS>1 THEN J=J+IPL OCP PORT<<12
*LB_X'601A'; *LSS_J; *ST_(0+B )
!
!* Wait for DCU2s to initialise
!
TCB==RECORD(GROPESEG)
TCB=0
TCB_CMD=X'2C41400E'; ! read stream properties
TCB_STE=REALISE(GROPESEG)!1
TCB_LEN=8
TCB_DATAD=GROPESEG+64
UT==RECORD(UT VA)
UT=0
UT_PD=X'E7000000'
UT_STRM=1
UT_FLAGS=X'81'
UT_IDEST=X'000E4000'
TCB DESC=GROPESEG&X'0FFFFFFFF'!LENGTHENI(X'2800000E')<<32
UT DESC=UT VA&X'0FFFFFFFF'!LENGTHENI(X'B0000001')<<32
SAVE IST=IST
*JLK_<DCUTO>; *LSS_TOS ; *ST_I
IST_PC=I
IST_SSR=X'0180FFFE'
*STLN_I
IST_LNB=I
*STSF_I
IST_SF=I
ONOFF(INH PHOTO OFFSET,0); ! no photos whilst initiating
ONOFF(INH REPS OFFSET,-1); ! retry reporting to catch all fails
FOR I=1,1,DCU CONF(0) CYCLE
J=DCU CONF(I)
IF J>>8=0 START ; ! DCU2
UT_FMN=J
TCB_RESP=0
INIT WAITS=0
RETRY:
*PRCL_4
*LSS_2
*SLSD_TCB DESC
*ST_TOS
*LD_UT DESC
*RALN_8
*CALL_(DR )
*ST_K
->INIT FAILS UNLESS K=0
K=0
K=K+1 UNTIL TCB_RESP#0 OR K>100000
->INIT FAILS IF TCB_RESP=0
K=BYTEINTEGER(TCB_DATAD+5); ! h/w no.
DCU2HWN(J)=K
DCU CONF(I)=K<<8!J
MSG="DCU ".HTOS(K,2)." is fmn "
IF J<10 THEN MSG=MSG." "
MSG=MSG.STRINT(J)
UNLESS INIT WAITS=0 THEN MSG=MSG."*"
OPMESS(MSG)
CONTINUE
DCUTO: ! syserr if DCU not initialised
*JLK_TOS ; *LSS_TOS
*LSS_TOS ; *ST_R
INIT WAITS=INIT WAITS+1
->INIT FAILS IF INIT WAITS>MAX INIT WAITS
WAIT(10000//MAX INIT WAITS); ! 10 seconds total wait time
->RETRY
INIT FAILS: ! intialise fails - abandon DCU2
*LSQ_J; ! fmn/K/seip/DCU2S
*LSS_X'DCFA'
DCU CONF(I)=-1; ! abandon DCU
OPMESS("DCU2 fmn ".STRINT(J)." init fails".TOSTRING(17))
FINISH
REPEAT
IST=SAVE IST
ONOFF(INH REPS OFFSET,0); ! retry reporting off
ONOFF(INH PHOTO OFFSET,-1); ! photos back on
RESCAN:
J=DCU CONF(0)
FOR I=1,1,J CYCLE
IF DCU CONF(I)=-1 START
DCU CONF(0)=DCU CONF(0)-1
FOR K=I,1,J CYCLE
DCU CONF(K)=DCU CONF(K+1)
REPEAT
->RESCAN
FINISH
REPEAT
FINISH
IF NOCPS>1 THEN OPMESS("Dual OCP found")
FINISH ELSE START
ROUTINESPEC SAC GROPE(INTEGER PORT)
INTEGER B,J, K, REALA, BLOCK, CONFBITS, WORK, BLKSIZE, BLKSPERSEG
INTEGER SMAC, SF, LNB, INT PARAM, I, OLDSSN, PORTS, SMACMAX
RECORD (SMACINF)NAME SMACINF
STRING (7) S,T
LONGINTEGER L
CONSTINTEGER NO=0
CONSTINTEGER MINSTORE=6; ! (768k) minimum store for SMAC0 supvsr etc.
CONSTINTEGER DAC=X'02000000'; ! SMAC is a DAC
SAVE IST=IST
SMACINF==RECORD(ADDR(ISAS(ISAS PTR+SMACINF OFFSET)))
SMACMAX=SMACINF_SMACMAX
FOR J=0,1,15 CYCLE
ONLINE(J)=-1
REPEAT
B=0
INT PARAM=0
FOR J=0,1,15 CYCLE ; !set block mask
B=B!SMACINF_BLOCK0<<(J*SMACINF_BLKSHIFT)
REPEAT
PORTS=0
SMAC MAP=0
FOR SMAC=0,1,SMACMAX CYCLE
*STLN_LNB
*STSF_SF
IST_LNB=LNB
IST_PSR=X'14FF01'
*JLK_<TOUTAD>
*LSS_TOS
*ST_I
IST_PC=I
IST_SSR=X'01800FFE'
IST_SF=SF
J=SMACINF_CONFREG!(SMAC<<SMACINF_SMACPOS)
*LB_J
*L_(0+B ); ! this instruction causes timeout if SMAC not present
*ST_J
PORTS=PORTS!(J>>2&15)
SMAC MAP=SMAC MAP!1<<SMAC; !for com seg
ONLINE(SMAC)=J
!
! P4 processor can not turn off hamming reporting in OCP. Must be done in each SMAC
! separately. Therefore turn it off here. It will be turned on again
! by the periodic kick of 'TURN OFF ER' in supervisor
!
IF SMAC#0 AND OCPTYPE=4 START ; ! already done for SMAC0
J=SMACINF_SESR!(SMAC<<SMACINF_SMACPOS)
K=SMACINF_HOFFBIT
*LB_J
*LSS_(0+B )
*OR_K
*ST_(0+B )
FINISH
!
! Highest SMAC no. on thE P3 & P4 is 7 - however if the 'INTERLEAVE' bit is set
! then store accesses are interleaved between the odd & even highways.
! The SMAC responds to addresses for one highway in SMAC n
! & for the other in SMAC n+8. corresponding blocks must be present
! in both SMAC n & SMAC n+8.
! Highest SMAC no. on a P2 is 1.
! Thus :-
!
IF OCPTYPE>=4 AND SMAC>7 START
->REPT IF ONLINE(SMAC&7)=NO; ! no corresponding SMAC
J=(ONLINE(SMAC)&B)!!(ONLINE(SMAC&7)&B)
IF J#0 START ; ! non-corresponding blocks
OPMESS("SMACS ".STRINT(SMAC&7)."/".STRINT(SMAC). C
" BLK clash".TOSTRING(17))
ONLINE(SMAC)=ONLINE(SMAC)&(¬J); ! reduce to common blocks only
ONLINE(SMAC&7)=ONLINE(SMAC&7)&(¬J)
FINISH
IF SMAC=8 THEN ONLINE(SMAC)=ONLINE(SMAC)!SMACINF_BLOCK0
! block 0 SMAC 8 always present
FINISH
->REPT
TOUTAD:
*JLK_TOS ; ! gets PC of next instruction
! timed out
*LSS_TOS ; ! discard old SSN
*ST_OLDSSN
*LSS_TOS
*ST_INT PARAM
IF 0<=SMAC<=15 THEN ONLINE(SMAC)=NO
REPT:
IF SMAC=0 THEN ONLINE(SMAC)=ONLINE(SMAC)!SMACINF_BLOCK0; !block0 SMAC 0
REPEAT
IST=SAVE IST
!
! On P3 SMACs (blksize=128K) must allow for 16K ram variant with
! 256K blksize. This is distinguished by bit7(X01000000) set in
! the configuration register. NB both sorts of SMAC can be present
! on one machine
!
FOR J=0,1,SMACMAX CYCLE
CONFBITS=ONLINE(J)
BLKSIZE=SMACINF_BLKSIZE
BLKSPERSEG=SMACINF_BLKSPERSEG
IF BLKSIZE=X'20000' AND CONFBITS&X'01000000'#0 THEN C
BLKSIZE=X'40000' AND BLKSPERSEG=1
I=0
B=0
FOR K=0,1,15 CYCLE
BLOCK=SMACINF_BLOCK0<<(K*SMACINF_BLKSHIFT)
IF CONFBITS&BLOCK#0 THEN START
REALA=J<<22!I<<17
FOR WORK=0,1,BLKSIZE//X'20000'-1 CYCLE
BLOCK ADDR(STORE BLOCKS+WORK)=REALA+WORK*X'20000'
REPEAT
!
! Set up virtual=real mapping in segs 64 onwards
! but have a care! If bottom block of a 128K pair is missing
! the segment table entry will lie and pretend both are present.
! This ruse is to facilitate real->virtual conversion viz:-
!
! (REAL ADDRESS)+X'81000000' = VIRTUAL ADDRESS
!
WORK=1+K-(K//BLKSPERSEG)*BLKSPERSEG
L=BLKSIZE*WORK-X'80'; ! PST bound field
L=L<<32
PST(64+REALA>>18)=WDIRRDIR!X'080000001'+L+REALA& C
X'FFC0000'
WORK=BLKSIZE//X'20000'
I=I+WORK
B=B+WORK
STORE BLOCKS=STORE BLOCKS+WORK
STORE EPAGES=STORE EPAGES+EPAGES PER BLOCK*WORK
FINISH ELSE I=I+BLKSIZE//X'20000'
REPEAT
IF CONFBITS&DAC=0 THEN S="SMAC " ELSE S=" DAC "
IF B#0 THEN START
OPMESS(S.STRINT(J)." has ".STRINT(B*128)."K bytes")
!
! Ensure that same ports closed in all SMACs
!
I = PORTS<<2
K = SMACINF_CONFREG!(J<<SMACINF_SMACPOS)
*LB_K
*LSS_(0+B )
*OR_I
*ST_(0+B )
FINISH
ONLINE(J)=B; ! SMAC storesize
REPEAT
S=""; T="PORT "
FOR J=0,1,3 CYCLE
IF 8>>J&PORTS#0 THEN START
IF S#"" THEN S=S."," AND T="PORTS "
S=S.STRINT(J)
FINISH
REPEAT
IF S#"" THEN OPMESS(T.S." closed")
!
! Multiprocessor standard is SAC on ports0&1,CPUs on 2&3
! with all unused ports closed off
!
!
! Work out CPU ports
!
J=(PORTS!!(-1))&3
IF J=3 THEN START
OPMESS("Dual OCP found")
NOCPS=2
REMOTE OCP PORT=IPL OCP PORT!!1
FINISH
PST(IPL OCP PORT!!1)=PST(IPL OCP PORT)-X'200'
! separate ISTS for duals
! (single could become dual)
!
! Work out SAC ports
!
J=(PORTS!!(-1))&X'C'
IF J=X'C' START ; ! dual SAC confign
OPMESS("Dual SACS found")
!
! Open paths for ints from SACs to ipl OCPs where necessary
! this is hardware dependent coding !
!
IF OCP TYPE=4 START
*LSS_(X'4012')
*OR_X'C030'; ! peri&se ints from both SACs
*ST_(X'4012')
FINISH ELSE START
*LSS_(X'600A')
*AND_X'FFFFFF33';! ! open peri se int paths
*ST_(X'600A')
FINISH
NSACS=2
OTHER SAC PORT=IPL SAC PORT!!1
FINISH ELSE START ; ! single SAC confign
IF OCPTYPE=4 START
I=X'8020'>>IPL SAC PORT
*LSS_(X'4012')
*OR_I; ! open perei & se ints from SAC
*ST_(X'4012')
FINISH
!
! P2&P3 single SAC mcs: paths opened by hardware on IPL
!
FINISH
!
! P4 series processors need clock port no in an internal register
! before the RRTC intruction(needed for groping) will work
!
IF OCPTYPE=4 AND OCP VAR=0 THEN CLOCK PORT=IPL SAC PORT C
ELSE CLOCK PORT=IPL OCP PORT
IF OCPTYPE=4 START ; !P4 series - set up port for RTC
*LSS_(X'4013')
*SLSS_CLOCK PORT
*USH_20
*OR_TOS
*ST_(X'4013')
FINISH
!
! Before groping the SAC(s), ensure the C toggle is clear in SMAC 0 if
! it is a P2 or P3 SMAC. It can be left set by a failed remote IPL on a
! dual. If not cleared here, it will cause a spurious syserr on first
! attempt to grope SAC. This is because the activate is sent OK, but
! words 8 and 9 in SMAC 0 still contain the values for remote IPL. The
! easiest way to clear the toggle is to access a SAC (e.g. try to master
! clear a trunk) and ignore any resulting syserr. Subsequent gropes
! will then be clean.
!
IF SSERIES=NO AND OCPTYPE <= 3 THEN START
SAVE IST = IST
*STLN _LNB
*STSF _SF
IST_LNB = LNB
IST_PSR = X'14FF01'
*JLK _<SEAD>
*LSS _TOS
*ST _I
IST_PC = I
IST_SSR = X'01800FFE'
IST_SF = SF
I = X'40000800'!(IPL SAC PORT<<20)
*LB _I
*LSS _2; ! for master clear
*ST _(0+B )
-> CTOGGLE OK
SEAD:
*JLK _TOS ; ! return link
*LSD _TOS ; ! clear stack
CTOGGLE OK:
IST = SAVE IST
FINISH
!
! now can grope the SAC(s)
!
IF NSACS=2 START ; ! grope SACS - lowest first
SAC GROPE(0)
SAC GROPE(1)
FINISH ELSE SAC GROPE(IPL SAC PORT)
I=REAL0ADDR; !clear photo area protem
J=X'100'
LONGINTEGER(I+J)=0 AND J=J+8 WHILE J<X'1000'
INTEGER(REAL0ADDR+X'104')=X'000F0000';! mp stop char for duals
!
! clear store with STQ to avoid IPL troubles on 2970 up to x370000
! is cleared by the boot. Rest is full of parities
!
FOR J=X'81037000',16,X'81040000'-16 CYCLE
LONGLONGREAL(J)=0
REPEAT
J=2
WHILE J<STORE BLOCKS CYCLE
I=X'80000000'+(64<<18)+BLOCK ADDR(J)
K=0
! %WHILE K<128*1024 %CYCLE
! LONGLONGREAL(I+K)=0
! K=K+16
! %REPEAT
*LDTB_X'38002000'; *LDA_I; *LB_0; *LSQ_0
AGN: *ST_(DR +B ); *CPIB_X'1FFF'
*JCC_4,<AGN>
J=J+1
REPEAT
IF ONLINE(0)>=MINSTORE START ; ! resident supvsr into SMAC0
SMAC MAP=SMAC MAP!(SMAC MAP&X'101')<<16;! mark SMAC0 (& 8) in permanent use
SYSTEM STORE BLOCKS=ONLINE(0)
FINISH ELSE START
SMAC MAP=SMAC MAP!SMAC MAP<<16; ! all SMACS in permanent use
SYSTEM STORE BLOCKS=STORE BLOCKS
FINISH
LAST REAL BYTE=BLOCK ADDR(SYSTEM STORE BLOCKS-1)+128*1024
TOP BLOCK=SYSTEM STORE BLOCKS-1
NEXT COM SEG=49
ROUTINE SAC GROPE(INTEGER PORT)
!***********************************************************************
!* Tries all trunks in the port. Put them into direct control mode *
!* and reads out the controller properties. Controller gropes can *
!* then find the devices on the controller *
!***********************************************************************
INTEGERFNSPEC WAITRFB
INTEGER LNB,PC,SF
CONSTINTEGER GPC1=1, FPC2=5, SFC1=6
CONSTSTRING (4)ARRAY CTYPE(1:16)="GPC1","CPC1","CPC2",
"FPC1","FPC2","SFC1","EM1","EM2","EM3",
"EC1","EC2","EC3","CPC3","GPCS","CPC4","D16?"
INTEGER TRUNK, TRUNKMAX, PT, I, J, ISA, MASK
IST==RECORD(IST VA)
SAVE IST=IST
TRUNKMAX=15
*STLN_LNB
*STSF_SF
*JLK_<NOTRUNK>
*LSS_TOS
*ST_PC
IST_LNB=LNB
IST_PSR=X'14FF01'
IST_PC=PC
IST_SSR=X'01800FFF'
IST_SF=SF
IST_IT=X'7FFFFF'
IST_IC=X'7FFFFF'
MASK=0
TRUNK=0
NEXT:
WHILE TRUNK<=TRUNKMAX CYCLE
PT=PORT<<20!TRUNK<<16
ISA=X'40000800'!PT
*LB_ISA; *LSS_2; *ST_(0+B ); ! master clear
TRUNK=TRUNK+1
REPEAT
FOR I=TRUNKMAX,-1,0 CYCLE
IF MASK&1<<I=0 THEN TRUNKMAX=I AND ->PART2
REPEAT
IF NSACS=1 THEN START ; ! no port on only SAC
*IDLE_X'0DDD'
FINISH
RETURN ; ! hope other SAC is more useful
PART2:
OPMESS(STRINT(TRUNKMAX+1)." TRUNKS on SAC ".STRINT(PORT))
! inhibits photo's so uninhibit
! xcept 2960 where photo stops mc!
ONOFF(INH PHOTO OFFSET,-1) UNLESS OCPTYPE=2
IST=SAVE IST
WAIT(100)
FOR TRUNK=0,1,TRUNKMAX CYCLE
IF MASK&1<<TRUNK=0 START ; ! trunk was ok
!
! Step 1 perform 2 suspends at least 50 musecs apart
!
PT=PORT<<20!TRUNK<<16
ISA=X'40000800'!PT
*LB_ISA
*LSS_3
*ST_(0+B )
WAIT(1)
*LB_ISA
*LSS_(0+B ); ! read to clear lock on P4
*LSS_3
*ST_(0+B )
*LSS_(0+B ); ! to clear lock on P4
!
!Step 2 set direct control mode bit(21) in the diagnostic
! control register for this port&trunk
!
*ADB_X'500'; ! from 40PT0800 to 40PT0D00
*LSS_X'400'; ! bit 21
*ST_(0+B )
!
! Step 3 send a request contoller properties & waitfor 'RFB'
!
*ADB_X'100'; ! from 40PT0D00 to 40PT0E00
*STB_ISA
*LSS_X'C0000E80'
*ST_(0+B )
I=WAITRFB
!
! Step 4 send AFA and unset all the from bs
!
*LB_ISA
*LSS_X'100'; *ST_(0+B )
*LSS_X'1E12'; *ST_(0+B ); ! master clear combined with FBs
!
! Step 5 unset dcm and master clear
!
*SBB_X'100'; ! from 40PT0E00 to 40PT0D00
*LSS_0
*ST_(0+B )
I=I>>24
IF I>16 THEN I=16
IF I#0 THEN OPMESS("TRUNK ".STRINT(TRUNK). C
" reports ".CTYPE(I))
IF I=GPC1 THEN START
J=GPCCONF(0)+1
GPCCONF(0)=J
GPCCONF(J)=PT<<8
CONTYPE(16*PORT+TRUNK)=3
FINISH
IF I=FPC2 THEN START
J=FPCCONF(0)+1
FPCCONF(0)=J
FPCCONF(J)=PT<<8
CONTYPE(16*PORT+TRUNK)=2
FINISH
IF I=SFC1 THEN START
J=SFCCONF(0)+1
SFCCONF(0)=J
SFCCONF(J)=PT<<8
CONTYPE(16*PORT+TRUNK)=1
FINISH
FINISH ELSE START ; ! trunk did not masterclear
OPMESS("Bad SACTRUNK ".HTOS(16*PORT+TRUNK,2))
FINISH
REPEAT
WAIT(100); ! to let DFCs setlle after mclear
RETURN
NOTRUNK: ! syserr int if illegal trunk
*JLK_TOS
*LSS_TOS ; *LSS_TOS ; *ST_I
J=I>>29; ! failing port
IF 0<=J<=1 START ; ! SAC syserr
J=X'44000200'!J<<20
*LB_J; *LSS_(0+B ); *ST_J; ! read & clear syserr
OPMESS("SAC syserr ".STRHEX(I))
FINISH
*LSS_X'01800FFE'; *ST_(3)
MASK=MASK!1<<TRUNK
TRUNK=TRUNK+1
->NEXT
INTEGERFN WAITRFB
CONSTINTEGER RFB=X'400'
INTEGER I,Q
Q=500
AGN:
*LB_ISA; *LSS_(0+B ); *ST_I
IF I&RFB#0 THEN RESULT =I
Q=Q-1
->AGN IF Q>0
RESULT =0
END
END
FINISH
END
!-----------------------------------------------------------------------
ROUTINE ITIMER
OWNINTEGER COUNT
RECORD (PARMF) P
INTEGER I,J,K
STRING (23)MSG
COUNT=COUNT+1
IF ACT1#0 THEN START
IF SSERIES=YES START
! turn on retry reporting so that DCUs are recovered on comms fail etc.
I=ISAS(ISAS PTR+INH REPS OFFSET)
J=I&X'FFFF'; I=¬(I>>16)
*LB_J; *LSS_(0+B ); *AND_I; *ST_(0+B )
IF NOCPS>1 START
J=J!X'400C0000'!OCP1 SCU PORT<<22
*LB_J; *LSS_(0+B ); *AND_I; *ST_(0+B )
FINISH
FINISH
*ACT_ACT1
FINISH
IF COUNT&3=0 THEN START
P_DEST=X'360000'; PON(P)
IF AUTO SLOAD#0 START ; ! AUTO SLOAD supervisor
I=AUTO SLOAD>>8
J=(AUTO SLOAD&X'FF')<<4
IF X'40'<=J<=X'1C0' AND J#X'100' AND J&X'3F'=0 C
AND BYTEINTEGER(COM_DLVNADDR+I)<254 START
IF J>255 THEN K=3 ELSE K=2
MSG="from ".STRINT(I)." X".HTOS(J,K)
P=0
P_DEST=X'3B0000'
P_P1=I
P_P2=J
PON(P)
FINISH ELSE MSG="HKEYs ??"
OPMESS("AUTO SLOAD ".MSG)
AUTO SLOAD=0
FINISH
FINISH
END
!-----------------------------------------------------------------------
ROUTINE NULL SERVICE(RECORD (PARMF)NAME P)
PKMONREC("Unsupported service",P)
END
END
SYSTEMROUTINE MOVE(INTEGER LENGTH, FROM, TO)
*LB_LENGTH; *JAT_14,<L99>
*LDTB_X'18000000'; *LDB_B ; *LDA_FROM
*CYD_0; *LDA_TO; *MV_L =DR
L99: END ; ! of MOVE
SYSTEMROUTINE ITOE(INTEGER AD, L)
*LB_L; *JAT_14,<L99>
*LDTB_X'18000000'; *LDB_B ; *LDA_AD
*LSS_ITOETAB+4; *LUH_X'18000100'
*TTR_L =DR
L99: END ; ! ITOE
SYSTEMROUTINE ETOI(INTEGER AD, L)
*LB_L; *JAT_14,<L99>
*LDTB_X'18000000'; *LDB_B ; *LDA_AD
*LSS_ETOITAB+4; *LUH_X'18000100'
*TTR_L =DR
L99: END ; ! ETOI
ROUTINE HOOT(INTEGER NUM)
INTEGER J, HOOTISA, HOOTBIT
HOOTBIT=COM_HBIT
HOOTISA=COM_HOOT
IF HOOTISA#0 START ; ! lest no hooter
FOR J=1,1,NUM CYCLE
*LB_HOOTISA; *LSS_(0+B )
*OR_HOOTBIT; *ST_(0+B )
WAIT(40)
*LB_HOOTISA; *LSS_(0+B )
*SLSS_-1; *NEQ_HOOTBIT
*AND_TOS ; *ST_(0+B )
WAIT(40)
REPEAT
FINISH
WAIT(300)
END
EXTERNALROUTINE PTREC(RECORD (PARMAF)NAME P)
INTEGER I, J, SPTR, VAL
STRING (120) S
SPTR=1
FOR I=ADDR(P),4,ADDR(P)+28 CYCLE
VAL=INTEGER(I)
FOR J=28,-4,0 CYCLE
CHARNO(S,SPTR)=HEXDS((VAL>>J)&15)
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
REPEAT
FOR I=ADDR(P)+8,1,ADDR(P)+31 CYCLE
J=BYTEINTEGER(I)
IF J<32 OR J>95 THEN J='_'
CHARNO(S,SPTR)=J
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=NL
LENGTH(S)=SPTR
PRINTSTRING(S)
END
EXTERNALROUTINE PKMONREC(STRING (20)TEXT,RECORD (PARMAF)NAME P)
PRINTSTRING(TEXT)
SPACE
PTREC(P)
END
EXTERNALINTEGERFN REALISE(INTEGER AD)
CONSTINTEGER RA=X'0FFFFFFC'
RESULT =(AD&X'3FFFF')+INTEGER(PST VA+(AD>>15)&X'FFF8'+4)& C
RA
END
EXTERNALROUTINE DUMPTABLE(INTEGER TABLE, ADD, LENGTH)
OWNINTEGER NEXT
INTEGER I, K, END, SPTR, VAL
STRING (132) S
NEXT=NEXT+1; ADD=ADD&(-4)
! Some sort of validation is required here
PRINTSTRING("
**** SUPERVISOR DUMP TABLE: ".STRINT( C
TABLE)." ADDR ")
PRINTSTRING(STRHEX(ADD)." LENGTH: ".STRINT(LENGTH))
PRINTSTRING(" DUMP NO: ".STRINT(NEXT)."****")
! Time of day and date added here
NEWLINE
END=ADD+LENGTH; I=1
S=" "
UNTIL ADD>=END CYCLE
*LDTB_X'18000020'; *LDA_ADD
*VAL_(LNB +1); *JCC_3,<INVL>
IF I=0 THEN START
FOR K=ADD,4,ADD+28 CYCLE
->ON IF INTEGER(K)#INTEGER(K-32)
REPEAT
S="O"; ->UP
FINISH
ON:
CHARNO(S,2)='('; SPTR=3
FOR I=28,-4,0 CYCLE
CHARNO(S,SPTR)=HEXDS((ADD>>I)&15)
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=')'
CHARNO(S,SPTR+1)=' '
SPTR=SPTR+2
FOR K=ADD,4,ADD+28 CYCLE
VAL=INTEGER(K)
FOR I=28,-4,0 CYCLE
CHARNO(S,SPTR)=HEXDS((VAL>>I)&15)
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
FOR K=ADD,1,ADD+31 CYCLE
I=BYTEINTEGER(K)&X'7F'
UNLESS 32<=I<=95 THEN I=' '
CHARNO(S,SPTR)=I
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
CHARNO(S,SPTR)=NL
BYTEINTEGER(ADDR(S))=SPTR
PRINTSTRING(S)
S=" "
UP: ADD=ADD+32
I=0
REPEAT
RETURN
INVL: PRINTSTRING("Address validation fails
")
END ; !ROUTINE DUMP
! own variables for joint use by 'IOCP' and 'PRINTER'
CONSTINTEGER MASK=X'80FC3FFF'
OWNINTEGER INPTR=X'80FC0000', OUTPTR=X'80FC0000', PAVAIL=0
OWNINTEGER BUSY, INTPEND, TESTPEND=0, INIT=0
SYSTEMROUTINE IOCP(INTEGER EP, N)
!***********************************************************************
!* This routine receives all the output from main via IMP stmts *
!* such as printstring, and sends it to the main print file. *
!* A cyclic buffer is maintained in page 2 and one other buffer *
!* is used in segment public 63. If output arrives faster *
!* than the printer can cope it is discarded. *
!***********************************************************************
RECORD (PARMF) Q
INTEGER I, J, ADR, L, OLDINPTR, SYM, NLSEEN
STRING (63) S
->END UNLESS X'280A8'&1<<EP¬=0; !check for valid entry
OLDINPTR=INPTR; NLSEEN=0
IF EP=17 THEN START ; ! repeated symbols
L=N>>8&63; J=L
WHILE J>0 CYCLE
CHARNO(S,J)=N&127; J=J-1
REPEAT
ADR=ADDR(S)+1
FINISH ELSE START
IF EP>=7 THEN START ; ! print string
L=BYTE INTEGER(N); ADR=N+1
FINISH ELSE START ; ! print symbol & print ch
L=1; ADR=ADDR(N)+3
FINISH
FINISH
I=1
WHILE I<=L CYCLE
->END IF BUSY=1; ! buffers busy discard output
J=(INPTR+1)&MASK
IF J#OUTPTR THEN START ; ! room for current char
SYM=BYTE INTEGER(ADR)
BYTE INTEGER(J)=SYM
IF SYM=NL THEN NLSEEN=1
ADR=ADR+1; INPTR=J; I=I+1
FINISH ELSE BUSY=1 AND RETURN
REPEAT
RETURN IF PAVAIL=0
IF OLDINPTR=OUTPTR AND NLSEEN#0 THEN C
Q_DEST=X'360000' AND PON(Q)
END: END ; ! of routine IOCP
EXTERNALROUTINE PRINTER(RECORD (PARMF)NAME P)
!***********************************************************************
!* Version for a real printer. *
!***********************************************************************
ROUTINESPEC ETOE(INTEGER AD, L)
INTEGER I, J
OWNBYTEINTEGERARRAY BUFFER(0:133)
IF SSERIES=YES START
RECORDFORMAT TCBF(INTEGER COMMAND,STE,LEN,DATAD,NTCB,RESP, C
INTEGERARRAY PREAMBLE,POSTAMBLE(0:3))
OWNRECORD (TCBF)NAME TCB
OWNINTEGER INITLP=X'FC10'
CONSTINTEGER TCBM=X'2F004000'
FINISH ELSE START
RECORDFORMAT RQBF(INTEGER LFLAG, LSTBA, LBL, LBA, ALL, ALA, INIT)
OWNRECORD (RQBF) RQB
OWNINTEGER LBE=X'80700300',ALE1,ALE2
FINISH
RECORD (ENTFORM)NAME D
OWNINTEGER MNEM=M'LP0',TRANSTABAD=0
RECORD (PARMF) Q
SWITCH DACT(0:8)
IF INIT=0 THEN START
Q=0
Q_DEST=X'30000B'
Q_SRCE=X'360007'
Q_P1=M'LP'
Q_P2=X'360002'; ! ints to act 2
IF SSERIES=NO START
RQB_LBL=4
RQB_LBA=ADDR(LBE)
RQB_ALL=8
RQB_ALA=ADDR(ALE1)
RQB_INIT=X'FC10'
ALE2=ADDR(BUFFER(1))
FINISH
PON(Q)
INIT=1
FINISH
->DACT(P_DEST&15)
NEXTLINE:
BUFFER(0)=0
DACT(0): ! alarm clock tick or equivalent
IF INTPEND#0 OR TESTPEND#0 OR PAVAIL=0 THEN ->END
IF INPTR=OUTPTR THEN ->UNBUSY
I=BUFFER(0)
CYCLE
J=BYTE INTEGER(OUTPTR)
BYTE INTEGER(OUTPTR)=0
OUTPTR=(OUTPTR+1)&MASK
IF J=10 OR J=12 OR I=132 START
IF I=132 THEN J=10
J=133 IF J=10; !for "NEW" trantabs
I=I+1; BUFFER(I)=J
BUFFER(0)=I
IF SSERIES=YES THEN TCB_LEN=I ELSE ALE1=X'58000000'+I
ITOE(ADDR(BUFFER(1)),I)
ETOE(ADDR(BUFFER(1)),I); ! deal with unprintables
->PRINT
FINISH
IF J#13 THEN I=I+1 AND BUFFER(I)=J
IF INPTR=OUTPTR THEN BUFFER(0)=I AND ->UNBUSY
! incomplete line
REPEAT
PRINT: ! print line in array buffer(again)
INTPEND=1
PRINTI:
IF SSERIES=YES START
P_P1=ADDR(TCB)
FINISH ELSE START
P_P1=ADDR(RQB)
P_P3=X'11'; ! do stream req. clear abnormal
FINISH
P_DEST=X'30000C'
P_SRCE=X'360008'
P_P2=INIT
PON(P)
->END
DACT(8): ! request rejected
OPMESS("Main LP request reject")
INTPEND=0
->END
DACT(1): ! not now used
->END
DACT(2): ! printer interupt normal termn
J=(P_P1)>>20&15
IF J&1#0 THEN ->ATTN
IF J&4#0 THEN ->ABTERM
IF INTPEND=0 THEN START
OPMESS("Main LP INT???")
RETURN
FINISH
IF SSERIES=YES AND INTPEND=2 START
TCB_COMMAND=TCBM!X'83'; ! write (was initialise)
TCB_DATAD=ADDR(BUFFER(1))
FINISH
INTPEND=0
->NEXT LINE
ABTERM: ! abnormal termination
INTPEND=0
IF SSERIES=YES START
IF TCB_POSTAMBLE(0)>>24=X'20' START ; ! illegal char only
TCB_LEN=1
BUFFER(1)=X'15'; ! EBCDIC newline
->PRINT; ! blank line
FINISH
FINISH ELSE START
D==RECORD(P_P3); ! onto device entry
IF D_SENSE1>>24=X'20' START
ALE1=X'58000001'
BUFFER(1)=X'15'
->PRINT
FINISH
FINISH
PKMONREC("Printer abtermn:",P)
OPMESS("Attend main LP")
TESTPEND=1; ->END
ATTN: ! attention
IF TESTPEND#0 AND P_P1&X'8000'#0 C
THEN TESTPEND=0 AND ->PRINT
->END
DACT(6): ! reset printer
Q=0; Q_DEST=X'300005'
Q_P1=MNEM; Q_SRCE=X'360000'; ! reply is ignored
PON(Q); ! deallocate from whoever has it
Q_DEST=X'30000B'
Q_P2=X'360002'; ! ints to act 2
Q_P1=M'LP'
Q_SRCE=X'360007'
PON(Q)
PAVAIL=0
INTPEND=0; ->NEXT LINE
DACT(7): ! reply from allocate
IF P_P1#0 THEN OPMESS("Main LP alloc fails ".STRINT(P_P1)) C
ELSE START
INTPEND=0
PAVAIL=1
TESTPEND=0
INIT=P_P2
MNEM=P_P6
D==RECORD(P_P3)
TRANSTABAD=D_TRTABAD
IF SSERIES=YES START
TCB==RECORD(D_UA AD)
TCB_COMMAND=TCBM!X'81'; ! initialise
TCB_STE=REALISE(ADDR(INITLP)&X'FFFC0000')!1
TCB_LEN=4
TCB_DATAD=ADDR(INITLP)
INTPEND=2
->PRINTI
FINISH
FINISH
->NEXTLINE
UNBUSY: ! restart if buffer oflow occurred
IF BUSY=1 START
BUSY=0; PRINTSTRING("
*** Output lost ***
")
FINISH
->END
ROUTINE ETOE(INTEGER AD, L)
INTEGER J
RETURN IF TRANSTABAD=0
J=TRANSTABAD
*LB_L
*JAT_14,<L99>
*LDTB_X'18000000'
*LDB_B
*LDA_AD
*LSS_J
*LUH_X'18000100'
*TTR_L =DR
L99:
END
END: END ; ! of routine PRINTER
EXTERNALROUTINE GET PSTB(INTEGERNAME PSTB0, PSTB1)
! Machine-independent version
! Public segment PST SEG is mapped to the PST itself
RECORDFORMAT EF(INTEGER LIM, RA)
CONSTRECORD (EF)NAME E=PST VA+PST SEG*8
! E_LIM gives the size of the PST (bytes)
! for double words, >>3, and this is the top public seg which is
! potentially available. To get the va limit therefore we <<18.
! we add the top bit and also the bottom 7 bits >>3 and <<18, which
! is the '3C'.
PSTB0=((E_LIM&X'0003FF80')<<15)!X'803C0000'
PSTB1=E_RA&X'0FFFFFC0'
END ; ! GET PSTB
SYSTEMROUTINE STOP
INTEGER I,W0,W1,W2,W3
I=COM_LSTL
*LB_I; *LSS_(0+B ); *ST_W2
I=COM_LSTB
*LB_I; *LSS_(0+B ); *ST_W3
*STSF_I
W1=I>>18<<18
W0=-1; ! dummy syserr param
*LXN_UNDUMPSEG; *LSQ_W0; *ST_(XNB +0)
!
! Now if supervisor stop seg 10 is set up as if we have had a dummy
! system error. A tape dump will then look ok to the dump analyser
!
IF SSERIES=YES THEN LIGHTS(FOOTPRINT!X'DEAD')
HOOT(15)
*IDLE_X'3333'
END ; ! STOP
IF SSERIES=YES START
EXTERNALINTEGERFN PINT
RECORDFORMAT ISTF(INTEGER LNB,PSR,PC,SSR,SF,IT,IC)
RECORD (ISTF)NAME IST4,IST14
RECORD (ISTF) SAVE IST4,SAVE IST14
INTEGER LNB,PC,SF
INTEGER I,J
I=0
IST4==RECORD(IST VA+(4-1)*32)
IST14==RECORD(IST VA+(14-1)*32)
SAVE IST4=IST4
SAVE IST14=IST14
*STLN_LNB
*STSF_SF
*JLK_<INT>
*LSS_TOS
*ST_PC
IST4_LNB=LNB
IST4_PSR=X'14FF01'
IST4_PC=PC
IST4_SSR=X'3FFE'
IST4_SF=SF
IST4_IT=X'7FFFFF'
IST4_IC=X'7FFFFF'
IST14=IST4
*LSS_X'1FF6'; *ST_(3); ! allow unit & peripheral ints.
WAIT(10)
->FINI
INT:
*JLK_TOS
*LSS_TOS
*LSS_TOS
*ST_I; !interrupt param
FINI:
*LSS_X'3FFE'
*ST_(3)
IST4=SAVE IST4
IST14=SAVE IST14
RESULT =I
END
FINISH
!*
ROUTINE RESTART
!
ROUTINESPEC DOWAIT(INTEGER MASK)
IF SSERIES=YES START
OWNINTEGERARRAY TCBA(0:14)
OWNINTEGERARRAYFORMAT TCBF(0:13)
OWNINTEGERARRAYNAME TCB
TCB==ARRAY(ADDR(TCBA(1))&X'FFFFFFF8',TCBF); ! double-word align
CONSTINTEGER TCBM=X'2C404000'
OWNINTEGER INIT=X'FC03'; ! 1600 BPI/PE
OWNINTEGERARRAY ACTIVATE(0:1)=X'10001400',0
INTEGER PSM,AWORDA,PCWORDA
FINISH ELSE START
RECORD (PARMF) P
RECORDFORMAT RQBF(INTEGER LFLAG,LSTBA,LBL,LBA,ALL,ALA,INIT)
RECORDFORMAT STRMF(INTEGER SAW0,SAW1,RESP0,RESP1)
RECORDFORMAT CAF(INTEGER MARK,PAW,PIW0,PIW1,CSAW0,CSAW1,CRESP0,C
CRESP1,RECORD (STRMF)ARRAY STRMS(0:15))
RECORD (CAF)NAME CA
RECORD (RQBF)NAME RQB
RECORD (ENTFORM)NAME D
INTEGERNAME LBE,ALE1,ALE2
INTEGER PTSM,STRM,RESP0,RESP1
FINISH
RECORDFORMAT SEG10F(INTEGER SYSERRP,STACK,LSTL,LSTB,PSTL,PSTB, C
HKEYS,INPTR,OUTPTR,BUFFLASTBYTE,OLDSE,OLDST,OLDLSTL,OLDLSTB,SBLKS,C
PASL,KQ,RQ1,RQ2,LONGINTEGER SA,PARM,PARML,INTEGERARRAY BLOCKAD(0:127))
CONSTRECORD (SEG10F)NAME SEG10=UNDUMPSEG
OWNINTEGERARRAYFORMAT BF(0:127)
INTEGERARRAYNAME BLOCKAD
LONGINTEGER A
INTEGER I,J
SLAVESONOFF(0)
!
! Seg 10 (which must be in SMAC0/SCU0-block0) is used at failure to pass
! info to the dump program. First 4 words are set up by system
! error routine (where appropiate)
!
FOR I=0,4,8 CYCLE
J=INTEGER(ADDR(COM_PSTL)+I)
*LB_J; *LSS_(0+B ); *ST_J
INTEGER(REAL0ADDR+I)=J
INTEGER(X'80280010'+I)=J
REPEAT
SEG10_INPTR=INPTR; ! for the printer buffer
SEG10_OUTPTR=OUTPTR
SEG10_BUFFLASTBYTE=MASK
SEG10_SBLKS=COM_SBLKS
BLOCKAD==ARRAY(COM_BLKADDR,BF)
FOR I=0,1,SEG10_SBLKS-1 CYCLE
SEG10_BLOCKAD(I)=BLOCKAD(I)
REPEAT
SEG10_PASL=PARMASL
SEG10_KQ=KERNELQ
SEG10_RQ1=0
SEG10_RQ2=0
*LSD_SERVA; *ST_A; SEG10_SA=A
*LSD_PARM; *ST_A; SEG10_PARM=A
SEG10_PARML=0
IF SSERIES=YES START
PSM=HANDKEYS&X'FFFFF'
AWORDA=X'60000000'!PSM>>16<<22; !activate word address
*LSS_(16); *USH_-24; *ST_PCWORDA; ! OCP SCU port
PCWORDA=PCWORDA<<22!X'60000010'; ! processor coupler address
*LB_PCWORDA; *MPSR_X'12'; *L_(0+B ); ! free CC (perhaps!)
ACTIVATE(1)=REALISE(ADDR(TCB(0))&X'FFFC0000')!X'80000001'
J=0
I=PINT AND J=J+1 UNTIL I=0 OR J=100
A=LONGINTEGER(ADDR(ACTIVATE(0)))
*LSD_A; !set emergency CCA (@ X'1400')
*LB_AWORDA
*ADB_X'20'
*ST_(0+B )
ACTIVATE(0)=ADDR(TCB(0))
ACTIVATE(1)=3<<24!PSM>>8&X'FF'; !connect stream
A=LONGINTEGER(ADDR(ACTIVATE(0)))
I=100; ! for timeout
*LSD_A
*LB_AWORDA
*ST_(0+B )
CON: *MPSR_X'12'
*L_(0+B )
*MPSR_X'11'
*JAT_4,<CONOK>
I=I-1
IF I<=0 THEN ->CONOK; ! forget it (stream probably connected anyway)
*LB_AWORDA
*J_<CON>
CONOK:
J=0
I=PINT AND J=J+1 UNTIL I#0 OR J=100
ACTIVATE(1)=ACTIVATE(1)&X'00FFFFFF'!1<<24; !start stream
TCB(0)=TCBM!X'81'; !initialise
TCB(1)=REALISE(ADDR(INIT)&X'FFFC0000')!1; !GLA STE
TCB(2)=4; !data length
TCB(3)=ADDR(INIT); !data address
INIT=INIT!(PSM&15)<<24; !mechanism
DOWAIT(X'C00000')
TCB(0)=TCBM!X'238'; !rewind to BT (& skip data)
TCB(1)=1; !fixed
TCB(2)=0
TCB(3)=0
DOWAIT(X'C00000'); !wait for term
J=0
I=PINT AND J=J+1 UNTIL I#0 OR J=100; !wait for BT sense
WAIT(2000)
FINISH ELSE START
PTSM=HANDKEYS&X'FFFF'
P=0
P_DEST=8; P_P1=PTSM
P_SRCE=X'80360000'
GDC(P)
IF P_P1#0 THEN START
PKMONREC("Claim dumpmt:",P)
NEWLINE
HOOT(4)
*IDLE_X'12121'
FINISH
D==RECORD(P_P3)
CA==RECORD(D_CAA)
RQB==RECORD(D_GRCB AD)
CA_MARK=-1
LBE==INTEGER(RQB_LBA)
ALE1==INTEGER(RQB_ALA)
ALE2==INTEGER(RQB_ALA+4)
RQB_LFLAG=1<<18!X'C000'; ! LST 1 seg,note mech no,ACR=0
! and trusted chain
RQB_LSTBA=X'8080'
RQB_LBL=4; RQB_ALL=8
RQB_INIT=(PTSM&15)<<24!X'FC03'; ! status mask&1600BPI
STRM=PTSM>>4&15
ALE1=X'58001000'
ALE2=X'81000000'
LBE=X'00F10800'; ! connect stream if nec
DOWAIT(X'C00000')
LBE=X'80F03800'; ! rewind
DOWAIT(X'C00000'); ! wait for term(=rewnd starts)
DOWAIT(X'80100000'); ! wait for attmnt(=at BT)
FOR I=1,1,500*COM_INSPERSEC CYCLE ; ! wait about 1 sec
REPEAT ; ! (RTC may be down in duals - avoid 'wait')
FINISH
IF SSERIES=YES START ; ! read over label
TCB(0)=TCBM!X'202'
TCB(2)=4096
FINISH ELSE LBE=X'80F04200'
DOWAIT(X'C00000')
IF SSERIES=YES THEN TCB(0)=TCBM!X'A3' ELSE LBE=X'80F02300'
DOWAIT(X'C00000'); ! write TM
IF SSERIES=YES THEN TCB(0)=TCBM!X'83' ELSE LBE=X'80C00300'
FOR I=0,1,SEG10_SBLKS-1 CYCLE ; ! dump store in 4K blocks
IF SSERIES=YES THEN TCB(1)=BLOCKAD(I)!1
FOR J=0,4096,31*4096 CYCLE
IF SSERIES=YES THEN TCB(3)=J ELSE C
ALE2=X'81000000'+SEG10_BLOCKAD(I)+J
DOWAIT(X'C00000')
REPEAT
REPEAT
IF SSERIES=YES THEN TCB(0)=TCBM!X'A3' ELSE LBE=X'80F02300'
DOWAIT(X'C00000'); ! write 2 TMs
DOWAIT(X'C00000')
IF SSERIES=YES THEN TCB(0)=TCBM!X'258' ELSE LBE=X'80F03800'
DOWAIT(X'C00000'); ! unload
HOOT(40)
*IDLE_X'E00E'
STOP
ROUTINE DOWAIT(INTEGER MASK)
!***********************************************************************
!* Fires an I-O operation and waits for the reply. Any attentions *
!* are thrown away. Response words are left in globals *
!***********************************************************************
IF SSERIES=YES START
INTEGER TCBR
INTEGER I
LONGLONGREAL TCBP
UNLESS MASK<0 START
*LB_PCWORDA; !clear unwanted ints.
*MPSR_X'12'
*L_(0+B )
TCB(5)=0; !clear response word
A=LONGINTEGER(ADDR(ACTIVATE(0)))
*LSD_A
*LB_AWORDA
*ST_(0+B )
CA: *MPSR_X'12'
*L_(0+B )
*MPSR_X'11'
*JAF_4,<CA>
CR: TCBR=TCB(5)
*LSS_TCBR; !wait for response
*JAT_4,<CR>
->FIREOK IF TCBR>>30=0 OR TCBR&X'FFFF'=0 OR MASK=0
TCBP=LONGLONGREAL(ADDR(TCB(10)))
*LB_TCBR
*LSQ_TCBP
*JCC_0,<FIREOK>
*IDLE_X'EEEE'
FIREOK:
RETURN
FINISH
*LB_PCWORDA; !wait for interrupt
*MPSR_X'12'
CI: *L_(0+B )
*JAT_4,<CI>
RETURN
FINISH ELSE START
INTEGER CHISA
RECORD (STRMF)NAME STRMS
IF MASK<0 THEN MASK=MASK&X'7FFFFFFF' AND ->AGN
WAIT: *LXN_CA+4; *INCT_(XNB +0)
*JCC_7,<WAIT>
CA_PAW=1<<24!STRM; ! do stream request
CA_PIW0=0
STRMS==CA_STRMS(STRM)
STRMS_SAW0=1<<28!32; ! clear abnormal termination
STRMS_SAW1=ADDR(RQB)
STRMS_RESP0=0
STRMS_RESP1=0
CA_MARK=-1
CHISA=X'40000800'!(PTSM>>8<<16)
*LB_CHISA; *LSS_1; *ST_(0+B ); ! send channel flag
!
AGN: UNTIL STRMS_RESP0#0 AND CA_MARK=-1 CYCLE ; REPEAT
!
GET: *LXN_CA+4; *INCT_(XNB +0); *JCC_7,<GET>
RESP0=STRMS_RESP0
RESP1=STRMS_RESP1
STRMS_RESP0=0
STRMS_RESP1=0
CA_PIW0=0
CA_MARK=-1
->AGN UNLESS RESP0&MASK#0; ! normal or abnorml set
FINISH
END
END ; ! RESTART
EXTERNALROUTINE ENTER(INTEGER A, B)
RECORDFORMAT REGF(INTEGER LNB, PSR, PC, SSR, SF, IT, IC, LTB)
RECORD (REGF)NAME R
INTEGER SSNP1ADDR, PB0, PB1, THIS LNB, THIS SF, REACT PC, CURSTKAD
CONSTINTEGER RESSTKAD = X'80180000'
CONSTINTEGER REACTAD=X'81000080'
*STLN_THIS LNB
!
! Copy words from alternate stack segment to RA word 32(dec) ie. X80 bytes
! work out alt stack seg from current stack front
!
*STSF_THIS SF
CURSTKAD = THIS SF&X'FFFC0000'
SSNP1ADDR = CURSTKAD!X'00040000'
!
! Copy sufficient of current stack to the restart stack (public 6) to
! allow 'RESTART' to be called on it.
!
MOVE(THIS SF&X'3FFFF',CURSTKAD,RESSTKAD)
!
! Now set up re-activation words for re-entry below
!
*JLK_<ELAB>
*LSS_TOS
*ST_REACT PC
R == RECORD(REACTAD)
R_LNB = RESSTKAD!(THIS LNB&X'3FFFF')
R_PSR = X'0014FF01'
R_PC = REACT PC
R_SSR = X'0180FFFE'; ! VA mode all masked except system error
R_SF = RESSTKAD!(THIS SF&X'3FFFF')
GET PSTB(PB0,PB1)
INTEGER(REACTAD+X'48') = PB0
INTEGER(REACTAD+X'4C') = PB1
CHOP29
*IDLE_X'CCCC'
ELAB:
*JLK_TOS
! re-entry here for post mortem
RESTART
*IDLE_X'CCCC'
END ; ! ENTER
EXTERNALROUTINE PRHEX(INTEGER N)
PRINTSTRING(STRHEX(N))
END
ROUTINE MONITOR(STRING (63) S)
PRINT STRING(S."
")
MONITOR
STOP
END
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
EXTERNALROUTINE DPON(RECORD (PARMF)NAME P,INTEGER DELAY)
PON(P)
END
!----------------------------------------------------------------------
ROUTINE PUTONQ(INTEGER SERVICE)
RECORD (SERVF)NAME SERV, SERVQ
SERV==SERVA(SERVICE)
IF KERNELQ=0 THEN SERV_L=SERVICE ELSE START
SERVQ==SERVA(KERNELQ)
SERV_L=SERVQ_L
SERVQ_L=SERVICE
FINISH
KERNELQ=SERVICE
END
!-----------------------------------------------------------------------
INTEGERFN PPINIT(RECORD (PARMXF)ARRAYNAME PARMSPACE,INTEGER LASTCELL)
INTEGER I, J, CELLS, PARMAD
RECORD (PARMXF)NAME HDCELL
PARMAD=ADDR(PARMSPACE(0))
PARM==PARMSPACE
CELLS=LASTCELL
HDCELL==PARM(0); ! set up hdecell for dump prg
HDCELL_DEST=LASTCELL
HDCELL_SRCE=LASTCELL
HDCELL_P1=LASTCELL+1
FOR I=1,1,CELLS-1 CYCLE
PARM(I)_LINK=I+1
REPEAT
PARM(CELLS)_LINK=1
PARMASL=CELLS
J=PARMAD
I=PCELLSIZE*(LASTCELL+1)!X'18000000'
PARMDES=LONGINTEGER(ADDR(I)); ! descrptr to PP area
RESULT =PARMAD
END
!-----------------------------------------------------------------------
EXTERNALROUTINE MORE PPSPACE
!***********************************************************************
!* Called when PARM ASL is empty *
!* Chopsupe version just gives up *
!***********************************************************************
MONITOR("PARM ASL empty")
END
!-----------------------------------------------------------------------
EXTERNALROUTINE PON(RECORD (PARMF)NAME P)
RECORD (SERVF)NAME SERV
RECORD (PARMXF)NAME ACELL, SCELL, NCELL
INTEGER SERVICE, NEWCELL, SERVP
SERVICE=P_DEST>>16
UNLESS SERVICE<=MAXSERV C
THEN PKMONREC("Invalid PON:",P) AND RETURN
IF PARMASL=0 THEN MORE PPSPACE
ACELL==PARM(PARMASL); ! ACELL =ASL headcell
NEWCELL=ACELL_LINK
NCELL==PARM(NEWCELL); ! NCELL mapped onto NEWCELL
IF NEWCELL=PARMASL THEN PARMASL=0 C
ELSE ACELL_LINK=NCELL_LINK
NCELL<-P; ! copy parameters in
SERV==SERVA(SERVICE)
SERVP=SERV_P&X'7FFFFFFF'
IF SERVP=0 THEN NCELL_LINK=NEWCELL ELSE START
SCELL==PARM(SERVP)
NCELL_LINK=SCELL_LINK
SCELL_LINK=NEWCELL
FINISH
SERV_P=SERV_P&X'80000000'!NEWCELL
IF SERV_P>0 AND SERV_L=0 THEN PUTONQ(SERVICE)
END
!-----------------------------------------------------------------------
EXTERNALROUTINE FASTPON(INTEGER CELL)
RECORD (PARMF)NAME P
P==RECORD(ADDR(PARM(CELL)))
PON(P)
RETURN PPCELL(CELL)
END
!-----------------------------------------------------------------------
EXTERNALINTEGERFN NEWPPCELL
!***********************************************************************
!* Provide a PP cell for use elsewhere than in PON-POFF area *
!***********************************************************************
INTEGER NEWCELL
RECORD (PARMXF)NAME ACELL
IF PARMASL=0 THEN MORE PPSPACE
ACELL==PARM(PARMASL)
NEWCELL=ACELL_LINK
IF NEWCELL=PARMASL THEN PARMASL=0 C
ELSE ACELL_LINK=PARM(NEWCELL)_LINK
RESULT =NEWCELL
END
!-----------------------------------------------------------------------
ROUTINE POFF(RECORD (PARMF)NAME P)
!***********************************************************************
!* Remove a set of paramaters from their queue and copy them *
!* into the parameter record. The service no is in P_DEST and an *
!* empty or inhibited queue is notified by returning a zero P_DEST *
!***********************************************************************
RECORD (SERVF)NAME SERV
RECORD (PARMXF)NAME ACELL, CCELL, SCELL
INTEGER SERVICE, CELL, SERVP
SERVICE=P_DEST>>16
UNLESS 0<SERVICE<=MAXSERV C
THEN PKMONREC("Invalid POFF:",P) AND P_DEST=0 AND RETURN
SERV==SERVA(SERVICE)
SERVP=SERV_P
IF SERVP<=0 THEN P_DEST=0 AND RETURN
SCELL==PARM(SERVP)
CELL=SCELL_LINK
CCELL==PARM(CELL)
P<-CCELL; ! copy parameters out
IF CELL=SERV_P THEN SERV_P=0 ELSE SCELL_LINK=CCELL_LINK
IF PARMASL=0 THEN CCELL_LINK=CELL ELSE START
ACELL==PARM(PARMASL)
CCELL_LINK=ACELL_LINK
ACELL_LINK=CELL
FINISH
PARMASL=CELL
END
!-----------------------------------------------------------------------
EXTERNALROUTINE RETURN PPCELL(INTEGER CELL)
!***********************************************************************
!* Returns a cell suplied for other purposes via NEWPPCELL *
!***********************************************************************
RECORD (PARMXF)NAME ACELL, CCELL
CCELL==PARM(CELL)
IF PARMASL=0 THEN CCELL_LINK=CELL ELSE START
ACELL==PARM(PARMASL)
CCELL_LINK=ACELL_LINK
ACELL_LINK=CELL
FINISH
PARMASL=CELL
END
!-----------------------------------------------------------------------
EXTERNALROUTINE INHIBIT(INTEGER SERVICE)
!***********************************************************************
!* Inhibit a service by setting top bit in SERV_P *
!***********************************************************************
RECORD (SERVF)NAME SERV
UNLESS 0<SERVICE<=MAXSERV C
THEN PRINT STRING("INVALID INHIBIT: ".STRINT(SERVICE)."
") AND RETURN
SERV==SERVA(SERVICE)
SERV_P=SERV_P!X'80000000'
END
!-----------------------------------------------------------------------
EXTERNALROUTINE UNINHIBIT(INTEGER SERVICE)
!***********************************************************************
!* Uninhibit a service by unsetting top bit in P_SERV and adding *
!* any service calls to appropiate queue *
!***********************************************************************
RECORD (SERVF)NAME SERV
UNLESS 0<SERVICE<=MAXSERV C
THEN PRINT STRING("Invalid UNINHIBIT: ".STRINT(SERVICE)."
") AND RETURN
SERV==SERVA(SERVICE)
SERV_P=SERV_P&X'7FFFFFFF'
IF SERV_L=0 AND SERV_P#0 THEN PUTONQ(SERVICE)
END
!----------------------------------------------------------------------
EXTERNALSTRING (8) FN STRHEX(INTEGER VALUE)
STRING (8) S
*LD_S; *LSS_8; *ST_(DR )
*INCA_1; *STD_TOS ; *STD_TOS
*LSS_0; *LUH_VALUE
*MPSR_X'24'; ! set CC=1
*SUPK_L =8
*LD_TOS ; *ANDS_L =8,0,15; ! throw away zone codes
*LSS_HEXDS+4; *LUH_X'18000010'
*LD_TOS ; *TTR_L =8
RESULT = S
END
SYSTEMROUTINE WRITE(INTEGER VALUE,PLACES)
STRING (16)S
INTEGER D0,D1,D2,D3,L
PLACES=PLACES&15
*LSS_VALUE; *CDEC_0
*LD_S; *INCA_1; *STD_TOS
*CPB_B ; ! set CC=0
*SUPK_L =15,0,32; ! unpack & space fill
*STD_D2; *JCC_8,<WASZERO>
*LD_TOS ; *STD_D0; ! for sign insertion
*LD_TOS
*MVL_L =15,63,0; ! force ISO zone codes
IF VALUE<0 THEN BYTEINTEGER(D1)='-'
L=D3-D1
OUT: IF PLACES>=L THEN L=PLACES+1
D3=D3-L-1
BYTEINTEGER(D3)=L
PRINTSTRING(STRING(D3))
RETURN
WASZERO:
BYTEINTEGER(D3-1)='0'
L=2; ->OUT
END
EXTERNALSTRING (8) FN HTOS(INTEGER VALUE, PLACES)
STRING (8) S
INTEGER I
I=64-4*PLACES
*LD_S; *LSS_PLACES; *ST_(DR )
*INCA_1; *STD_TOS ; *STD_TOS
*LSS_VALUE; *LUH_0; *USH_I
*MPSR_X'24'; ! set CC=1
*SUPK_L =8
*LD_TOS ; *ANDS_L =8,0,15; ! throw away zone codes
*LSS_HEXDS+4; *LUH_X'18000010'
*LD_TOS ; *TTR_L =8
RESULT = S
END
!-----------------------------------------------------------------------
EXTERNALSTRING (15) FN STRINT(INTEGER N)
STRING (16) S
INTEGER D0,D1,D2,D3
*LSS_N; *CDEC_0
*LD_S; *INCA_1; ! past length byte
*CPB_B ; ! set CC=0
*SUPK_L =15,0,32; ! unpack 15 digits space fill
*STD_D2; ! final DR for length calcs
*JCC_8,<WASZERO>; ! N=0 case
*LSD_TOS ; *ST_D0; ! sign descriptor stked by SUPK
*LD_S; *INCA_1
*MVL_L =15,15,48; ! force in ISO zone codes
IF N<0 THEN BYTEINTEGER(D1)='-' AND D1=D1-1
BYTEINTEGER(D1)=D3-D1-1
RESULT =STRING(D1)
WASZERO: RESULT ="0"
END
EXTERNALROUTINE OPMESS2(INTEGER OPER,STRING (63) MESS)
!***********************************************************************
!* PON a message to the OPER. In preparation for interrupt driven *
!* operator routines which can not be called *
!***********************************************************************
STRING (23) T
RECORD (PARMF) P
INTEGER I
T<-MESS
P_DEST=X'2F0007'!OPER<<8
P_SRCE=0
FOR I=0,1,23 CYCLE
BYTE INTEGER(ADDR(P_P1)+I)=BYTE INTEGER(ADDR(T)+I)
REPEAT
PON(P)
END
EXTERNALROUTINE OPMESS(STRING (63)MESS)
OPMESS2(0,MESS)
END
ROUTINE OPER RELAY(RECORD (PARMF)NAME P)
!***********************************************************************
!* To hold up OPER message prior to initialisation *
!***********************************************************************
P_DEST=P_DEST&X'FFFF'!X'00320000'
PON(P)
END
EXTERNALROUTINE WAIT(INTEGER MILLESECS)
LONGINTEGER T
*CPSR_B ; *MPSR_X'C0'; ! mask out overflow
*RRTC_0; *SHS_1; ! ACC=microsecs
*SLSS_MILLESECS; *IMY_2
*IAD_1; *IMYD_512; ! ACC=delay in microsecs
*IAD_TOS ; *ST_T
*JAF_15,<L1>; ! jump unless overflow
*JAT_6,<L1>; ! logical ok +ve to -ve oflow
! Addition has caused clock to overflow -ve to +ve. Use signed comparision
L2:*RRTC_0; *SHS_1
*ICP_T; *JCC_4,<L2>
*J_<L3>
L1:*RRTC_0; *SHS_1
*UCP_T; *JCC_4,<L1>
L3:*MPSR_B ; ! reset program mask
END
INTEGERFN STOI(STRINGNAME S)
STRING (50) P
INTEGER SIGN,AD,I,J,HEX
LONGINTEGER TOTAL
HEX=0; TOTAL=0; SIGN=1
AD=ADDR(P)
->NULLS IF S=""
L1: I=CHARNO(S,1); ! first char
IF I=' ' THEN S->(" ").S AND ->L1; ! chop leading spaces
IF I='-' THEN S->("-").S AND SIGN=-1 AND ->L1
IF I='X' THEN S->("X").S AND HEX=1 AND ->L1
P=S
UNLESS S->P.(" ").S THEN S=""
I=1
WHILE I<=BYTEINTEGER(AD) CYCLE
J=BYTE INTEGER(I+AD)
->FAULT UNLESS '0'<=J<='9' OR (HEX#0 AND 'A'<=J<='F')
IF HEX=0 THEN TOTAL=10*TOTAL ELSE TOTAL=TOTAL<<4+9*J>>6
TOTAL=TOTAL+J&15; I=I+1
REPEAT
IF HEX#0 AND I>9 THEN ->FAULT
J<-TOTAL
IF I>1 THEN RESULT =SIGN*J
FAULT: S=P." ".S
NULLS: RESULT =X'80808080'
END
ROUTINE KTIME(INTEGERNAME H,M,S,INTEGER DAYSECS)
*LSS_DAYSECS; *IMDV_60; *IMDV_60
*ST_(H); *LSD_TOS
*STUH_(S)
*ST_(M)
END
ROUTINE KDATE(INTEGERNAME D,M,Y,INTEGER K)
!***********************************************************************
!* K is days since 1st Jan 1900. Returns D:M:YY *
!***********************************************************************
INTEGER W
! k=k+693902; ! days since CAESARS bday
! W=4*K-1
! Y=W//146097
! K=W-146097*Y
! D=K//4
! K=(4*D+3)//1461
! D=4*D+3-1461*K
! D=(D+4)//4
! M=(5*D-3)//153
! D=5*D-3-153*M
! D=(D+5)//5
! Y=K
*LSS_K; *IAD_693902
*IMY_4; *ISB_1; *IMDV_146097
*LSS_TOS ; *IDV_4; *IMY_4; *IAD_3
*IMDV_1461; *ST_(Y)
*LSS_TOS ; *IAD_4; *IDV_4
*IMY_5; *ISB_3; *IMDV_153
*ST_(M); *LSS_TOS
*IAD_5; *IDV_5; *ST_(D)
IF M<10 THEN M=M+3 ELSE M=M-9 AND Y=Y+1
END
INTEGERFN KDAY(INTEGER D,M,Y)
IF M>2 THEN M=M-3 ELSE M=M+9 AND Y=Y-1
RESULT =1461*Y//4+(153*M+2)//5+D+58
END
ROUTINE SETAD(INTEGER VALUE,AD)
!***********************************************************************
!* Sets two byte at AD &AD+1 to value in character form *
!***********************************************************************
*LSS_VALUE; *IMDV_100; ! in case >100
*LSS_TOS ; *IMDV_10
*USH_8; *IAD_TOS ; *IAD_X'3030'; ! to ASCII chars
*LDTB_X'58000002'; *LDA_AD; *ST_(DR )
END
ROUTINE TIMEEVAL(INTEGER FLAG)
!***********************************************************************
!* Evaluate date&time from RTC and display to operator for corrn *
!* must allow for any old rubbish in RTC on IPL ! *
!***********************************************************************
INTEGER D,M,Y,HR,MIN,SEC,JDAY,DAYSECS,AD,ISA,RTC1,RTC2
CONSTLONGINTEGER MILL=1000000,SECSIN24HRS=86400
*RRTC_0; *ST_RTC1
IF RTC1&1#RTC2>>31 START ; ! guard bit indicates oflow
ISA=COM_CLKX
*LSS_RTC1; *UAD_1; ! overflow has happened here
*ST_RTC1
*LB_ISA; *ST_(0+B )
FINISH
RTC2=RTC2<<1
*LSD_RTC1
*JAT_5,<OK>; ! check for -ve
*LSD_0
OK: *IDV_MILL; *IMDV_SECSIN24HRS
*STUH_B ; *ST_JDAY
*LSS_TOS ; *ST_DAYSECS
COM_TOJDAY=JDAY
KDATE(D,M,Y,JDAY)
KTIME(HR,MIN,SEC,DAYSECS)
AD=ADDR(COM_DATE1)
SETAD(D,AD)
SETAD(M,AD+3)
SETAD(Y,AD+6)
SETAD(HR,AD+12)
SETAD(MIN,AD+15)
SETAD(SEC,AD+18)
IF FLAG#0 THEN C
OPMESS("DT=".STRING(AD-1)." ".STRING(AD+11))
END
EXTERNALROUTINE PARSE COM(INTEGER SRCE,STRINGNAME S)
!***********************************************************************
!* Transcribe a command to a PON message and PON it *
!***********************************************************************
INTEGERFNSPEC TAPEPLACE(INTEGERNAME A, B, C
STRINGNAME S, INTEGER F)
INTEGERFNSPEC DISCPLACE(INTEGERNAME A, B, C
STRINGNAME S, INTEGER F)
INTEGERFNSPEC GET MNEM(STRINGNAME S)
OWNINTEGER SRCESERV
CONSTINTEGER LIMIT=24, COMREP=X'3E0000'
CONSTBYTEINTEGERARRAY PARAMS(1:LIMIT)=2,1,0,0,0,0,0,3,2,0,0,1,2,0,1(3),
2,2,2,1,2,2,0
IF SSERIES=YES START
CONSTSTRING (7)ARRAY COMMAND(1:LIMIT)="PON ","SRCE ","PLOT ",
"PLOD ","LABEL ","ILABEL ","FORMAT ","RREAD ",
"SLOAD ","DUMP ","PRIME ","POFFMON","KMON ",
"UNPLOT ","INH ","UNINH ","DIRVSN ","DT ",
"XDUMP ","REP ","ISR ","ISW ","SHOW ","DCU "
FINISH ELSE START
CONSTSTRING (7)ARRAY COMMAND(1:LIMIT)="PON ","SRCE ","PLOT ",
"PLOD ","LABEL ","ILABEL ","FORMAT ","RREAD ",
"SLOAD ","DUMP ","PRIME ","POFFMON","KMON ",
"UNPLOT ","INH ","UNINH ","DIRVSN ","DT ",
"XDUMP ","REP ","ISR ","ISW ","SHOW ","GPC "
FINISH
SWITCH SWT(1:LIMIT)
RECORD (PARMF) PP
INTEGERARRAY DATA(1:6)
INTEGER I, J, K, WORK, OP, D, M, Y, HR, MIN
CONSTINTEGER SECSIN24HRS=86400
LONGINTEGER L
STRING (40) P, Q
!
RETURN IF LENGTH(S) = 0; ! ignore null lines
!
PP=0
OP=SRCE>>8&7
P=S
IF LENGTH(P)>23 START ; ! split long lines
FOR I=23,-1,1 CYCLE
EXIT IF CHARNO(P,I)=' '
REPEAT
I=I-1
I=23 IF I=0
J=LENGTH(P)
LENGTH(P)=I
OPMESS2(OP,P)
LENGTH(P)=J-I
FOR K=1,1,J-I CYCLE
CHARNO(P,K)=CHARNO(P,K+I)
REPEAT
FINISH
OPMESS2(OP,P); ! log input line
!
FOR I=1,1,LIMIT CYCLE
->FOUND IF S->Q.(COMMAND(I)).P AND Q=""
REPEAT
ERR:
OPMESS2(OP,"????".S)
RETURN
!
FOUND: ! command recognised
J=PARAMS(I); ! (minimum) no of parameters
K=1
WHILE K<=J CYCLE
DATA(K)=STOI(P)
->ERR IF DATA(K)=X'80808080'
K=K+1
REPEAT
->SWT(I)
SWT(1): ! PON (variable params)
PP_DEST=DATA(1)<<16!DATA(2)
FOR K=0,1,5 CYCLE
I=STOI(P)
IF I=X'80808080' AND CHARNO(P,1)='"' C
AND P->("""").Q.("""").P START
STRING(ADDR(PP_P1)+4*K)=Q
K=K+LENGTH(Q)//4
FINISH ELSE INTEGER(ADDR(PP_P1)+4*K)=I
REPEAT
PP_SRCE=SRCESERV
POUT:
PKMONREC("OPER command",PP)
PON(PP)
RETURN
SWT(2): ! SRCE = srce serv no for PON
SRCESERV=DATA(1)
RETURN
SWT(3): ! PLOT T F D PGE NPAGES
PP_DEST=X'240000'; ! bulk mover
PP_SRCE=COMREP!SRCE&X'FF00'
->ERR UNLESS TAPEPLACE(PP_P2,PP_P3,P,1)=0
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,1)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'04020000'+I
PP_P6=M'PLOT'
->POUT
SWT(4): ! PLOD FD FP TD TP NP
PP_DEST=X'240000'
PP_SRCE=COMREP!SRCE&X'FF00'
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,1)=0
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,1)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'02020000'+I
PP_P6=M'PLOD'
->POUT
SWT(5): ! LABEL
SWT(6): ! ILABEL=IPL label
PP_DEST=X'230000'
PP_SRCE=0
PP_P1=GET MNEM(P)
->ERR IF PP_P1=0
->ERR UNLESS LENGTH(P)=6
STRING(ADDR(PP_P2))=P
PP_P4=I-5
PP_P5=M'DISC'
PP_P6=M'LABL'
->POUT
SWT(7): ! FORMAT MNEM LC UC LT UT
PP=0; PP_DEST=X'260000'
PP_P1=GET MNEM(P)
->ERR IF PP_P1=0
K=STOI(P)
IF K<0 THEN PP_P2=K ELSE PP_P2=K<<16!STOI(P)
K=STOI(P)
IF K<0 THEN PP_P3=K ELSE PP_P3=K<<16!STOI(P)
->POUT
SWT(8): ! RREAD removed 30th june 1980 (JM)
->ERR
SWT(9): ! SLOAD DEV PAGE(Chopsupe only)
IF COM_DATE2&X'FFFF'<M'78' THEN C
OPMESS2(OP,"Date&time not given") AND RETURN
PP=0; PP_DEST=X'3B0000'
PP_P1=DATA(1)
PP_P2=DATA(2)
->POUT
SWT(10): ! DUMP T D NPAGES
PP_DEST=X'240000'; PP_SRCE=COMREP
->ERR UNLESS TAPEPLACE(PP_P4,PP_P5,P,0)=0
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,0)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'02040000'+I
PP_P6=M'DUMP'
->POUT
SWT(11): ! PRIME T D NPAGES
PP_DEST=X'240000'; PP_SRCE=COMREP
->ERR UNLESS TAPEPLACE(PP_P2,PP_P3,P,0)=0
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,0)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'04020000'+I
PP_P6=M'PRME'
->POUT
SWT(12): ! POFFMON
POFFMON=DATA(1); RETURN
SWT(13): ! KMON
I=DATA(1)
J=DATA(2)
->ERR UNLESS 0<=J<=1
L=LENGTHENI(1)<<I
KMON=KMON&(L!!X'FFFFFFFFFFFFFFFF')
IF J=1 THEN KMON=KMON!L
COM_KMON=KMON
RETURN
SWT(14): ! UNPLOT
PP_DEST=X'240000'; ! bulk mover
PP_SRCE=COMREP!SRCE&X'FF00'
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,1)=0
->ERR UNLESS TAPEPLACE(PP_P4,PP_P5,P,1)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'02040000'+I
PP_P6=M'PLOT'
->POUT
SWT(15): ! INH
INHIBIT(DATA(1)); RETURN
SWT(16): ! UNINH
UNINHIBIT(DATA(1)); RETURN
SWT(17): ! DIRVSN
COM_DIRSITE=X'200'+(DATA(1)&3)*64
RETURN
SWT(18): ! DT DATE TIME
WORK=DATA(1); ! date
*LSS_WORK; *IMDV_100; *IMDV_100
*ST_D; ! days
*LSS_TOS ; *ST_M; ! months
*LSS_TOS ; *ST_Y; ! year
->ERR UNLESS 1<=D<=31 AND 1<=M<=12 AND Y>=77
J=KDAY(D,M,Y); ! days since 01/01/1900
!
WORK=DATA(2); ! time
*LSS_WORK; *IMDV_100
*ST_HR; ! hours
*LSS_TOS ; *ST_MIN; ! mins
->ERR UNLESS 0<=HR<=23 AND 0<=MIN<60
*LSS_J; *IMYD_SECSIN24HRS; *ST_L
L=(L+60*(60*HR+MIN))*1000000; ! microsecs since Jan 1900
I=COM_CLKX
*LB_I; *LSS_L; *ST_(0+B ); ! set clock X register
I=COM_CLKY; L=L>>1
*LB_I; *LSS_L+4; *ST_(0+B )
TIMEEVAL(0)
RETURN
SWT(19): ! XDUMP
DUMPTABLE(32,DATA(1),DATA(2))
RETURN
SWT(20): ! REP AT WITH
I=DATA(1)
*LDTB_X'18000004'; *LDA_I; *VAL_(LNB +1)
*JCC_7,<ERR>
J=INTEGER(I); INTEGER(I)=DATA(2)
OPMESS2(OP,STRHEX(DATA(2))." reps ".STRHEX(J))
RETURN
SWT(21): ! image store read
I=DATA(1); *LB_I
*LSS_(0+B ); *ST_J
OPMESS2(SRCE>>8&255,"IS ".STRHEX(I)."=".STRHEX(J))
RETURN
SWT(22): ! image store write
I=DATA(1); J=DATA(2)
*LB_I; *LSS_J; *ST_(0+B )
RETURN
SWT(23): ! SHOW VIRTADDR LENGTH
I=DATA(1); J=DATA(2)
IF J<=0 OR J>64 THEN J=64
*LDTB_X'18000000'
*LDB_J; *LDA_I
*VAL_(LNB +1)
*JCC_3,<ERR>
CYCLE
OPMESS(HTOS(I,4)." ".HTOS(INTEGER(I),8)." ". C
HTOS(INTEGER(I+4),8))
I=I+8; J=J-8
EXIT IF J<=0
REPEAT
RETURN
SWT(24): ! DCU/GPC <TEXT>
->ERR IF LENGTH(P)>23
PP_DEST=X'300001'
PP_SRCE=SRCE
STRING(ADDR(PP_P1))=P
->POUT
INTEGERFN GET MNEM(STRINGNAME S)
!***********************************************************************
!* Extract a device mnemonic from S returning the string remnant *
!***********************************************************************
INTEGER I, J
STRING (15) P
J=0
P=""
IF S->P.(" ").S AND LENGTH(P)=4 THEN STRING(ADDR(I)+3)=P
RESULT =J
END
INTEGERFN DISCPLACE(INTEGERNAME A, B, STRINGNAME S, C
INTEGER FLAG)
!***********************************************************************
!* Extract a disc no or label from S and set A&B in bulkmover format*
!* flag=0 if no page no expected(when page 0 assumed) *
!***********************************************************************
INTEGER I, J, K
STRING (63) P
I=STOI(S); B=0; K=0
IF I>=0 THEN A=I+M'ED00' AND ->PAGE
AGN:
RESULT =1 UNLESS S->P.(" ").S
->AGN IF P=""
RESULT =1 UNLESS LENGTH(P)=6
FOR I=0,1,5 CYCLE
BYTEINTEGER(ADDR(J)+I)=CHARNO(P,I+1)
REPEAT
A=J; B=K; ! 6 char vol label
PAGE:
IF FLAG#0 START
I=STOI(S)
IF I<0 THEN RESULT =1
B=B&X'FFFF0000'+I
FINISH
RESULT =0
END
INTEGERFN TAPEPLACE(INTEGERNAME A, B, STRINGNAME S, C
INTEGER FLAG)
!***********************************************************************
!* Extract a tape no or label from S and set A&B in bulkmover format*
!* flag=0 if no chap no expected (when 1 is assumed) *
!***********************************************************************
INTEGER I, J, K
STRING (63) P
I=STOI(S); B=1; K=1
IF I>=0 THEN A=X'0031006E'+I AND ->CHAP
AGN:
RESULT =1 UNLESS S->P.(" ").S
->AGN IF P=""
RESULT =1 UNLESS LENGTH(P)=6
STRING(ADDR(J))=P
A=J; B=K
CHAP:
IF FLAG#0 THEN START
I=STOI(S)
IF I<0 THEN RESULT =1
B=B&X'FFFFFF00'+I&255
FINISH
RESULT =0
END
END
ROUTINE COMREP(RECORD (PARMF)NAME P)
!***********************************************************************
!* This routine collects the replies from routines kicked by the *
!* operator using opcomm and parse *
!***********************************************************************
SWITCH SW(0:3)
->SW(P_DEST&15)
SW(0): ! bulk mover replies
IF P_P1=0 THEN OPMESS("Load OK") C
ELSE OPMESS("Load failed ".STRHEX(P_P1))
RETURN
SW(1): ! reply from deallocate tape
IF P_P2#0 THEN OPMESS("Dealloc fails - ".STRING(ADDR(P_P3)))
END
INTEGERFN HANDKEYS
INTEGER I
I=ISAS(ISAS PTR+HK OFFSET)
*LB_I; *LSS_(0+B ); *EXIT_-64
END
EXTERNALROUTINE SLAVESONOFF(INTEGER MASK)
!***********************************************************************
!* Turn off all slaves if MASK=0 *
!* Turn on all slaves if MASK=-1 *
!* or turn off and on slectively if MASK == a bitmask *
!***********************************************************************
ONOFF(SLAVES OFFSET,MASK)
END
ROUTINE ONOFF(INTEGER OFFSET,MASK)
INTEGER I,J,K
I=ISAS(ISAS PTR+OFFSET)
J=I>>16; I=I&X'FFFF'
K=J!!(-1); J=J&(MASK!!(-1))
*LB_I; *LSS_(0+B )
*AND_K; *OR_J; *ST_(0+B )
END
EXTERNALROUTINE CONTROLLERDUMP(INTEGER CONTYPE,PT)
PRINTSTRING("CHOPSUPE can not dump PT=".HTOS(PT,2)."
")
END
EXTERNALROUTINE SEMALOOP(INTEGERNAME SEMA,INTEGER PARM)
!***********************************************************************
!* Loop till a SEMA comes free. Maxcount is large enough so that *
!* it is only invoked when another OCP has gone down holding a sema *
!***********************************************************************
CONSTINTEGER MAXCOUNT=64000
INTEGER I
FOR I=1,1,MAXCOUNT CYCLE
*INCT_(SEMA)
*JCC_7,<ON>
RETURN
ON: REPEAT
PRINTSTRING("
SEMA forced free at ".STRHEX(ADDR(SEMA)))
SEMA=0
END
IF SSERIES=YES START
EXTERNALROUTINE RETRY REPORTING(INTEGER PARM)
!*
!* Turn retry reporting on or off
!*
ONOFF(INH REPS OFFSET,PARM)
END
EXTERNALINTEGER DCU RFLAG=0; ! GDC reconnects DCU1 streams if non-zero
EXTERNALROUTINE DCU1 RECOVERY(INTEGER PARM)
PRINTSTRING("CHOPSUPE cannot recover DCU1s
")
END
ROUTINE LIGHTS(INTEGER PATTERN)
!*********************************************************************
!* Display 'PATTERN' on the SCP monitor *
!*********************************************************************
*LB_X'6016'
*LSS_PATTERN
*ST_(0+B )
END
FINISH
ENDOFFILE