home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol023 / xref.bas < prev    next >
Encoding:
BASIC Source File  |  1984-04-29  |  5.4 KB  |  220 lines
  1. 10 ' XREF
  2. 20 '
  3. 30 DEFINT A-F
  4. 40 DEFDBL L-N
  5. 50 DEFSTR P-Z
  6. 60 '
  7. 70 ZEND1=STRING$(2,&HFF)+STRING$(2,&H1A)
  8. 80 ZEND2=STRING$(4,&H1A)
  9. 90 '
  10. 100 DIM A(20):' for caps conversion routine
  11. 110 '
  12. 120 ACOLS=2:' number of columns in list - this keeps display within
  13.         default 72 char/line value
  14. 130 APAGE=66:' total depth of page
  15. 140 ALINES=APAGE-6:' depth of list
  16. 150 BCOLS=ACOLS-1
  17. 160 ABLOCK=ACOLS*ALINES
  18. 170 '
  19. 180 ' MBASIC assumes 72 columns as a default width, which means that
  20. 190 ' two columns of xref listing can be accomodated. If listing is to
  21. 200 ' be sent to a device with a wider display, the value can be
  22. 210 ' specified either absolutely with WIDTH <value> or by the following
  23. 220 ' relative values. Note that ACOLS has to be adjusted accordingly.
  24. 230 '
  25. 240 ' WIDTH (32*ACOLS)-6
  26. 250 ' WIDTH LPRINT (32*ACOLS)-6
  27. 260 '
  28. 270 '
  29. 280 ' If this program is to be compiled with BASCOM the following
  30. 290 ' arrays will have to be dimensioned absolutely.
  31. 300 '
  32. 310 DIM F(ABLOCK)
  33. 320 '
  34. 330 ASORT=(FRE(0)/8)-500
  35. 340 DIM G(ASORT+1):DIM H(ASORT+1):' sort tables
  36. 350 '
  37. 360 T1="XREFWORK.###":' working file 1
  38. 370 T2="XREFWORK.$$$":' working file 2
  39. 380 '
  40. 390 FC=1:' console listing flag
  41. 400 FP=0:' print listings flag
  42. 410 '
  43. 420 DEF FNZNO(I)=RIGHT$(STR$(I),LEN(STR$(I))-1)
  44. 430 DEF FNZHEX(I)=RIGHT$("0000"+HEX$(I),4)
  45. 440 '
  46. 450 P(0)="DISABLED"
  47. 460 P(1)="ENABLED"
  48. 470 '
  49. 480 Q(1)=CHR$(9)
  50. 490 Q(2)=Q(1)+Q(1)
  51. 500 '
  52. 510 PRINT
  53. 520 CLOSE
  54. 530 PRINT "Enter:"
  55. 540 PRINT " C - Console listing toggle";TAB(35);P(FC)
  56. 550 PRINT " P - Print listing toggle";TAB(35);P(FP)
  57. 560 PRINT " L - List sorted X-ref table"
  58. 570 PRINT " S - Sort & list X-ref table"
  59. 580 PRINT " E - End"
  60. 590 '
  61. 600 S=INPUT$(1)
  62. 610 IF S="c" OR S="C" THEN IF FC=0 THEN FC=1 ELSE FC=0
  63. 620 IF S="p" OR S="P" THEN IF FP=0 THEN FP=1 ELSE FP=0
  64. 630 IF S="l" OR S="L" THEN FJ=1:GOTO 680
  65. 640 IF S="s" OR S="S" THEN FJ=0:GOTO 680
  66. 650 IF S="e" OR S="E" THEN CLOSE:END
  67. 660 GOTO 510
  68. 670 '
  69. 680 PRINT
  70. 690 INPUT "X-ref file name (.XRF assumed):  ",S
  71. 700 IF LEN(S)=0 THEN GOTO 680
  72. 710 IF INSTR(S,".")=0 THEN S=S+".XRF"
  73. 720 GOSUB 2010
  74. 730 IF FJ=1 THEN GOTO 1560
  75. 740 '
  76. 750 ' INPUT UNSORTED FILE
  77. 760 '
  78. 770 FM=-1
  79. 780 FE=0
  80. 790 ON ERROR GOTO 1940
  81. 800 OPEN "R",1,S,8
  82. 810 FIELD #1,4 AS X1,4 AS X2
  83. 820 FOR A=1 TO ASORT
  84. 830 GET 1
  85. 840 IF X1=ZEND1 THEN FE=1:GOTO 910
  86. 850 G(A)=CVS(X1)
  87. 860 H(A)=CVS(X2)
  88. 870 NEXT A
  89. 880 '
  90. 890 ' SORT
  91. 900 '
  92. 910 FM=FM+1
  93. 920 A=A-1
  94. 930 ALAST=A
  95. 940 A1=A
  96. 950 B=INT(A/2)+1
  97. 960 IF B=1 THEN GOTO 1010
  98. 970 B=B-1
  99. 980 G=G(B)
  100. 990 H=H(B)
  101. 1000 GOTO 1070
  102. 1010 G=G(A1)
  103. 1020 H=H(A1)
  104. 1030 G(A1)=G(1)
  105. 1040 H(A1)=H(1)
  106. 1050 A1=A1-1
  107. 1060 IF A1=1 THEN GOTO 1210
  108. 1070 D=B
  109. 1080 E=D
  110. 1090 D=2*D
  111. 1100 IF D=A1 THEN GOTO 1140
  112. 1110 IF D>A1 THEN GOTO 1180
  113. 1120 L=(2^18*G(D))+H(D):M=(2^18*G(D+1))+H(D+1):IF L>=M THEN GOTO 1140
  114. 1130 D=D+1
  115. 1140 L=(2^18*G)+H:M=(2^18*G(D))+H(D):IF L>M THEN GOTO 1180
  116. 1150 G(E)=G(D)
  117. 1160 H(E)=H(D)
  118. 1170 GOTO 1080
  119. 1180 G(E)=G
  120. 1190 H(E)=H
  121. 1200 GOTO 960
  122. 1210 G(E)=G
  123. 1220 H(E)=H
  124. 1230 IF G(1)=G(2) AND H(1)>H(2) THEN SWAP H(1),H(2)
  125. 1240 '
  126. 1250 ' BUILD INTERMEDIATE FILES
  127. 1260 '
  128. 1270 PRINT
  129. 1280 IF FM>0 THEN NAME T1 AS T2:OPEN "R",3,T2,8:FIELD #3,4 AS Z1,4 AS Z2
  130. 1290 OPEN "R",2,T1,8
  131. 1300 FIELD #2,4 AS Y1,4 AS Y2
  132. 1310 FF=0
  133. 1320 FG=0
  134. 1330 IF FM<1 THEN FOR A=1 TO ALAST:LSET Y1=MKS$(G(A)):LSET Y2=MKS$(H(A)):PUT 2:
  135.     NEXT A:GOTO 1440
  136. 1340 GET 3
  137. 1350 G=CVS(Z1)
  138. 1360 H=CVS(Z2)
  139. 1370 A=1
  140. 1380 IF FF=0 THEN L=(2^18*G)+H:NM(2^18*G(A))+H(A):
  141.     IF (L<M OR FG=1) THEN LSET Y1=MKS$(G):LSET Y2=MKS$(H):PUT 2:
  142.     IF LOC(3)<=(FM*ASORT) THEN GET 3:G=CVS(Z1):H=CVS(Z2):GOTO 1380 
  143.     ELSE FF=1:IF FG=1 THEN GOTO 1440
  144. 1390 LSET Y1=MKS$(G(A))
  145. 1400 LSET Y2=MKS$(H(A))
  146. 1410 PUT 2
  147. 1420 A=A+1:IF A=ALAST THEN FG=1
  148. 1430 IF FF+FG<2 THEN GOTO 1380
  149. 1440 LSET Y1=ZEND1
  150. 1450 LSET Y2=ZEND2
  151. 1460 PUT 2
  152. 1470 CLOSE 2
  153. 1480 IF FM>0 THEN CLOSE 3:KILL T2
  154. 1490 IF FE=0 THEN GOTO 820
  155. 1500 CLOSE
  156. 1510 KILL S
  157. 1520 NAME T1 AS S
  158. 1530 '
  159. 1540 ' LIST .XRF FILE
  160. 1550 '
  161. 1560 IF FC+FP=0 THEN PRINT:PRINT "*** NO LISTING SPECIFIED ***":GOTO 510
  162. 1570 ERASE G,H
  163. 1580 DIM G(ABLOCK)
  164. 1590 DIM H(ABLOCK)
  165. 1600 ON ERROR GOTO 1940
  166. 1610 OPEN "R",1,S,8
  167. 1620 FIELD #1,4 AS X1,4 AS X2
  168. 1630 FE=0
  169. 1640 FA=1
  170. 1650 PRINT
  171. 1660 FOR A=1 TO ABLOCK
  172. 1670 GET 1
  173. 1680 IF X1=ZEND1 THEN CLOSE:FE=1:GOTO 1730
  174. 1690 G(A)=CVS(X1)
  175. 1700 H(A)=INT(CVS(X2)/4)
  176. 1710 F(A)=CVS(X2)-(4*H(A))
  177. 1720 NEXT A
  178. 1730 IF FE=1 THEN ALAST=A-1 ELSE ALAST=A
  179. 1740 PRINT FNZNO(FA);TAB(11);"Cross reference listing";TAB(40);S
  180. 1750 PRINT
  181. 1760 FOR A=1 TO ALINES
  182. 1770 FOR B=0 TO BCOLS
  183. 1780 C=(B*ALINES)+A
  184. 1790 IF C<=ALAST AND FC=1 THEN PRINT TAB(32*B);FNZHEX(G(C));Q(F(C));
  185.     FNZHEX(H(C));:IF B<BCOLS THEN PRINT TAB((32*(1+B))-6);":"; 
  186. 1800 IF C<=ALAST AND FP=1 THEN LPRINT TAB(32*B);FNZHEX(G(C));Q(F(C));
  187.     FNZHEX(H(C));:IF B<BCOLS THEN LPRINT TAB((32*(1+B))-6);":"; 
  188. 1810 NEXT B
  189. 1820 IF FC=1 THEN PRINT
  190. 1830 IF FP=1 THEN LPRINT
  191. 1840 NEXT A
  192. 1850 FOR A=1 TO 4
  193. 1860 PRINT
  194. 1870 NEXT A
  195. 1880 FA=FA+1
  196. 1890 IF FE=0 THEN GOTO 1660
  197. 1900 GOTO 510
  198. 1910 '
  199. 1920 ' FILE ERROR
  200. 1930 '
  201. 1940 PRINT
  202. 1950 PRINT "*** FILE ";S;" NOT FOUND ***"
  203. 1960 PRINT
  204. 1970 GOTO 510
  205. 1980 '
  206. 1990 ' CONVERT STRING TO CAPS
  207. 2000 '
  208. 2010 A=LEN(S)
  209. 2020 IF A>20 THEN S=LEFT$(S,20):A=20
  210. 2030 FOR B=1 TO A
  211. 2040 A(B)=ASC(MID$(S,B,1))
  212. 2050 NEXT B
  213. 2060 S=""
  214. 2070 FOR B=1 TO A
  215. 2080 IF A(B)=ASC(" ") THEN GOTO 2110
  216. 2090 IF A(B)>=ASC("a") AND A(B)<=ASC("z") THEN A(B)=A(B)-32
  217. 2100 S=S+CHR$(A(B))
  218. 2110 NEXT B
  219. 2120 RETURN
  220.