CDC Community

๐Ÿ”น Historical Conservation ๐Ÿ”น

User Tools

Site Tools


plato.source:plaopl:comprt

COMPRT

Table Of Contents

Source Code

COMPRT.txt
  1. COMPRT
  2. * /--- FILE TYPE = E
  3. * /--- BLOCK START 00 000 81/10/30 15.12
  4. PROGRAM COMPRT(INPUT=1002,TAPE2,OUTPUT=1002,
  5. X TAPE1=INPUT,TAPE4=OUTPUT)
  6. *
  7. * THIS PROGRAM PRINTS A CROSS-REFERENCE LISTING OF
  8. * THE COMMON SYMBOL TABLE FOR THE PLATO SYSTEM.
  9. *
  10. * WRITTEN BY DOUG BROWN
  11. * CONVERTED TO NOS BY TIM HALVORSEN
  12. *
  13. *
  14. * CALL PROGRAM WITH FOLLOWING CARD --
  15. *
  16. * LGO,SOURCE,BINARY.
  17. *
  18. * WHERE *SOURCE* IS THE OUTPUT FILE FROM THE
  19. * COMPILATION OF THE COMMON STUFF. *BINARY*
  20. * IS THE BINARY OF THE SYSTEM TO CROSS REFERENCE.
  21. *
  22. IMPLICIT INTEGER(A-Z)
  23.  
  24. LOGICAL ERROR
  25.  
  26. COMMON /PRINT/ SUBHEAD(13),PLINES,DATIME(2),
  27. X LASTLET,MESSAGE(3),BLKLTH
  28.  
  29. *
  30. * THESE TABLES SHOULD HAVE THE FOLLOWING SIZES --
  31. *
  32. * BUFFER -- BUFLTH
  33. * LINKS -- NLINKS
  34. * COMMONS,CINFO,LCT -- NCOMS
  35. * TEXTS -- TEXTL
  36. * CGUNK -- TCOML
  37. *
  38. DIMENSION BUFFER(8000)
  39. DIMENSION LINKS(8000)
  40. DIMENSION COMMONS(40),CINFO(40),LCT(40)
  41. DIMENSION TEXTS(600)
  42. DIMENSION CGUNK(8000)
  43. *
  44. * THE FOLLOWING DECLARATIONS ARE FIXED SIZE --
  45. *
  46. DIMENSION QREF(6,14)
  47. DIMENSION PSH(3)
  48. DIMENSION QLINKS(2),QBUFF(2),QCOM(2)
  49. DIMENSION QGUNK(2),QTEXT(2)
  50. DIMENSION NAMER(7),ADDRR(6),BLOCKR(7)
  51.  
  52. *
  53. * THESE ARE THE PARAMETERS TO FUSS WITH --
  54. * BE SURE TO CHANGE THE DIMENSIONS OF THE ABOVE
  55. * ARRAYS THAT ALSO REFERENCE A PARAMETER.
  56. *
  57. * --NOTE-- NLINKS AND TCOML CANNOT EXCEED 16000 UNLESS
  58. * THE TABLE FORMATS ARE CHANGED. MWW 80/6/9.
  59. *
  60. DATA (NLINKS=8000),(BUFLTH=8000),(NCOMS=40)
  61. DATA (LOADFWA=111B),(TEXTL=600),(TCOML=8000)
  62. DATA (BLKLTH=320)
  63. *
  64. * COMPILER PARAMETERS
  65. *
  66. DATA (COLNAME=11),(COLADDR=22),(COLBLOK=33)
  67.  
  68. *
  69. * THESE ARE MASKS; DONT FUSS WITH THEM --
  70. *
  71. DATA (L9= 7777 7777 7777 7777 7700 B)
  72. DATA (L8= 7777 7777 7777 7777 0000 B)
  73. DATA (L7= 7777 7777 7777 7700 0000 B)
  74. DATA (L6= 7777 7777 7777 0000 0000 B)
  75. DATA (L5= 7777 7777 7700 0000 0000 B)
  76. DATA (L4= 7777 7777 0000 0000 0000 B)
  77. DATA (L3= 7777 7700 0000 0000 0000 B)
  78. DATA (L2= 7777 0000 0000 0000 0000 B)
  79. DATA (L1= 7700 0000 0000 0000 0000 B)
  80. DATA (R9= 0077 7777 7777 7777 7777 B)
  81. DATA (R8= 0000 7777 7777 7777 7777 B)
  82. DATA (R7= 0000 0077 7777 7777 7777 B)
  83. DATA (R6= 0000 0000 7777 7777 7777 B)
  84. DATA (R5= 0000 0000 0077 7777 7777 B)
  85. DATA (R4= 0000 0000 0000 7777 7777 B)
  86. DATA (R3= 0000 0000 0000 0077 7777 B)
  87. DATA (R2= 0000 0000 0000 0000 7777 B)
  88. DATA (R1= 0000 0000 0000 0000 0077 B)
  89. DATA (HISIGN= 4000 0000 0000 0000 0000 B)
  90. DATA (LOSIGN= 0000 0000 0040 0000 0000 B)
  91. *
  92. * /--- BLOCK FORMATS 00 000 80/06/10 03.08
  93. *
  94. * TAPE USAGE
  95. * 1=FIXED INPUT - COMPILER OUTPUT WITH COMMON NAMES
  96. * 2=FIXED INPUT - BINARY
  97. * 4=OUTPUT
  98. *
  99. *
  100. * THIS IS THE TABLE STRUCTURE -
  101. *
  102. * LINKS(X)=42/PROGRAM,4/N.REFS,14/NEXT.LINK
  103. * NLI IS LENGTH (LAST USED INDEX)
  104. * NLINKS IS MAXIMUM LENGTH
  105. *
  106. * COMMONS(ALPHA)=42/NAME,18/PTR
  107. * CINFO(PTR)=6/0,18/A.ADDR,18/LTH,18/FWA
  108. * NCO IS LENGTH
  109. * LCT(CHRON)=SAME AS CINFO
  110. * LCTLTH IS LENGTH
  111. * NCOMS IS MAXIMUM LENGTH OF ALL
  112. *
  113. * TEXTS(WHATEVER)=10/0,5/WC,18/B.ADDR,9/LR,18/L
  114. * NTXT IS LENGTH
  115. * TEXTL IS MAXIMUM LENGTH
  116. *
  117. * ECS RESIDENT -- USES WORDS 0 THROUGH (TCOML-1)
  118. * CGUNK(FWA+VALUE)=24/0,18/FIRST,18/LAST
  119. * (PASS 2 = 42/NAME,18/FIRST)
  120. * CGL IS LENGTH
  121. * TCOML IS MAXIMUM LENGTH
  122. * CGUNK(FWA+BL) IS AOR (VALUE .GE. BL)
  123. * CGUNK(FWA+BL+1) IS GOK (NOT DONE BY TEXT)
  124. *
  125. * /--- BLOCK INITIAL 00 000 80/06/13 10.01
  126. *
  127. * GET THE PROPER AMOUNT OF ECS (USED BY GETNAME
  128. * FOR SWAPPING AREA FOR THE *COMMONS* TABLE)
  129. *
  130. CALL GETECX(BLKLTH+NCOMS)
  131.  
  132. *
  133. * THIS IS FOR THE PAGE HEADERS
  134. *
  135. CALL DATE(DATIME(2))
  136. CALL TIME(DATIME(1))
  137. CALL NEWPAGE
  138.  
  139. *
  140. * THESE ARE FOR THE GENERAL ERROR CHECKS
  141. * AND BOMB-OFF MESSAGES.
  142. *
  143. QLINKS(1)=NLINKS
  144. QLINKS(2)=10HNLINKS
  145. QBUFF(1)=BUFLTH
  146. QBUFF(2)=10HBUFLTH
  147. QCOM(1)=NCOMS
  148. QCOM(2)=10HNCOMS
  149. QGUNK(1)=TCOML
  150. QGUNK(2)=10HTCOML
  151. QTEXT(1)=TEXTL
  152. QTEXT(2)=10HTEXTL
  153.  
  154. *
  155. * NOW TO INITIALIZE THE TABLES
  156. *
  157. DO 10 I=1,TCOML
  158. * CALL WRITEC(0,I-1,1)
  159. CGUNK(I)=0
  160. 10 CONTINUE
  161. CGL=0
  162.  
  163. PSH(1)=0
  164. PSH(2)=45
  165. PSH(3)=30
  166.  
  167. NLI=0
  168.  
  169. MAXBUF=0
  170. MAXTXT=0
  171.  
  172. NCO=0
  173.  
  174. *
  175. * START LOADING AT *NWA*
  176. *
  177. NWA=LOADFWA
  178.  
  179. *
  180. * (0,0) LOAD ADDRESS
  181. *
  182. OVERA=0
  183.  
  184. REWIND 1
  185. REWIND 2
  186. * /--- BLOCK LINKING 00 000 76/12/15 14.29
  187. *
  188. * NOW SEARCH THROUGH THE BINARY
  189. *
  190. 300 MESSAGE(1)=10H LINKING
  191. MESSAGE(3)=0
  192.  
  193. *
  194. * READ A RECORD FROM THE BINARY
  195. *
  196. 310 BUFFER IN(2,1)(BUFFER(1),BUFFER(BUFLTH))
  197. IF(UNIT(2))330,500,500
  198.  
  199. 330 NN=LENGTH(2)
  200. CALL CHECK(NN,QBUFF)
  201. MAXBUF=MAX0(NN,MAXBUF)
  202.  
  203. IF((BUFFER(1).AND.L7).NE.7LOVERLAY)GOTO 337
  204. IF(NWA.EQ.LOADFWA) GOTO 310
  205. IF(OVERA.EQ.0)OVERA=NWA+1
  206. NWA=OVERA
  207. GOTO 310
  208.  
  209. * BUFFER POINTER
  210. 337 PT=1
  211. PIDL=LCTLTH=NTXT=0
  212. * CODE NUMBER
  213. 340 CN=SHIFT(BUFFER(PT),6).AND.77B
  214. * WORD COUNT
  215. WC=SHIFT(BUFFER(PT),24).AND.7777B
  216. * RELOCATION
  217. LR=SHIFT(BUFFER(PT),-18).AND.777B
  218. * LOAD ADDRESS
  219. LLL=BUFFER(PT).AND.777777B
  220. *
  221. * DETERMINE IF TABLE WITH INFO THAT WE WANT
  222. *
  223. * TEXT
  224. IF(CN.EQ.40B)GOTO 360
  225. * FILL
  226. IF(CN.EQ.42B)GOTO 370
  227. * PIDL
  228. IF(CN.EQ.34B)GOTO 390
  229. *
  230. * GO ON TO NEXT TABLE
  231. *
  232. 350 PT=PT+WC+1
  233. IF(PT.LE.NN)GOTO 340
  234. GOTO 310
  235.  
  236. *
  237. * -TEXT- TABLE
  238. * USE TO GET WHICH WORD OF COMMON BLOCK REFERENCED
  239. *
  240. 360 CALL CHECK(NTXT,QTEXT)
  241. NTXT=NTXT+1
  242. MAXTXT=MAX0(NTXT,MAXTXT)
  243. TEXTS(NTXT)=SHIFT(WC-2,45).OR.SHIFT(PT+2,27)
  244. X .OR.SHIFT(LR,18).OR.LLL
  245. GOTO 350
  246. * /--- BLOCK LINKING 00 000 80/06/10 03.13
  247. *
  248. * -FILL- TABLE
  249. * TELLS REFERENCES TO COMMON
  250. *
  251. 370 DO 389 SUBPT=1,WC
  252. WORD=BUFFER(PT+SUBPT)
  253. HW=0
  254. 372 IF(WORD.LT.0)GOTO 374
  255. AR=SHIFT(WORD,30).AND.777B
  256. GOTO 385
  257. 374 IF(AR.LE.2)GOTO 385
  258. FWA=LCT(AR-2).AND.R3
  259. BL=SHIFT(LCT(AR-2),-18).AND.R3
  260. RLOC=SHIFT(WORD,30).AND.777 777 777 B
  261. PPP=SHIFT(WORD,3).AND.3
  262. DO 375 TT=1,NTXT
  263. TTT=TEXTS(TT).AND.777 777 777 B
  264. IF(RLOC.LT.TTT)GOTO 375
  265. UUU=TTT+(SHIFT(TEXTS(TT),15).AND.37B)
  266. IF(RLOC.GT.UUU)GOTO 375
  267. BADD=SHIFT(TEXTS(TT),33).AND.R3
  268. BADD=BADD+RLOC-TTT
  269. BITSHF=PSH(PPP+1)
  270. CADD=SHIFT(BUFFER(BADD),BITSHF).AND.R3
  271. IF(CADD.GT.BL)CADD=BL
  272. GOTO 376
  273. 375 CONTINUE
  274. CADD=BL+1
  275. 376 CALL CHECK(NLI,QLINKS)
  276. CADD=CADD+FWA
  277. * CALL READEC(ECGUNK,CADD,1)
  278. ECGUNK=CGUNK(1+CADD)
  279. * IF NOT FIRST LINK
  280. IF(ECGUNK.NE.0)GOTO 378
  281. NLI=NLI+1
  282. ECGUNK=NLI.OR.SHIFT(NLI,18)
  283. * CALL WRITEC(ECGUNK,CADD,1)
  284. CGUNK(1+CADD)=ECGUNK
  285. LINKS(NLI)=IDENT.OR.SHIFT(1,14)
  286. GOTO 385
  287. 378 LLAST=ECGUNK.AND.R3
  288. LASTP=LINKS(LLAST).AND.L7
  289. * SENSE NEW PROGRAM
  290. IF(LASTP.NE.IDENT)GOTO 382
  291. NUM=SHIFT(LINKS(LLAST),-14).AND.17B
  292. IF(NUM.LT.15)NUM=NUM+1
  293. LINKS(LLAST)=IDENT.OR.SHIFT(NUM,14)
  294. GOTO 385
  295. 382 NLI=NLI+1
  296. LINKS(NLI)=IDENT.OR.SHIFT(1,14)
  297. LINKS(LLAST)=LINKS(LLAST).OR.NLI
  298. ECGUNK=(ECGUNK.AND.L7).OR.NLI
  299. * CALL WRITEC(ECGUNK,CADD,1)
  300. CGUNK(1+CADD)=ECGUNK
  301.  
  302. 385 IF(HW.NE.0)GOTO 389
  303. WORD=SHIFT(WORD,30)
  304. HW=1
  305. GOTO 372
  306. 389 CONTINUE
  307. GOTO 350
  308.  
  309. *
  310. * -PIDL- TABLE
  311. * HAS THE PROGRAM AND COMMON BLOCK LENGTHS
  312. *
  313. 390 IDENT=BUFFER(PT+1).AND.L7
  314. PL=BUFFER(PT+1).AND.R3
  315. IF(WC.LT.2)GOTO 397
  316. DO 395 I=2,WC
  317. CNAME=BUFFER(PT+I).AND.L7
  318. BL=BUFFER(PT+I).AND.R3
  319. OLDLTH=NCO
  320. CALL GETNAME(CNAME,COMMONS,NCO,QCOM,RET)
  321. * IF ALREADY THERE, BYPASS FOLLOWING
  322. IF(OLDLTH.EQ.NCO)GOTO 393
  323. CINFO(RET)=SHIFT(BL,18).OR.CGL.OR.SHIFT(NWA,36)
  324. CGL=CGL+BL+2
  325. CALL CHECK(CGL,QGUNK)
  326. NWA=NWA+BL
  327. 393 CONTINUE
  328. LCTLTH=LCTLTH+1
  329. LCT(LCTLTH)=CINFO(RET).AND.R6
  330. 395 CONTINUE
  331. * SENSE NOT FIRST ONE IN RECORD
  332. 397 IF(PIDL.NE.0) GOTO 350
  333. PIDL=1
  334. * THIS PROGRAM ADDRESS
  335. TPA=NWA
  336. * AND UPDATE NEXT-WORD-ADDRESS
  337. NWA=NWA+PL
  338. MESSAGE(2)=IDENT
  339. CALL BDISP(MESSAGE)
  340. GOTO 350
  341. * /--- BLOCK NAMING 00 000 80/06/10 03.16
  342. *
  343. * GET THE NAMES OF THE COMMON VARIABLES
  344. *
  345. 500 CONTINUE
  346. MESSAGE(1)=10HGETTING CO
  347. MESSAGE(2)=10HMMON NAMES
  348. CALL BDISP(MESSAGE)
  349.  
  350. CALL ECHECK(NCO,7HCOMMONS)
  351. *
  352. * MAKE ROOM FOR THE NAMES
  353. *
  354. DO 510 I=1,CGL
  355. * ECA=I-1
  356. * CALL READEC(ECGUNK,ECA,1)
  357. * ECGUNK=SHIFT(ECGUNK,-12)
  358. * CALL WRITEC(ECGUNK,ECA,1)
  359. CGUNK(I)=SHIFT(CGUNK(I),-18)
  360. 510 CONTINUE
  361.  
  362. 520 READ(1,5200)D1,NAMER,D2,ADDRR,D3,BLOCKR,D4
  363. 5200 FORMAT(R8,7R1,R2,6R1,R5,7R1,R8)
  364. IF(EOF(1))400,522
  365. 522 IF(D1.NE.8R )GOTO 520
  366. IF(D2.NE.2R )GOTO 520
  367. IF(D3.NE.5R )GOTO 520
  368. IF(D4.NE.8R )GOTO 520
  369. CALL NAMIT(NAMER,NAME)
  370. IF(NAME.EQ.0) GOTO 520
  371. CALL NAMIT(BLOCKR,BLOCK)
  372. IF(BLOCK.EQ.0)GOTO 520
  373. CALL ATOO(ADDRR,ADDR)
  374. IF(ADDR.LT.0)GOTO 520
  375.  
  376. CALL BCHOP(BLOCK,COMMONS,NCO,RET)
  377. IF(RET.LT.0)GOTO 520
  378. RET=COMMONS(RET).AND.R3
  379. FWA=CINFO(RET).AND.R3
  380. LTH=SHIFT(CINFO(RET),-18).AND.R3
  381. IF(ADDR.GE.LTH)GOTO 520
  382. ECA=FWA+ADDR
  383. * CALL READEC(ECGUNK,ECA,1)
  384. ECGUNK=CGUNK(1+ECA)
  385. ECGUNK=NAME.OR.(ECGUNK.AND.R3)
  386. * CALL WRITEC(ECGUNK,ECA,1)
  387. CGUNK(1+ECA)=ECGUNK
  388. GOTO 520
  389. * /--- BLOCK PRINTING 00 000 80/06/10 03.47
  390. *
  391. * NOW TO PRINT THE TABLES
  392. *
  393. 400 MESSAGE(1)=10H PRINTING
  394. MESSAGE(3)=0
  395. ENCODE(130,4200,SUBHEAD)
  396. 4200 FORMAT(6X,*BLOCK RELATIVE ABSOLUTE NAME*
  397. X 6X,*PROGRAMS WITH REFERENCES*
  398. X *(NUMBER OF REFERENCES)*)
  399.  
  400. DO 490 PT=1,NCO
  401. HI=COMMONS(PT).AND.L7
  402. PTR=COMMONS(PT).AND.R3
  403. MESSAGE(2)=HI
  404. CALL BDISP(MESSAGE)
  405. CALL CSLASH(HI)
  406. FWA=CINFO(PTR).AND.R3
  407. LTH=SHIFT(CINFO(PTR),-18).AND.R3
  408. ABS=SHIFT(CINFO(PTR),-36).AND.R3
  409. IF(LTH.EQ.0) GOTO 490
  410. QZONK=LTH+2
  411. DO 489 FAKPT=1,QZONK
  412. SUBPT=FAKPT-1
  413. J=SUBPT
  414. CALL OTOA(J,HJ)
  415. K=ABS+J
  416. CALL OTOA(K,HK)
  417. ECA=FWA+SUBPT
  418. * CALL READEC(ECGUNK,ECA,1)
  419. ECGUNK=CGUNK(1+ECA)
  420. HL=ECGUNK.AND.L7
  421. NL=ECGUNK.AND.R3
  422.  
  423. * IGNORE IF NO REFERENCES
  424. IF(NL.EQ.0)GOTO 489
  425.  
  426. * SENSE IF REGULAR OR NOT
  427. IF(SUBPT.LT.LTH)GOTO 440
  428. IF(SUBPT.EQ.LTH)HL=5H*AOR*
  429. IF(SUBPT.EQ.(LTH+1))HL=5H*GOK*
  430. 440 CALL CLEAN(HL)
  431. *
  432. * GET LINKS AND NUMBER OF REFS AND PRINT THEM
  433. *
  434. LP=0
  435. 450 LP=LP+1
  436. NAME=LINKS(NL).AND.L7
  437. NUMBER=SHIFT(LINKS(NL),-14).AND.17B
  438. IF(NUMBER.EQ.15)NUMBER=63
  439. CALL PACK(NAME,NUMBER,QREF(LP,1))
  440. NL=LINKS(NL).AND.37777B
  441. * TEST IF OUTPUT LINE FULL
  442. IF(LP.EQ.6)GOTO 460
  443. * SEE IF ANY MORE REFERENCES
  444. IF(NL.NE.0)GOTO 450
  445. 460 CALL NEXTLN
  446. PRINT 4600,HI,HJ,HK,HL,((QREF(M,N),N=1,14),M=1,LP)
  447. 4600 FORMAT(6X,4A10,84R1)
  448. HI=1H
  449. IF(NL.EQ.0)GOTO 489
  450. * THE FOLLOWING IS FOR CONTINUED LINES
  451. HJ=HK=HL=1H
  452. GOTO 440
  453. 489 CONTINUE
  454. 490 CONTINUE
  455. *
  456. * ALL DONE - PRINT TABLE LENGTH INFO
  457. *
  458. PRINT 4900,NLI,NLINKS,NCO,NCOMS,MAXTXT,TEXTL,
  459. X CGL,TCOML,MAXBUF,BUFLTH
  460. 4900 FORMAT(/////* REFERENCES *I5*/*I5
  461. X *, COMMON BLOCKS *I5*/*I5
  462. X *, TEXT TABLES *I5*/*I5 /
  463. X *, COMMON WORDS *I5*/*I5
  464. X *, MAXIMUM RECORD SIZE *I5*/*I5)
  465. STOP
  466. END
  467. * /--- BLOCK ROUTINES 00 000 76/12/15 14.07
  468. SUBROUTINE ATOO(IN,OUT)
  469. *
  470. * ALPHA TO OCTAL CONVERSION ROUTINE
  471. *
  472. IMPLICIT INTEGER(A-Z)
  473. DIMENSION IN(6)
  474. OUT=0
  475. DO 10 I=1,6
  476. TEMP=IN(I)
  477. IF(TEMP.EQ.1R )GOTO 10
  478. IF(TEMP.GT.1R7)GOTO 99
  479. IF(TEMP.LT.1R0)GOTO 99
  480. OUT=SHIFT(OUT,3).OR.(TEMP-1R0)
  481. 10 CONTINUE
  482. RETURN
  483. 99 OUT=-1
  484. END
  485.  
  486. SUBROUTINE NAMIT(IN,OUT)
  487. *
  488. * CONVERT AN NAME IN THE FORM OF AN ARRAY (ONE CHARACTER
  489. * PER ENTRY) TO A SINGLE WORD, LEFT-JUSTIFIED.
  490. *
  491. IMPLICIT INTEGER(A-Z)
  492. DIMENSION IN(7)
  493. OUT=0
  494. BITSHF=54
  495. DO 10 I=1,7
  496. TEMP=IN(I)
  497. IF(TEMP.EQ.1R )RETURN
  498. OUT=OUT.OR.SHIFT(TEMP,BITSHF)
  499. BITSHF=BITSHF-6
  500. 10 CONTINUE
  501. NAME=0
  502. RETURN
  503. END
plato.source/plaopl/comprt.txt ยท Last modified: 2021/02/06 16:21 by 127.0.0.1