.
. ELEMENT SELECT ROUTINES
.
.
. (C) Copyright 1972-1978 John Walker
.
. This software is in the public domain
.
AXR$
DEFUNCT$
FANG
.
PURE CODE
.
. ELEMENT SELECT SUBROUTINE
.
. LX,U X5,<ELEMENT CLASS PACKET>
. LX,U X6,<ELEMENT FIND PACKET>
. LMJ X11,SELECT
. <DIDN'T CHOOSE IT>
. <CHOSE IT>
.
SELECT* TZ ELALL,X5 ALL ELEMENTS SELECTED ?
J 1,X11 YES. MARK THIS ONE SELECTED
TNZ ELTBIT,X5 ANY TYPES SPECIFIED ?
J SELNOT NO. DON'T APPLY TYPE SELECTION RULES
LMJ A0,TBITS COMPUTE TYPE SELECTION BITS FROM TYPE
AND A1,ELTBIT,X5 AND WITH TYPE SELECTION
JZ A2,,X11 DESELECT IF NOT VALID TYPE
.
. CHOSEN ON BASIS OF TYPE. CHECK NAME AND VERSION
.
SELNOT DL A1,ELELTN,X5 LOAD ELEMENT NAME
DL A4,EIEN,X6 LOAD ELEMENT NAME OF VICTIM
LMJ A0,NAMCOMP COMPARE NAMES
J 0,X11 DESELECT IF NO MATCH
DL A1,ELTVERN,X5 LOAD VERSION OF ELEMENT
DL A4,EIVER,X6 LOAD VERSION MASK
LMJ A0,NAMCOMP COMPARE NAMES
J 0,X11 RETURN IF NO MATCH
J 1,X11 AHA!! WE FOUND IT
.
. NAME COMPARISON SUBROUTINE
.
NAMCOMP LR,U R1,11 LOAD LENGTH OF NAME
NMCP2 AND,U A2,077 GET A CHARACTER OF MASK
TNE,U A3,'*' IS IT THE SELECT ANYTHING FLAG ?
J NMCP1 YES. DON'T EXAMINE NAME
AND,U A5,077 EXTRACT CHARACTER FROM NAME
TE A3,A6 MATCH ?
J 0,A0 NO. NAMES DON'T MATCH
NMCP1 DSC A1,6 MOVE NEXT CHARACTERS
DSC A4,6 ...INTO POSITION
JGD R1,NMCP2 DO FOR ALL CHARACTERS
J 1,A0 RETURN TO SELECTED EXIT
.
. COMPUTE TYPE SELECTION BITS
.
TBITS LA,U A1 CLEAR BITS ACCUMULATOR
LA A2,EITYP,X6 LOAD MAJOR ELEMENT TYPE
TG,U A2,GTTYPE+1 ILLEGAL TYPE ON ELEMENT ?
J 0,A0 NO. RETURN WITH NO TYPE
LA,U A1,1 LOAD A BIT
ANA,U A2,1 SUBTRACT ONE FROM THE TYPE
LSSL A1,,A2 FORM BASE TYPE
TE,U A2,TY$SYM-1 IS IS SYMBOLIC ?
J 0,A0 NO. RETURN SIMPLY MAJOR TYPE
LA A2,EIPCOD,X6 LOAD PROCESSOR CODE
LA,U A3,1*/GTTYPE LOAD BIT FOR ZERO PROCESSOR CODE
LSSL A3,,A2 SHIFT BY PROCESSOR CODE
AA A1,A3 ADD PROCESSOR CODE TO TYPE
J 0,A0 RETURN
.
. LOOK UP TYPE MNEMONIC
.
. LA A0,<TYPE NAME>
. LMJ X11,SELTLU
. <NO FIND>
. <normal return> A1 = numeric type code
. A2 = selection bits for type
.
seltlu* sa a0,a2 save original parameter
AND A0,(0777777770000) GET FIRST 4 CHARACTERS
TNE A1,('ASMP@@') ASM PROC MNEMONIC ?
LA A0,('APR ') YES. CHANGE TO OURS
TNE A1,('COBP@@') COBOL PROC ?
LA A0,('CPR ') YES. FIX IT
TNE A1,('FORP@@') FORTRAN PROC ?
LA A0,('FPR ') YES. CHANGE TO OURS
SSL A0,18 TAKE ONLY THE FIRST THREE LETTERS
LR,U R1,SELTBL LOAD LENGTH OF SELECT TABLE
LA A1,(2,SELTAB) GET TABLE POINTER
SE,H2 A0,,*A1 SEARCH FOR NAME
J seltst go try standard types of not one of ours
ANA,U A1,2 BACK UP TO POINT TO ENTRY
la a2,1,a1 load selection bits for type
la,h1 a1,,a1 load numeric type code
J 1,X11 RETURN TO NORMAL EXIT
.
. The type specification was not one of our special ones. Search the
. table of standard system types (SSTYP$) for the subtype.
.
seltst lr,h2 r1,sstyp$ load length of type list
jgd r1,$+1 decrement it for search
la a1,(1,0) load pointer to search table
se a2,sstyp$+1,*a1 look for type in table
j 0,x11 not found. take error return
la,u a2,1*/(gttype-1) load bit for selection
lssl a2,,a1 shift bit to proper position
ah a1,(-1,010000-1) form numeric type identifier in A1
j 1,x11 take normal return to caller
.
.
PURE DATA
.
. SELECTION BIT DEFINITION
.
P PROC 1,2
SELBIT* NAME 0
* P(1,2)+010000*P(1,*2),P(1,1) NUMERIC TYPE, NAME
A(0) EQU 0 CLEAR ACCUMULATOR OF BITS
SELP* PROC 0
DO P(1,*I+1)=0 ,A*(0) EQU A(0)++1*/(P(1,I+1)-1)
DO P(1,*I+1) ,A*(0) EQU A(0)++1*/(GTTYPE+P(1,I+1))
END
I DO P(1)-1 , SELP
* A(0)
END
.
.
SELTAB* .
SELBIT 'SYM',1,2,3,4 ALL SYMBOLICS
SELBIT 'PRO',2,3,4 ALL PROCS
SELBIT 'APR',2 ASM PROCS
SELBIT 'CPR',3 COBOL PROCS
SELBIT 'FPR',4 FORTRAN PROCS
SELBIT 'REL',5 RELOCATABLE
SELBIT 'ABS',6 ABSOLUTE
SELBIT 'OMN',7 OMNIBUS
.
SELBIT 'UNT',*0 UNTYPED SYMBOLIC
SELBIT 'ASS',*2 SYMBOLIC ASSEMBLY
SELTBL* EQU ($-SELTAB)/2
END