{{htmlmetatags>metatag-description:(ICL George 3 and George 4 source: LISTAST867)}}
====== LISTAST867 ======
(George Source)
**Macros used:** [[george:macro:ACROSS|ACROSS]], [[george:macro:AND|AND]], [[george:macro:APPEND|APPEND]], [[george:macro:APROPNAME|APROPNAME]], [[george:macro:GEOERR|GEOERR]], [[george:macro:HUNT2OPT|HUNT2OPT]], [[george:macro:LGEOG|LGEOG]], [[george:macro:MASK|MASK]], [[george:macro:MENDAREA|MENDAREA]], [[george:macro:MHUNTW|MHUNTW]], [[george:macro:MXB|MXB]], [[george:macro:OR|OR]], [[george:macro:PROPERTY|PROPERTY]], [[george:macro:SEGENTRY|SEGENTRY]], [[george:macro:SETNCORE|SETNCORE]], [[george:macro:TESTREP|TESTREP]], [[george:macro:TRACE|TRACE]], [[george:macro:VFREE|VFREE]]
22FL #OPT K0LISTAST=0
22^= ...#SEG LISTAST [LEN WAGSTAFF
2394 ...# COPYRIGHT INTERNATIONAL COMPUTERS 1982
23DW #LIS K0LISTAST>K0ALLGEO>K0GREATGEO>K0COMMAND
23YG 8HLISTAST
24D6 #OPT K6LISTAST=K6ALLGEO
24XQ #
25CB #
25X2 # THIS SEGMENT LISTS THE ATTRIBUTIONS AND ASSOCIATIONS OF LINES
26BL # AND IDENTIFIERS IN THE IDF. THE SEGMENT IS ENTERED FROM SEGMENT
26W= # LISTIDF, AND EXPECTS SYSTEM.PROPERTIES TO BE OPEN AT LEVEL 2,
27*W # THE OUTPUT FILE AT LEVEL 1, AND THE IDF AT LEVEL 0.
27TG #
28*6 #
28SQ #
29#B SEGENTRY K1LISTAST,X1LISTAST
29S2 #
2=?L #
2=R= WLINE 4H----
2?=W THEAD 32HATTRIBUTIONS AND ASSOCIATIONS
2?QG TSUB 16HCONSOLE PROPERTY
2#=6 XLIN 4HLINE
2#PQ ...ZIDEN 12HIDENTIFIER
2*9B ZOTH 8H OTHER
2*P2 UNIT 4H MX
2B8L 4H UX
2BN= 4H CC
2C7W 4H CI
2CMG XIDEN 4H I
2D76 XLF 4H,LF
2DLQ XTP 4H*TP
2F6B XLP 4H*LP
2FL2 XCP 4H*CP
2G5L SUNIT 4HLP
2GK= 4HCR
2H4W 4HTW
2HJG 4HTR
2J46 4HTP
2JHQ XCON +10000
2K3B MASK #77000000
2KH2 SPD 12HASSOCIATIONS
2L2L XMESS 40HNO CURRENT ATTRIBUTIONS OR ASSOCIATIONS
2LG= X1LISTAST
2L^W CALL 7 SETUP [CALL ROUTINE TO SET UP FAPB
2MFG SMO FX1 [X1 POINTS TO FAPB
2M^6 LDN 4 THEAD
2NDQ LDN 5 #51
2NYB STO 5 A1+1(1) [STORE NEW PAGE CONTROL
2PD2 LDN 5 A1+13(1)
2PXL MOVE 4 8 [MOVE IN TITLE LINE
2QC= CALL 7 WRITE [WRITE TITLE LINE AWAY
2QWW SMO FX1
2RBG LDX 0 WLINE
2RW6 STO 0 A1+13(1)
2S*Q LDN 5 A1+13(1)
2STB LDN 6 A1+14(1) [AND UNDERLINE IT
2T*2 MOVE 5 6
2TSL DCH 0 A1+20(1)
2W#= LDN 0 #41
2WRW STO 0 A1+1(1)
2X?G CALL 7 WRITE
2XR6 SMO FX1
2Y=Q LDN 5 TSUB
2YQB LDN 6 A1+12(1)
2^=2 MOVE 5 4 [MOVE IN SUB-TITLE
2^PL SMO FX1
329= LDN 5 ZOTH
32NW LDN 6 A1+18(1)
338G MOVE 5 2
33N6 CALL 7 WRITE [WRITE SUB-TITLE LINE AWAY
347Q LDN 5 #41 [SET UP FAPB
34MB STO 5 A1+1(1) [STORE PFFC
3572 SMO FX1
35LL LDN 5 THEAD
366= LDN 6 A1+12(1)
36KW MOVE 5 3
375G SMO FX1
37K6 LDN 5 THEAD
384Q LDN 6 A1+18(1)
38JB MOVE 5 3
3942 SMO FX1
39HL LDN 5 SPD
3=3= LDN 6 A1+22(1)
3=GW MOVE 5 3
3?2G CALL 7 WRITE [WRITE LAST TITLE LINE AWAY
3?G6 SMO FX1
3?^Q LDX 0 WLINE
3#FB STO 0 A1+12(1)
3#^2 STO 0 A1+18(1)
3*DL STO 0 A1+22(1)
3*Y= LDN 0 #41
3BCW STO 0 A1+1(1) [ &
3BXG LDN 5 A1+12(1)
3CC6 LDN 6 A1+13(1)
3CWQ MOVE 5 3 [ UNDERLINE THEM
3DBB LDN 5 A1+18(1)
3DW2 LDN 6 A1+19(1)
3F*L MOVE 5 2 [ ALL
3FT= LDN 5 A1+22(1)
3G#W LDN 6 A1+23(1)
3GSG MOVE 5 2
3H#6 CALL 7 WRITE
3HRQ #
3J?B # MAIN ROUTINE
3JR2 #
3K=L LDX 0 GSIGN [SET "NO ATTRIBS OR ASSOCS FOUND YET"
3KQ= ORS 0 A1+1(1) [MARKER
3L9W LDX 2 FX2
3LPG LDN 0 0
3M96 CALL 7 XMXB [GET POINTER TO IDF BASE CELL
3MNQ LDX 3 BUNIT(3) [LOAD BASE OF UNIT CHAIN
3N8B STO 3 AWORK1(2) [STORE IT IN AWORK1
3NN2 #
3P7L # INITIALISATION NOW COMPLETE. WE NOW ENTER THE MAIN ROUTINE
3PM= # FOR MULTIPLEXORS AND UNIPLEXORS
3Q6W #
3QLG ZUNIT [UNIT CHAIN LOOP
3R66 ZJPQ
3RKQ LDX 4 AWORK1(2) [RESTORE UNIT CHAIN POINTER
3S5B BZE 4 UNITEND [BR IF NO MORE UNITS
3SK2 CALL 7 SPACES
3T4L LDX 0 4
3TJ= CALL 7 XMXB [ACCESS NEXT UNIT CELL FROM IDF
3W3W CALL 4 X659
3WHG BRN ZJPQ
3X36 LDX 4 BTYPE(3)
3XGQ LDN 2 0
3Y2B LDCH 5 4(2) [LOAD UNIT TYPE
3YG2 SBN 5 10
3Y^L BZE 5 ZUPX [BRANCH IF UNIPLEXOR
3^F= SMO FX1
3^YW LDX 0 UNIT [LOAD UNIT NAME (MPX)
42DG STO 0 A1+3(1) [STORE IT IN FAPB
42Y6 SMO FX1
43CQ LDX 0 XLIN
43XB STO 0 A1+6(1) [STORE "LINE" IN FAPB
44C2 BRN XNORM [JUMP OVER UNIPLEXOR
44WL ZUPX
45B= SMO FX1
45TW LDX 0 UNIT+1
46*G STO 0 A1+3(1) [MOVE IN UNIT NAME (UPK)
46T6 XNORM
47#Q LDN 5 #7777
47SB ANDX 5 4 [GEOG NO. TO X5
48#2 ADN 1 A1+4
48RL CALL 7 XCBD [CONVERT TO DECIMAL AND STORE
49?= SBN 1 A1+5
49QW LDX 0 BLINE(3) [STORE POINTER TO LINE CHAIN
4==G SMO FX2
4=Q6 STO 0 AWORK2 [IN AWORK2
4?9Q ZLINE [LINE CHAIN LOOP
4?PB LDX 2 FX2
4#92 LDX 0 ACES [OVERWRITE VARIABLE DETAILS OF
4#NL STO 0 A1+7(1)
4*8= LDN 4 A1+7(1) [ OUTPUT LINE WITH
4*MW LDN 5 A1+8(1)
4B7G MOVE 4 3 [ SPACES
4BM6 LDX 0 AWORK2(2)
4C6Q BZE 0 ZUNIT
4CLB CALL 7 XMXB [ACCESS NEXT LINE CELL
4D62 LDX 0 0(3) [LOAD NEXT LINE CELL POINTER
4DKL STO 0 AWORK2(2) [STORE IN AWORK2
4F5= LDX 0 BLINE(3) [LOAD BASE OF 7020 CHAIN
4FJW STO 0 AWORK3(2) [STORE IN AWORK3
4G4G LDX 0 A1+6(1)
4GJ6 SBX 0 ACES [TEST FOR UNIPLEXOR
4H3Q BZE 0 PUPX
4HHB LDX 5 BNO(3) [MPX - LOAD LINE NUMBER
4J32 ADN 1 A1+7
4JGL CALL 7 XCBD [CONVERT AND STORE
4K2= SBN 1 A1+8 [RESET POINTER
4KFW PUPX
4K^G LDX 0 BASS(3) [LOAD POINTER TO ASSOCIATE CELL AND
4LF6 STO 0 AWORK4(2) [STORE IN AWORK4
4LYQ LDX 4 BATT(3) [PTR TO ATT CELL TO X4
4MDB ADX 0 4
4MY2 BZE 0 X7020 [BR IF NO ASS OR ATT ON THIS LINE
4NCL CALL 6 XLASAT [LIST ASS. AND ATT. FOR THIS LINE
4NX= X7020 [7020 LOOP
4PBW LDX 0 AWORK3(2) [LOAD NEXT 7020 CELL POINTER
4PWG BZE 0 ZLINE [NO MORE 7020'S ON THIS LINE
4QB6 CALL 7 XMXB [ACCESS NEXT 7020 CELL
4QTQ LDX 0 0(3)
4R*B STO 0 AWORK3(2) [STORE NEXT 7020 CELL PTR IN AWORK3
4RT2 SMO FX1
4S#L LDX 0 XIDEN [INSERT CHAR "I" IN FAPB
4SS= STO 0 A1+8(1)
4T?W LDX 0 BNO(3)
4TRG SRL 0 12
4W?6 SLL 0 12 [IDENTIFIER TO L.H.S. OF X0
4WQQ LDX 4 BTYPE(3)
4X=B ANDN 4 #77 [GET INTERFACE NO
4XQ2 SLL 4 6 [MOVE UP FOR INSERTION IN FAPB
4Y9L ADN 4 #34 [INSERT ","
4YP= ADX 0 4 [AMALGAMATE WITH IDENTIFIER & STORE
4^8W STO 0 A1+9(1) [IN FAPB
4^NG LDN 2 0
5286 SMO 3
52MQ LDCH 0 BTYPE(2) [LOAD DEVICE TYPE INTO X0
537B LDX 2 FX1
53M2 SMO 0
546L LDX 4 SUNIT-1(2) [LOAD RELEVANT CHARS. INTO X4
54L= SBN 0 3
555W LDX 2 FX2
55KG BNZ 0 XNCON [BR IF NOT CONSOLE TW
5656 LDX 0 BTYPE+1(3) [OBTAIN INTERFACE NO. OF OTHER
56JQ ANDN 0 #77 [HALF OF CONSOLE TW
574B SBN 4 #20
57J2 ADX 4 0 [AND INSERT IT
583L XNCON
58H= STO 4 A1+10(1) [PUT LINE IN FAPB
592W LDX 4 BASS(3) [LOAD POINTER TO ASSOC. CELL AND
59GG STO 4 AWORK4(2) [STORE IT IN AWORK4
5=26 LDX 0 4
5=FQ LDX 4 BATT(3) [LOAD PTR. TO ATT. CELL INTO X4
5=^B ADX 0 4
5?F2 BZE 0 X7020 [BR IF NO ASS OR ATT ON THIS 7020
5?YL CALL 6 XLASAT [LIST ASSOCS. AND ATTS.
5#D= BRN X7020 [GO BACK DOWN 7020 CELL
5#XW UNITEND [END OF MPX/UPX CHAIN
5*CG #
5*X6 # NOW TO DO 7900'S
5BBQ #
5BWB LDX 2 FX2
5CB2 STOZ ACOMMUNE3(2)
5CTL LDX 3 FX2
5D*= MXB 3 [ACCESS IDF BASE CELL
5DSW LDX 0 BIPB(3) [LOAD BASE OF 7900 CHAIN
5F#G STO 0 AWORK1(2) [STORE IT IN AWORK1
5FS6 X7900 [7900 LOOP
5G?Q XMIPB
5GRB LDX 4 AWORK1(2) [LOAD PTR TO NEXT 7900 CELL
5H?2 BZE 4 XNO7900 [NO MORE 7900'S
5HQL CALL 7 SPACES [BPACEFILL FAPB
5J== LDX 0 4
5JPW CALL 7 XMXB [GET NEXT 7900 CELL
5K9G LDX 0 BTYPE(3) [GEOG.NO
5KF# ... ANDN 0 #7777
5KP6 BNZ 0 XNOTCI [J. IF NOT CI
5L8Q SMO FX1
5LNB LDX 0 UNIT+3 [INSERT "CI" IN FAPB
5M82 STO 0 A1+3(1)
5MML LDX 0 CIPROPNO(3) [CONVERT PROPNO.
5N7= ANDX 0 BITS22LS [INTO NAME
5NLW APROPNAME 0,1,NOPR
5P6G MHUNTW 1,FILE,FAPB [APROPNAME COORS
5PL6 LDN 4 ACOMMUNE1(2) [PUT NAME IN FAPB
5Q5Q LDCT 5 #400
5QKB ORN 5 A1+4(1)
5R52 MVCH 4 12
5RJL LDN 0 #2020 [CUPLA SPACES
5S4= ORS 0 A1+7(1)
5WGB LDX 0 AWORK1(2) [RE-HUNT IDF CELL
5X22 CALL 7 XMXB
5X78 ... LDX 0 0(3) [PT TO NEXT IPB CELL
5X#B ... STO 0 AWORK1(2)
5XFL BRN XCCCI [BACK TO COMMON PATH
5X^= XNOTCI
5YDW CALL 4 X659
5YYG BRN XMIPB
5^D6 SMO FX1
5^XQ LDX 0 UNIT+2 [INSERT CHARS "CC" IN FAPB
62CB STO 0 A1+3(1)
62X2 LDN 5 #7777
63BL ANDX 5 BTYPE(3) [ACCESS GEOG. NO
63W= ADN 1 A1+4
64*W CALL 7 XCBD [CONVERT TO DECIMAL AND
64TG SBN 1 A1+5 [STORE IT
67?L XCCCI
67BQ ... SMO FX1 [STORE "IDENTIFIER"
67FW ... LDN 4 ZIDEN
67K2 ... LDN 5 A1+8(1)
67N6 ... MOVE 4 3
67R= LDX 0 BLINE(3) [LOAD POINTER TO IDENTIFIER CELL
68=W STO 0 AWORK2(2) [& STORE IT IN AWORK2
68QG LDX 4 BASS(3) [LOAD ASSOC CELL POINTER
69=6 STO 4 AWORK4(2) [& STORE IT IN AWORK4
69PQ LDX 0 4
6=9B LDX 4 BATT(3) [ATT CELL POINTER TO X4
6=P2 ADX 0 4
6?8L BZE 0 YIDEN [BR IF NO ASS OR ATT ON THIS CELL
6?N= CALL 6 XLASAT [LIST ASS AND ATT.
6#7W YIDEN [IDENTIFIER CHAIN LOOP
6#MG LDX 2 FX2
6*76 LDX 0 AWORK2(2) [RESTORE CELL POINTER
6*LQ BZE 0 X7900 [END OF IDENTIFIER CHAIN
6B6B CALL 7 XMXB [ACCESS NEXT IDENTIFIER CELL
6BL2 LDX 5 BNO(3) [LOAD IDENTIFIER NO INTO X5
6BS= ... ADN 1 A1+10
6C2G ... BCHX 1 £
6C8Q ... BCHX 1 £
6CC2 ... BCHX 1 £
6CK= CALL 7 XCBD [CONVERT AND STORE
6CXM ... SBN 1 A1+11
6D=4 ... ANDX 1 BITS22LS
6DJG LDX 0 0(3) [STORE POINTER TO NEXT IDENTIFIER
6F46 STO 0 AWORK2(2) [CELL IN AWORK2
6FHQ LDX 0 BASS(3) [LOAD POINTER TO ASSOC CELL
6G3B STO 0 AWORK4(2) [& STORE IT IN AWORK4
6GH2 LDX 4 BATT(3) [LOAD POINTER TO ATT CELL
6H2L ADX 0 4
6HG= BZE 0 YIDEN [BR IF NO ASS OR ATT ON THIS IDEN
6H^W CALL 6 XLASAT [LIST ASS AND ATT
6JFG BRN YIDEN
6J^6 XNO7900
6KDQ MHUNTW 3,FILE,FAPB
6KYB LDX 0 A1+1(3) [TEST IF "NO ASSOCS OR ATTRIBS"
6LD2 BPZ 0 XAC [MARKER SET, AND BR IF NOT
6LXL SMO FX1
6MC= LDN 4 XMESS
6MWW LDN 5 A1+3(3)
6NBG MOVE 4 10 [MOVE IN MESSAGE
6NW6 CALL 7 WRITE [WRITE BLOCK AWAY
6P*Q XAC
6PTB VFREE FILE,FAPB
6Q*2 ACROSS LISTPROP,1
6QSL ZFULL [FILEFULL ERROR LABEL
6R#= GEOERR 1,LIFFULL
6RRW YERR [MASTER FAPB LOST IN XLASAT
6S?G GEOERR 1,FAPBLOST
6SR6 NOPR
6T=Q GEOERR 1,LOSTPROP
6TQB WRITE
6W=2 #
6WPL # THRS SUBROUTINE IS AN EXTENSION TO THE SUBROUTINE SETUP TO APPEND
6X9= # A FILE/FAPB, AND TO TEST THE REPLY AND THEN FREE RT
6XNW #
6Y8G SBX 7 FX1
6YN6 APPEND 2,XREFU [WRITE LINE AWAY
6^7Q TESTREP REFUSED,XREFU
6^MB TESTREP FILEFULL,ZFULL [TEST REPLY
7272 MHUNTW 1,FILE,FAPB [HUNT FAPB (POINTER IN X1)
72LL LDX 2 FX2
736= BRN XWRIT
73KW SETUP
745G SBX 7 FX1 [RELATIVISE LINK
74K6 LDX 2 FX2
754Q SETNCORE 32,1,FILE,FAPB [SET UP AN APPEND BLFCK
75JB XWRIT
7642 LDN 5 32
76HL STO 5 A1(1) [STORE WORDCOUNT
773= LDN 5 #42 [PFFC
77GW STO 5 A1+1(1)
782G BRN X1
78G6 SPACES
78^Q # THIS SECTION SPACEFILLS THE FAPB
79FB SBX 7 FX1
79^2 MHUNTW 1,FILE,FAPB
7=DL X1
7=Y= LDX 5 ACES
7?CW STO 5 A1+2(1)
7?XG LDN 5 A1+2(1) [SPACEFILL FAPB
7#C6 LDN 6 A1+3(1)
7#WQ MOVE 5 29
7*BB ADX 7 FX1 [REFIX LINK
7*W2 EXIT 7 0
7B*L XREFU ACROSS LISTSTAR,30
7BT= XCBD [CONVERT BINARY TO DECIMAL AND
7C#W LDN 6 0 [STORE IN ADDRESS HELD IN X1
7CSG SMO FX1
7D#6 DVR 5 XCON [NUMBER TO BE CONVERTED IN X5
7DRQ LDX 5 6
7F?B LDCT 6 #200
7FR2 MODE 1 [SET ZERO SUPPRESSION MODE
7G=L LDN 0 4 [4 CHARACTERS TO CONVERT
7GQ= XBDC
7H9W CBD 5 0(1) [X1 HOLDS DESTINATION ADDRESS
7HPG BCHX 1 £
7J96 BCT 0 XBDC
7JNQ EXIT 7 0
7K8B XMXB [SUBROUTINE ACCESSES A RECORD IN THE
7KN2 # [IDF WHOSE POINTER IS IN ACOMMUNE3
7L7L SBX 7 FX1 [AND GIVES A POINTER TO IT (IN CORE)
7LM= LDX 3 FX2 [IN X3
7M6W LDX 4 0
7MLG #SKIP K6LISTAST>199$199
7N66 TRACE 4,CELLPTR
7NKQ SLL 0 1 [REMOVE BIT 0
7P5B SRL 0 10 [RECORD POINTER TO X0
7PK2 STO 0 ACOMMUNE3(3)
7Q4L MXB 3 [ACCESS RECORD
7QJ= ANDN 4 #777 [MASK IN CELL POINTER
7R3W ADX 3 4 [CELL(CORE) POINTER IN X3
7RHG MHUNTW 1,FILE,FAPB [PRESERVE POINTER TO FAPB IN X1
7S36 ADX 7 FX1
7SGQ EXIT 7 0
7T2B XLASAT [SUBROUTINE LISTS THE ASSOCIATIONS
7TG2 # AND ATTRIBUTIONS CONTAINED IN THE CELLS POINTED AT BY
7T^L # AWORK4 (ASSOC) AND X4 (ATT).AN FAPB IS EXPECTED, HOLDING
7WF= # DETAILS TO BE PRINTED ON THE FIRST LINE. THIS BLOCK IS
7WYW # PRESERVED. AN ADATA CSTORE BLOCK IS CREATED TO HOLD THE
7XDG # TWO CELLS IN THE FIRST INSTANCE
7XY6 SMO FX2
7YCQ LDX 3 AWORK4 [RESTORE ASSOC. CELL POINTER
7YXB SBX 6 FX1 [LINK IN X6
7^C2 SMO FX2
7^WL STO 6 AWORK4 [STORE LINK
82B= CALL 7 SETUP [SET UP SUBS. FAPB BLOCK
82TW LDX 2 1 [SUBS. FAPB PTR. TO X2
83*G HUNT2OPT 1,FILE,FAPB [PTR. TO MASTER FAPB IN X1
83T6 BNG 1 YERR [IT'S NOT THERE
84#Q LDN 5 A1+2(1)
84SB LDN 6 A1+2(2)
85#2 ... MOVE 5 10 [MOVE IN UNIT DETAILS FROM MASTER
85RL LDX 5 3 [PRESERVE POINTER TO ASSOC. CELL
86?= SETNCORE 16,3,ADATA,CSTORE [GET ADATA/CSTORE BLOCK, PTR. IN X3
86QW LDX 0 5
87=G LDX 5 4 [POINTER TO ATT CELL TO X6
87Q6 BZE 0 XNOASS
889Q CALL 7 XMXB [GET ASSOCIATION CELL INTO CORE
88PB LDX 4 5
8992 MHUNTW 2,ADATA,CSTORE [FIND ADATA/CSTORE
89NL LDN 5 0(3)
8=8= LDN 6 A1(2)
8=MW MOVE 5 8 [MOVE ASSOC CELL INTO ADATA/CSTORE
8?7G BRN XQRL
8?M6 XNOASS [NO ASSOCIATIONS, SO ZEROISE 1ST 8
8#6Q LDX 4 5
8#LB STOZ A1(3) [WORDS OF ADATA/CSTORE
8*62 LDN 5 A1(3)
8*KL LDN 6 A1+1(3)
8B5= MOVE 5 7
8BJW LDX 2 3
8C4G XQRL
8CJ6 BZE 4 XNOATT [BR. IF NO ATTRIBUTIONS
8D3Q LDX 0 4
8DHB CALL 7 XMXB [ACCESS ATTRIBUTION CELL
8F32 MHUNTW 2,ADATA,CSTORE [FIND ADATA/CSTORE
8FGL LDN 5 0(3)
8G2= LDN 6 A1+8(2)
8GFW MOVE 5 8 [MOVE ATT CELL INTO ADATA/CSTORE
8G^G BRN YQRL
8HF6 XNOATT [NO ATTRIBUTIONS, SO ZEROISE LAST
8HYQ STOZ A1+8(2) [8 WORDS OF ADATA/CSTORE
8JDB LDN 5 A1+8(2)
8JY2 LDN 6 A1+9(2)
8KCL MOVE 5 7
8KX= YQRL
8LBW LDX 7 A1+8(2) [LOAD ATT CELL INTERNAL POINTER
8LWG BNG 7 XNOTFIN [BR. IF NO MORE ATTRIBUTIONS
8MB6 SMO 7
8MTQ LDX 6 A1+10(2) [LOAD ATTRIBUTION WORD
8N*B BNZ 6 ZETA
8NT2 BZE 7 XLMN
8P#L ZETA
8PS= BZE 6 ZNOATT [BR. IF NO MORE ATTRIBUTIONS
8Q?W CALL 5 XPROP [ACCESS PROPERTY NAME
8QRG LDN 5 A1+12(1)
8R?6 BZE 7 ZCONS [BR. IF CONSOLE PROPERTY
8RQQ ADN 5 6
8S=B ZCONS
8SQ2 MOVE 4 3 [MOVE IN PROPERTY
8T9L XLMN
8TP= LDX 0 7
8W8W ADN 7 1
8WNG STO 7 A1+8(2) [UPDATE POINTER
8X86 BZE 0 YQRL [LAST ATT WAS CONSOLE, SO GO AND DO
8XMQ SBN 0 5 [ANOTHER ONE
8Y7B BNZ 0 XZYW
8YM2 ZNOATT
8^6L NGS 1 A1+8(2) [NO MORE ATTRIBUTIONS: SET PTR -VE
8^L= XZYW
925W # NOW TO DO AN ASSOCIATION
92KG #
9356 LDX 7 A1(2) [LOAD INTERNAL ASSOC CELL POINTER
93JQ BNG 7 ZNOASS [BR. IF NO MORE ASSOCIATIONS
944B SMO 7
94J2 LDX 6 A1+2(2) [LOAD NEXT ASSOCIATE WORD
953L BZE 6 ZNOASS [BR. IF NO MORE
95H= SMO FX1 [MK.6 - ASSUME LF ASSOCIATED
962W LDX 4 XLF [MOVE CHARACTERS ",LF " INTO
96GG STO 4 A1+25(1) [FAPB
9726 ANDN 6 #3200 [MASK IN *LP,*TP*CP BITS
97FQ BNZ 6 ZOK
97^B GEOERR 1,IDF CLTP
98F2 ZOK
98YL LDX 3 FX1
99D= LDN 5 0
99XW SLL 6 13 [*TP BIT TO B0
9=CG BPZ 6 XNTP [BR IF NOT *TP ASSOCIATED
9=X6 LDX 0 XTP(3)
9?BQ STO 0 A1+26(1) [STORE *TP IN FAPB
9?WB ADN 5 1
9#B2 XNTP
9#TL SLL 6 1 [*LP BIT TTO B0
9**= BPZ 6 XNLP [BR IF NOT *LP ASSOCIATED
9*SW LDX 0 XLP(3)
9B#G SMO 5
9BS6 STO 0 A1+26(1) [STORE *LP IN FAPB
9C?Q ADN 5 1
9CRB XNLP
9D?2 SLL 6 2 [*CP BIT TO B0
9DQL BPZ 6 XNCP [BR IF NOT *CP ASSOCIATED
9F== LDX 0 XCP(3)
9FPW SMO 5
9G9G STO 0 A1+26(1) [STORE *CP IN FAPB
9GP6 XNCP
9H8Q SMO 7
9HNB LDX 6 A1+3(2) [LOAD PROPERTY NUMBER
9J82 CALL 5 XPROP [ACCESS PROPERTY NAME
9JML LDN 5 A1+22(1)
9K7= MOVE 4 3 [MOVE PROPERTY INTO FAPB
9KLW ADN 7 2
9L6G STO 7 A1(2) [UPDATE ASSOC CELL POINTER
9LL6 SBN 7 5
9M5Q BNG 7 XNOTFIN
9MKB ZNOASS
9N52 NGS 2 A1(2) [END OF ASSOC. CELL REACHED
9NJL XNOTFIN
9P4= CALL 7 WRITE [WRITE LINE AWAY
9PHW MHUNTW 2,ADATA,CSTORE [HUNT ADATA/CSTORE
9Q3G LDN 0 #41 [SINGLE LINE PFFC
9QH6 STO 0 A1+1(1)
9R2Q LDX 0 A1+8(2)
9RGB BNG 0 WEST [BR. IF NO MORE ASSOCS TO DO
9S22 BRN YQRL
9SFL WEST
9S^= LDX 0 A1(2)
9TDW BNG 0 QUIT [BR IF NO MORE ASSOCS EITHER
9TYG BRN XZYW
9WD6 QUIT [IT'S ALL OVER
9WXQ VFREE ADATA,CSTORE
9XCB VFREE FILE,FAPB
9XX2 MHUNTW 1,FILE,FAPB [HUNT MASTER FAPB
9YBL LDX 2 FX2
9YW= LDX 6 AWORK4(2)
9^*W ADX 6 FX1
9^TG EXIT 6 0
=2*6 XPROP
=2SQ # THIS SUBROUTINE ISSUES THE MACRO APROPNAME TO ACCESS, AND STORE
=3#B # IN ACOMMUNE1,2,3, THE PROPNRTY WHOSE NUMBER IS PROVIDED IN X6
=3S2 #
=4?L SBX 5 FX1 [RELATIVISE LINK IN X5
=4R= ANDX 6 BITS22LS [MASK OUT EXCL/PERM BITS
=4S^ ...[
=4WN ...[ FOR SHFS IF A PROPERTY WAS CANCELLED WHILE THE LINK WAS DOWN THERE
=4YC ...[ MAY STILL BE REFERENCES IN IDFB TO PROP. NOS. THAT NO LONGER EXIST
=526 ...[
=57? ...SNOMATTER
=5=W APROPNAME 6,1,NOPR [GET PROP NAME
=5QG MHUNTW 2,ADATA,CSTORE [HUNT ADATA/CSTORE
=6=6 MHUNTW 1,FILE,FAPB [HUNT FILE/FAPB
=6PQ HUNT2OPT 3,FILE,FAPB,1 [HUNT MASTER FAPB
=79B LDX 0 BITS22LS [UNSET "NO ASSOCS OR ATTRIBS FOUND
=7P2 ANDS 0 A1+1(3) [YET" MARKER
=88L SMO FX2
=8N= LDN 4 ACOMMUNE1 [ADDRESS OF PROPERTY NAME LOCATION
=97W ADX 5 FX1 [REFIX LINK
=9MG EXIT 5 0
==76 X659
==LQ LDX 0 0(3)
=?6B STO 0 AWORK1(2)
=?L2 LDCH 0 BNUMB(3)
=#5L ANDN 0 #20
=#K= BZE 0 REX
=*4W LDEX 7 BTYPE(3)
=*82 ...#UNS AV7900S
=*?6 ... FINDPERE 2,APGEOG,7,,AV7900 [FIND DEVICE LIST.(INCLUDE V7900 DLS)
=*B= ...#UNS AV7900S
=*FB ...#SKI
=*JG FINDPERE 2,APGEOG,7
=B46 BNG 2 XIT1
=BHQ LDEX 0 BTYPE(3)
=C3B LGEOG 2,7
=CH2 TXU 0 7
=D2L BCC REX
=DG= XIT1
=D^W LDX 2 FX2
=FFG EXIT 4 0
=F^6 REX
=GDQ LDX 2 FX2
=GYB EXIT 4 1
=HD2 #PAGE
=HXL MENDAREA 19,K100LISTAST
=JC= #END
^^^^ ...74011112000100000000