CDC Community

๐Ÿ”น Historical Conservation ๐Ÿ”น

User Tools

Site Tools


plato.source:plaopl:define

DEFINE

Table Of Contents

  • [00007] -DEFINE- COMMAND
  • [00028] READIN FOR -DEFINE- COMMAND
  • [00042] ADTYPES REQUIRE TWO 12 BIT BYTES - THE FIRST
  • [01660] SEGMENT/ARRAY/UNITS
  • [01690] READ-IN FOR -SEGMENT- COMMAND
  • [01981] ARRAY DEFINE
  • [02448] READ-IN FOR -UNITS- COMMAND

Source Code

DEFINE.txt
  1. DEFINE
  2. * /--- FILE TYPE = E
  3. * /--- BLOCK DEFINE 00 000 81/07/13 01.10
  4. IDENT DEFINE
  5. LCC OVERLAY(1,1)
  6. *
  7. TITLE -DEFINE- COMMAND
  8. TITLE
  9. *
  10. *
  11. CST
  12. *
  13. *
  14. DEFINE$ OVFILE
  15. *
  16. *
  17. EXT ECSPRTY,COMPNAM,CSYMADD
  18. EXT KEYTYPE,ERRORC,NXTC,COMCONT,HOLDEFN
  19. EXT SEGREAD,UNSREAD,SEGFLG
  20. EXT CHARERR,BADPAR,DECERR,VARERR
  21. EXT LOGERR,FORMERR,EQERR,OCTERR
  22. EXT ALFERR,INDXERR,DEFERR,SEGERR
  23. EXT COMPERR,LNGERR,LITERR,TEMPERR
  24. EXT KLOCAL
  25. *
  26. *
  27. * /--- BLOCK DEFINE 00 000 76/06/07 15.09
  28. TITLE READIN FOR -DEFINE- COMMAND
  29. *
  30. * -DEFREAD-
  31. * READIN ROUTINE FOR -DEFINE- COMMAND
  32. *
  33. * USE OF BUFFERS -
  34. *
  35. * *VARS* CONTAINS SEVEN CHARACTER DEFINE
  36. * NAMES WITH 18 BIT GETVAR CODES LOWER IN ORDER
  37. * BY FIRST CHARACTER
  38. *
  39. * *TOKBUF* (ECS RESIDENT TABLE)
  40. * CONTAINS 12 BIT TOKENS ASSOCIATED WITH NON
  41. * PRIMITIVE DEFINES
  42. ** ADTYPES REQUIRE TWO 12 BIT BYTES - THE FIRST
  43. * BYTE HAS THE UPPER BIT SET TO INDICATE ADTYPE
  44. ** UNNAMED LONG LITERALS REQUIRE A WHOLE WORD
  45. * FOLLOWING THEIR ADTYPES - THE FIRST BYTE OF THEIR
  46. * ADTYPES HAVE THE SECOND TO THE UPPER BIT SET
  47. ** NAMED LONG LITERALS REQUIRE A WHOLE WORD
  48. *
  49. *
  50. * ECS DATA STRUCTURE
  51. *
  52. * THE ECS DEFINE BUFFER IS PARTITIONED INTO PAIRS OF
  53. * NAME AND TOKEN BUFFERS. THE DEFINE SET THAT IS CURRENTLY
  54. * ACTIVE HAS ALL THE UNUSED SPACE IN THE DEFINE BUFFER
  55. * LOCATED BETWEEN THE END OF ITS TOKEN BUFFER AND THE
  56. * BEGINNING OF ITS NAME BUFFER. FOR EXAMPLE;
  57. *
  58. * START OF ECS DEFINE BUFFER
  59. * TOKENS FOR DEFINE SET A
  60. * NAMES FOR DEFINE SET A
  61. * TOKENS FOR DEFINE SET B
  62. * NAMES FOR DEFINE SET B
  63. * TOKENS FOR DEFINE SET C
  64. * UNUSED SPACE
  65. * NAMES FOR DEFINE SET C
  66. * END OF ECS DEFINE BUFFER
  67. *
  68. * WHEN ANOTHER DEFINE SET IS ACTIVATED, THE TOKEN AND
  69. * NAME BUFFERS ARE MOVED SO THAT THE UNUSED SPACE IS BETWEEN
  70. * THAT DEFINE SETS TOKEN AND NAME BUFFER. FOR EXAMPLE;
  71. *
  72. * START START
  73. * TOKEN A TOKEN A
  74. * NAME A NAME A
  75. * TOKEN B TOKEN B
  76. * NAME B UNUSED SPACE -DEFINE- SET B IS NOW ACTIVE
  77. * TOKEN C NAME B
  78. * UNUSED SPACE TOKEN C
  79. * NAME C NAME C
  80. * END END
  81. *
  82. * AS A -DEFINE- COMMAND IS PROCESSED, THE STARTING LOCATION
  83. * OF THE NAMES DECREASES AS NAMES ARE ADDED AND THE ENDING
  84. * LOCATION OF THE TOKENS INCREASES AS TOKENS ARE ADDED UNTIL
  85. * THERE IS NO UNUSED SPACE, AT WHICH TIME A CONDENSE ERROR
  86. * IS ISSUED AND NO MORE DEFINES ARE PROCESSED UNTIL ONE
  87. * OR MORE DEFINE SETS ARE PURGED.
  88. *
  89. *
  90. * NAME BUFFER
  91. *
  92. * THE NAME BUFFER CONTAINS AN ALPHABETICAL LIST OF ALL
  93. * SYMBOLS GIVEN DEFINITIONS IN THE DEFINE SET SO FAR.
  94. * EACH SYMBOL IS LEFT JUSTIFIED IN A WORD, USING A MAXIMUM
  95. * /--- BLOCK DEFINE 00 000 76/06/07 15.09
  96. * OF 7 CHARACTERS. THE BOTTOM 3 CHARACTERS CONTAIN INFO
  97. * DESCRIBING THE FUNCTION OF THE SYMBOL, CALLED THE SYMBOLS
  98. * GETVAR CODE. THIS CODE CONSISTS OF 4 BITS OF TYPE
  99. * INFORMATION AND 14 BITS OF ADDRESS INFORMATION. FOR ALL
  100. * EXCEPT SIMPLE VARIABLE TYPES OR LITERAL TYPES OF LESS THAN
  101. * 15 BITS, THE ADDRESS INFORMATION POINTS TO THE WORD IN
  102. * THE TOKEN BUFFER WHERE A DESCRIPTION OF THE DEFINE BEGINS
  103. * (SEE DISCUSSION OF TOKENS BELOW). THE ADDRESS INFORMATION
  104. * FOR SIMPLE VARIABLES INDICATES THE NUMBER OF THE VARIABLE
  105. * BEING REFERENCED; FOR 14 BIT LITERALS, THE LITERAL ITSELF
  106. * IS THE ADDRESS.
  107. *
  108. * TOKEN BUFFER
  109. *
  110. * THE TOKEN BUFFER CONTAINS COMPLEX DEFINITIONS OF SYMBOLS
  111. * IN THE NAME TABLE. FOR ALL EXCEPT LITERALS OF MORE THAN
  112. * 14 BITS, THESE DEFINITIONS ARE OF THE FORM;
  113. *
  114. * <NUMBER OF ARGUMENTS> <CHARACTER STRING ANALOG> <EOL>
  115. *
  116. * FOR 60 BIT LITERALS, ALL THAT IS STORED IS THE LITERAL
  117. * ITSELF.
  118. * THE NON60-BIT LITERAL ELEMENTS OF THE TOKEN BUFFER ARE
  119. * 12 BIT OR 24 BIT BYTES, PACKED FROM HIGH TO LOW ORDER
  120. * BITS OF WORDS. THE <NUMBER OF ARGUMENTS> IS ALWAYS LEFT
  121. * JUSTIFIED SO THAT THE GETVAR CODE ASSOCIATED WITH THE
  122. * SYMBOL MAY POINT DIRECTLY TO THE FIRST WORD OF THE
  123. * SYMBOLS DEFINITION. FOR ALL EXCEPT THE ARGUMENT COUNT,
  124. * 12 BIT TOKENS CORRESPOND TO LEXICAL ELEMENTS OF THE
  125. * DEFINITION CALLED OPERATORS. INCLUDED IN THIS CATEGORY ARE
  126. * SEPARATORS SUCH AS PARENTHESIS, COMMAS, END OF LINES, ETC.
  127. * AS WELL AS SYSTEM DEFINED SYMBOLS (INT, ZRECS, +, -, ^O,).
  128. * 24 BIT TOKENS ARE OF TWO TYPES; 1) ARGUMENT TOKENS, THE
  129. * TOP 12BIT BYTE OF WHICH HAS A UNIQUE VALUE NOT CORRESPOND-
  130. * ING TO ANY OPERATOR, AND THE BOTTOM 12 BIT BYTE THE NUMBER
  131. * OF THE ARGUMENT AS IT APPEARS IN THE ARGUMENT LIST;2)
  132. * ADTYPE TOKENS, WITH THE 2**LITSHFT BIT SET AND THE BOTTOM 18
  133. * BITS CONTAINING A GETVAR CODE FOR A SIMPLE VARIABLE OR
  134. * LITERAL. 60 BIT LITERALS THAT APPEAR IN THE DEFINITION OF
  135. * A SYMBOL THAT IS NOT REDUCABLE TO A SINGLE LITERAL ITSELF,
  136. * HAVE THE 2**LITSHFT BIT SET INDICATING THAT THE REST
  137. * OF THE CURRENT TOKEN WORD IS IRRELEVANT, THE LITERAL
  138. * APPEARS IN THE NEXT WORD IN THE TOKEN BUFFER AND THE NEXT
  139. * TOKEN WILL BE LEFT JUSTIFIED IN THE WORD AFTER THE
  140. * LITERAL. *** WARNING *** IN ALL OTHER CONTEXTS, THE
  141. * 2**LITSHFT BIT SET IN AN ADTYPE MEANS THAT THE LONG LITERAL
  142. * RESIDES IN *LITS* (THE LITERAL STACK GENERATED BY *LEX*
  143. * AND *DEFLEX*. *** WARNING ***
  144. *
  145. * /--- BLOCK DEFINE 00 000 80/03/27 23.09
  146. * WHEN THE DEFINITION OF A SYMBOL CONTAINS A PREVIOUSLY
  147. * DEFINED SYMBOL, THE TOKEN BUFFER REPRESENTATION OF
  148. * THE DEFINITION CONTAINS THE TOKENS FOR THE PREVIOUSLY
  149. * DEFINED SYMBOL ENCLOSED BY PARENTHESIS TOKENS.
  150. *
  151. *
  152. * EXAMPLE DEFINE SET NAME AND TOKEN BUFFERS
  153. *
  154. * DEFINE ABC=7
  155. * DEF=N1
  156. * VECT(X)=N(X+100)
  157. * LIT='7ABCDEF'7+1
  158. * FUNCT(X,Y)=SIN(Y+LIT-VECT(X)"DEF+'7GEHI'7)
  159. *
  160. * TOKEN BUFFER (* INDICATES START OF WORD)
  161. * *0001 0077 0015 03760000 *0002 40000144 0016 0001
  162. * *01020304050600000001
  163. * *0002 0051 0015 03760001 *0002 40040002 0003 0015 *0077
  164. * 0015 0015 03760000 *0016 0002 40000144 0016 *0016
  165. * 0013 40100001 0002 *60040011 *07051011000000000000
  166. * *0016 0001
  167. *
  168. * NAME BUFFER
  169. * <NAME> <GETVAR>
  170. * ABC 000007
  171. * DEF 100001
  172. * FUNCT 200003
  173. * LIT 040002
  174. * VECT 200000
  175. *
  176. *
  177. * CM NAME PAGING
  178. *
  179. * A CM BUFFER IS USED DURING BINARY CHOP SEARCHES FOR
  180. * DEFINED NAMES. IN DEFINE SETS WITH NAME BUFFERS LARGER
  181. * THAN THE CM BUFFER, THE ECS NAME BUFFER IS DIVIDED UP INTO
  182. * PAGES THE SAME SIZE AS THE CM BUFFER. THESE PAGES ARE
  183. * READ INTO CM AS NEEDED FOR THE BINARY CHOP.
  184. * CM TABLES
  185. *
  186. * *TOKADDS* CONTAINS THE ECS LOCATIONS OF TOKEN BUFFERS
  187. * *NAMADDS* CONTAINS THE ECS LOCATIONS OF NAME BUFFERS
  188. * (TOKADDS(N)) IS ALWAYS LESS THAN OR EQUAL TO (TOKADDS(N+1))
  189. * (NAMADDS(N)) IS ALWAYS LESS THAN OR EQUAL TO (NAMADDS(N+1))
  190. * *TOKLENS* CONTAINS THE LENGTHS OF TOKEN BUFFERS
  191. * *NAMLENS* CONTAINS THE LENGTH OF NAME BUFFERS
  192. * *SETNAMS* CONTAINS THE NAMES OF DEFINE SETS
  193. *
  194. * THERE IS AN ENTRY IN EACH TABLE WITH AN INDEX OF -1. THESE
  195. * ENTRIES DESCRIBE THE NULL DEFINE SET WHICH IS OPENED WHEN
  196. * NO DEFINE SET IS ACTIVE. THIS MAKES MUCH OF THE CODE MORE
  197. * ELEGANT AND EFFICIENT BY AVOIDING SPECIAL CASES.
  198. *
  199. * *PGTBL* CONTAINS THE LAST NAME OF EACH PAGE IN THE NAME
  200. * BUFFER. THIS IS TO SPEED UP THE PROCESS OF FINDING
  201. * WHICH PAGE SHOULD BE CM RESIDENT IF THE PAGE IN ECS COULD
  202. * NOT CONTAIN THE NAME BEING SEARCHED FOR.
  203. *
  204. *
  205. * AT THE END OF CONDENSATION THE DEFINE SET NAMED
  206. * *STUDENT* IS APPENDED TO THE LESSON BINARY - OTHER
  207. * DEFINES ARE NOT AVAIABLE IN STUDENT MODE
  208. *
  209. *
  210. DEFOV OVRLAY
  211. SA1 OVARG1 X1 = CALL TYPE
  212. SB1 X1
  213. JP B1+DEFJMP JUMP TO DEFINE OPTION
  214. *
  215. DEFJMP EQ DEFNIN BEGIN DEFINE SET
  216. + EQ PURGELU PURGE LOCAL DEFINE SET FOR NEW
  217. + EQ ELN1 RETURN FROM SEGOV
  218. + EQ PURGELD PURGE LOCAL DEFINE SET FOR GBL
  219. *
  220. * /--- BLOCK DEFINE 00 000 80/05/19 22.16
  221. DEFNIN CALL SETSET SET TO CURRENT DEFINE SET
  222. SX6 VARS
  223. SA6 PVARS POINTER TO DEFN NAME LIST
  224. SX7 -2 *UNITS* NOT ACTIVE
  225. SA7 NUNITS
  226. MX6 0
  227. SA6 UDMODE NO INTERPRETATION OF *UNITS*
  228. SA6 COMPNAM
  229. SA6 CSYMADD
  230. SA1 COMMAND
  231. SA2 COMCONT SEE IF CONTINUED COMMAND
  232. BX2 X1-X2
  233. ZR X2,DEFRD JUMP IF CONTINUED
  234. * /--- BLOCK D050 00 000 80/03/23 08.25
  235. *
  236. SA1 LOCAL
  237. ZR X1,D025 IF NOT LOCAL SET
  238. *
  239. *+ EQ *
  240. + SA1 KLOCAL X1 = LOCAL SET NAME
  241. BX6 X1
  242. SA6 KBLANK LOCAL SET HANDLING LIKE BLANK
  243. SX6 60 NO BITS LEFT IN 0TH WORD
  244. SA6 LSHIFT
  245. SA6 LBYTES LOCAL BYTE SIZE
  246. MX6 0 0TH WORD
  247. SA6 LVARN
  248. SA6 MERGEL ASSUME MERGE OPTION NOT USED
  249. SX6 100000B LOCAL TYPE IS INTEGER
  250. SA6 LTYPE
  251. SX6 1 SIGNED
  252. SA6 LSIGN
  253. SA1 DSET SAVE CURRENT SET NUMBER
  254. BX6 X1
  255. SA6 GSET GLOBAL SET NUMBER
  256. * SAVE UNIT TAG
  257. SA1 WORDPT
  258. BX6 X1
  259. SA6 LWRDPT
  260. SA0 TAG
  261. SA1 ATEMPEC X1 = ADDR OF TEMP ECS
  262. BX0 X1
  263. WE TAGLTH+1 WRITE OUT -UNIT- W/ARGS
  264. RJ ECSPRTY
  265. SA0 LUNIT SAVE -UNIT- COMMAND W/ARGS
  266. RE TAGLTH+1
  267. RJ ECSPRTY
  268. RJ =XGETLINE
  269. D025 SA1 WORDPT SAVE WORDPT
  270. BX6 X1
  271. SA6 OLDPT
  272. CALL GETNAME,9 GET NAME OF DEFINE SET **
  273. ZR X6,DEFR0 JUMP IF NO NAME=BLANK SET
  274. SX7 DEFNAML NUMBER OF NAMES TO SEARCH
  275. SA1 LOCAL
  276. IX7 X7+X1 IF LOCAL SET, INCLUDE *MERGE*
  277. RJ DEFNAMS CHECK FOR SPECIAL NAME
  278. NZ X7,D170 JUMP IF SPECIAL NAME FOUND
  279. *
  280. *
  281. SB2 7
  282. GT B1,B2,ERR7 ERROR IF NAME OVER 7 CHARS
  283. *
  284. SA1 LOCAL
  285. NZ X1,D100 IF LOCAL SET
  286. *
  287. *
  288. * SPECIAL NAMES= SEGMENT(SEGFLG=1), SEGMENTV(3), UNITS(4),
  289. * ARRAY(4), ARRAYSEG(5), ARRAYSEGV(6), COMPLEX(7),
  290. * SEGMENTF(8), PURGE(9)
  291. *
  292. SX0 X2-OPCOMMA IF TERMINATOR IS COMMA
  293. ZR X0,DEFR1 JUMP , THIS IS SET NAME
  294. D050 SA1 LOCAL
  295. NZ X1,D100 IF LOCAL SET, NO NAMED SETS
  296. *
  297. SX3 X2-EOL
  298. ZR X3,DEFR1 IF SETNAME EOL
  299. *
  300. ZR X3,DEFR1 JUMP IF SETNAME(EOL)
  301. D100 SA1 OLDPT THIS IS DEFINE NAME
  302. BX6 X1 RESET -WORDPT-
  303. SA6 WORDPT
  304. * /--- BLOCK D050 00 000 80/03/23 08.25
  305. EQ DEFR0 USE BLANK SET
  306. *
  307. D170 SA1 LOCAL
  308. ZR X1,D171 IF NOT LOCAL SET
  309. *
  310. SX0 X7-DEFNAML-1
  311. ZR X0,DEFL0 IF LOCAL MERGE OPTION
  312. *
  313. EQ D100 TREAT AS NORMAL DEFINE LINE
  314. *
  315. * /--- BLOCK D050 00 000 80/03/23 06.44
  316. D171 SX0 X7-DEFNAML
  317. ZR X0,PURGE JUMP IF PURGE OPTION
  318. SX3 X2-OPCOMMA ZERO IF ENDS WITH COMMA
  319. ** FOLLOWING IS CAUSED BY DIFF BETWEEN TREATMENT OF
  320. ** SEGMENT AND UNITS/ARRAY/COMPLEX * MAYBE SHOULD CHANGE
  321. ZR X3,D172 IF IT DOES, IS SPECIAL NAME
  322. SX0 X7-1 ZERO IF SEGMENT
  323. NZ X0,D050 JUMP IF NOT, ALLOW UNITS=V1
  324. EQ ERR8 SEGMENT MUST END WITH COMMA
  325. D172 SA1 KBLANK
  326. BX6 X1 ASSUME BLANK SET
  327. RJ =XFINDSET
  328. PL B1,DSEG1 JUMP IF SET EXISTS
  329. RJ NEWSET
  330. *
  331. DSEG1 RJ =XGETSET BRING IN THE SET
  332. SA1 SEGFLG
  333. SX1 X1-3
  334. ZR X1,UNSREAD JUMP IF -UNITS-
  335. EQ SEGREAD JUMP IF SEGMENT/ARRAY/COMPLEX
  336. *
  337. DEFL0 SX6 1
  338. SA6 MERGEL FLAG MERGE OPTION SELECTED
  339. *
  340. DEFR0 SA1 KBLANK BLANK NAME (UNNAMED SET)
  341. BX6 X1
  342. *
  343. DEFR1 BX7 X2 SAVE TERMINATOR CODE
  344. SA7 ENDKEY
  345. RJ =XFINDSET SEE IF SET ALREADY EXISTS
  346. PL B1,DEFR2 JUMP IF ALREADY EXISTS
  347. RJ NEWSET INITIALIZE A NEW SET
  348. RJ =XGETSET OPEN IT UP AND BRING IT IN
  349. SA1 LOCAL
  350. ZR X1,DEFL5 IF NOT LOCAL SET
  351. *
  352. SA1 MERGEL
  353. ZR X1,DEFRD IF NO MERGED SET, BEGIN SET
  354. *
  355. CALL GETNAME,8
  356. BX7 X2 SAVE ENDKEY
  357. SA7 ENDKEY
  358. SA3 GSET X3 = PREVIOUS GLOBAL SET NUM
  359. SB1 X3 B1 = PREVIOUS GLOBAL SET NUM
  360. SA1 KPREVN X1 = *PREVIOUS* KEYWORD
  361. BX1 X1-X6
  362. ZR X1,DEFL10 IF PREVIOUS SET TO BE MERGED
  363. SA1 KGLOBAL X1 = *GLOBAL* KEYWORD
  364. BX1 X1-X6
  365. NZ X1,DEFL05 IF NAME IS NOT *GLOBAL*
  366. PL B2,DEFL05 IF NAME IS NOT *GLOBAL';*
  367. SX7 EOL SET TERMINATING CHAR
  368. SA7 ENDKEY
  369. EQ DEFL10 DO THE MERGE
  370. *
  371. DEFL05 SX3 X2-EOL
  372. ZR X3,DEFR1A ANOTHER SETNAME IF EOL
  373. *
  374. SX3 X2-OPCOMMA
  375. NZ X3,ERR8 IF BAD TERMINATION
  376. *
  377. EQ DEFR1A
  378. *
  379. MERGEL DATA 0 MERGE OPTION FLAG FOR LOCAL SET
  380. *
  381. DEFL5 BSS 0
  382. SA1 ENDKEY
  383. SX2 X1-OPCOMMA
  384. NZ X2,ENDLIN CONTINUE IF NOT COMMA
  385. CALL GETNAME,7 GET NEXT NAME
  386. SX3 X2-EOL
  387. ZR X3,DEFR1A ANOTHER SET NAME IF EOL
  388. SX3 X2-OPCOMMA
  389. NZ X3,DEFRDA ANOTHER DEFINE IF NOT COMMA
  390. * /--- BLOCK DEFR1A 00 000 75/02/11 20.31
  391. *
  392. DEFR1A SX7 X2 SAVE TERMINATOR
  393. SA7 ENDKEY
  394. ZR X6,ERR8 ERROR EXIT IF NO SET
  395. RJ =XFINDSET SEARCH FOR OLD SET
  396. DEFL10 NG B1,ERR8 ERROR IF NO SET
  397. SX7 B1
  398. SA7 ODSET SAVE OLD SET NUMBER
  399. SA1 DSET
  400. SB2 X1
  401. SA1 UNTLENS+B1 *NDEFU*
  402. BX7 X1
  403. SA7 UNTLENS+B2
  404. SA2 B2+TOKADDS (X2)=ECS ADDR OF NEW SET TOKENS
  405. SA1 B1+TOKADDS (X1)=ECS ADDR OF OLD SET TOKENS
  406. SA3 B1+TOKLENS (X3)=ECS LENG OF OLD SET TOKENS
  407. IX4 X2+X3 MUST BE LESS THAN OR EQUAL TO
  408. SA5 NAMADDS+B2
  409. IX4 X5-X4
  410. NG X4,ERR4 IF NOT ENOUGH ROOM IN BUFFER
  411. BX7 X3
  412. SA7 B2+TOKLENS
  413. SA0 VARS (A0)=ADDR OF MOVE BUFFER
  414. SB1 VARLONG (B1)=LENGTH OF MOVE BUFFER
  415. RJ =XMVECS MOVE TOKENS TO NEW DEFINE SET
  416. SA1 ODSET
  417. SB1 X1
  418. SA1 DSET
  419. SB2 X1
  420. SA2 B2+NAMADDS (X2)=ECS ADDR OF NEW SET NAMES
  421. SA1 B1+NAMADDS (X1)=ECS ADDR OF OLD SET NAMES
  422. SA3 B1+NAMLENS (X3)=ECS LENG OF OLD SET NAMES
  423. IX2 X2-X3 (X2)=NEW ADDR OF NEW SET NAMES
  424. SA4 TOKADDS+B2 SEE IF ENOUGH ROOM IN BUFFER
  425. SA5 TOKLENS+B2
  426. IX4 X4+X5 MUST NOT BE GT NAMADDS+B2
  427. IX4 X2-X4
  428. NG X4,ERR4 IF NOT ENOUGH ROOM
  429. BX7 X2
  430. SA7 B2+NAMADDS
  431. BX7 X3
  432. SA7 B2+NAMLENS
  433. SA0 VARS (A0)=ADDR OF MOVE BUFFER
  434. SB1 VARLONG (B1)=LENGTH OF MOVE BUFFER
  435. RJ =XMVECS MOVE NAMES TO NEW DEFINE SET
  436. SA1 DSET
  437. SB1 X1
  438. RJ =XSETSET BRING IN NEW DEFINE SET
  439. SA1 ENDKEY
  440. EQ ENDLIN
  441. *
  442. * /--- BLOCK DEFR2 00 000 80/03/23 06.50
  443. ODSET BSS 1
  444. *
  445. DEFR2 RJ =XGETSET BRING IN THE SET
  446. *
  447. DEFR3 SA1 ENDKEY
  448. EQ ENDLIN SEE IF NEED NEW LINE
  449. *
  450. DEFRD CALL GETNAME,9 GET NAME OF DEFINE
  451. * FOLLOWING CHECKS FOR -DEFINE- ENDING IN COMMA
  452. * AND TRAILING BLANKS
  453. SX7 X2-EOL CHECK FOR EOL TERMINATOR
  454. BX7 X7+X6 AND NO NAME
  455. ZR X7,ELN1 END-OF-LINE OK
  456. DEFRDA ZR X6,ERR7 ERROR IF NO NAME
  457. SA6 DEFNAME
  458. SX7 DEFNAML-1 DO NOT LOOK FOR *PURGE*
  459. RJ DEFNAMS CHECK FOR SPECIAL NAMES
  460. ZR X7,DEFRDAB JUMP IF NOT
  461. SX0 X7-3
  462. NG X0,SEGREAD JUMP IF SEGMENT
  463. SX1 X2-OPCOMMA CHECK IF TERMINATOR=COMMA
  464. NZ X1,DEFRDB IF NOT, MUST BE UNITS=V1 ETC.
  465. ZR X0,UNSREAD REMOTE EXIT IF UNITS
  466. SX0 X7-DEFGNML-1
  467. NG X0,SEGREAD IF ARRAY/COMPLEX
  468. *
  469. SA1 LOCAL
  470. ZR X1,DEFRDB IF NOT LOCAL SET
  471. *
  472. * CONDENSING LOCAL DEFINE SET ',X,Y,S';', FORM
  473. * X = (INTEGER,FLOATING)
  474. * Y = SEGMENT SIZE (INTEGER ONLY)
  475. * S = SIGNED SEGMENT IF PRESENT
  476. *
  477. SX6 100000B X6 = PRESET N GETVAR TYPE
  478. SX0 X0-1
  479. NG X0,DEFL20 IF INTEGER DECLARATION
  480. *
  481. SX6 5B X6 = V GETVAR TYPE
  482. LX6 15
  483. DEFL20 SA6 TLTYPE TEMPORARY LTYPE
  484. RJ COLON X0 = -1 IF COLON IS LAST CHAR
  485. NG X0,DEFL100 IF FULL WORD DECLARATION
  486. *
  487. RJ SAVEO SAVE WORDPT ETC.
  488. RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  489. RJ =XCOMPILE
  490. MX0 -XCODEAL
  491. BX0 X0*X1 MUST BE SHORT LITERAL
  492. BX6 X1
  493. SA2 OLDINX RESTORE INX
  494. BX7 X2
  495. SA7 INX
  496. ZR X0,DEFL30 IF X6 IS SHORT LITERAL
  497. *
  498. DEFL25 RJ RESTO BACK UP POINTERS TO KEYWORD AND
  499. SA2 WORDPT SET X2 TO CORRECT ENDKEY
  500. SA2 X2-1
  501. SA2 X2+KEYTYPE
  502. EQ DEFRDB ASSUME IT A DEFINE NAME
  503. *
  504. DEFL30 SA6 TLBYTES TEMPORARY LOCAL BYTE SIZE
  505. RJ COLON X0 = -1 IF COLON LAST CHAR
  506. NG X0,DEFL110 IF UNSIGNED DECLARATION
  507. *
  508. CALL GETNAME,7 X6 = SIGN OPTION
  509. ZR X6,DEFL25 ASSUME ITS A DEFINED NAME
  510. *
  511. SA3 KSIGN CHECK FOR SIGNED SEGMENT
  512. BX3 X6-X3
  513. * /--- BLOCK DEFR2 00 000 80/03/23 06.50
  514. ZR X3,DEFL40 IF SIGNED DECLARATION
  515. *
  516. SA3 KS CHECK FOR ABBREVIATED SIGN
  517. BX3 X6-X3
  518. NZ X3,DEFL25 IF NOT ,S ASSUME DEFINED NAME
  519. *
  520. DEFL40 RJ COLON
  521. PL X0,DEFL25 MUST END IN COLON
  522. *
  523. SX6 1
  524. SA6 TLSIGN TEMPORARY LOCAL VAR SIGN
  525. EQ DEFL120 BEGIN INTEGRITY CHECK
  526. *
  527. * /--- BLOCK DEFR2 00 000 80/03/23 06.47
  528. DEFL100 SX6 60 60 BIT DECLARATION
  529. SA6 TLBYTES
  530. SX6 1 HAS TO BE SIGNED
  531. SA6 TLSIGN
  532. EQ DEFL200 SET DECLARATION PARAMETERS
  533. *
  534. DEFL110 SX6 0 UNSIGNED
  535. SA6 TLSIGN
  536. *
  537. DEFL120 SA1 TLBYTES CHECK BYTE SIZE
  538. NG X1,BADCNT IF BYTE SIZE LT 0
  539. ZR X1,BADCNT IF BYTE SIZE EQ 0
  540. *
  541. SX2 61
  542. IX1 X1-X2
  543. PL X1,BADCNT IF BYTE SIZE GT 60
  544. *
  545. SA2 TLTYPE
  546. SX2 X2-100000B
  547. ZR X2,DEFL200 IF INTEGER, EVERYTHING OK
  548. *
  549. SX1 X1+1
  550. NZ X1,BADCNT IF FLOATING BYTE SIZE NE 60
  551. *
  552. DEFL200 SA1 TLTYPE TYPE OF LOCAL VAR
  553. BX6 X1
  554. SA6 LTYPE
  555. SA1 TLBYTES LENGTH OF BYTE
  556. BX6 X1
  557. SA6 LBYTES
  558. SA1 TLSIGN UN/SIGNED
  559. BX6 X1
  560. SA6 LSIGN
  561. EQ DEFRD CONTINUE SINCE MORE TO COME
  562. *
  563. *
  564. TLTYPE DATA 0
  565. TLBYTES DATA 0
  566. TLSIGN DATA 0
  567. * /--- BLOCK DEFR2 00 000 80/03/23 06.49
  568. *
  569. * -COLON-
  570. *
  571. * LOOK AT LAST TWO CHARACTER CODES TO CHECK FOR
  572. * A COLON
  573. *
  574. * ON RETURN X0 = -1 IF COLON, 0 IF NOT
  575. *
  576. COLON EQ *
  577. SX0 B0 PRESET X0 TO NOT COLON
  578. SA2 WORDPT
  579. SA2 X2-1
  580. SX2 X2-77B LAST CHAR - ;
  581. NZ X2,COLON IF NOT COLON
  582. *
  583. SA2 A2-1
  584. SX2 X2-70B LAST CHAR - SHIFT
  585. NZ X2,COLON IF NOT COLON
  586. *
  587. SX0 -1 IT WAS A COLON
  588. EQ COLON
  589. *
  590. *
  591. * -SAVEO-
  592. *
  593. * SAVE ALL INFORMATION NECESSARY TO DO A COMPILE
  594. * LOOK AHEAD IN THE *OLD* BUFFER
  595. *
  596. SAVEO EQ *
  597. SA2 WORDPT SAVE WORDPT
  598. BX6 X2
  599. SA6 OWORDPT
  600. SA2 INX SAVE INX
  601. BX6 X2
  602. SA6 OLDINX
  603. SA2 LASTKEY SAVE LASTKEY
  604. BX6 X2
  605. SA2 OLDLAST
  606. EQ SAVEO
  607. *
  608. *
  609. * -RESTO-
  610. *
  611. * RESTORE INFORMATION SAVED BEFORE LOOK AHEAD
  612. * FROM *OLD* BUFFER
  613. *
  614. RESTO EQ *
  615. SA2 OWORDPT RESTORE WORDPT
  616. BX6 X2
  617. SA6 WORDPT
  618. SA2 OLDINX RESTORE INX
  619. BX6 X2
  620. SA6 INX
  621. SA2 OLDLAST RESTORE LASTKEY
  622. BX6 X2
  623. SA6 LASTKEY
  624. EQ RESTO
  625. *
  626. *
  627. DEFRDAB NG B2,BADTYP IF ILLEGAL TYPE DECLARATION
  628. *
  629. DEFRDB SX7 X2 SAVE TERMINATOR
  630. SA7 ENDKEY
  631. * /--- BLOCK DEFR2 00 000 76/08/01 23.59
  632. SA1 DSET CURRENT SET NUMBER
  633. NG X1,ERR9
  634. MX6 0
  635. SA6 NARGS CLEAR ARGUMENT COUNT
  636. SA6 NADS CLEAR ADTYPE COUNT
  637. SA6 NOPS CLEAR OPERATION COUNT
  638. SX3 X2-OPASIGN OK IF ASSIGNMENT ARROW
  639. ZR X3,DNAME
  640. SX3 X2-OP= OK IF EQUAL SIGN
  641. ZR X3,DNAME
  642. SX3 X2-OP( OK IF L PAREN (FUNCTION)
  643. ZR X3,DNAME
  644. SA1 LOCAL X1 = LOCAL SET FLAG
  645. ZR X1,ERR1 IF NOT PROCESSING LOCAL SET
  646. *
  647. SX3 X2-OPCOMMA COMMA LEGAL IN LOCAL SET
  648. ZR X3,DNAME IF COMMA
  649. *
  650. SX3 X2-EOL EOL LEGAL IN LOCAL SET
  651. NZ X3,ERR1 OTHERWISE, ILLEGAL CHARACTER
  652. *
  653. *
  654. DNAME CALL SYMCHK,DEFNAME
  655. SX7 -1 SET VSEEK TO NO EXPANSION
  656. SA7 VSKMODE
  657. MX6 0
  658. SA6 UDMODE NO INTERPRETATION OF *UNITS*
  659. SA1 DEFNAME
  660. BX6 X1 PUT NAME IN X6 FOR CALL
  661. RJ =XVSEEK SEE IF NAME ALREADY DEFINED
  662. SA1 ADTYPE
  663. PL X1,ERR6 ERROR IF DUPLICATE NAME
  664. SA7 DEFNLOC STORE LOCATION TO INSERT DEFN
  665. RJ =XINITLEX SETUP FOR PROGRAM -LEX-
  666. SA1 ENDKEY
  667. SX2 X1-OP( CHECK TERMINATOR KEY
  668. NZ X2,DEFIN JUMP IF NOT FUNCTION DEFINE
  669. *
  670. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  671. *
  672. *
  673. SA1 LOCAL
  674. ZR X1,ARGDO IF NOT LOCAL SET
  675. *
  676. RJ SAVEO SAVE COMPILATION LOCATION
  677. RJ =XRTOKNAM
  678. RJ =XLEX IS NEXT LEXICAL ITEM DEFINED
  679. SA1 OP
  680. NZ X1,DEFL280 IF AN OPERATOR, ASSUME CONSTANT
  681. *
  682. SA1 ADTYPE
  683. NG X1,DEFL290 IF UNDEFINED, ASSUME AN ARG
  684. *
  685. DEFL280 RJ RESTO RESTORE TO PRE-LEX CONDITION
  686. SA1 WORDPT POINT TO LEFT PAREN
  687. SX6 X1-1
  688. SA6 A1
  689. RJ =XCOMPILE
  690. SA2 OLDINX RESTORE INX
  691. BX6 X2
  692. SA6 INX
  693. MX0 -XCODEAL
  694. BX0 X0*X1 X0 = GETVAR W/ZEROED ADDRESS
  695. ZR X0,DEFL300 IF A SHORT LITERAL
  696. *
  697. DEFL290 RJ RESTO RESTORE COMPILATION
  698. SX7 -1 SET VSEEK TO NO EXPANSION
  699. SA7 VSKMODE
  700. MX6 0
  701. SA6 UDMODE
  702. RJ =XINITLEX
  703. EQ ARGDO CONTINUE WITH ARGUMENTS
  704. *
  705. DEFL300 BSS 0
  706. *
  707. *
  708. * ADD LOCAL VECTOR DEFINE
  709. *
  710. SA2 LBYTES X2 = BYTE SIZE
  711. SX3 X2-60
  712. NZ X3,DEFL500 IF HORIZONTAL SEGMENT
  713. *
  714. * FULL WORD VECTOR
  715. *
  716. SA2 LVARN X2 = NUMBER OF LOCALS SO FAR
  717. IX6 X1+X2 INDEX OF LAST VAR IN THIS ARRAY
  718. BX7 X1 SAVE VECTOR LENGTH
  719. RJ =XLBOUND CHECK ITS BOUNDS
  720. SA6 A2 STORE NEW NUMBER OF LOCALS
  721. BX6 X2 SAVE OLD NUMBER OF LOCALS
  722. SA6 OLVARN
  723. *
  724. * SIMULATE ',ARRAY,XXX(YYY)=NL(ZZZ)', WHERE ',XXX', IS
  725. * DEFINE NAME AND ',YYY', IS THE VECTOR LENGTH
  726. * AND ZZZ IS THE BASE LOCATION OF THE VECTOR
  727. *
  728. SX6 X7-1 X6 = VECTOR SIZE - 1
  729. SX5 1 SET ARRAY DIMENSIONS TO 1
  730. LX5 9
  731. BX7 X5+X7
  732. LX7 9 X7 = ARRAY WORD W/NUM WORDS
  733. BX7 X6+X7 NUMBER OF ROWS - 1
  734. LX7 36 BY-PASS PLANES FOR 3D MATRIX
  735. SA1 OLVARN RESTORE PREVIOUS LVARN
  736. SX1 X1+1 VECTOR BEGINS AT NEXT WORD
  737. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  738. SA2 ASVARS X2 = ADDR OF STUDENT VARS
  739. SA3 ALVARS X3 = ADDR OF LOCAL VARS
  740. IX3 X3-X2 OFFSET TO LOCAL VARS
  741. IX1 X1+X3 OFFSET TO LOCAL VECTOR
  742. SA2 LTYPE X2 = TYPE GETVAR
  743. BX7 X7+X2 ADD GETVAR OF FIRST ELEMENT
  744. BX1 X7+X1
  745. RJ =XSTUFLIT
  746. SA2 TOKWRD
  747. RJ =XAPTWD
  748. SX4 6 INDICATE AN ARRAY TYPE DEFINE
  749. EQ DEFL530 TREAT LIKE SEGMENT NOW
  750. *
  751. *
  752. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  753. * ADD LOCAL SCALAR DEFINE
  754. *
  755. DEFL400 BSS 0
  756. SA1 WORDPT SET LASTKEY FOR EOL TEST
  757. SA1 X1-1
  758. BX7 X1
  759. SA7 LASTKEY
  760. SA1 LBYTES X1 = BITS PER BYTE
  761. SX2 X1-60
  762. NZ X2,DEFL410 IF SEGMENTED SCALAR
  763. *
  764. * FULL WORD SCALAR
  765. *
  766. SX6 60 ALL BITS USED IN NEW WORD
  767. SA6 LSHIFT
  768. SA2 LVARN X2 = NUMBER OF LOCAL VARS
  769. SX6 X2+1
  770. RJ =XLBOUND CHECK BOUNDS
  771. SA6 A2 NEW NUMBER OF LOCALS
  772. SA1 ASVARS ADDRESS OF STUDENT VARS
  773. SA3 ALVARS ADDRESS OF LOCAL VARS
  774. IX6 X3+X6 ADDRESS OF LOCAL VAR
  775. IX6 X6-X1 BIAS TO LOCAL VAR
  776. SA1 LTYPE GETVAR TYPE CODE
  777. BX4 X6+X1 X4 = NL/VL GETVAR CODE
  778. EQ ADNAM ADD LOCAL VAR TO DEFINE TABLE
  779. *
  780. * ADD LOCAL SCALAR SEGMENT DEFINE
  781. *
  782. DEFL410 SA2 LSHIFT X2 = BITS USED IN CURRENT WORD
  783. SA3 LSIGN X3 = 1 IF SIGNED
  784. SA4 LVARN X4 = VARLOC OF SEGMENTF
  785. LX3 2 POSITION SIGN BIT
  786. SX3 X3+3 INDICATE SEGMENTF
  787. LX3 20
  788. BX3 X3+X1 NUMBER OF BITS PER BYTE
  789. IX6 X2+X1 INCREMENT BITS USED
  790. SX7 X6-61 - BITS LEFT IN WORD
  791. NG X7,DEFL420 IF CAN FIT IN THIS WORD
  792. *
  793. BX6 X1 BITS USED IN NEW WORD
  794. MX2 0 START OF NEW BYTE
  795. SX4 X4+1 INCREMENT LVARN
  796. DEFL420 SA6 A2 STORE NEW NUMBER OF BITS USED
  797. BX6 X4 STORE NEW LVARN
  798. RJ =XLBOUND CHECK BOUNDS ON LOCAL INDEX
  799. SA6 A4
  800. SA1 ASVARS ADDRESS OF STUDENT VARS
  801. SA4 ALVARS ADDRESS OF LOCAL VARS
  802. IX6 X4+X6 ADDRESS OF LOCAL VAR
  803. IX6 X6-X1 BIAS TO LOCAL VAR
  804. LX3 18
  805. BX3 X3+X6 BIAS TO SEGMENTF
  806. LX3 18
  807. SX2 X2+1 BIT POSITION OF SEGMENTF
  808. BX1 X2+X3
  809. RJ =XSTUFLIT STORE SEGMENT DESCIPTOR
  810. SA2 TOKWRD IN ECS TOKEN BUFFER
  811. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  812. RJ =XAPTWD
  813. SX4 5 X4 = TYPE CODE FOR SEGMENT
  814. LX4 XCODEAL POSITION TYPE CODE
  815. SA1 TOKWRD
  816. SX1 X1-1 X1 = TOKEN ADDR OF SEG LIT
  817. BX4 X4+X1 X4 = COMPLETE GETVAR
  818. EQ ADNAM
  819. *
  820. *
  821. * ADD LOCAL VECTOR SEGMENT DEFINE
  822. *
  823. DEFL500 EQ NOTYET NO SEGMENTED VECTOR LOCALS YET
  824. PX3 X2 X3 = FLOAT(BYTESIZE)
  825. NX3 X3
  826. SA4 K60 X4 = 60.0
  827. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  828. RX3 X4/X3 X3 = 60/BYTESIZE
  829. UX3 X3,B1
  830. LX3 X3,B1 X3 = BYTES PER WORD
  831. PX3 X3
  832. NX3 X3
  833. PX4 X1 X4 = FLOAT(BYTES)
  834. NX4 X4
  835. RX4 X4/X3 X4 = BYTES/BYTESPERWORD
  836. UX4 X4,B4
  837. LX4 X4,B4 X4 = NUMBER OF FULL WORDS USED
  838. UX3 X3,B3
  839. LX3 X3,B3 X3 = BYTES/WORD
  840. IX5 X3*X4 X3 = BYTES RESIDING IN FULL WDS
  841. IX5 X1-X5 X5 = BYTES IN LAST WORD
  842. IX7 X5*X2 X7 = BITS USED IN LAST WORD
  843. SA7 LSHIFT
  844. BX5 X3 SAVE BYTES PER WORD
  845. SA3 LVARN X3 = WORDS USED SO FAR
  846. ZR X7,DEFL510 IF ALL BITS USED IN LAST WORD
  847. *
  848. SX4 X4+1 X4 = NUMBER OF WORDS INVOLVED
  849. EQ DEFL520
  850. *
  851. DEFL510 IX6 X2*X5 ALL BYTES USED IN LAST WORD
  852. SA6 LSHIFT
  853. DEFL520 IX6 X4+X3 HIGHEST VARLOC IN SEGMENT
  854. RJ =XLBOUND MAKE SURE WITHIN RANGE
  855. SA6 LVARN
  856. SA1 LSIGN X1 = UN/SIGNED SEGMENT
  857. LX1 22
  858. BX1 X1+X2 BYTE SIZE
  859. LX1 18
  860. SA2 ASVARS ADDRESS OF STUDENT VARS
  861. SA4 ALVARS ADDRESS OF LOCAL VARS
  862. SX3 X3+1 VARLOC OF FIRST BYTE
  863. IX4 X3+X4 ADDRESS OF LOCAL VAR
  864. IX4 X4-X2 BIAS TO LOCAL VAR
  865. BX1 X1+X4 BIAS TO SEGMENT
  866. LX1 18
  867. BX1 X1+X5 NUMBER OF BYTES PER WORD
  868. RJ =XSTUFLIT
  869. SA2 TOKWRD
  870. RJ =XAPTWD
  871. SX4 5 X4 = SEGMENT TYPE
  872. DEFL530 LX4 XCODEAL POSITION TYPE
  873. SA1 TOKWRD
  874. BX4 X4+X1 INCLUDE ADDRESS
  875. SX4 X4-1 X4 = GETVAR CODE
  876. EQ ADNAM
  877. *
  878. *
  879. ARGDO CALL LEX GET NEXT ITEM
  880. SA1 OP
  881. ZR X1,GOTARG JUMP IF ARG NOT SEPERATOR
  882. SX2 X1-OPDEFN
  883. ZR X2,ERR6 DEFINE NAME USED AS ARGUMENT
  884. SX2 X1-OP)
  885. ZR X2,ENDARGS DONE WITH ARGS IF PAREN
  886. SX2 X1-OPCOMMA
  887. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  888. NZ X2,ERR1 ERROR IF NOT SEPERATOR
  889. SX7 -1
  890. SA7 LASTKEY CLEAR LASTKEY
  891. EQ ARGDO
  892. *
  893. GOTARG SA1 ADTYPE MUST BE UNRECOGNIZED NAME
  894. PL X1,ERR12
  895. SA2 NARGS CURRENT NUMBER OF ARGUMENTS
  896. SX6 X2+1
  897. SX0 X2-MAXARG CHECK TOO MANY ARGS
  898. PL X0,ERR5
  899. SA6 A2
  900. SA1 AD GET NAME OF ARGUMENT
  901. BX6 X1
  902. SA6 X2+ARGLIST SAVE NAME OF ARGUMENT
  903. * /--- BLOCK ARGDO 00 000 77/01/26 20.37
  904. EQ ARGDO
  905. *
  906. ENDARGS SA2 NARGS
  907. ZR X2,ERR13 JUMP IF ZERO ARGUMENTS F()
  908. RJ =XLEX GET NEXT ITEM
  909. SA1 OP
  910. SX2 X1-OP= LAST CODE MUST BE =
  911. ZR X2,DEFIN
  912. SX2 X1-OPASIGN OR ASSIGNMENT
  913. NZ X2,ERR1
  914. *
  915. DEFIN MX6 0 RIGHT SIDE OF A DEFINITION
  916. SA6 VSKMODE RESET MODE FOR VSEEK
  917. SA6 UREF CLEAR *UNIT* ENCOUNTERED FLAG
  918. SA6 UDMODE NO INTERPRETATION OF *UNITS*
  919. SA1 TOKWRD
  920. BX6 X1 SAVE BEGINNING ADDRESS
  921. SA6 DEFLOC
  922. SX6 60 INITIALIZE SHIFT COUNT
  923. SA6 TOKSHF
  924. MX6 0 CLEAR NEXT TOKEN WORD
  925. SA6 TWD
  926. SA6 DNVAR CLEAR NUMBER VARIABLES
  927. MX6 -1 ASSUME CONSTANT OR SIMPLE
  928. SA6 DCONST
  929. SA1 WORDPT
  930. BX6 X1 SAVE *WORDPT*
  931. SA6 IWORDPT
  932. SA2 LOCAL
  933. ZR X2,DEFIN10 IF NOT PROCESSING LOCAL SET
  934. *
  935. SA1 ENDKEY X1 = TERMINATOR/DELIMITER
  936. SX2 X1-OPCOMMA
  937. ZR X2,DEFL400 IF SCALAR LOCAL DEFINE
  938. *
  939. SX2 X1-EOL
  940. ZR X2,DEFL400 IF SCALAR LOCAL DEFINE
  941. *
  942. DEFIN10 BSS 0
  943. SA1 NARGS NUMBER OF ARGS IS FIRST TOKEN
  944. RJ STUFF
  945. * /--- BLOCK DLEX 00 000 77/02/25 03.58
  946. *
  947. * NOW INTERPRET DEFN
  948. *
  949. DLEX BSS 0
  950. SX7 1 INITIALIZE LITS POINTER
  951. SA7 NLITS
  952. RJ =XLEX GET NEXT OP/ADD
  953. SA1 OP
  954. ZR X1,ADDR JUMP IF ADDRESS
  955. SX2 X1-OPCOMMA
  956. ZR X2,ENDDEF
  957. SX2 X1-EOL
  958. ZR X2,ENDDEF END OF DEFINE
  959. *
  960. RJ STUFF
  961. SA2 NOPS
  962. SX6 X2+1 COUNT OPS
  963. SA6 A2
  964. EQ DLEX
  965. *
  966. * PROCESS ADDRESS
  967. *
  968. ADDR SA1 NADS
  969. SX6 X1+1 INCREMENT ADDRESS COUNT
  970. SA6 A1
  971. SA1 ADTYPE
  972. NG X1,ARGLOOK UNRECOGNIZED - CHECK ARGLIST
  973. BX2 X1
  974. AX2 XCODEAL SHIFT OFF ADDRESS
  975. MX0 -4 MASK FOR I/F BIT AND TYPE CODE
  976. BX2 -X0*X2
  977. SB1 X2
  978. JP B1+*+1 JUMP BY TYPE
  979. *
  980. + EQ ADDR1 SHORT LITERAL
  981. + EQ ADRLIT LONG LITERAL
  982. + EQ ADDRV STUDENT VARIABLE
  983. + EQ ADDRV COMMON VARIABLE
  984. + EQ ERR11 IMPOSSIBLE
  985. + EQ ADRSEG SEGMENT
  986. + EQ ADRARY ARRAY
  987. + EQ ERR11 IMPOSSIBLE
  988. *
  989. + EQ ADUNIT UNIT
  990. + EQ ADRLIT LONG LITERAL
  991. + EQ ADDRV STUDENT VARIABLE
  992. + EQ ADDRV COMMON VARIABLE
  993. + EQ ERR11 IMPOSSIBLE
  994. + EQ ERR11 IMPOSSIBLE
  995. + EQ ERR11 IMPOSSIBLE
  996. + EQ ERR11 IMPOSSIBLE
  997. *
  998. *
  999. ADDRV SA2 DNVAR INC NUMBER VARS ENCOUNTERED
  1000. SX6 X2+1
  1001. SA6 A2
  1002. *
  1003. ADDR1 RJ STUFADR *STUFF* BOTTOM 24(X1) IN TOKENS
  1004. EQ DLEX
  1005. * /--- BLOCK ADRSEG 00 000 77/02/25 04.19
  1006. *
  1007. * PROCESS LONG LITERAL
  1008. *
  1009. * SEGMENT HAS A LITERAL ASSOCIATED -- A 60-BIT WORD
  1010. * DESCRIBING THE SEGMENTATION. SIMILARLY, ARRAYS HAVE
  1011. * AN INFO WORD (AND BASE-BIAS OR SEGMENTED ARRAYS HAVE TWO)
  1012. *
  1013. ADRARY BSS 0
  1014. MX6 0 MARK NOT ALL CONSTANT/SIMPLE
  1015. SA6 DCONST
  1016. EQ ADDR1 PREVIOUSLY DEFINED
  1017. *
  1018. ADRSEG MX6 0 MARK NOT ALL CONSTANT/SIMPLE
  1019. SA6 DCONST
  1020. EQ ADDR1 PREVIOUSLY DEFINED
  1021. *
  1022. ADRLIT BSS 0
  1023. LX1 60-LITSHF1
  1024. NG X1,IMMLIT IF IMMEDIATE LITERAL
  1025. *
  1026. LX1 LITSHF1
  1027. EQ ADDR1 PREVIOUSLY DEFINED
  1028. *
  1029. IMMLIT LX1 LITSHF1
  1030. RJ STLIT1 LITERAL IMMEDIATELY FOLLOWS ADT
  1031. EQ DLEX
  1032. *
  1033. ADUNIT MX6 1 MARK UNIT ENCOUNTERED
  1034. LX6 XCODEAL
  1035. SA6 UREF
  1036. MX6 0 MARK NOT ALL CONSTANTS
  1037. SA6 DCONST
  1038. EQ ADDR1
  1039. *
  1040. * /--- BLOCK ARGLOOK 00 000 76/02/17 20.05
  1041. *
  1042. ARGLOOK SA1 NARGS NUMBER OF ARGUMENTS
  1043. SA2 AD GET NAME TO SEARCH FOR
  1044. MX6 0 MARK NOT ALL CONSTANTS
  1045. SA6 DCONST
  1046. *
  1047. ASEEK1 SX1 X1-1 DECREMENT INDEX
  1048. NG X1,ERR3 JUMP IF NAME NOT FOUND
  1049. SA3 X1+ARGLIST
  1050. BX6 X3-X2 SEE IF NAMES MATCH
  1051. NZ X6,ASEEK1
  1052. BX7 X1 SAVE INDEX
  1053. SX1 OPARG INSERT CODE FOR ARG
  1054. RJ STUFF
  1055. BX1 X7
  1056. RJ STUFF INSERT ARG NUMBER
  1057. SA1 LASTKEY
  1058. SX2 X1-1R( CHECK FOR IMPLIED MULTIPLY
  1059. ZR X2,ARGMULT
  1060. SX2 X1-KLBRACK
  1061. NZ X2,DLEX
  1062. ARGMULT SX1 OPMULT INSERT MULTIPLY
  1063. RJ STUFF
  1064. EQ DLEX
  1065. *
  1066. * /--- BLOCK ENDDEF 00 000 76/02/24 19.36
  1067. *
  1068. * FINAL PROCESSING
  1069. * CHECK FOR PRIMITIVE DEFN
  1070. *
  1071. ENDDEF SX1 EOL INSERT AN EOL
  1072. RJ STUFF
  1073. SA2 TOKWRD
  1074. RJ APTWD WRITE OUT CURRENT *TWD*
  1075. SA1 NARGS CHECK IF FUNCTION
  1076. NZ X1,ENDD50
  1077. SA1 DCONST CHECK IF MAY BE ALL CONSTANTS
  1078. ZR X1,ENDD50 OR SIMPLE VARIABLES
  1079. SA1 DNVAR
  1080. SX1 X1-2 CHECK IF MORE THAN ONE VARIABLE
  1081. PL X1,ENDD50 ENCOUNTERED
  1082. *
  1083. SA1 WORDPT SAVE *WORDPT*
  1084. BX6 X1
  1085. SA6 OWORDPT
  1086. SA1 INX SAVE *INX*
  1087. BX6 X1
  1088. SA6 OLDINX
  1089. SA1 IWORDPT RE-SET *WORDPT* TO BEGIN OF
  1090. BX6 X1 EXPRESSION
  1091. SA6 WORDPT
  1092. SA1 LASTKEY
  1093. BX6 X1 SAVE *LASTKEY*
  1094. SA6 OLDLAST
  1095. RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  1096. RJ =XCOMPILE EVALUATE EXPRESSION
  1097. SA2 OWORDPT
  1098. BX6 X2 RESTORE *WORDPT*
  1099. SA6 WORDPT
  1100. SA2 OLDINX
  1101. BX6 X2 RESTORE *INX*
  1102. SA6 INX
  1103. SA2 OLDLAST
  1104. BX6 X2 RESTORE *LASTKEY*
  1105. SA6 LASTKEY
  1106. BX4 X1 X4 = -GETVAR- CODE
  1107. AX1 XCODEAL POSTION -GETVAR- CODE TYPE
  1108. MX0 -3
  1109. BX1 -X0*X1
  1110. SB1 X1 PICK UP CODE TYPE
  1111. JP B1+*+1
  1112. *
  1113. + EQ ENDD40 SHORT LITERAL
  1114. + EQ ENDD20 LONG LITERAL
  1115. + EQ ENDD40 STUDENT VARIABLE
  1116. + EQ ENDD40 COMMON VARIABLE
  1117. + EQ NORMAL EXPRESSION
  1118. + EQ NORMAL UNUSED
  1119. + EQ NORMAL ARRAY
  1120. + EQ NORMAL SPECIAL JUMP
  1121. *
  1122. * /--- BLOCK ENDD20 00 000 76/02/19 02.45
  1123. *
  1124. ENDD20 BSS 0
  1125. SA1 DEFLOC RE-SET TOKEN POINTER
  1126. BX6 X1
  1127. SA6 TOKWRD
  1128. MX0 -XCODEAL
  1129. BX2 -X0*X4 ISOLATE ADDRESS
  1130. SA2 X2+INFO LOAD LITERAL
  1131. BX6 X2
  1132. SA6 TWD
  1133. MX6 0
  1134. SA6 TOKSHF INDICATE NO BITS LEFT
  1135. BX4 X0*X4 ZERO ADDRESS
  1136. BX4 X4+X1 INSERT ADDR(LIT IN TOKBUFF)
  1137. RJ ENDDTWD
  1138. EQ ADNAM
  1139. *
  1140. ENDD40 BSS 0
  1141. MX6 0
  1142. SA6 TWD
  1143. SA1 DEFLOC RE-SET TOKEN POINTER
  1144. BX6 X1
  1145. SA6 TOKWRD
  1146. SX6 60 ALL BITS AVAILABLE
  1147. SA6 TOKSHF
  1148. EQ ADNAM
  1149. *
  1150. ENDD50 SA1 NADS NUMBER OF ADDRESSES
  1151. SX1 X1-1
  1152. NZ X1,NORMAL JUMP IF NOT SIMPLE
  1153. SA1 NOPS NUMBER OF OPERATIONS
  1154. NZ X1,NORMAL JUMP IF NOT SIMPLE
  1155. SA1 DEFLOC ADDRESS OF DEFN
  1156. RJ =XSETDEF
  1157. RJ =XGETDEF NUMBER OF ARGUMENTS
  1158. NZ X1,NORMAL
  1159. RJ =XGETDEF GET FIRST ITEM
  1160. MX0 42 (X0) = GETVAR MASK
  1161. BX4 -X0*X1 SAVE *GETVAR* CODE
  1162. EQ ADNAM ADD DEFN NAME TO TABLE
  1163. *
  1164. * -ENDDTWD-
  1165. * ADD THE LAST TOKEN WORD TO *TOKBUF*
  1166. *
  1167. ENDDTWD EQ *
  1168. BX6 X4 SAVE GETVAR CODE
  1169. SA6 GVSAVE
  1170. SA2 TOKWRD
  1171. RJ APTWD
  1172. SA4 GVSAVE
  1173. EQ ENDDTWD
  1174. *
  1175. GVSAVE BSS 1
  1176. * /--- BLOCK NORMAL 00 000 75/02/11 02.52
  1177. *
  1178. NORMAL SX4 4 USE CODE FOR CALC
  1179. LX4 XCODEAL POSITION CODE
  1180. SA1 UREF
  1181. BX4 X1+X4 ATTACH *UNIT* BIT
  1182. SA1 DEFLOC
  1183. BX4 X4+X1 ATTACH ADDRESS
  1184. * SA1 TOKWRD
  1185. * SX6 X1+1 ADVANCE TO NEXT FREE WORD
  1186. * SA1 ATOKEN
  1187. * IX5 X1+X6 ECS ADDRESS OF NEXT TWD
  1188. * SA2 AVAR ECS ADDRESS OF FIRST NAME
  1189. * IX1 X5-X2
  1190. * PL X1,ERR4 BUFFER FULL
  1191. * SA6 TOKWRD
  1192. *
  1193. ADNAM BSS 0
  1194. CALL ADDNAM,DEFNAME
  1195. * /--- BLOCK ENDLIN 00 000 81/07/16 04.21
  1196. SA1 LASTKEY CHECK IF MORE TO LINE
  1197. SA1 X1+KEYTYPE
  1198. SX2 X1-OPCOMMA
  1199. NZ X2,ELN1 JUMP IF NOT COMMA
  1200. SA1 WORDPT
  1201. SA2 X1 SEE IF END-OF-LINE
  1202. ZR X2,ELN1
  1203. EQ DEFRD CONTINUE IF MORE
  1204. *
  1205. ENDLIN SX2 X1-EOL SEE IF END OF LINE CODE
  1206. ZR X2,ELN1 JUMP IF END-OF-LINE
  1207. EQ DEFRD
  1208. *
  1209. ELN1 RJ =XRTOKNAM FOR CONDITIONAL CSTOP/CSTART
  1210. RJ =XGETLINE
  1211. SA1 COMMAND CHECK FOR BLANK COMMAND
  1212. SA2 COMCONT
  1213. BX2 X1-X2 BLANK FOR CONTINUED COMMAND
  1214. ZR X2,DEFRD JUMP IF CONTINUED
  1215. SA3 LOCAL SEE IF LOCAL SET PROCESSING
  1216. ZR X3,ELN5 NEXT COMMAND IF GLOBAL SET
  1217. *
  1218. RJ =XSAVETAG SAVE THE NEXT LINES TAG
  1219. SA0 LUNIT RESTORE -UNIT- TAG FOR ARG
  1220. SA1 ATEMPEC
  1221. BX0 X1
  1222. WE TAGLTH+1
  1223. RJ ECSPRTY
  1224. SA0 TAG
  1225. RE TAGLTH+1
  1226. RJ ECSPRTY
  1227. *
  1228. SA1 LWRDPT POINT TO ARGUMENTS LIST
  1229. BX6 X1
  1230. SA6 WORDPT
  1231. EXEC JOINOV,14 RE-ENTER -UNIT PROCESSING
  1232. *
  1233. ELN5 BSS 0
  1234. SA2 HOLDEFN
  1235. IX2 X1-X2 CHECK FOR ANOTHER -DEFINE-
  1236. ZR X2,DEFNIN
  1237. *
  1238. EQ NXTC
  1239. NOSET SB1 11 NO SET
  1240. SA2 KE1
  1241. EQ ERRX
  1242. *
  1243. NAMERR SB1 12 BAD NAME
  1244. SA2 KE2
  1245. EQ ERRX
  1246. *
  1247. DUPNAM SB1 13 DUPLICATE
  1248. SA2 KE3
  1249. EQ ERRX
  1250. *
  1251. BADVAR SB1 14 BAD VAR
  1252. SA2 KE4
  1253. EQ ERRX
  1254. *
  1255. BADFORM SB1 15 BAD FORM
  1256. SA2 KE5
  1257. EQ ERRX
  1258. *
  1259. BADCNT SB1 16 BAD COUNT
  1260. SA2 KE6
  1261. EQ ERRX
  1262. *
  1263. BADSIZ SB1 17 BAD SIZE
  1264. SA2 KE7
  1265. EQ ERRX
  1266. *
  1267. BADTYP1 MX6 0 RESET LOCALS FLAG
  1268. SA6 LOCAL
  1269. BADTYP SB1 18 ARRAY TYPE
  1270. SA2 KE8
  1271. * /--- BLOCK ENDLIN 00 000 80/03/23 08.26
  1272. EQ ERRX
  1273. *
  1274. LITFULL SB1 19 MANY LITS
  1275. SA2 KE9
  1276. EQ ERRX
  1277. *
  1278. NAMFULL SB1 20 MANY NAMES
  1279. SA2 KE10
  1280. EQ ERRX
  1281. *
  1282. UFULL SB1 21 MANY UNITS
  1283. SA2 KE11
  1284. EQ ERRX
  1285. *
  1286. NOTYET SB1 22 NOT YET IN
  1287. SA2 KE12
  1288. EQ ERRX
  1289. *
  1290. *
  1291. *
  1292. * /--- BLOCK ENDLIN 00 000 80/03/23 08.25
  1293. ERR1 EQ CHARERR
  1294. *
  1295. ERR2 EQ LITERR
  1296. *
  1297. ERR3 SB1 25 UNDEFINED
  1298. SA1 KERR3
  1299. *
  1300. ERRX BX7 X1
  1301. SA7 CERROR1 STORE MESSAGE
  1302. ERRXX SX7 11 CODE FOR DEFINE ERROR
  1303. SA7 TFORMOK
  1304. SA3 LOCAL
  1305. ZR X3,=XERR IF NOT PROCESING LOCAL SET
  1306. *
  1307. SA1 DSET
  1308. SA1 SETNAMS+X1 X1 = NAME OF CURRENT SET
  1309. SA2 KLOCAL X2 = NAME OF LOCAL SET
  1310. IX3 X1-X2
  1311. ZR X3,=XERR IF LOCAL SET PROCESSING OK
  1312. *
  1313. MX6 0 NO LOCAL SET IN EFFECT
  1314. SA6 A3 ZERO LOCAL FLAG
  1315. EQ =XERR
  1316. *
  1317. ERR4 SB1 26 TOO MUCH
  1318. SA1 KERR4
  1319. EQ ERRX
  1320. *
  1321. ERR5 SB1 27 MANY ARGS
  1322. SA1 KERR5
  1323. EQ ERRX
  1324. *
  1325. ERR6 SB1 28 DUPLICATE
  1326. SA1 KERR6
  1327. EQ ERRX
  1328. *
  1329. ERR7 SB1 29 BAD NAME
  1330. SA1 KERR7
  1331. EQ ERRX
  1332. *
  1333. ERR8 SB1 30 BAD SET
  1334. SA1 KERR8
  1335. EQ ERRX
  1336. * /--- BLOCK ERR9 00 000 80/03/23 07.50
  1337. *
  1338. LIST X
  1339. *CALL DEFTEXT
  1340. LIST *
  1341. * /--- BLOCK ERR9 00 000 80/03/23 07.50
  1342. *
  1343. ERR9 SB1 31 NO SET
  1344. SA1 KERR9
  1345. EQ ERRX
  1346. *
  1347. ERR10 EQ FORMERR
  1348. *
  1349. ERR11 SB1 32 SYS ERR 1
  1350. SA1 KERR11
  1351. EQ ERRX
  1352. *
  1353. ERR12 SB1 33 ARG MUST BE UNRECOGNIZED NAME
  1354. EQ ERRXX
  1355. *
  1356. ERR13 SB1 34 CAN'7T HAVE ZERO ARGUMENTS F()
  1357. EQ ERRXX
  1358. *
  1359. * /--- BLOCK PURGE/ALL 00 000 79/02/18 17.47
  1360. *
  1361. PURGE SX3 X2-EOL
  1362. ZR X3,PURGALL PURGE ALL DEFINE SETS
  1363. CALL GETNAME,7 GET NAME OF SET TO PURGE
  1364. SX3 X2-EOL ERROR IF NOT END-OF-LINE
  1365. NZ X3,ERRORC
  1366. RJ =XFINDSET SEE IF SET EXISTS
  1367. NG B1,ERRORC
  1368. *
  1369. RJ PURGSET PURGE DSET B1
  1370. EQ PNXTLN
  1371. *
  1372. PURGALL BSS 0
  1373. RJ ALLPURG SUBROUTINE SINCE USED ELSEWHER
  1374. EQ PNXTLN
  1375. *
  1376. *
  1377. * *PURGSET*
  1378. *
  1379. * PURGE DEFINE SET
  1380. * ON ENTRY B1 = DSET TO PURGE
  1381. * DSET = CURRENTLY OPEN SET
  1382. *
  1383. * ON EXIT DSET = -1 IF ACTIVE SET PURGED
  1384. *
  1385. PURGSET EQ *
  1386. SX6 B1 SAVE DSET TO BE PURGED
  1387. SA6 PSET
  1388. SA1 DSET SEE IF IT IS CURRENT SET
  1389. SB2 X1
  1390. NE B1,B2,NOCLOSE IF NOT PURGING ACTIVE DSET
  1391. *
  1392. SX1 -1 NULL SET TO BE ACTIVE
  1393. NOCLOSE BX6 X1 SAVE ACTIVE DSET
  1394. SA6 ODSET
  1395. SB1 -1 GET NULL SET
  1396. RJ =XGETSET
  1397. SA1 PSET B1 = SET TO PURGE
  1398. SB1 X1
  1399. SA1 TOKADDS+B0 SOURCE OF MOVE
  1400. SA2 TOKLENS+B1
  1401. SA3 NAMLENS+B1
  1402. IX2 X2+X3
  1403. IX2 X2+X1 DESTINATION OF MOVE
  1404. SA3 TOKADDS+B1
  1405. IX3 X3-X1 LENGTH OF MOVE
  1406. SB4 B1 SET TO END UPDATE
  1407. SB3 -1 SET TO BEGIN UPDATE
  1408. RJ =XUPDNT UPDATE TOK/NAMADDS
  1409. MX6 0 NO TOKENS OR DEFNAMS
  1410. SA6 SETNAMS+B1
  1411. SA6 NAMLENS+B1
  1412. SA6 TOKLENS+B1
  1413. SA4 TOKADDS+B1
  1414. BX6 X4
  1415. SA6 NAMADDS+B1
  1416. SA0 VARS
  1417. SB1 VARLONG
  1418. RJ =XMVECS DELETE ECS COPY OF DSET
  1419. SA1 ODSET
  1420. SB1 X1
  1421. RJ =XGETSET
  1422. SA1 PSET RESTORE B1
  1423. SB1 X1
  1424. EQ PURGSET
  1425. PSET BSS 1
  1426. * /--- BLOCK ALLPURG 00 000 81/07/16 04.20
  1427. *
  1428. ALLPURG EQ *
  1429. SB1 B0 BEGIN WITH DSET 0
  1430. PURGLP SA1 SETNAMS+B1 DO NOT PURGE STUDENT DEFINE SET
  1431. SA2 KSTUD X2 = STUDENT SET NAME
  1432. IX1 X1-X2
  1433. ZR X1,NOPURG IF STUDENT SET, DO NOT PURGE
  1434. *
  1435. RJ PURGSET
  1436. NOPURG BSS 0
  1437. SB1 B1+1
  1438. SB2 MAXSET
  1439. NE B1,B2,PURGLP IF MORE TO PURGE
  1440. EQ ALLPURG
  1441. *
  1442. PURGEL EQ *
  1443. RJ =XSETSET SET UP LOCAL DEFINE SET PARMS.
  1444. SA1 KLOCAL X1 = NAME OF LOCAL SET
  1445. BX6 X1
  1446. RJ =XFINDSET B1 = SET NUMBER OF SET X6
  1447. NG B1,LPERR IF NO LOCAL SET
  1448. *
  1449. RJ PURGSET PURGE SET NUMBER B1
  1450. EQ PURGEL
  1451. *
  1452. PURGELU RJ PURGEL
  1453. SA1 GSET REACTIVATE GLOBAL DEFINE SET
  1454. SB1 X1
  1455. RJ =XGETSET
  1456. EXEC JOINOV,15 RE-ENTRY TO -UNIT- PROCESSING
  1457. *
  1458. PURGELD RJ PURGEL
  1459. EQ =XDFRD10
  1460. *
  1461. LPERR EQ "CRASH" LOCAL SET DIDNT EXIST
  1462. *
  1463. *
  1464. *
  1465. PNXTLN RJ =XGETLINE
  1466. SA1 COMMAND CHECK FOR BLANK COMMAND
  1467. SA2 COMCONT
  1468. BX2 X1-X2 BLANK FOR CONTINUED COMMAND
  1469. ZR X2,ERRORC ERROR IF CONTINUED
  1470. EQ NXTC
  1471. *
  1472. * /--- BLOCK NEWSET 00 000 75/05/29 04.20
  1473. *
  1474. *
  1475. * -NEWSET-
  1476. * INITIALIZES A DEFINE GROUP FOR THE NAME IN X6
  1477. * ON RETURN B1 CONTAINS THE INDEX OF THE GROUP
  1478. *
  1479. NEWSET EQ *
  1480. SA6 SAVEDNM SAVE THE SET NAME
  1481. NW1 MX6 0 0 NAME IS EMPTY SLOT
  1482. RJ =XFINDSET LOOK FOR EMPTY SLOT
  1483. GE B1,B0,NW2 IF EMPTY SLOT FOUND, INITIALIZE
  1484. *
  1485. RJ ALLPURG PURGE ALL BUT -STUDENT-
  1486. EQ NW1 THIS TIME IT WILL FIND IT
  1487. *
  1488. NW2 BSS 0
  1489. SA1 SAVEDNM
  1490. BX6 X1
  1491. SA6 SETNAMS+B1 STORE THE SET NAME
  1492. EQ NEWSET
  1493. *
  1494. * /--- BLOCK STUFF 00 000 75/02/11 03.16
  1495. *
  1496. *
  1497. * -STUFF-
  1498. * STORES THE 12 BIT BYTE IN LOWER X1 IN THE NEXT
  1499. * BYTE POSITION OF *TOKBUF*
  1500. *
  1501. STUFF EQ *
  1502. SA2 TOKWRD WORD COUNT
  1503. SA3 TOKSHF SHIFT COUNT
  1504. SB1 X3-12
  1505. PL B1,STUF1 JUMP IF DONT NEED NEW WORD
  1506. *
  1507. RJ APTWD WRITE OUT CURRENT TOKEN WORD
  1508. SA3 TOKSHF
  1509. SB1 48 DECREMENT *TOKSHF*
  1510. STUF1 MX0 48 12 BIT MASK
  1511. BX1 -X0*X1
  1512. SA2 TWD LOAD CURRENT WORD
  1513. LX1 X1,B1 POSITION NEW BYTE
  1514. LX0 X0,B1
  1515. BX6 X2*X0 CLEAR NEW BYTE POSITION
  1516. BX6 X6+X1 ATTACH NEW BYTE
  1517. SA6 A2 STORE NEW *TWD*
  1518. SX6 B1 STORE NEW *TOKSHF*
  1519. SA6 A3
  1520. EQ STUFF
  1521. *
  1522. *
  1523. * SET THE TOP BIT OF THE FIRST 12 BIT BYTE
  1524. * OF AN ADDRESS *ADTYPE* TO INDICATE THE
  1525. * FOLLOWING BYTE CONTAINS FURTHER INFORMATION
  1526. * AND PUT BOTH BYTES IN THE TOKEN BUFFER
  1527. * ON ENTRY (X1) = ADTYPE
  1528. *
  1529. STUFADR EQ *
  1530. BX7 X1
  1531. AX1 12 STORE FIRST 12 BITS
  1532. SX2 4000B SET 12TH BIT OF 1ST BYTE
  1533. BX1 X1+X2
  1534. RJ STUFF
  1535. BX1 X7 RESTORE
  1536. RJ STUFF STORE 2ND 12 BITS
  1537. BX1 X7 RESTORE
  1538. EQ STUFADR
  1539. *
  1540. * /--- BLOCK STLIT1 00 000 79/02/20 21.04
  1541. *
  1542. * LITERAL IS IMMEDIATE SO IT ADDS IT TO THE
  1543. * TOKEN BUFFER IN THE FIRST WHOLE WORD AFTER ITS
  1544. * ADTYPE WITH THE 22ND BIT OF THE ADTYPE SET
  1545. * TO INDICATE IMMEDIACY TO *GETDEF*
  1546. * ON ENTRY (X1) = GETVAR CODE
  1547. * ADDRESS OF GETVAR CODE POINTS INTO *LITS*
  1548. *
  1549. STLIT1 EQ *
  1550. SA2 TOKSHF PREDICT ADDR OF LIT
  1551. SA3 TOKWRD
  1552. SX4 X2-24
  1553. PL X4,NXTWD IF LIT CAN BEGIN AT NEXT WORD
  1554. *
  1555. SX3 X3+1 MUST BEGIN ONE WORD AFTER THAT
  1556. NXTWD SX3 X3+1 POINT TO NEXT WORD
  1557. MX0 -XCODEAL
  1558. BX2 -X0*X1 GET ADDRESS OF LIT IN *LITS*
  1559. SA2 LITS+X2 GET LITERAL
  1560. BX6 X2
  1561. SA6 LIT
  1562. BX1 X0*X1 ZERO OUT ADDRESS
  1563. BX1 X1+X3 ENTER LIT ADDR IN TOKEN BUFF
  1564. RJ STUFADR STUFF BOTH BYTES OF (X1)
  1565. SA1 LIT (X1) = LITERAL
  1566. RJ STUFLIT WRITE OUT LITERAL TO TOKENS
  1567. * IN NEXT AVAILABLE WORD
  1568. EQ STLIT1
  1569. * /--- BLOCK CONSTANTS 00 000 80/03/23 07.51
  1570. * SUBROUTINE TO CHECK LIST OF SPECIAL NAMES
  1571. LUPDUN SA7 SEGFLG SET SPECIAL DEFINE TYPE
  1572. DEFNAMS EQ * ENTER WITH MAX NO NAMES IN X7
  1573. LUPNAM SA3 X7+DEFNAM-1 GET SPL NAME IN X3
  1574. IX3 X3-X6 NAME IS IN X6
  1575. ZR X3,LUPDUN QUIT IF FOUND
  1576. SX7 X7-1
  1577. NZ X7,LUPNAM
  1578. EQ LUPDUN
  1579. *
  1580. * LIST OF SPECIAL DEFINE TYPE NAMES
  1581. *
  1582. DEFNAM DATA 7LSEGMENT
  1583. DATA 8LSEGMENTV
  1584. DATA 5LUNITS
  1585. DATA 5LARRAY
  1586. DATA 8LARRAYSEG
  1587. DATA 9LARRAYSEGV
  1588. DATA 7LCOMPLEX
  1589. DATA 0LSEGMENTF
  1590. DEFGNML EQU *-DEFNAM
  1591. DATA 7LINTEGER
  1592. DATA 8LFLOATING
  1593. DEFLNML EQU *-DEFNAM
  1594. DATA 5LPURGE ONLY ACTIVE ON FIRST LINE
  1595. DEFNAML EQU *-DEFNAM
  1596. DATA 5LMERGE ONLY ACTIVE IN LOCAL SET, LN 1
  1597. *
  1598. K60 DATA 60.0
  1599. KVERT DATA 0LVERTICAL
  1600. KSIGN DATA 0LSIGNED
  1601. KS DATA 0LS
  1602. KE1 DATA 10LNO SET
  1603. KE2 DATA 10LBAD NAME
  1604. KE3 DATA 10LDUPLICATE
  1605. KE4 DATA 10LBAD VAR
  1606. KE5 DATA 10LBAD FORM
  1607. KE6 DATA 10LBAD COUNT
  1608. KE7 DATA 10LBAD SIZE
  1609. KE8 DATA 10LARRAY TYPE
  1610. KE9 DATA 10LMANY LITS
  1611. KE10 DATA 10LMANY NAMES
  1612. KE11 DATA 10LMANY UNITS
  1613. KE12 DATA 10LNOT YET IN
  1614. *
  1615. KPREVN DATA 8LPREVIOUS
  1616. KGLOBAL DATA 0LGLOBAL
  1617. *
  1618. *
  1619. KBLANK DATA 10L BLANKS
  1620. KSTUD DATA 7LSTUDENT
  1621. *
  1622. *
  1623. KERR3 DATA 10LUNDEFINED
  1624. KERR4 DATA 10LTOO MUCH
  1625. KERR5 DATA 10LMANY ARGS
  1626. KERR6 DATA 10LDUPLICATE
  1627. KERR7 DATA 10LBAD NAME
  1628. KERR8 DATA 10LBAD SET
  1629. KERR9 DATA 10LNO SET
  1630. KERR11 DATA 10LSYS ERR 1
  1631. *
  1632. *
  1633. SAVEDNM BSS 1
  1634. DEFNAME BSS 1
  1635. DEFLOC BSS 1
  1636. ENDKEY BSS 1
  1637. UREF BSS 1
  1638. DCONST BSS 1
  1639. DNVAR BSS 1
  1640. IWORDPT BSS 1
  1641. OWORDPT BSS 1
  1642. INDLIT BSS 1
  1643. OLDINX BSS 1
  1644. OLDLAST BSS 1
  1645. NARGS BSS 1
  1646. ARGLIST BSS MAXARG
  1647. *
  1648. *
  1649. ENDOV
  1650. *
  1651. *
  1652. OVTABLE
  1653. *
  1654. *
  1655. END DEFINE$
  1656. * /--- BLOCK SEGMENT 00 000 81/07/13 01.10
  1657. IDENT SEGMENT
  1658. LCC OVERLAY(1,1)
  1659. *
  1660. TITLE SEGMENT/ARRAY/UNITS
  1661. TITLE
  1662. *
  1663. *
  1664. CST
  1665. *
  1666. *
  1667. SEGMNT$ OVFILE
  1668. *
  1669. *
  1670. EXT CHARERR,BADPAR,DECERR,VARERR
  1671. EXT LOGERR,FORMERR,EQERR,OCTERR
  1672. EXT ALFERR,INDXERR,DEFERR,SEGERR
  1673. EXT COMPERR,LNGERR,LITERR,TEMPERR
  1674. EXT ECSPRTY
  1675. *
  1676. EXT COMCONT,DEFREAD,NXTC
  1677. EXT KEYTYPE,SEGFLG
  1678. *
  1679. *
  1680. SEGOV OVRLAY
  1681. SA1 OVARG1 GET OVERLAY ARGUMENT
  1682. SB1 X1
  1683. JP B1+*+1
  1684. *
  1685. + EQ SEGRD -SEGMENT-
  1686. + EQ UNSRD -UNITS-
  1687. *
  1688. *
  1689. * /--- BLOCK SEGMENT 00 000 73/00/00 00.00
  1690. TITLE READ-IN FOR -SEGMENT- COMMAND
  1691. *
  1692. *
  1693. * -SEGREAD-
  1694. * READ-IN ROUTINE FOR -SEGMENT- COMMAND
  1695. * ADDS THE NAME OF THE SEGMENT TO THE DEFINED
  1696. * NAME TABLE AND ADDS A LITERAL CONTAINING THE
  1697. * SEGMENT INFO TO THE DEFINED TOKEN TABLE
  1698. *
  1699. * FORMAT OF SEGMENT INFO WORD -
  1700. *
  1701. * SIGN BIT = 0 FOR STUDENT, 1 FOR COMMON
  1702. * NEXT BIT = 0 IF UNSIGNED, 1 IF SIGNED
  1703. * NEXT BIT = 0 IF HORIZONTAL, 1 IF VERTICAL
  1704. * NEXT BIT = 1 IF SEGMENTF
  1705. * NEXT 2 BITS = UNUSED
  1706. * NEXT 18 BITS = NUMBER OF BITS PER BYTE
  1707. * NEXT 18 BITS = BIAS TO START OF ARRAY
  1708. * NEXT 18 BITS = NUMBER OF BYTES PER WORD (HORIZ)
  1709. * BIT POSITION OF BYTE (VERT)
  1710. *
  1711. * /--- BLOCK SEGRD 00 000 76/08/02 00.06
  1712. *
  1713. SEGRD SA1 DSET MUST HAVE DEFINE SET
  1714. NG X1,NOSET
  1715. SA1 WORDPT
  1716. SA1 X1-1 BACK UP TO PREVIOUS CHARACTER
  1717. SA2 X1+KEYTYPE
  1718. SX1 X2-OPCOMMA SEE IF ENDED WITH COMMA
  1719. NZ X1,BADFORM
  1720. MX6 -1 SET MODE FOR -VSEEK- SEARCH
  1721. SA6 VSKMODE
  1722. CALL GETNAME,8 GET NAME OF SEGMENT/ARRAY
  1723. ZR X6,NAMERR
  1724. SA6 SEGNAM
  1725. SB2 B1-8 CHECK HOW MANY CHARACTERS
  1726. NG B2,SEG005
  1727. SA3 KVERT
  1728. BX3 X3-X6 CHECK FOR SEGMENT,VERTICAL
  1729. ZR X3,VERTSEG
  1730. EQ NAMERR 8 CHARACTER NAME NOT LEGAL
  1731. *
  1732. SEG005 SA3 SEGFLG IS 1,2 IF SEGMENT,SEGMENTV
  1733. SX3 X3-3
  1734. NG X3,SEG008 IF SEGMENT/SEGMENTV
  1735. SX3 X3-8+3
  1736. NZ X3,ARAYDEF IF NOT SEGMENTF
  1737. SEG008 SX1 X2-OPCOMMA CHECK FOR COMMA
  1738. ZR X1,SEG010
  1739. SX1 X2-OP= CHECK FOR =
  1740. ZR X1,SEG010
  1741. SX1 X2-OPASIGN CHECK FOR ASSIGNMENT
  1742. NZ X1,BADFORM
  1743. *
  1744. SEG010 RJ =XVSEEK SEE IF ALREADY DEFINED
  1745. SA1 ADTYPE
  1746. PL X1,DUPNAM EXIT IF DUPLICATE NAME
  1747. SA7 DEFNLOC SAVE LOCATION OF DEFINITION
  1748. CALL SYMCHK,SEGNAM
  1749. RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  1750. RJ =XCOMPILE STARTING VARIABLE OF ARRAY
  1751. MX0 -XCODEAL MASK FOR ADDRESS PORTION
  1752. BX6 -X0*X1
  1753. LX6 18 POSITION ADDRESS
  1754. AX1 XCODEAL POSITION -GETVAR- CODE TYPE
  1755. MX0 -3
  1756. BX1 -X0*X1 MASK OFF 3 BIT TYPE CODE
  1757. SX2 X1-2
  1758. ZR X2,SEG100 OK IF STUDENT BANK
  1759. SX2 X1-3
  1760. NZ X2,BADVAR ERROR IF NOT COMMON
  1761. MX7 1
  1762. BX6 X6+X7 SET SIGN BIT FOR COMMON
  1763. SEG100 SA6 SEGWORD SAVE TYPE BIT AND ADDRESS
  1764. SA1 SEGFLG
  1765. SX1 X1-1 CHECK FOR SEGMENT
  1766. NZ X1,VSEG20 IF SEGMENTV/F
  1767. * /--- BLOCK SEG200 00 000 75/05/29 04.25
  1768. *
  1769. RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  1770. RJ =XCOMPILE
  1771. MX0 -XCODEAL
  1772. BX6 X0*X1 MUST BE SHORT LITERAL
  1773. NZ X6,BADCNT
  1774. ZR X1,BADCNT
  1775. SX6 X1-60 CHECK IF BYTE TOO BIG
  1776. PL X6,BADCNT
  1777. PX6 X1
  1778. NX6 X6 CONVERT TO FLOATING
  1779. SA2 K60
  1780. FX6 X2/X6 COMPUTE BYTES PER WORD
  1781. UX6 X6,B1
  1782. LX6 X6,B1 BACK TO INTEGER
  1783. LX1 18+18
  1784. BX6 X1+X6 COMBINE BIT AND BYTE COUNTS
  1785. SA1 SEGWORD
  1786. BX6 X1+X6 COMBINE WITH INFO WORD
  1787. SA6 A1
  1788. *
  1789. SEG200 SA2 LASTKEY LOAD LAST CHARACTER
  1790. ZR X2,ADDLIT JUMP IF END-OF-LINE
  1791. SA2 X2+KEYTYPE
  1792. SX6 X2-OPCOMMA CHECK FOR COMMA
  1793. NZ X6,BADFORM
  1794. *
  1795. * CHECK FOR SIGNED SEGMENT OPTION
  1796. *
  1797. CALL GETNAME,7 GET OPTION NAME
  1798. ZR X6,NAMERR
  1799. NZ X1,BADFORM ERROR IF NOT END-OF-LINE
  1800. SA3 KSIGN CHECK FOR SIGNED SEGMENT
  1801. BX3 X6-X3
  1802. ZR X3,SIGNSEG
  1803. SA3 KS ALLOW ABBREVIATION
  1804. BX3 X6-X3
  1805. NZ X3,NAMERR ERROR IF NOT -S-
  1806. *
  1807. SIGNSEG MX6 1
  1808. LX6 59 POSITION FOR SECOND BIT
  1809. SA1 SEGWORD
  1810. BX6 X1+X6 SET SECOND BIT
  1811. SA6 A1
  1812. EQ ADDLIT
  1813. *
  1814. * /--- BLOCK VERTSEG 00 000 76/08/02 00.10
  1815. *
  1816. * PROCESS SEGMENT,VERTICAL CASE
  1817. *
  1818. VERTSEG SA3 SEGFLG CHECK TYPE FLAG
  1819. SX3 X3-1
  1820. NZ X3,NAMERR ERROR IF NOT -SEGMENT-
  1821. SX1 X2-OPCOMMA
  1822. NZ X1,BADFORM ERROR IF DID NOT END WITH COMMA
  1823. CALL GETNAME,7 GET NAME OF SEGMENT
  1824. ZR X6,NAMERR
  1825. SA6 SEGNAM
  1826. SX7 2
  1827. SA7 SEGFLG SET SEGMENTV
  1828. EQ SEG008
  1829. *
  1830. VSEG20 RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  1831. RJ =XCOMPILE EVALUATE STARTING BIT POSITION
  1832. ZR X1,BADCNT EXIT IF BAD BIT POSITION
  1833. MX0 -XCODEAL
  1834. BX0 X0*X1 MASK ALL BUT ADDRESS PORTION
  1835. NZ X0,BADCNT EXIT IF NOT A SHORT LITERAL
  1836. SX0 X1-61
  1837. PL X0,BADCNT EXIT IF ILLEGAL BIT POSITION
  1838. SA2 SEGWORD
  1839. BX6 X1+X2 MERGE BIT POSITION WITH INFO
  1840. SA6 A2
  1841. *
  1842. RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  1843. RJ =XCOMPILE EVALUATE LENGTH OF BYTE
  1844. ZR X1,BADCNT EXIT IF BAD BYTE SIZE
  1845. MX0 -XCODEAL
  1846. BX0 X0*X1 MASK ALL BUT ADDRESS PORTION
  1847. NZ X0,BADCNT
  1848. SX0 X1-60
  1849. PL X0,BADCNT EXIT IF BAD BYTE SIZE
  1850. SA2 SEGWORD
  1851. SX0 X2-1 PICK UP BIT POSITION
  1852. IX0 X0+X1 ADD LENGTH OF BYTE
  1853. SX0 X0-61
  1854. PL X0,BADCNT EXIT IF BYTE SIZE TOO BIG
  1855. LX1 18+18 POSITION LENGTH OF BYTE
  1856. BX6 X1+X2
  1857. MX0 1
  1858. LX0 58 POSITION VERTICAL BIT
  1859. BX6 X0+X6
  1860. SA1 SEGFLG CHECK IF SEGMENTF
  1861. SX1 X1-8
  1862. NZ X1,VSEG30 IF NOT SEGMENTF
  1863. LX0 -1
  1864. BX6 X0+X6
  1865. VSEG30 SA6 A2 UPDATE SEGMENT INFO WORD
  1866. EQ SEG200
  1867. *
  1868. *
  1869. * /--- BLOCK ADDLIT 00 000 81/07/16 04.20
  1870. *
  1871. * ADD SEGMENT INFO WORD TO DEFINED LITERAL TABLE
  1872. * ARRAY USES THIS IF HAS ONLY ONE LITERAL WORD
  1873. *
  1874. ADDLIT BSS 0
  1875. SA1 SEGWORD
  1876. RJ =XSTUFLIT STORE SEGMENT DESCRIPTOR
  1877. SA2 TOKWRD IN ECS TOKEN BUFFER
  1878. RJ =XAPTWD
  1879. SA2 TOKWRD ADDRESS OF LITERAL IN TOKENS
  1880. SB1 X2-1
  1881. SA1 SEGFLG CHECK TYPE
  1882. SX1 X1-3
  1883. NG X1,SEG400 JUMP IF -SEGMENT-
  1884. ZR X1,SEG400 IN CASE -UNITS- USES THIS LATER
  1885. SX1 X1-8+3
  1886. ZR X1,SEG400 IF SEGMENTF
  1887. *
  1888. SEG310 SX4 6 6=CODE FO ARRAY IN *DEFNLEX*
  1889. EQ SEG410
  1890. *
  1891. SEG400 SX4 5 5=SEGMENT
  1892. SEG410 LX4 XCODEAL POSITION TYPE
  1893. SX1 B1
  1894. BX4 X4+X1 FORM GETVAR CODE
  1895. CALL ADDNAM,SEGNAM
  1896. *
  1897. ENDSEG EXEC DEFOV,2 RETURN FROM SEGOV
  1898. *
  1899. * /--- BLOCK SEGERRS 00 000 76/06/30 02.59
  1900. *
  1901. NOSET SB1 11 NO SET
  1902. SA2 KE1
  1903. EQ ERRX
  1904. *
  1905. NAMERR SB1 12 BAD NAME
  1906. SA2 KE2
  1907. EQ ERRX
  1908. *
  1909. DUPNAM SB1 13 DUPLICATE
  1910. SA2 KE3
  1911. EQ ERRX
  1912. *
  1913. BADVAR SB1 14 BAD VAR
  1914. SA2 KE4
  1915. EQ ERRX
  1916. *
  1917. BADFORM SB1 15 BAD FORM
  1918. SA2 KE5
  1919. EQ ERRX
  1920. *
  1921. BADCNT SB1 16 BAD COUNT
  1922. SA2 KE6
  1923. EQ ERRX
  1924. *
  1925. BADSIZ SB1 17 BAD SIZE
  1926. SA2 KE7
  1927. EQ ERRX
  1928. *
  1929. BADTYP SB1 18 ARRAY TYPE
  1930. SA2 KE8
  1931. EQ ERRX
  1932. *
  1933. LITFULL SB1 19 MANY LITS
  1934. SA2 KE9
  1935. EQ ERRX
  1936. *
  1937. NAMFULL SB1 20 MANY NAMES
  1938. SA2 KE10
  1939. EQ ERRX
  1940. *
  1941. UFULL SB1 21 MANY UNITS
  1942. SA2 KE11
  1943. EQ ERRX
  1944. *
  1945. NOTYET SB1 22 NOT YET IN
  1946. SA2 KE12
  1947. EQ ERRX
  1948. *
  1949. ERRX BX6 X2 PLANT ERROR MESSAGE
  1950. SA6 CERROR1
  1951. SX7 11 DEFINE ERROR
  1952. SA7 TFORMOK
  1953. EQ =XERR NEW CONDENSE ERROR PROCESSING
  1954. *
  1955. *
  1956. SEGNAM BSS 1
  1957. USNAM EQU SEGNAM
  1958. *
  1959. SEGWORD BSS 1
  1960. ARAYWD EQU SEGWORD
  1961. ARAYWD2 BSS 1
  1962. *
  1963. *
  1964. * /--- BLOCK ADDNAM 00 000 75/02/10 20.14
  1965. LIST X
  1966. *CALL DEFTEXT
  1967. LIST *
  1968. *
  1969. ERR4 SB1 26 TOO MUCH
  1970. SA1 KERR4
  1971. BX7 X1
  1972. SA7 CERROR1 STORE MESSAGE
  1973. SX7 11 CODE FOR DEFINE ERROR
  1974. SA7 TFORMOK
  1975. EQ =XERR
  1976. *
  1977. KERR4 DATA 10LTOO MUCH
  1978. * /--- BLOCK ARAYDEF 00 000 76/07/02 01.12
  1979. *
  1980. *
  1981. TITLE ARRAY DEFINE
  1982. *
  1983. * READIN FOR -ARRAY- AND -COMPLEX-
  1984. *
  1985. * PERMISSABLE FORMS FOR ARRAY DEFINE...
  1986. * ARRAY,NAME=V1 (SCALAR ARRAY WITH ROWS=COLS=1)
  1987. * ARRAY,NAME(ROWS)=N1 (VECTOR WITH COLS=1)
  1988. * ARRAY,NAME(ROWS,COLS)=VC1 (MATRIX)
  1989. * ARRAY,NAME(ROW1;ROWS)=V1 (VECTOR BASE REDEFN)
  1990. * ARRAY,NAME(ROWS,COLS;ROW1,COL1)=N1 (BASE REDEFN)
  1991. * ARRAY,..ANY ABOVE FORM..=N1,6,S (SEGMENTED ARRAY)
  1992. * COMPLEX,...ANY REAL NON-SEGMENTED SPEC ABOVE OK
  1993. *
  1994. * FORMAT OF ARRAY/COMPLEX INFO WORD
  1995. *
  1996. * BIT 59 = 0 FOR STUDVAR, 1 FOR COMMON
  1997. * BIT 58 = 0 FOR REAL, 1 FOR COMPLEX ARRAY
  1998. * BIT 57 = 0 FOR BASE INDEX OF 1, =1 FOR OTHER
  1999. * BIT 56 = 0 FOR WORD, 1 FOR SEGMENTED ARRAY
  2000. * IF BITS 56OR57 ON, NEXT LITWORD HAS DETAILS
  2001. * BITS 55,54 HAVE ARRAY DIMENSIONS, 0 IS SCALAR,
  2002. * 1 FOR VECTOR, 2 FOR MATRIX, 3-D NOT IMPLEMENTED
  2003. * NEXT 9 BITS ARE SIZE = ROWS"COLS (MAX 511)
  2004. * NEXT 9 BITS ARE NUMBER OF ROWS-1
  2005. * NEXT 9 BITS ARE NUMBER OF COLS-1
  2006. * NEXT 9 BITS ARE NUMBER OF PLANES-1 (FOR 3-D)
  2007. * LOWER 18 BITS ARE GETVAR CODE OF FIRST ELEMENT
  2008. * I/F BIT,3 TYPEBITS(2=STUD,3=COMM),14BITS REL ADDR
  2009. *
  2010. * ARAYWD2 (2D LITWORD) FORMAT USED FOR
  2011. * SEGMENTED AND BASE-REDEFINED ARRAYS
  2012. *
  2013. * BIT 59 SET IF SIGNED SEGMENT
  2014. * BIT 58 SET IF VERTICAL SEGMENT, 0 IF HORIZONTAL
  2015. * NEXT 4 BITS UNUSED
  2016. * NEXT 6 BITS ARE (BITS/BYTE) FOR SEGMENT
  2017. * NEXT 6 ARE (BYTES/WD) (0-63) FOR HORIZ SEG
  2018. * OR ARE (BIAS TO START OF SEG) IF VERTICAL
  2019. * NEXT 14 ARE ROW BASE INDEX
  2020. * NEXT 14 ARE COL BASE INDEX
  2021. * LAST 14 ARE PLANE BASE INDEX
  2022. *
  2023. *
  2024. ARAYDEF SX7 1 INITIALIZE
  2025. SA7 NROW
  2026. SA7 NCOL
  2027. SA7 ROW1
  2028. SA7 COL1
  2029. MX7 0
  2030. SA7 ARAYWD
  2031. SA7 ARAYWD2
  2032. SA7 DIMEN
  2033. BX7 X2
  2034. SA7 SIZ SAVE TERMINATOR
  2035. *
  2036. * /--- BLOCK ARAYNAM 00 000 76/06/30 03.00
  2037. * DETERMINE ARRAY NAME AND ANALYZE DIMENSIONS
  2038. RJ =XVSEEK SEE IF ALREADY DEFINED
  2039. SA1 ADTYPE
  2040. PL X1,DUPNAM ERROR IF DUPLICATE NAME
  2041. SA7 DEFNLOC SAVE ECS LOC TO INSERT DEFN
  2042. CALL SYMCHK,SEGNAM CHECK FOR REDEFN WARNING
  2043. SA2 SIZ RESTORE TERMINATOR
  2044. SX1 X2-OP= CHECK FOR =
  2045. ZR X1,ARAYLOC IS SCALAR
  2046. SX1 X2-OPASIGN CHECK FOR ASSIGNMENT
  2047. ZR X1,ARAYLOC IS SCALAR
  2048. SX7 1
  2049. SA7 DIMEN
  2050. SX1 X2-OP( CHECK FOR (SIZE) IN PAREN
  2051. NZ X1,BADFORM
  2052. RJ SIZFIL GET 1ST SIZE FIELD
  2053. SA6 NROW AND SAVE IT
  2054. SX3 X2-OP) CHECK FOR ONLY ONE FIELD
  2055. ZR X3,ARAYNUL JUMP IF VECTOR
  2056. SX3 X2-OPCOMMA CHECK FOR COMMA OR SEMICOLON
  2057. NZ X3,BADFORM
  2058. SX3 X1-56B CHECK FOR COMMA
  2059. ZR X3,ARAYMAT JUMP IF MATRIX
  2060. SA6 ROW1 IS VECTOR BASE IF SEMICOLON
  2061. RJ SIZFIL GET ROWS
  2062. SA6 NROW
  2063. SX3 X2-OP)
  2064. NZ X3,BADFORM MUST BE )
  2065. EQ ARAYNUL VECTOR DONE
  2066. *
  2067. ARAYMAT SX6 2
  2068. SA6 DIMEN DIMEN=2 FOR MATRIX
  2069. RJ SIZFIL GET COLS
  2070. SA6 NCOL
  2071. SX3 X2-OP) CHECK FOR LAST FIELD
  2072. ZR X3,ARAYNUL JUMP IF IS
  2073. SX3 X1-77B TEST FOR SEMICOLON TERMINATOR
  2074. NZ X3,BADFORM ERROR IF ISNT
  2075. SA6 COL1 REDEFINE BASE INDICES
  2076. SA3 NROW
  2077. BX7 X3
  2078. SA7 ROW1
  2079. RJ SIZFIL GET ROWS
  2080. SA6 NROW
  2081. SX3 X1-56B TEST FOR COMMA
  2082. NZ X3,BADFORM ERROR IF NOT
  2083. RJ SIZFIL GET COLS
  2084. SA6 NCOL
  2085. SX3 X2-OP) CHECK IF LAST FIELD
  2086. NZ X3,BADFORM ERROR IF NOT
  2087. *
  2088. * /--- BLOCK ARAYNUL 00 000 76/08/02 03.34
  2089. *
  2090. * CHECK FOR = OR _ FOLLOWING )
  2091. *
  2092. ARAYNUL CALL GETNAME,7 VECTOR,MATRIX ENTER HERE
  2093. NZ X6,BADFORM NEXT NAME SHOULD BE BLANK
  2094. SX3 X2-OP=
  2095. ZR X3,ARAYLOC TERMINATOR SHOULD BE =
  2096. SX3 X2-OPASIGN OR ASSIGN ARROW
  2097. NZ X3,BADFORM
  2098. *
  2099. * GET STARTLOC AND CHECK IF IN BOUNDS
  2100. *
  2101. ARAYLOC RJ =XRTOKNAM MAKE READY FOR *INITDEF*
  2102. RJ =XCOMPILE GET STARTLOC ADTYPE IN X1
  2103. BX6 X1
  2104. AX1 XCODEAL POSITION CODETYPE
  2105. MX3 -3
  2106. BX3 -X3*X1 GETVAR CODE TYPE
  2107. MX4 0 STUD/COM BIT OFF
  2108. SX2 X3-2 CHECK STARTING VARIABLE TYPE
  2109. ZR X2,ARAYSTB JUMP IF STUDENT BANK
  2110. SX2 X3-3 MUST BE COMMON
  2111. NZ X2,BADVAR ERROR IF NOT
  2112. MX4 1 SET COMMON BIT
  2113. ARAYSTB BX6 X4+X6 MERGE IN
  2114. SA6 ARAYWD SAVE IT
  2115. SA2 LASTKEY
  2116. ZR X2,ARAYSTD JUMP IF E.O.L (NOT SEGMENT)
  2117. *
  2118. * HANDLE SEGMENTED ARRAY ARGUMENTS
  2119. *
  2120. SA2 X2+KEYTYPE GET KEYTYPE
  2121. SX3 X2-OPCOMMA
  2122. NZ X3,BADTYP MUST BE COMMA IF SEGMENTED
  2123. MX0 1 SEE BELOW
  2124. **ALLOW EITHER V OR N TYPE
  2125. SA1 DIMEN
  2126. ZR X1,BADTYP ERROR IF SEGMENTED SCALAR
  2127. LX0 57
  2128. BX6 X6+X0 SET SEGMENT BIT 56 ON
  2129. LX0 3+XCODEL-XFBIT I/F BIT OFF SINCE
  2130. BX6 -X0*X6 ALL SEGMENTS ARE INTEGERS
  2131. SA6 ARAYWD SAVE TEMPORARILY
  2132. *
  2133. RJ SIZFIL GET 1ST SEGMENT ARGUMENT
  2134. ZR X6,BADCNT CANNOT BE ZERO
  2135. NG X6,BADCNT OR NEGATIVE
  2136. SX3 X6-61 CHECK IF BYTE TOO BIG
  2137. PL X3,BADCNT
  2138. SA6 ATEMP SAVE TEMPORARILY
  2139. ***
  2140. SA3 SEGFLG
  2141. SX0 X3-6
  2142. ZR X0,ARAYVER JUMP IF VERTICAL SEGMENT
  2143. SX0 X3-5
  2144. NZ X0,BADFORM ERROR IF NOT HORIZ SEGMENT
  2145. ZR X1,ARAYSEG IF E.O.L. SIGNBIT(X1)=0
  2146. SX3 X2-OPCOMMA
  2147. NZ X3,BADFORM MUST BE ,SIGNED
  2148. *
  2149. CALL GETNAME,7
  2150. ZR X6,NAMERR
  2151. NZ X1,BADFORM MUST BE E.O.L.
  2152. MX1 1 SET SIGNBIT
  2153. EQ SIGNCHK
  2154. *
  2155. ARAYSTD SA3 SEGFLG IF NO TAGS AFTER LOCATION
  2156. SX0 X3-6 IT CANNOT BE SEGMENTED ARRAY
  2157. ZR X0,BADFORM
  2158. SX0 X3-5 CHECK BOTH SEGMENT,SEGMENTV
  2159. ZR X0,BADFORM
  2160. EQ ARAYSIZ
  2161. * /--- BLOCK ARAYVER 00 000 76/08/02 03.43
  2162. *
  2163. * GET VERTICAL SEGMENT BYTESIZE
  2164. *
  2165. ARAYVER SX3 X2-OPCOMMA
  2166. NZ X3,BADFORM MUST BE , BETWEEN START,BYTE
  2167. RJ SIZFIL GET SEGMENT BYTESIZ
  2168. ZR X6,BADCNT CANT BE ZERO
  2169. NG X6,BADCNT OR NEGATIVE
  2170. SA3 ATEMP = STARTBIT
  2171. IX7 X3+X6
  2172. SX7 X7-62
  2173. PL X7,BADCNT IS .GT.61
  2174. LX6 6
  2175. BX6 X6+X3 BYTESIZ/STARTBIT
  2176. SA6 SIZ SAVE AGAIN IN SIZ
  2177. BX3 X1 SAVE TERMINATOR
  2178. MX1 1
  2179. LX1 59 SET VERTICAL,NONSIGNED BITS
  2180. ZR X3,ARAYSEG JUMP IF E.O.L.
  2181. *
  2182. * CHECK FOR SIGNED OPTION
  2183. SX3 X2-OPCOMMA
  2184. NZ X3,BADFORM ERROR IF TERMINATOR NOT COMMA
  2185. CALL GETNAME,7
  2186. ZR X6,NAMERR
  2187. NZ X1,BADFORM ERROR IF NOT E.O.L.
  2188. MX1 2 SET SIGN,VERTICAL BITS
  2189. SIGNCHK SA3 KSIGN
  2190. BX3 X6-X3 CHECK FOR SIGNED SEGMENT
  2191. ZR X3,ARAYSEG
  2192. SA3 KS ALLOW ABBREVIATION
  2193. BX3 X6-X3
  2194. NZ X3,NAMERR ERROR IF NO S AFTER COMMA
  2195. *
  2196. * /--- BLOCK ARAYSEG 00 000 78/02/11 00.12
  2197. *
  2198. * HORIZONTALLY SEGMENTED ARRAYS
  2199. *
  2200. ARAYSEG SA2 ARAYWD2
  2201. BX6 X1+X2 ADD SIGNED+VERT SEGMENT BITS
  2202. *
  2203. SA2 SIZ GET BACK SEGMENT SIZE
  2204. LX1 1
  2205. ****
  2206. * EQ NOTYET **USE THIS TO TURN OFF VERTSEG
  2207. ****
  2208. NG X1,ARAYVSG JUMP IF VERTICAL SEG
  2209. *****
  2210. EQ NOTYET **THIS TURNS OFF HORIZ SEG
  2211. *****
  2212. PX7 X2
  2213. NX7 X7 FLOAT BITS/BYTE
  2214. SA3 K60 =60.0
  2215. FX7 X3/X7 COMPUTE BYTES/WORD
  2216. UX7 X7,B1
  2217. LX7 X7,B1 AS INTEGER
  2218. LX2 6
  2219. BX2 X7+X2 COMBINE BIT/BYTE COUNT
  2220. ARAYVSG LX2 42
  2221. BX6 X6+X2 MERGE WITH ARAYWD2
  2222. SA6 ARAYWD2 AND SAVE
  2223. *
  2224. *
  2225. * CALCULATE ARRAY SIZE
  2226. *
  2227. ARAYSIZ SA1 NROW GET LAST,FIRST ROW,COL
  2228. SA2 NCOL
  2229. SA3 ROW1
  2230. SA4 COL1
  2231. IX6 X1-X3 NUMBER OF ROWS-1, COLS-1
  2232. IX7 X2-X4 = COLS-1
  2233. BX5 X6+X7 BOTH SHOULD BE POSITIVE
  2234. NG X5,BADSIZ
  2235. SX1 X6+1 NUMROWS
  2236. SX2 X7+1 NUMCOLS
  2237. DX4 X1*X2 NUMROWS*NUMCOLS
  2238. * IF COMPLEX MUST DOUBLE SIZE
  2239. SA3 SEGFLG
  2240. SX3 X3-7
  2241. SX0 0 BIT 58 OFF FOR REAL
  2242. SA2 ARAYWD
  2243. NZ X3,ARAYPAK JUMP IF NOT COMPLEX
  2244. IX4 X4+X4 DOUBLE SIZE
  2245. LX2 60-XCODEL+XFBIT CHECK I/F BIT
  2246. PL X2,BADTYP ERROR IF COMPLEX INTEGER TYPE
  2247. SX0 20B SET REAL/COMPLEX BIT ON
  2248. *****
  2249. EQ NOTYET ***TURNS OFF COMPLEX ARRAYS***
  2250. *****
  2251. *
  2252. * START BUILDING ARRAY INFORMATION WORD(S)
  2253. *
  2254. * ARAYPAK SX3 X4-ARAYLTH MAX SIZE OF ARRAY (256)
  2255. ARAYPAK SX3 ARAYLTH MAX SIZE OF ARRAY (255)
  2256. IX3 X4-X3
  2257. PL X3,BADSIZ ERROR IF >256
  2258. SB1 X4-1 SAVE SIZE -1
  2259. SA3 DIMEN START BUILDING ARAYWD
  2260. BX3 X0+X3 MERGE REAL/CMPLX BIT AND DIMEN
  2261. LX3 9
  2262. BX3 X3+X4 MERGE THIS WITH SIZE
  2263. LX3 9 THEN MERGE IN
  2264. BX6 X3+X6 NUMROWS-1,
  2265. LX6 9
  2266. BX6 X7+X6 NUMCOLS-1,
  2267. LX6 9 N PLANES-1 = 0 FOR NOW
  2268. LX6 XCODEAL+4 ROOM FOR GETVAR CODE(18BITS)
  2269. SA2 ARAYWD
  2270. BX6 X6+X2 MERGE SHAPE,GETVAR,COM+SEG BITS
  2271. *
  2272. * AT THIS POINT X6=ARAYWD, X2 HAS GETVAR, X4=SIZE
  2273. *
  2274. * NOW GET START LOCATION AND CHECK LENGTH IN BOUNDS.
  2275. *
  2276. * /--- BLOCK ARAYCHK 00 000 82/10/06 17.19
  2277. MX5 -XCODEAL
  2278. BX7 -X5*X2 MASK OFF ADDRESS INTO X7
  2279. LX2 3 SEGMENT BIT AT LEFT
  2280. PL X2,ARAYCHK JUMP IF NOT SEGMENTED
  2281. *
  2282. * REPLACE SEGMENTED ARRAY SIZE WITH NUMBER OF WORDS USED
  2283. *
  2284. SA1 ARAYWD2
  2285. LX1 1
  2286. MX2 -6
  2287. NG X1,ARAYCHK JUMP IF VERTICAL SEGMENT
  2288. LX1 17
  2289. BX1 -X2*X1 BYTES/WD
  2290. SX4 X4-1 SIZE-1
  2291. PX4 X4
  2292. NX4 X4 FLOAT SIZE
  2293. PX1 X1
  2294. NX1 X1 FLOAT BYTES/WD
  2295. FX4 X4/X1 (SIZE-1)/(BYTES/WD)
  2296. UX4 X4,B2
  2297. LX4 X4,B2 +1=
  2298. SX4 X4+1 NUMBER OF WORDS USED BY SEGARAY
  2299. *
  2300. ARAYCHK SX4 X4-1 SIZE-1
  2301. IX4 X7+X4 X4=LAST ARRAY ELEMENT INDEX
  2302. PL X6,ARAYSTU JUMP IF IN STUDENT BANK
  2303. SX1 X4-NCVRLIM-1 (LAST ELEMENT)-(LIM+1)
  2304. PL X1,BADSIZ ERROR IF LAST EL NOT IN BOUNDS
  2305. EQ ARAYOK
  2306. *
  2307. ARAYSTU SX2 X4-VARLIM-1 (LAST)-(LIM+1)
  2308. NG X2,ARAYOK JUMP IF ALL INSIDE STUD BANK
  2309. SX2 X7-VARLIM-1 COULD BE ROUTER ARRAY
  2310. NG X2,BADSIZ JUMP IF START LOC NOT ROUTER
  2311. SA1 ARVARS
  2312. SA2 ASVARS
  2313. IX1 X1-X2 BIAS TO ROUTER VARS
  2314. SA2 RVARL (X2) = NUMBER OF RVARS ALLOWED
  2315. IX1 X1+X2 OFFSET TO LAST ROUTER VAR
  2316. SX1 X1+1 LIMIT FOR ROUTER VARS
  2317. IX2 X4-X1 CHECK IF INDEX IS TOO LARGE
  2318. NG X2,ARAYOK INSIDE ROUTER VAR LIMIT
  2319. IX2 X7-X1 CHECK IF BASE WAS ROUTER VAR
  2320. NG X2,BADSIZ IF SO, INDEX WAS TOO LARGE
  2321. *
  2322. * AT THIS POINT, MUST BE A LOCAL VAR OR AN ERROR. THIS
  2323. * DEPENDS ON THE FACT THAT THE CM ADDRESSES FOR STUDENT
  2324. * VARS, ROUTER VARS AND LOCAL VARS (WHICH UNFORTUNATELY
  2325. * ALL HAVE THE SAME GETVAR CODE -- GRR) ASCEND IN THE
  2326. * ABOVE ORDER.
  2327. *
  2328. SA1 ASVARS ADDRESS OF STUDENT VARS
  2329. SA3 ALVARS ADDRESS OF LOCAL VARS
  2330. BX0 X6 PRESERVE X6 OVER FOLLOWING
  2331. IX6 X1-X3 OFFSET INTO LOCAL VARS
  2332. IX6 X6+X4 OFFSET OF LAST ELEMENT + 1
  2333. RJ =XLBOUND CHECK IN BOUNDS (A1/X1 USED)
  2334. SA1 LVARN NUMBER OF LOCALS USED SO FAR
  2335. IX3 X6-X1 NUMBER NEEDED - NUMBER AVAIL.
  2336. NG X3,LVOK MORE THAN ENOUGH AVAILABLE
  2337. ZR X3,LVOK JUST ENOUGH AVAILABLE
  2338. SA6 A1 MAKE NUMBER NEEDED NEW NUM USED
  2339. BX6 X1 SAVE THE OLD NUMBER USED SO FAR
  2340. SA6 OLVARN
  2341. *
  2342. * /--- BLOCK ARAYOK 00 000 82/10/06 17.20
  2343. LVOK BX6 X0 RESTORE X6 = ARAYWD
  2344. ARAYOK SA6 ARAYWD SAVE ARRAY INFO WORD
  2345.  
  2346. *
  2347. * ADD BASE REDEFINITION INFO TO ARAYWD2
  2348. *
  2349. SA1 ARAYWD2 CONTAINS SEGMENT INFO SO FAR
  2350. SA2 ROW1
  2351. SA3 COL1
  2352. SX4 1 SET PLANE1=1 FOR NOW
  2353. BX2 -X5*X2 X5 STILL = -XCODEAL 14BIT MASK
  2354. BX3 -X5*X3
  2355. BX4 -X5*X4
  2356. LX2 XCODEAL
  2357. BX2 X2+X3 ROW1,COL1
  2358. LX2 XCODEAL
  2359. BX2 X2+X4 ROW1,COL1,PLANE1
  2360. SA4 RCPCHK SUBTRACT 1,1,1
  2361. IX7 X2-X4
  2362. ZR X7,ARAYDUN JUMP IF NO BASE REDEFINITION
  2363. MX7 1
  2364. LX7 58 POSITION FOR BIT 57
  2365. *
  2366. ARAYDUN BX6 X6+X7 MERGE BASEREDEF BIT INTO ARAYWD
  2367. SA6 ARAYWD WHICH IS NOW COMPLETE
  2368. BX7 X2+X1 MERGE SEGMENT + BASEREDEF INFO
  2369. SA7 ARAYWD2 AND SAVE IT
  2370. MX0 2
  2371. LX6 2
  2372. BX6 X0*X6
  2373. ZR X6,ADDLIT JUMP IF NO ARAYWD2 INFO
  2374. SA1 ARAYWD
  2375. RJ =XSTUFLIT
  2376. SA1 ARAYWD2
  2377. RJ =XSTUFLIT
  2378. SA1 TOKWRD
  2379. RJ =XAPTWD
  2380. SA1 TOKWRD ADDRESS OF SECOND LITERAL
  2381. SB1 X1-2 POINT TO FIRST LIT
  2382. EQ SEG310
  2383. *
  2384. * EXIT TO ADDLITS PUTS ARAYWD INTO TOKEN TABLE
  2385. * AND PUTS ARRAY NAME INTO DEFINED NAMES TABLE.
  2386. * EXIT TO SEG310 JUST DOES LATTER.
  2387. *
  2388. * /--- BLOCK SIZFIL 00 000 80/03/23 07.51
  2389. *
  2390. * SUBROUTINE TO GET SIZE INDEX IN X6
  2391. * TERMINATOR IS IN *LASTKEY* AND X1
  2392. * RETURN TERMINATOR KEYTYPE IN X2
  2393. * INDEX MUST BE + OR - 13BIT MAXIMUM
  2394. *
  2395. *
  2396. SIZFIL EQ *
  2397. MX7 0
  2398. MX6 59
  2399. SA6 VSKMODE SET -1...DONT EXPAND DEFINE
  2400. SA7 SIZ SET 0 FOR +, -0 FOR -
  2401. RJ =XINITLEX
  2402. SIZFIL2 RJ =XLEX GET SIZE ELEMENT
  2403. SA1 ADTYPE
  2404. SA2 OP
  2405. ZR X2,SIZFIL8 JUMP IF PURE NUMBER IN X1
  2406. SX2 X2-OPSUB
  2407. ZR X2,SIZFIL4 JUMP IF UNARY MINUS
  2408. SX2 X2+OPSUB-OPADD
  2409. ZR X2,SIZFIL2 IGNORE UNARY PLUS
  2410. SX2 X2+OPADD-OPDEFN
  2411. ZR X2,SIZFIL5 JUMP IF DEFINE
  2412. EQ BADFORM NO OTHER OPS ALLOWED
  2413. *
  2414. SIZFIL4 SA2 SIZ
  2415. BX7 -X2 TOGGLE SIGN
  2416. SA7 A2
  2417. EQ SIZFIL2
  2418. *
  2419. SIZFIL5 MX0 -XCODEAL
  2420. BX6 X0*X1
  2421. NZ X6,BADSIZ JUMP IF NOT SHORT LITERAL IN X1
  2422. *NOTE...NO USE TRYING LONGLITS, - NUMBERS ARE COMPILED..UGH
  2423. *
  2424. SIZFIL8 SA2 SIZ
  2425. BX6 X1-X2 COMPLEMENTS ADTYPE IF SIZ=-0
  2426. BX1 X6
  2427. AX1 59 SIGN
  2428. BX1 X6-X1 ABS VALUE
  2429. AX1 13 CHECK FOR 13BIT MAXIMUM SIZE
  2430. NZ X1,BADSIZ ERROR IF GREATER
  2431. SA1 LASTKEY EXIT WITH TERMINATOR IN X1
  2432. SA2 X1+KEYTYPE TERM. KEYTYPE IN X2
  2433. EQ SIZFIL AND INTEGER SIZE ELEMENT IN X6
  2434. *
  2435. *
  2436. NROW BSS 1
  2437. NCOL BSS 1
  2438. ROW1 BSS 1
  2439. COL1 BSS 1
  2440. DIMEN BSS 1
  2441. SIZ BSS 1
  2442. ATEMP BSS 1
  2443. RCPCHK DATA 2000040001B
  2444. SIGNED VFD 42/6LSIGNED,1/1,17/0 SPECIAL GETVAR FOR
  2445. VFD 42/1LS,1/1,17/0 COMPSYM CHECK
  2446. *
  2447. * /--- BLOCK UNITS 00 000 76/07/21 20.54
  2448. TITLE READ-IN FOR -UNITS- COMMAND
  2449. *
  2450. *
  2451. *
  2452. * -UNSREAD-
  2453. * READ-IN ROUTINE FOR -UNITS- COMMAND - ADDS TO THE
  2454. * DEFINED NAME TABLE AND TO THE TOTAL UNITS COUNT
  2455. * (DIMENSIONALITY COUNT)
  2456. *
  2457. *
  2458. UNSRD SA1 DSET MUST HAVE DEFINE SET
  2459. NG X1,NOSET
  2460. SA1 WORDPT
  2461. SA1 X1-1 BACK UP TO PREVIOUS CHARACTER
  2462. SA2 X1+KEYTYPE
  2463. SX1 X2-OPCOMMA SEE IF ENDED WITH COMMA
  2464. NZ X1,BADFORM
  2465. MX6 -1 SET MODE FOR -VSEEK- SEARCH
  2466. SA6 VSKMODE
  2467. SA6 ENDFLG MARK NOT END-OF-LINE YET
  2468. *
  2469. UNS100 CALL GETNAME,7 GET NAME OF NEXT *UNIT*
  2470. ZR X6,NAMERR
  2471. SA6 USNAM
  2472. SX1 X2-OPCOMMA CHECK FOR COMMA
  2473. ZR X1,UNS120
  2474. SX1 X2-EOL CHECK FOR END-OF-LINE
  2475. NZ X1,BADFORM
  2476. MX7 0 MARK END-OF-LINE ENCOUNTERED
  2477. SA7 ENDFLG
  2478. *
  2479. UNS120 RJ =XVSEEK SEE IF ALREADY DEFINED
  2480. SA1 ADTYPE
  2481. PL X1,DUPNAM EXIT IF DUPLICATE NAME
  2482. SA7 DEFNLOC SAVE ECS LOC TO INSERT NAME
  2483. CALL SYMCHK,USNAM
  2484. SA1 NDEFU GET NUMBER OF *UNITS* DEFINED
  2485. SX6 X1-NUMAX SEE IF TOO MANY *UNITS*
  2486. PL X6,UFULL
  2487. SX6 X1+1
  2488. SA6 A1
  2489. SX4 8 8=SHORT FLOATING LITERAL
  2490. LX4 XCODEAL
  2491. BX4 X4+X1 X4=GETVAR CODE
  2492. CALL ADDNAM,USNAM ADD TO DEFINE TABLES
  2493. SA1 ENDFLG
  2494. NZ X1,UNS100 CONTINUE IF NOT END-OF-LINE
  2495. EQ ENDSEG
  2496. *
  2497. *
  2498. ENDFLG BSS 1
  2499. *
  2500. K60 DATA 60.0
  2501. KVERT DATA 0LVERTICAL
  2502. KSIGN DATA 0LSIGNED
  2503. KS DATA 0LS
  2504. KE1 DATA 10LNO SET
  2505. KE2 DATA 10LBAD NAME
  2506. KE3 DATA 10LDUPLICATE
  2507. KE4 DATA 10LBAD VAR
  2508. KE5 DATA 10LBAD FORM
  2509. KE6 DATA 10LBAD COUNT
  2510. KE7 DATA 10LBAD SIZE
  2511. KE8 DATA 10LARRAY TYPE
  2512. KE9 DATA 10LMANY LITS
  2513. KE10 DATA 10LMANY NAMES
  2514. KE11 DATA 10LMANY UNITS
  2515. KE12 DATA 10LNOT YET IN
  2516. *
  2517. *
  2518. ENDOV
  2519. *
  2520. *
  2521. OVTABLE
  2522. *
  2523. *
  2524. END SEGMNT$
plato.source/plaopl/define.txt ยท Last modified: 2021/02/06 16:22 by 127.0.0.1