CDC Community

๐Ÿ”น Historical Conservation ๐Ÿ”น

User Tools

Site Tools


plato.source:plaopl:exec3

Table of Contents

EXEC3

Table Of Contents

  • [00005] TUTOR EXECUTION-INTERPRETER
  • [00012] EXTERNALS
  • [00047] -JOIN- AND -JOIN*- COMMANDS
  • [00137] -IEUEND- COMMAND
  • [00154] CHANGE LOCAL VAR STACK POINTER
  • [00191] -JUMP- AND -JUMP*- COMMANDS
  • [00232] GOTO AND GOTO*
  • [00296] CONDITIONAL -GOTO- COMMAND
  • [00348] DO, DO(L), DO*, AND DO*(L)
  • [00642] -ARGS- COMMAND
  • [00837] -PREARGS-
  • [00892] -ARGCODE-
  • [00946] WRITE COMMAND INTERRUPT
  • [01066] -STEP- SINGLE COMMAND EXECUTION
  • [01223] -STEP- COMMAND
  • [01328] OKWORD AND NOWORD
  • [01360] -SCORE- AND -STATUS- COMMANDS
  • [01396] VARIOUS GRAPHING SUBROUTINES
  • [01540] GRAFS SUBROUTINES
  • [01625] -SET- COMMAND EXECUTION ROUTINE
  • [01775] -LESSON- COMMAND
  • [01814] TRANSFR EXECUTION
  • [02037] MOVE
  • [02398] -COLOR- COMMAND EXECUTION
  • [02569] -FONT- COMMAND EXECUTION

Source Code

EXEC3.txt
  1. EXEC3
  2. * /--- FILE TYPE = E
  3. * /--- BLOCK EXTERNALS 00 000 79/08/25 16.48
  4. IDENT EXEC3
  5. TITLE TUTOR EXECUTION-INTERPRETER
  6. *
  7. * GET COMMON SYMBOL TABLE
  8. *
  9. CST
  10. *
  11. *
  12. TITLE EXTERNALS
  13. *
  14. *
  15. EXT BOUNDS,PROCESS,PROCO,PROC,PROC1
  16. EXT UNITJ,DO=,DOS=,ARG=,JTABLE
  17. EXT UNITGO
  18. EXT RETRNZ (EXEC2)
  19. EXT ILOC,ECSPRTY,COMPUSE,TOOMUCH
  20. EXT POSTEXC,XSLICE,OUTFLOW
  21. EXT PCHECK
  22. EXT ERXJOIN ERROR EXIT, -EXEC2-
  23. EXT ERXVAL,ERXMXLW,ERXMBED
  24. EXT ERXHSEG
  25. EXT LVLOAD (AUTLOAD)
  26. EXT TSLERR
  27. EXT XDATA,YDATA
  28. EXT ERXROLV,ERXROLC (TUTORX)
  29. EXT WINDOW (TUTOUT)
  30. *
  31. *
  32. * /--- BLOCK CONSTANTS 00 000 80/01/25 13.02
  33. *
  34. * WORKING VARIABLES IN *TBINTSV*
  35. *
  36. * THESE DEFINES MUST MATCH IN DECKS
  37. * *EXEC3*, *GRAFS*, *GRAFS2*
  38. *
  39. XMINUS EQU TBINTSV THESE MUST BE IN THIS ORDER'.
  40. YMINUS EQU XMINUS+1
  41. XPLUS EQU YMINUS+1
  42. YPLUS EQU XPLUS+1
  43. XORGIN EQU YPLUS+1
  44. YORGIN EQU XORGIN+1
  45. *
  46. * /--- BLOCK JOIN 00 000 77/07/25 20.19
  47. TITLE -JOIN- AND -JOIN*- COMMANDS
  48. *
  49. * -JOIN- AND -JOIN*- COMMANDS
  50. *
  51. * UNCONDITIONAL AND CONDITIONAL JOIN OF UNIT.
  52. *
  53. *
  54. ENTRY JOINCX
  55. JOINCX CALL CUNIT GET CONDITIONAL JOIN UNIT
  56. *
  57. ENTRY JOINX
  58. JOINX NG X5,JARGS JUMP IF JOIN WITH ARGUMENTS
  59. AX5 48 POSITION UNIT NUMBER
  60. ZR X5,UNITJ JUMP IF UNIT -Q-
  61. SA1 JOIN GET JOIN COUNTER
  62. SX6 X1+1 ADD ONE TO JOIN COUNTER
  63. SX2 X6-JOINLTH ALLOW 1 EXTRA FOR PAUSE / ARROW
  64. PL X2,ERXJOIN ERROR IF TOO DEEP IN JOINS
  65. SB3 B1 B3 = CONDITION INDEX
  66. SA6 A1
  67. SA4 ILESUN PRESENT LESSON AND UNIT
  68. MX0 42
  69. BX2 X0*X4 LESSON NUMBER
  70. LX4 12
  71. SB1 A5
  72. SX3 B5-B1 COMMAND BIAS (12 BITS)
  73. BX6 X4+X3
  74. SX3 B3+1 X3 = CONDITION INDEX+1
  75. LX3 -7
  76. MX4 7
  77. BX3 X3*X4
  78. LX3 -5
  79. BX6 X6+X3 X6 = JS ENTRY W/CONDITION
  80. SA6 X1+JOINL STUFF INTO LIST
  81. BX6 X6-X3 X6 = JS ENTRY WO/CONDITION
  82. BX6 X5+X2 ADD LESSON NUMBER
  83. SA6 A4 STORE IN -ILESUN-
  84. SA1 TLVLESS
  85. ZR X1,UNITGO IF NO LOCAL VARIABLES
  86. *
  87. CALL LVLOAD,-1 UNLOAD LOCAL VARS
  88. CALL LVINCSP,1 INCREMENT LOCAL VAR STACK PTR
  89. EQ UNITGO AND BEGIN TUTOR UNIT EXECUTION
  90. *
  91. *
  92. * /--- BLOCK JOIN 00 000 77/07/25 20.19
  93. *
  94. * PROCESSING FOR -JOIN- WITH ARGUMENTS
  95. *
  96. JARGS SB3 B1 B3 = CONDITION INDEX
  97. SA1 JOIN X1 = JOIN SP
  98. SX6 X1+1
  99. SX2 X6-JOINLTH ALLOW 1 EXTRA FOR PAUSE / ARROW
  100. PL X2,ERXJOIN ERROR IF TOO DEEP IN JOINS
  101. SA6 A1
  102. SA4 ILESUN PRESENT LESSON AND UNIT
  103. LX4 12
  104. SB1 A5
  105. SX3 B5-B1 COMMAND BIAS (12 BITS)
  106. BX6 X4+X3
  107. SX3 B3+1 SAVE CONDITION INDEX FOR RARGS
  108. LX3 -7
  109. MX2 7
  110. BX3 X3*X2
  111. LX3 -5
  112. BX6 X6+X3
  113. SA6 X1+JOINL STUFF INTO LIST
  114. *
  115. LX5 12 POSITION INDEX IN XSTOR
  116. *
  117. CALL PREARGS,1 SET UP ARGUMENTS
  118. CALL LVLOAD,-1 UNLOAD LOCAL VARS
  119. CALL LVINCSP,1 PUSH LV STACK
  120. *
  121. JGARGS BSS 0 ENTRY HERE FROM GOTOX
  122. SA1 ILESUN GET LESSON NUMBER
  123. MX0 42
  124. BX6 X0*X1
  125. BX6 X5+X6 PUT LESSON AND UNIT NUMBERS TOGETHER
  126. SA6 A1 FOR THIS TIME
  127. *
  128. SB1 A1 SEE IF THIS NEXT UNIT HAS ARGS
  129. SB2 ARWK ANY UNUSED VARIABLE
  130. CALL HOLUNIT TO GET -UNAM- INFO WORD
  131. LX1 1 GET BIT TELLING IF UNIT HAS ARGS
  132. NG X1,UNITGO GO EXECUTE UNIT WITH ARGS
  133. MX6 0 ELSE MARK NO ARGS IN HAND
  134. SA6 INARGS
  135. EQ UNITGO
  136. *
  137. TITLE -IEUEND- COMMAND
  138. *
  139. *
  140. * -IEUEND-
  141. * SPECIAL COMMAND INSERTED AT END OF INITIAL ENTRY
  142. * UNIT TO EXECUTE ANY -IMAIN- UNIT SPECIFIED
  143. *
  144. *
  145. ENTRY IEUENDX
  146. IEUENDX SA1 TIMAIN SEE IF ANY -IMAIN- UNIT
  147. ZR X1,PROC
  148. SX5 X1 SET UP FOR -JOIN-
  149. LX5 48
  150. EQ JOINX DO A -JOIN- OF -IMAIN- UNIT
  151. *
  152. *
  153. * /--- BLOCK LVINCSP 00 000 85/01/31 13.30
  154. TITLE CHANGE LOCAL VAR STACK POINTER
  155. *
  156. * -LVINCSP- INCREMENT OR DECREMENT LOCAL VAR
  157. * STACK POINTER.
  158. *
  159. * ENTER'; B1 = -1 DECREMENT, 1 INCREMENT
  160. *
  161. ENTRY LVINCSP
  162. *
  163. LVINCSP EQ *
  164. SA1 LVUCNT CURRENT UNIT LOCAL VAR COUNT
  165. SA2 TLVLESS GET STACK POINTER
  166. ZR X1,LVINCSP LEAVE IF NO VARS TO PUSH/POP
  167. ZR X2,LVINCSP SHOULD GET CAUGHT IN LVLOAD
  168. SX6 X2 STACK POINTER IN LOWEST 18 BITS
  169. SX0 B1 GET INCREMENT
  170. AX0 1 MAKE -0 OR +0
  171. BX1 X0-X1 NEGATE LOCAL VAR COUNT
  172. IX6 X6+X1 INCREMENT / DECREMENT
  173. NG X6,BADSP1 EXECERR - NEGATIVE SP
  174. * AX2 2*18 MOVE ECS BUFFER LENGTH
  175. * MX0 -18
  176. * BX0 -X0*X2 X0 = LENGTH
  177. * IX0 X6-X0
  178. * SA2 A2 RESTORE *TLVLESS*
  179. * SX0 X0-1 POSITIVE IF STACK OVERFLOW
  180. * PL X0,BADSP2
  181. MX0 -18
  182. BX2 X0*X2 CLEAN OUT STACK POINTER
  183. BX6 X6+X2 ADD IN NEW STACK POINTER
  184. SA6 A2 STORE IT
  185. EQ LVINCSP
  186. *
  187. BADSP1 BX1 X6 GET STACK POINTER VALUE
  188. EXECERR 931 STACK POINTER WENT NEGATIVE
  189. *
  190. * /--- BLOCK JUMP 00 000 79/06/10 21.31
  191. TITLE -JUMP- AND -JUMP*- COMMANDS
  192. *
  193. * -JUMP- AND -JUMP*- COMMANDS
  194. *
  195. * UNCONDITIONAL AND CONDITIONAL JUMP.
  196. *
  197. ENTRY JUMPXC
  198. JUMPXC CALL CUNIT GET UNIT NUMBER IN X5
  199. SB1 B7-XANSC CHECK FOR ANSWER-C
  200. NZ B1,JXX2
  201. BX6 X5 SAVE -X5-
  202. SA6 TBINTSV+5
  203. CALL ANSDAT OUTPUT STUDENT DATA
  204. SA1 TBINTSV+5
  205. BX5 X1 RESTORE -X5-
  206. EQ JXX2
  207. *
  208. *
  209. ENTRY JUMPXX
  210. JUMPXX SB1 B7-XANSC CHECK FOR ANSWER-C
  211. NZ B1,JXX2
  212. CALL ANSDAT OUTPUT STUDENT DATA
  213. SA5 A5 RESTORE -X5-
  214. *
  215. JXX2 PL X5,JXX3 JUMP IF NO ARGUMENTS
  216. LX5 12
  217. CALL PREARGS,1 SET UP ARGUMENTS
  218. EQ JXX4
  219. *
  220. JXX3 AX5 48 POSITION UNIT NUMBER
  221. JXX4 SA1 ILESUN
  222. MX0 42
  223. BX6 X0*X1 LESSON NUMBER
  224. BX5 X5+X6 COMBINE WITH LESSON NUMBER
  225. CALL PUNITE RETURNS IF UNIT DOES NOT EXIST
  226. MX6 0
  227. SA6 INARGS MARK NO ARGUMENTS IN HAND
  228. EQ PROCESS THEN JUST IGNORE COMMAND
  229. *
  230. *
  231. * /--- BLOCK GOTO 00 000 77/06/13 16.57
  232. TITLE GOTO AND GOTO*
  233. *
  234. *
  235. * -GOTO- AND -GOTO*- COMMANDS
  236. *
  237. * UNCONDITIONAL AND CONDITIONAL GOTO.
  238. *
  239. *
  240. ENTRY GOTOCX
  241. GOTOCX LX5 18 POSITION ADDRESS OF CODE
  242. SB1 B5+X5 JUMP INTO COMPILED CODE
  243. JP B1 RETURNS TO GOTOX VIA XGOTO
  244. *
  245. *
  246. * UNCONDITIONAL -GOTO- COMES HERE
  247. *
  248. ENTRY GOTOX
  249. GOTOX NG X5,GOTOXQ IF SPECIAL UNIT X OR Q
  250. *
  251. SA1 TLVLESS
  252. ZR X1,GOTOX10 IF NO LOCAL VARIABLES
  253. *
  254. SB1 B7-XANSC CHECK FOR ANSWER-C
  255. NZ B1,GOTOX10 IF NOT ANSWER-C
  256. *
  257. SA1 AJOIN
  258. BX2 X1
  259. AX2 18 X2 = ARROW UNIT LV SP
  260. SA3 TLVLESS
  261. SX3 X3 X3 = CURRENT UNIT LV SP
  262. IX3 X3-X2
  263. PL X3,GOTOX10 IF ARROW LVARS ALREADY PUSHED
  264. *
  265. SA1 X1+AJOIN
  266. AX1 12 SHIFT OFF COMMAND BIAS
  267. SA2 ILESUN
  268. IX1 X1-X2
  269. NZ X1,GOTOX10 IF NOT IN -ARROW- UNIT
  270. *
  271. CALL LVLOAD,-1 UNLOAD LOCAL VARIABLES
  272. CALL LVINCSP,1 PUSH LOCAL VARIABLE STACK
  273. GOTOX10 AX5 48 X5 = TOP 12 BITS
  274. ZR X5,XG2 JUMP IF TO SAME UNIT
  275. SA1 ILESUN PRESENT LESSON AND UNIT
  276. MX0 42
  277. BX3 X0*X1 PRESENT LESSON NUMBER
  278. BX6 X5+X3 COMBINE WITH UNIT NUMBER
  279. SA6 ILESUN ELSE SET PRESENT UNIT POINTER
  280. EQ UNITGO START EXECUTING TUTOR UNIT
  281. *
  282. XG2 SA5 B5 SET UP COMMAND POINTER
  283. EQ PROCESS
  284. *
  285. GOTOXQ LX5 12 POSITION UNIT NUMBER
  286. MX0 -12
  287. BX5 -X0*X5 MASK OFF UNIT NUMBER
  288. SX0 X5-UNXNUM
  289. ZR X0,PROCESS JUMP IF UNIT -X-
  290. SX0 X5-UNQNUM
  291. ZR X0,UNITJ JUMP IF UNIT -Q-
  292. CALL PREARGS,1 SET UP ARGUMENTS
  293. EQ JGARGS
  294. *
  295. * /--- BLOCK XGOTO 00 000 76/02/14 07.05
  296. TITLE CONDITIONAL -GOTO- COMMAND
  297. *
  298. *
  299. * -GOTO- COMMAND (CONDITIONAL)
  300. *
  301. * COMPILED GOTO CODE SETS UP---
  302. * X1 = INDEX IN TABLE
  303. * X2 = NUMBER OF ENTRIES IN TABLE
  304. * B2 = ABSOLUTE ADDRESS OF TABLE
  305. *
  306. *
  307. ENTRY XGOTO
  308. *
  309. XGOTO SX5 1 NEED CONSTANT ONE
  310. IX1 X1+X5 60 BITS ONLY
  311. MX0 -2
  312. PL X1,XGOTO1 IF NEGATIVE, MAKE 0
  313. MX1 0
  314. XGOTO1 IX3 X1-X2 SEE IF NUMBER IN BOUNDS
  315. NG X3,XGOTO2 JUMP IF OK
  316. IX1 X2-X5 ELSE SET FOR LAST ENTRY
  317. XGOTO2 BX2 -X0*X1 X2 = INTRA-WORD POSITION
  318. BX3 X2
  319. LX2 4 *16
  320. IX3 X2-X3 *15
  321. SB3 X3 B3 = SHIFT COUNT
  322. AX1 2 GET WORD BIAS (4-15 BIT PACKS/WORD)
  323. SA3 X1+B2 X3 = PACKED WORD
  324. LX5 X3,B3 POSITION CORRECT 15 BIT PACKAGE AT TOP
  325. LX5 3 ONLY 12 BITS OF UNIT INFO
  326. EQ GOTOX
  327. *
  328. *
  329. * -XGFTOI-
  330. * FLOATING TO INTEGER CONVERSION ROUTINE CALLED
  331. * BY -GOTO- COMMAND COMPILED CODE TO ROUND INDEX
  332. * FOR INDEXED VARIABLE
  333. *
  334. *
  335. ENTRY XGFTOI
  336. *
  337. XGFTOI EQ *
  338. SA2 =.5 ROUND INDEX FOR INDEXED VARIABLE
  339. PL X1,XGFI1
  340. BX2 -X2 SUB .5 IF ARGUMENT NEGATIVE
  341. XGFI1 RX1 X1+X2
  342. UX1 X1,B1 FIX THE ARGUMENT
  343. LX1 X1,B1
  344. MX6 0
  345. IX1 X1+X6 CHANGE -0 TO +0
  346. EQ XGFTOI
  347. * /--- BLOCK DO 00 000 73/00/00 00.00
  348. TITLE DO, DO(L), DO*, AND DO*(L)
  349. *
  350. *
  351. * -DO- COMMAND
  352. *
  353. * INITIALIZATION ENTRY FOR INTEGER INDEX DO.
  354. *
  355. ENTRY DOX
  356. DOX LX5 12+18 POSITION -GETVAR- CODE
  357. NGETVAR GET STARTING VALUE OF INDEX
  358. BX6 X1
  359. SA6 ILOC
  360. SA5 A5
  361. LX5 12+18 POSITION ADDR OF COMPILED CODE
  362. SB1 X5+B5
  363. SB3 DOXR1 SET UP RETURN ADDRESS
  364. JP B1 JUMP INTO COMPILED CODE
  365. *
  366. * RETURNS WITH *COMPUSE(2)* = ENDING VALUE
  367. * X1 = INCREMENT
  368. *
  369. DOXR1 SA2 ILOC X2 = INITIAL VALUE
  370. SA3 COMPUSE+1 X3 = ENDING VALUE
  371. PL X1,PDO JUMP IF POSITIVE INCREMENT
  372. IX1 X2-X3
  373. PL X1,OKDO OK IF STARTING VALUE .GE. END
  374. *
  375. NODO SA5 A5-1 SKIP FOLLOWING -DO(L)- COMMAND
  376. EQ PROCESS
  377. *
  378. PDO IX1 X3-X2
  379. NG X1,NODO EXIT IF INITIAL GT END
  380. *
  381. OKDO BX6 X2 MOVE INITIAL VALUE TO X6
  382. SB3 DOXR2 SET UP RETURN ADDRESS
  383. EQ DOLOC GO BACK INTO COMPILED CODE
  384. *
  385. DOXR2 SA5 A5 RESTORE COMMAND WORD
  386. EQ DOJOIN
  387. *
  388. * /--- BLOCK DO 00 000 73/00/00 00.00
  389. *
  390. *
  391. * -DO(L)- COMMAND
  392. *
  393. * INCREMENT AND LOOPING ENTRY FOR INTEGER INDEX DO.
  394. *
  395. ENTRY DOLX
  396. DOLX LX5 12+18 POSITION ADDR OF COMPILED CODE
  397. SB1 X5+B5
  398. SB3 DOLR1 SET UP RETURN ADDRESS
  399. JP B1 JUMP INTO COMPILED CODE
  400. *
  401. * RETURNS WITH *COMPUSE(1)* = VALUE OF INDEX
  402. * *COMPUSE(2)* = ENDING VALUE
  403. * X1 = INCREMENT
  404. *
  405. DOLR1 SA2 COMPUSE X2 = INDEX
  406. IX6 X1+X2
  407. SA3 COMPUSE+1 X3 = END VALUE
  408. NG X1,NDOL JUMP IF INCREMENT NEGATIVE
  409. IX3 X3-X6
  410. NG X3,DOLFIN DONE IF INDEX .GT. END VALUE
  411. SB3 DOLR2 SET UP RETURN ADDRESS
  412. EQ DOLOC GO BACK INTO COMPILED CODE
  413. *
  414. NDOL IX3 X6-X3
  415. NG X3,DOLFIN DONE IF INDEX .LT. END VALUE
  416. SB3 DOLR2 SET UP RETURN ADDRESS
  417. EQ DOLOC
  418. *
  419. DOLR2 SA5 A5+1 BACK UP TO PRECEEDING -DO-
  420. EQ DOJOIN
  421. *
  422. DOLFIN SB3 PROCESS EXIT TO *PROCESS* AFTER STORE
  423. EQ DOLOC TO COMPILED CODE FOR STORE
  424. *
  425. * /--- BLOCK DO 00 000 73/00/00 00.00
  426. *
  427. *
  428. * -DO*- COMMAND
  429. *
  430. * INITIALIZATION ENTRY FOR FLOATING POINT INDEX DO.
  431. *
  432. ENTRY DOFX
  433. DOFX LX5 12+18 POSITION -GETVAR- CODE
  434. FGETVAR GET INITIAL VALUE OF INDEX
  435. BX6 X1
  436. SA6 ILOC
  437. SA5 A5 RESTORE COMMAND WORD
  438. LX5 12+18 POSITION ADDR OF COMPILED CODE
  439. SB1 X5+B5
  440. SB3 DOFR1 SET UP RETURN ADDRESS
  441. JP B1 BRANCH INTO COMPILED CODE
  442. *
  443. * ON RETURN *COMPUSE(2)* = ENDING VALUE
  444. * X1 = INCREMENT
  445. *
  446. DOFR1 SA2 ILOC X2 = STARTING VALUE
  447. SA3 COMPUSE+1 X3 = ENDING VALUE
  448. PL X1,PDOF JUMP IF POSITIVE INCREMENT
  449. FX1 X2-X3
  450. PL X1,OKDO JUMP TO BEGIN DO LOOP
  451. EQ NODO
  452. *
  453. PDOF FX1 X3-X2
  454. PL X1,OKDO
  455. EQ NODO
  456. *
  457. * /--- BLOCK DO 00 000 73/00/00 00.00
  458. *
  459. *
  460. * -DO*(L)- COMMAND
  461. *
  462. * INCREMENT AND LOOPING ENTRY FOR FLOATING INDEX DO
  463. *
  464. ENTRY DOFLX
  465. DOFLX LX5 12+18 POSITION ADDR OF COMPILED CODE
  466. SB1 X5+B5
  467. SB3 DOFLR1 SET UP RETURN ADDRESS
  468. JP B1 JUMP INTO COMPILED CODE
  469. *
  470. * ON RETURN *COMPUSE(1)* = VALUE OF INDEX
  471. * *COMPUSE(2)* = ENDING VALUE
  472. * X1 = INCREMENT
  473. *
  474. DOFLR1 SA2 COMPUSE X2 = INDEX
  475. FX6 X1+X2
  476. NX6 X6 NORMALIZE RESULT
  477. SA3 COMPUSE+1 X3 = END VALUE
  478. NG X1,NDOFL JUMP IF INCREMENT NEGATIVE
  479. FX3 X3-X6
  480. NG X3,DOLFIN DONE IF INDEX .GT. END VALUE
  481. SB3 DOLR2 SET UP RETURN ADDRESS
  482. EQ DOLOC
  483. *
  484. NDOFL FX3 X6-X3
  485. NG X3,DOLFIN DONE IF INDEX .LT. END VALUE
  486. SB3 DOLR2 SET UP RETURN ADDRESS
  487. EQ DOLOC
  488. *
  489. *
  490. ENTRY DOLOC
  491. DOLOC EQ * COMPILED CODE COMES HERE
  492. JP B3 RETURN TO CALLER
  493. *
  494. *
  495. * /--- BLOCK DO 00 000 80/06/26 02.57
  496. *
  497. DOJOIN PL X5,JOINX JUMP IF NOT SPECIAL UNIT
  498. MX0 3
  499. BX1 X0*X5 CHECK CONDITIONAL ITERATED -DO-
  500. BX1 X0-X1
  501. NZ X1,JOINX JUMP IF NOT
  502. MX0 -9
  503. LX5 12 POSITION INDEX IN XSTOR
  504. BX5 -X0*X5
  505. SA1 X5+B5 LOAD TABLE INFO WORD
  506. BX6 X1
  507. SA6 ILOC
  508. BX5 X1 SET UP FOR -GETVAR- CALL
  509. *
  510. NGETVAR
  511. PL X1,CUNIT1 IF NEGATIVE, MAKE -1
  512. ZR X1,CUNIT1 MAKE -0 = 0
  513. SX1 -1
  514. CUNIT1 SX7 1
  515. IX1 X1+X7 MAKE SO GOES FROM 0 TO N-1
  516. SA4 ILOC
  517. MX0 48 SET FOR 12 BIT MASK
  518. AX4 XCMNDL
  519. BX2 -X0*X4 X2 = NUMBER OF ENTRIES
  520. AX4 12
  521. BX3 -X0*X4 X3 = RELATIVE START OF TABLE
  522. SB2 B5+X3 B2 = ABSOLUTE START OF TABLE
  523. MX0 -2
  524. IX3 X1-X2 SEE IF NUMBER IN BOUNDS
  525. NG X3,CUNIT2
  526. SX1 X2-1 ELSE SET FOR LAST ENTRY
  527. *
  528. CUNIT2 BX2 -X0*X1 X2 = INTRA-WORD POSITION
  529. BX3 X2
  530. LX2 4 *16
  531. IX3 X2-X3 *15
  532. SB3 X3 B3 = SHIFT COUNT
  533. AX1 2 GET WORD BIAS (4 BYTES/WORD)
  534. SA3 X1+B2 X3 = PACKED WORD
  535. LX5 X3,B3 POSITION CORRECT 15 BIT PACKAGE
  536. LX5 3 ONLY 12 BITS OF UNIT INFO
  537. PL X5,JOINX EXIT IF NORMAL UNIT
  538. MX0 12
  539. BX3 X0*X5 MASK OFF UNIT NUMBER
  540. LX3 12
  541. SX0 X3-UNXNUM
  542. ZR X0,PROCESS JUMP IF SPECIAL UNIT -X-
  543. SX0 X3-UNQNUM
  544. NZ X0,JOINX EXIT IF NOT UNIT -Q-
  545. SA5 A5-1 ADVANCE OUT OF -DO-
  546. EQ PROCESS
  547. *
  548. *
  549. * -RETURN- (COMMAND NUMBER ***)
  550. *
  551. * PASSES RETURN ARGUMENTS TO CALLING UNIT.
  552. * DOES NOTHING IF -RETURN- ATTEMPTED IN UN-DO-NE
  553. * UNIT.
  554. *
  555. ENTRY RETARGX
  556. *
  557. RETARGX BSS 0
  558. SA1 JOIN GET JOIN DEPTH
  559. ZR X1,PROCESS NO JOIN SO EXECUTE NEXT COMMAND
  560. *
  561. NG X5,=XUNJOIN NO ARGS TO RETURN
  562. LX5 12 POSITION INDEX IN XSTOR
  563. CALL PREARGS,-1 SET UP ARGUMENTS
  564. EQ =XUNJOIN IN -GETUNIT-
  565. *
  566. * /--- BLOCK DO 00 000 80/05/13 16.36
  567. *
  568. * -DOR- AND -JOINR- COMMANDS
  569. *
  570. * THESE PSEUDO COMMANDS ARE PLACED AFTER ANY
  571. * DO/JOIN COMMANDS THAT CONTAIN RETURN ARGUMENTS
  572. *
  573. ENTRY DORX,JOINRX
  574. JOINRX SX1 =XJOINC=
  575. EQ RARGS10
  576. *
  577. DORX SX1 =XDOC=
  578. *
  579. RARGS10 SA2 TBNARGS PRE-ZERO *ARGS*
  580. MX0 -6
  581. BX6 X0*X2
  582. SA6 A2
  583. *
  584. SA2 INARGS X2 = ARGUMENTS PRESENT FLAG
  585. ZR X2,PROCESS IF NO ARGUMENTS PRESENT
  586. *
  587. SA5 A5+1 LOOK AT PREVIOUS COMMAND
  588. MX2 -9
  589. BX2 -X2*X5 X2 = COMMAND NUMBER
  590. IX2 X2-X1
  591. NZ X2,RARGS20 IF UNCONDITIONAL DO/JOIN
  592. *
  593. SA1 JOIN X1 = JOIN STACK DEPTH
  594. SA1 JOINL+X1 X1 = PREVIOUS JOIN STACK ENTRY
  595. LX1 12 R.J. CONDITION INDEX
  596. MX3 -7 7 BITS IN THE CONDITION
  597. BX1 -X3*X1 ISOLATE CONDITION
  598. CALL CUNIT1A X5 = ARGTYPE/XSTOR POINTER
  599. *
  600. * /--- BLOCK DO 00 000 80/05/27 22.31
  601. *
  602. RARGS20 LX5 1
  603. PL X5,RARGS30 IF NO RETURN ARGUMENTS
  604. *
  605. LX5 11 ALREADY SHIFTED 1 AT RARGS20
  606. MX0 -10
  607. BX5 -X0*X5 X5 = BIAS TO EXTRA STORAGE
  608. SA1 B5+X5 ARG WORD FOR PREVIOUS DO/JOIN
  609. LX1 10 R.J. ARG COUNT
  610. BX1 -X0*X1 X1 = INPUT ARG COUNT
  611. SX1 X1+1 X1 = INT((NARGS+1)/3)+1
  612. PX1 X1
  613. NX1 X1
  614. SA2 =.33333333333334
  615. FX1 X1*X2
  616. UX1 X1,B1
  617. LX1 X1,B1
  618. SX1 X1+1
  619. IX1 X1+X5 X1 = XSTOR PTR TO RARGS PTR
  620. SA1 B5+X1 X1 = XSTOR PTR TO RARGS
  621. SA5 A5-1 RESET COMMAND POINTER
  622. LX1 48 POSITION XSTOR POINTER
  623. BX5 X5+X1 AND SIMULATE ARGUMENTED -UNIT-
  624. MX6 2 REMOVE TOP BITS
  625. BX5 -X6*X5
  626. SA1 INARGS MAKE SURE ARGS ARE PASSED
  627. ZR X1,PROCESS IF NO ARGS WERE PASSED
  628. *
  629. MX6 0 RESET INARGS
  630. SA6 A1
  631. SX6 46 SET EXECERR MESSAGE
  632. EQ ARGX EXECUTE -ARGS- COMMAND CODE
  633. *
  634. RARGS30 SA5 A5-1 RESET COMMAND POINTER
  635. MX6 0 MAKE SURE *INARGS* CLEARED
  636. SA6 INARGS
  637. EQ PROCESS
  638. *
  639. RARGCND BSS 1 RETURN ARGS CONDITION
  640. * /--- BLOCK ARGS 00 000 81/01/28 04.14
  641. *
  642. TITLE -ARGS- COMMAND
  643. *
  644. * PASS ARGUMENTS TO A UNIT (PSEUDO-COMMAND)
  645. *
  646. * *VARBUF(0)* = NUMBER OF ARGUMENTS
  647. * *VARBUF(N)* = -GETVAR- CODES
  648. * *VARBUF(N+UARGMAX+1)* = ARGUMENT VALUES
  649. * *NARGTR* = ARGUMENTS TO TRANSFER
  650. *
  651. *
  652. * OR
  653. *
  654. * RETRIEVE -JUMPOUT- ARGUMENTS
  655. *
  656. * *JPARGS*
  657. * 1 / FLAG AS ARGUMENTS PRESENT (SIGN BIT)
  658. * 2 / UNUSED
  659. * 9 / DESTINATION UNIT FOR PSEUDO-COMMAND XFER
  660. * 9 / NUMBER OF ARGUMENTS
  661. * 9 / NUMBER OF ARGUMENTS TO TRANSFER
  662. * 30 / -GETVAR- CODE BITS (3 " 10)
  663. * 1 - 1=BLANK ARGUMENT, 0=NON-BLANK
  664. * 2 - UNUSED
  665. * 3 - 1=FLOATING POINT, 0=INTEGER
  666. *
  667. * *JPARGBF* = UP TO TEN ARGUMENTS
  668. *
  669. * THESE ARE TRANSFERED TO APPROPRIATE *VARBUF* AND *NARGTR*
  670. *
  671. *
  672. * -DOR- AND -JOINR- ENTER AT *ARGX* WITH X5
  673. * MOCKED-UP AS AN -ARGS- COMMAND FOR LOCAL VARS
  674. *
  675. *
  676. ENTRY ARGSX
  677. ARGSX BX6 X5 SAVE COMMAND WORD
  678. SA6 TBINTSV
  679. SA1 INARGS CHECK FOR BRANCH-TYPE ARGUMENTS
  680. ZR X1,JARGTST -- IF NONE, TRY -JUMPOUT- ARGS
  681. MX6 0
  682. SA6 A1 CLEAR FLAG
  683. SX6 105 SET EXECERR MESSAGE
  684. PL X5,ARGX JUMP IF PSEUDO COMMAND
  685. *
  686. * IF IT IS NOT, TRY FOR -JUMPOUT- ARGUMENTS ANYWAY;
  687. * -ARGS- COMMAND SHOULD NOT ACCEPT BRANCH-TYPE ARGS
  688. *
  689. JARGTST SA1 JPARGS X1 = *JPARGS*
  690. PL X1,ARGXNO BRANCH IF NO -JUMPOUT- ARGS
  691. * /--- BLOCK ARGS 00 000 81/01/28 04.13
  692. *
  693. * VERIFY THAT ARGUMENTS SHOULD BE PASSED
  694. *
  695. NG X5,JPARGOK UPPER BIT 1 = REAL COMMAND
  696. BX3 X1
  697. AX3 48 GET DESTINATION UNIT
  698. SA2 ILESUN GET CURRENT UNIT
  699. MX0 -9
  700. BX3 -X0*X3
  701. BX2 -X0*X2
  702. IX3 X3-X2 COMPARE
  703. NZ X3,ARGXNO -- EXIT IF NOT SAME
  704. *
  705. * X1 = *JPARGS*
  706. *
  707. JPARGOK MX6 0 RESET *JPARGS*
  708. SA6 JPARGS
  709. MX6 59 PRESET *ZRETURN*
  710. SA6 TRETURN
  711. *
  712. MX0 -9 SET MASK FOR ARGUMENT COUNTS
  713. BX2 X1 SAVE COPY OF STATUS WORD
  714. AX2 30 POSITION TRANSFER COUNT
  715. BX6 -X0*X2
  716. ZR X6,ARGXNO -- EXIT IF NONE TO TRANSFER
  717. SA6 NARGTR
  718. AX2 9 POSITION ARGUMENT COUNT
  719. BX6 -X0*X2
  720. SA6 VARBUF
  721. SB2 X6 SAVE NUMBER OF ARGUMENTS
  722. LX1 30 PREPARE POSITION FOR FLAG BITS
  723. MX0 3 MASK FOR -GETVAR- FLAGS
  724. SB1 0 INITIALIZE INDEX
  725. *
  726. JARGFL SA2 JPARGBF+B1 TRANSFER ARGUMENTS
  727. SB1 B1+1 INCREMENT INDEX
  728. BX6 X0*X1 TRANSFER FLAGS TO TOP 3 BITS
  729. SA6 VARBUF+B1 OF *VARBUF* -GETVAR- CODES
  730. LX1 3 AND POSITION NEXT FLAG
  731. BX6 X2 TRANSFER ARGUMENT VALUES
  732. SA6 VARBUF+UARGMAX+1+B1
  733. LT B1,B2,JARGFL AND CONTINUE UNTIL FINISHED
  734. SX6 105 SET CORRECT EXECERR MESSAGE
  735. *
  736. * /--- BLOCK ARGS 00 000 80/05/27 15.31
  737. *
  738. * BRANCH-TYPE -ARGS- REJOINS -JUMPOUT- -ARGS- HERE
  739. *
  740. * -DOR- AND -JOINR- ROUTINES ALSO ENTER HERE,
  741. * WITH X5 MOCKED-UP TO BE AN -ARGS- COMMAND
  742. * WORD POINTING TO THE VARIABLE LIST TO RECEIVE
  743. * VALUES FROM THE -RETURN- COMMAND; THEREFORE
  744. * X5 CANNOT BE RESTORED BY -SA5 A5-. SEE THE
  745. * ROUTINES FOR -DOR- AND -JOINR- COMMANDS.
  746. *
  747. ARGX SA6 TBINTSV+1 SAVE EXECERR MESSAGE CODE
  748. BX6 X5
  749. SA6 TBINTSV
  750. SA4 NARGTR CHECK WHETHER ANY ARGUMENTS
  751. ZR X4,ARGXNO -- EXIT IF NONE TO TRANSFER
  752. MX0 -6
  753. SA2 TBNARGS
  754. BX6 X0*X2 CLEAR OUT OLD ARGUMENT COUNT
  755. BX6 X4+X6
  756. SA6 A2 STORE NEW ARGUMENT COUNT
  757. *
  758. MX0 -10
  759. LX5 12 POSITION INDEX IN XSTOR
  760. BX5 -X0*X5
  761. CALL ARGCODE,SHOWOUT
  762. SA1 VARBUF NUMBER OF ARGUMENTS GIVEN
  763. SA2 SHOWOUT NUMBER OF VARS TO PASS INTO
  764. MX6 0
  765. SA6 A2 INITIALIZE INDEX
  766. IX0 X2-X1
  767. PL X0,AXLP PROCEED IF ALL KOSHER
  768. *
  769. * OOPS -- MORE PIGEONS THAN PIGEONHOLES
  770. *
  771. SA3 TBINTSV EXAMINE COMMAND WORD
  772. PL X3,AEXECER EXECUTION ERROR FOR -UNIT- ARGS
  773. BX6 X1
  774. SA6 TRETURN NUMBER ATTEMPTED TO PASS
  775. BX6 X2
  776. SA6 A1 SLOTS AVAILABLE TO PASS INTO
  777. *
  778. * /--- BLOCK ARGS 00 000 80/05/13 16.35
  779. *
  780. * TRANSFER ARGUMENTS
  781. *
  782. AXLP SA1 SHOWOUT INDEX IN -GETVAR- CODE BUFFERS
  783. SX6 X1+1
  784. SA6 A1 UPDATE INDEX
  785. SA2 VARBUF
  786. IX0 X1-X2 END TEST
  787. PL X0,ARGXEND
  788. SA3 X6+VARBUF GET ARGUMENT -GETVAR- CODE
  789. NG X3,AXLP JUMP IF BLANK ARGUMENT
  790. SA2 X6+VARBUF+UARGMAX+1
  791. SA1 X6+SHOWOUT
  792. BX5 X1 GET VARIABLE -PUTVAR- CODE
  793. BX6 X2 GET VALUE OF ARGUMENT
  794. LX3 XFBIT
  795. NG X3,AVVAR JUMP IF FLOATING POINT
  796. NPUTVAR
  797. EQ AXLP
  798. *
  799. AVVAR FPUTVAR
  800. EQ AXLP
  801. *
  802. *
  803. ARGXEND SA1 TBINTSV RETRIEVE COMMAND WORD
  804. NG X1,PROCESS EXIT IF EXPLICIT -ARGS-
  805. *
  806. ARGXIT SA1 TIMAIN GET ANY -IMAIN- UNIT NUMBER
  807. PL X1,PROCESS
  808. MX6 1
  809. BX6 -X6*X1 CLEAR TOP BIT (SET BY *LOGIC*)
  810. SA6 A1
  811. SX5 X1 GET UNIT NUMBER
  812. ZR X5,PROCESS
  813. LX5 48 POSITION FOR -JOIN- EXECUTOR
  814. EQ JOINX MOCK UP A JOIN OF IMAIN UNIT
  815. *
  816. *
  817. * IF NO ARGUMENTS AVAILABLE
  818. *
  819. ARGXNO SA1 TBNARGS CLEAR OUT ARGUMENT COUNT
  820. MX0 -6
  821. BX6 X0*X1
  822. SA6 A1
  823. *
  824. SA1 TBINTSV RETRIEVE COMMAND WORD
  825. PL X1,ARGXIT EXIT FOR IMPLICIT -ARGS-
  826. MX6 0 SET *ZRETURN* = 0
  827. SA6 TRETURN
  828. EQ PROCESS EXIT FOR EXPLICIT -ARGS-
  829. *
  830. * ERROR 46 FOR ATTEMPTING TO PASS TOO MANY ARGS
  831. * ERROR 105 FOR ATTEMPTING TO RETURN TOO MANY VALUES
  832. *
  833. AEXECER SA3 TBINTSV+1
  834. EXECERR X3
  835. *
  836. * /--- BLOCK PREARGS 00 000 77/04/23 16.57
  837. TITLE -PREARGS-
  838. *
  839. *
  840. * -PREARGS-
  841. * SET UP FOR BRANCHING COMMAND WITH ARGUMENTS
  842. *
  843. * ON ENTRY - X5 = INDEX IN EXTRA STORAGE
  844. *
  845. * B1 = ARGUMENT DIRECTION FLAG
  846. * -1/0/1 = RETURN/UNDEFINED/PASSING
  847. *
  848. PREARGS EQ *
  849. SA1 INARGS
  850. NZ X1,"CRASH" IF FLAG ALREADY SET
  851. SX6 B1 STORE ARGUMENT DESTINATION FLAG
  852. SA6 A1 (A1 = *INARGS*)
  853. MX0 -10
  854. BX5 -X0*X5 MASK OFF INDEX IN XSTOR
  855. CALL ARGCODE,VARBUF
  856. BX6 X5
  857. SA6 ARWK1 SAVE -X5-
  858. MX6 0
  859. SA6 ARWK INITIALIZE INDEX
  860. *
  861. PALP SA1 ARWK
  862. SX6 X1+1 ADVANCE INDEX
  863. SA2 VARBUF
  864. IX2 X2-X6 END TEST
  865. NG X2,PREXIT
  866. SA6 A1
  867. SA1 X6+VARBUF LOAD -GETVAR- CODE
  868. NG X1,PALP
  869. BX5 X1
  870. LX1 XFBIT POSITION I/F BIT
  871. NG X1,PVVAR JUMP IF FLOATING POINT
  872. NGETVAR
  873. *
  874. PALP1 BX6 X1 GET VALUE OF ARGUMENT
  875. SA2 ARWK
  876. SA6 X2+VARBUF+UARGMAX+1
  877. EQ PALP
  878. *
  879. PVVAR FGETVAR
  880. EQ PALP1
  881. *
  882. PREXIT SA1 ARWK1
  883. BX5 X1 RESTORE -X5-
  884. EQ PREARGS
  885. *
  886. *
  887. ARWK BSS 1
  888. ARWK1 BSS 1
  889. *
  890. *
  891. * /--- BLOCK ARGCODE 00 000 79/03/13 01.36
  892. TITLE -ARGCODE-
  893. *
  894. *
  895. * -ARGCODE-
  896. * UNPACK ARGUMENT -GETVAR- CODES TO SPECIFIED BUFFER
  897. *
  898. * ENTER WITH X5 = INDEX IN EXTRA STORAGE
  899. * B1 = ADDRESS OF BUFFER
  900. *
  901. * RETURNS X5 = UNIT NUMBER
  902. * BUFFER(0) = NUMBER OF ARGUMENTS
  903. * BUFFER(N) = -GETVAR- CODES FOR ARGUMENTS
  904. * *NARGTR* = NUMBER OF ARGS TO TRANSFER
  905. *
  906. *
  907. ENTRY ARGCODE,NARGTR
  908. *
  909. ARGCODE EQ *
  910. SA1 X5+B5
  911. LX1 10 POSITION ARGUMENT COUNT
  912. MX0 -10
  913. BX6 -X0*X1
  914. BX4 X6 INITIALIZE REAL ARGUMENT COUNT
  915. SA6 B1
  916. LX1 10 POSITION UNIT NUMBER
  917. BX5 -X0*X1
  918. ZR X6,ARGCEX EXIT IF NO ARGUMENTS
  919. MX0 XCODEL MASK FOR -GETVAR- CODE
  920. SB2 2 INITIALIZE CODES/WORD COUNT
  921. SB3 B0 INITIALIZE BUFFER INDEX
  922. *
  923. ACLP BX7 X0*X1 MASK OFF NEXT -GETVAR- CODE
  924. LX1 XCODEL
  925. SB3 B3+1
  926. SA7 B1+B3
  927. + PL X7,*+1 JUMP IF NON-BLANK ARGUMENT
  928. SX4 X4-1 DECREMENT REAL ARGUMENT COUNT
  929. + SX6 X6-1 DECREMENT NUMBER OF CODES
  930. ZR X6,ARGCEX
  931. SB2 B2-1 DECREMENT CODES/WORD COUNT
  932. NZ B2,ACLP
  933. SA1 A1+1 LOAD NEXT WORD OF CODES
  934. SB2 3 RE-INITIALIZE COUNT
  935. EQ ACLP
  936. *
  937. ARGCEX BX6 X4 STORE REAL ARGUMENT COUNT
  938. SA6 NARGTR
  939. EQ ARGCODE
  940. *
  941. *
  942. NARGTR BSS 1
  943. *
  944. *
  945. * /--- BLOCK WINTRP 00 000 76/06/17 00.15
  946. TITLE WRITE COMMAND INTERRUPT
  947. *
  948. *
  949. *
  950. * -WINTRP-
  951. * INTERUPT ROUTINE FOR -WRITE- COMMAND OR OTHER
  952. * COMMANDS WHICH MAY BE USED IN EMBEDDED -WRITE-
  953. *
  954. * THREE 18 BIT COUNTS IN SHARE+1, +2, +3 ARE SAVED
  955. * OVER INTERRUPT
  956. *
  957. * ON ENTRY - SHARE+1 = CHARACTER COUNT
  958. * SHARE+2 = POINTER TO TEXT
  959. * SHARE+3 = TEXT WORD COUNT
  960. *
  961. *
  962. ENTRY WINTRP
  963. WINTRP EQ *
  964. *
  965. * PRESERVE 18 BIT QUANTITIES IN SHARE+1 - SHARE+3
  966. *
  967. MX0 -18
  968. SA1 SHARE+2 GET POINTER TO TEXT
  969. BX1 -X0*X1
  970. LX1 60-18
  971. SA2 SHARE+3 GET TEXT WORD COUNT
  972. BX2 -X0*X2
  973. LX2 60-18-18
  974. BX6 X1+X2
  975. SA1 SHARE+1 GET CHARACTER COUNT
  976. BX1 -X0*X1
  977. BX6 X6+X1
  978. SA6 WRTSAV1
  979. *
  980. * CHECK IF PROCESSING EMBEDDED -WRITE-
  981. *
  982. SA1 INEMBED SEE IF IN EMBEDDED -WRITE-
  983. NZ X1,WINT1
  984. MX6 0 X6 = -EMBED- WORD = 0
  985. SA6 WRTSAV2 CLEAR -EMBED- WORD
  986. EQ WINT3
  987. *
  988. * SAVE EMBEDDED WRITE PARAMETERS
  989. *
  990. WINT1 MX0 18+18
  991. BX6 X0*X1 DISCARD IRRELAVANT INFO
  992. SX2 A5
  993. BX6 X2+X6 SAVE -EMBED- COMMAND ADDRESS
  994. SA6 WRTSAV2
  995. SA5 X1 RESTORE A5 FOR -TFIN-
  996. SA1 VARBUF
  997. SX6 X1 X6 = EXIT COMMAND CODE
  998. *
  999. * SAVE RETURN ADDRESS
  1000. *
  1001. WINT3 MX0 18
  1002. SA1 WINTRP LOAD EXIT JUMP
  1003. LX1 12
  1004. BX1 X0*X1 MASK OFF RETURN ADDRESS
  1005. LX1 2*18
  1006. BX6 X1+X6 ATTACH WITH EMBED EXIT COMMAND
  1007. SA6 WRTSAV3
  1008. * /--- BLOCK WINTRP 00 000 77/07/25 23.03
  1009. *
  1010. * INTERRUPT
  1011. *
  1012. CALL TFIN END THIS TIME SLICE
  1013. *
  1014. * RESTORE SHARE+1 - SHARE+3 AFTER INTERRUPT
  1015. *
  1016. SA1 WRTSAV1
  1017. SX6 X1 RESTORE CHARACTER COUNT
  1018. SA6 SHARE+1
  1019. LX1 18
  1020. SX6 X1 RESTORE POINTER TO TEXT
  1021. SA6 SHARE+2
  1022. LX1 18
  1023. SX7 X1 RESTORE TEXT WORD COUNT
  1024. SA7 SHARE+3
  1025. *
  1026. * RESTORE EMBEDDED -WRITE- PARAMETERS
  1027. *
  1028. SA1 WRTSAV2 SEE IF -EMBEDDED- WRITE
  1029. ZR X1,WINT4
  1030. MX0 18+18
  1031. BX6 X0*X1
  1032. SX0 A5 ATTACH NEW COMMAND ADDRESS
  1033. BX6 X0+X6
  1034. SA6 INEMBED SET -EMBED- FLAG
  1035. SA5 X1 RESTORE -EMBED- COMMAND ADDRESS
  1036. LX6 18
  1037. SX0 X6 PICK OFF ECS BIAS
  1038. LX6 18
  1039. SB1 X6 PICK OFF ECS LENGTH
  1040. SX1 B1-VARBUFL+1
  1041. PL X1,WERXBIG CHECK LENGTH
  1042. SA1 ECSXSTO POINTER TO ECS XSTOR OF UNIT
  1043. IX0 X0+X1 INDEX INTO LESSON BINARY
  1044. SA0 VARBUF+1
  1045. + RE B1 READ COMMANDS TO *VARBUF*
  1046. RJ ECSPRTY
  1047. SA1 WRTSAV3
  1048. SX6 X1 RESTORE EXIT COMMAND
  1049. SA6 VARBUF
  1050. *
  1051. WINT4 SA1 WRTSAV3 PICK UP RETURN ADDRESS
  1052. AX1 18
  1053. SB1 X1
  1054. JP B1 RETURN TO CALLING ROUTINE
  1055. *
  1056. *
  1057. WRTSAV1 EQU TBINTSV+9
  1058. WRTSAV2 EQU TBINTSV+10
  1059. WRTSAV3 EQU TBINTSV+8
  1060. *
  1061. WERXBIG SX1 B1
  1062. SX2 VARBUFL-1 MAX NO. EMBEDS
  1063. EQ ERXMBED
  1064. *
  1065. * /--- BLOCK STEP 00 000 82/06/28 11.59
  1066. TITLE -STEP- SINGLE COMMAND EXECUTION
  1067. *
  1068. *
  1069. * -STEP-
  1070. * PROCESSING FOR STEP MODE EXECUTION - ALLOWS AN
  1071. * AUTHOR TO STEP THROUGH HIS LESSON ONE COMMAND
  1072. * AT A TIME
  1073. *
  1074. *
  1075. ENTRY STEP
  1076. *
  1077. STEP FINISH ILLEGAL IN -FINISH- UNIT
  1078. SA1 TBNARGS GET -STEP- COMMAND COUNT
  1079. LX1 60-STEPCSF
  1080. MX0 -6 MASK FOR SIX BIT COUNTER
  1081. BX6 X0*X1
  1082. BX1 -X0*X1 MASK OFF COMMAND COUNT
  1083. ZR X1,STEP05
  1084. SX1 X1-1 DECREMENT COMMAND SKIP COUNT
  1085. BX6 X1+X6
  1086. LX6 STEPCSF REPOSITION WORD
  1087. SA6 A1
  1088. EQ PROC1 GO PROCESS THIS COMMAND
  1089. *
  1090. STEP05 SA1 INEMBED
  1091. NZ X1,PROC1 EXIT IF IN EMBEDDED -WRITE-
  1092. SA1 INARGS
  1093. NZ X1,PROC1 EXIT IF ARGUMENTS IN HAND
  1094. SA1 TBITS
  1095. LX1 BRKBIT
  1096. NG X1,PROC1 EXIT IF -NOBREAK-
  1097. CALL LIBTEST,TBLESAC CHECK FOR SYSTEM LIB LESSN
  1098. NG X6,PROC1 -- STEP-OFF IN SYSLIB LESSONS
  1099. MX0 -XCMNDL MASK FOR COMMAND CODE
  1100. *
  1101. SSKIP SA1 A5-1
  1102. BX6 -X0*X1 SAVE COMMAND NUMBER
  1103. SA2 X6+JTABLE LOAD COMMAND TABLE ENTRY
  1104. LX2 B7,X2 SHIFT TO PROPER CONTINGENCY BIT
  1105. NG X2,STEP10 JUMP IF LEGAL IN THIS STATE
  1106. SA5 A5-1
  1107. EQ SSKIP GO ON TO NEXT COMMAND
  1108. *
  1109. STEP10 SA6 VARBUF
  1110. SX6 B7 SAVE CONTINGENCY
  1111. SA6 VARBUF+1
  1112. SB1 A1 COMPUTE COMMAND BIAS
  1113. SX6 B5-B1
  1114. SA6 VARBUF+2 SAVE COMMAND BIAS
  1115. SA1 TUNAME
  1116. BX6 X1 SAVE MAIN UNIT NAME
  1117. SA6 VARBUF+3
  1118. SA1 TUNAMEC SAVE CURRENT UNIT NAME
  1119. LX1 12
  1120. MX6 48
  1121. BX6 X6*X1 SAVE CURRENT UNIT NAME
  1122. SA6 VARBUF+4
  1123. *
  1124. SA1 TBASE
  1125. ZR X1,STEP15 JUMP IF NO BASE UNIT
  1126. CALL HOLUNIT,TBASE,(VARBUF+5)
  1127. EQ STEP20
  1128. *
  1129. STEP15 SX6 1R0 0 = NO BASE UNIT
  1130. LX6 60-6
  1131. SA6 VARBUF+5
  1132. *
  1133. STEP20 CALL SYSLIB,(=5LSTEPX),-1
  1134. STOPCHK PROCESS -STOP1- KEY
  1135. EQ PROC1
  1136. *
  1137. * /--- BLOCK STEP 00 000 74/01/14 05.17
  1138. *
  1139. ENTRY POSTEP
  1140. * ANOTHER PIECE OF TRASH FROM HELL. A JUMP TO
  1141. * *POSTEP* IS PLANTED AT *EXECUTX* IN DECK LOGICX
  1142. * DURING TIME-SLICE INITIALIZATION IN *PINITX* IF
  1143. * THE USER IS IN STEP MODE. HOWEVER, THERE SEEM TO
  1144. * BE WAYS FOR COMMANDS TO RE-START EXECUTION W/O
  1145. * GOING THRU *PINITX* (LIKE -ARROW- WHEN A JKEY IS
  1146. * PRESSED) AND THUS WIND UP HERE W/O BEING IN STEP.
  1147. * THIS KLUDGE PREVENTS THE MESSAGE FROM BEING DIS-
  1148. * PLAYED, SORRY 'I DON'7T HAVE THE TIME TO FIX THE
  1149. * ROOT OF THE PROBLEM. HARKRADER 83/08/09.
  1150. *
  1151. POSTEP BSS 0 SEE LOGICX (PINITX AND PAUSE)
  1152. SA1 TBITS *** TRAP *** BE SURE IN -STEP-
  1153. LX1 STEPBIT
  1154. PL X1,POSTEXC -- NOT IN STEP, RETURN TO PROC.
  1155. RJ STEPXX PLOT *WAITING FOR KEY* MESSAGE
  1156. EQ POSTEXC
  1157. *
  1158. *
  1159. ENTRY STEPXX
  1160. STEPXX EQ *
  1161. RJ STEPAA ERASE BOTTOM OF SCREEN
  1162. TWRIT =3003,=19,(=19H WAITING FOR KEY )
  1163. RJ STEPBB
  1164. EQ STEPXX
  1165. *
  1166. *
  1167. STEPAA EQ *
  1168. SA1 NX SAVE CURRENT X POSITION
  1169. BX6 X1
  1170. SA6 ISAVE
  1171. SA1 NY SAVE CURRENT Y POSITION
  1172. BX6 X1
  1173. SA6 ISAVE+1
  1174.  
  1175. * SAVE -SIZE BOLD- STATUS.
  1176.  
  1177. SA1 FSTFLGS
  1178. LX1 60-SIZBOLD
  1179. BX6 X1
  1180. SA6 SAVESBF
  1181.  
  1182. CLRFBIT SIZBOLD
  1183.  
  1184. SX1 3 SET TO WRITE MODE
  1185. OUTPUT WEFCODE
  1186. CALL WHROUT,=3001
  1187. CALL ERSOUT,=64
  1188. CALL WHROUT,=3101
  1189. CALL ERSOUT,=64
  1190. CALL WHROUT,=3201
  1191. CALL ERSOUT,=64
  1192. EQ STEPAA
  1193. *
  1194. *
  1195. STEPBB EQ *
  1196. SA1 ISAVE
  1197. BX6 X1 RESTORE NX
  1198. SA6 NX
  1199. SA1 ISAVE+1
  1200. BX6 X1 RESTORE NY
  1201. SA6 NY
  1202. CALL WHRFOUT,ISAVE,ISAVE+1
  1203. MX0 -3
  1204. SA1 TBNARGS RESTORE AUTHORS W/E MODE
  1205. AX1 6
  1206. BX1 -X0*X1
  1207. OUTPUT WEFCODE
  1208.  
  1209. * RESTORE -SIZE BOLD-.
  1210.  
  1211. SA1 SAVESBF
  1212. PL X1,STEPBB IF NO -SIZE BOLD- IN EFFECT
  1213.  
  1214. SETFBIT SIZBOLD
  1215.  
  1216. EQ STEPBB
  1217. *
  1218. ISAVE BSS 2
  1219. SAVESBF BSS 1 1/SIZE BOLD FLAG, 59/UNUSED
  1220. *
  1221. *
  1222. * /--- BLOCK STEP 00 000 78/10/01 00.06
  1223. TITLE -STEP- COMMAND
  1224. *
  1225. *
  1226. *
  1227. * -STEP- COMMAND
  1228. * ACTIVATE/DEACTIVATE -STEP- MODE EXECUTION
  1229. *
  1230. *
  1231. * CHANGED TO ALLOW ALL USER TYPES TO USE STEP MODE
  1232. *
  1233. * 'MIKE 'VOLLMER 78/09/08
  1234. *
  1235. ENTRY STEPX
  1236. *
  1237. STEPX NGETVAR 0 = NORMAL MODE 1 = STEP MODE
  1238. MX6 1
  1239. LX6 -STEPBIT FORM MASK FOR STEP BIT
  1240. SA2 TBITS
  1241. ZR X1,STEPOFF EXIT FROM -STEP- MODE
  1242. BX3 X6*X2
  1243. NZ X3,PROC EXIT IF ALREADY IN -STEP- MODE
  1244. BX6 X2+X6
  1245. SA6 A2 BEGIN STEP MODE EXECUTION
  1246. EQ STEPX5
  1247. *
  1248. STEPOFF BX3 X6*X2 EXIT IF NOT IN -STEP- MODE
  1249. ZR X3,PROC
  1250. BX6 -X6*X2 CLEAR -STEP- BIT
  1251. SA6 A2
  1252.  
  1253. * CLEAR TEMP BUSY FLAG
  1254.  
  1255. SA1 STATION
  1256. SA2 AGROUP
  1257. IX0 X1+X2 EM ADDR OF ENTRY FOR THIS STAT.
  1258. MX6 1 FORM SINGLE BIT MASK
  1259. RX1 X0 READ FROM EM
  1260. LX6 2 SHIFT TO TEMP BUSY POSITION
  1261. BX6 -X6*X1 CLEAR IT
  1262. WX6 X0 WRITE TO EM
  1263. RJ STEPAA ERASE BOTTOM OF SCREEN
  1264. RJ STEPBB
  1265. *
  1266. STEPX5 MX6 -6 MASK FOR STEP COMMAND COUNT
  1267. LX6 STEPCSF
  1268. SA1 TBNARGS
  1269. BX6 X6*X1 CLEAR OUT COMMAND COUNT
  1270. SA6 A1
  1271. EQ XSLICE
  1272. *
  1273. *
  1274. * /--- BLOCK ADD1 00 000 74/03/12 23.55
  1275. *
  1276. *
  1277. * -ADD1- (CODE=104)
  1278. *
  1279. * ADD 1 TO SPECIFIED VARIABLE(S)
  1280. *
  1281. ENTRY ADD1X
  1282. ADD1X BX1 X5
  1283. LX1 XFBIT
  1284. PL X1,ADD1I JUMP IF INTEGER VARIABLE
  1285. FGETVAR X1 = FLOATING POINT VALUE
  1286. SA2 =1.0
  1287. FX6 X1+X2 ADD 1.0
  1288. NX6 X6
  1289. SA5 A5 RESTORE X5
  1290. LX5 XCODEL
  1291. FPUTVAR STORE INCREMENTED VALUE
  1292. EQ PROC
  1293. *
  1294. ADD1I NGETVAR X1 = INTEGER VALUE
  1295. SX2 1
  1296. IX6 X1+X2 ADD 1
  1297. SA5 A5 RESTORE X5
  1298. LX5 XCODEL
  1299. NPUTVAR STORE INCREMENTED VALUE
  1300. EQ PROC
  1301. *
  1302. *
  1303. * -SUB1- (CODE=105)
  1304. *
  1305. * SUBTRACT 1 FROM SPECIFIED VARIABLE
  1306. *
  1307. ENTRY SUB1X
  1308. SUB1X BX1 X5
  1309. LX1 XFBIT
  1310. PL X1,SUB1I JUMP IF INTEGER VARIABLE
  1311. FGETVAR X1 = FLOATING POINT VALUE
  1312. SA2 =1.0
  1313. FX6 X1-X2 SUBTRACT 1.0
  1314. NX6 X6
  1315. SA5 A5 RESTORE X5
  1316. LX5 XCODEL
  1317. FPUTVAR STORE DECREMENTED VALUE
  1318. EQ PROC
  1319. *
  1320. SUB1I NGETVAR X1 = INTEGER VALUE
  1321. SX2 1
  1322. IX6 X1-X2 SUBTRACT 1
  1323. SA5 A5
  1324. LX5 XCODEL
  1325. NPUTVAR STORE DECREMENTED VALUE
  1326. EQ PROC
  1327. *
  1328. TITLE OKWORD AND NOWORD
  1329. * -OKWORD- (CODE=223)
  1330. *
  1331. * SETS VARIABLE *TOKWORD* TO SPECIFIED CHARACTER
  1332. * STRING TO PLOT FOR -OK- JUDGMENTS.
  1333. *
  1334. ENTRY OKWORDX
  1335. *
  1336. OKWORDX AX5 XCMNDL
  1337. SA1 B5+X5 GET EXTRA STORAGE WORD
  1338. BX6 X1
  1339. SA6 TOKWORD
  1340. EQ PROC --- EXIT
  1341. *
  1342. *
  1343. *
  1344. * -NOWORD- (CODE=224)
  1345. *
  1346. * SETS VARIABLE *TNOWORD* TO SPECIFIED CHARACTER
  1347. * STRING TO PLOT FOR -NO- JUDGMENTS.
  1348. *
  1349. ENTRY NOWORDX
  1350. *
  1351. NOWORDX AX5 XCMNDL
  1352. SA1 B5+X5 GET EXTRA STORAGE WORD
  1353. BX6 X1
  1354. SA6 TNOWORD
  1355. EQ PROC --- EXIT
  1356. * /--- BLOCK SCOR-STATU 00 000 77/07/25 20.40
  1357. *
  1358. *
  1359. *
  1360. TITLE -SCORE- AND -STATUS- COMMANDS
  1361. *
  1362. * SCORE N1 PLACES VALUE OF N1 INTO RESERVED
  1363. * WORD -LSCORE-. VALUE MUST BE BETWEEN 0 AND 100
  1364. * BLANK TAG SETS LSCORE TO -1 ; NO SCORE FOR LESSON
  1365. *
  1366. ENTRY SCOREX
  1367. SCOREX NG X5,SCORB TEST FOR BLANK TAG
  1368. NGETVAR
  1369. NG X1,SCORB SET TO -NOT DONE-
  1370. SX2 100 EXECERR IS PASSED X1 AND X2
  1371. IX0 X2-X1
  1372. NG X0,SERXBIG CANT BE GREATER THAN 100
  1373. EQ SCORST
  1374. *
  1375. SERXBIG EXECERR 107 SCORE TOO BIG
  1376. *
  1377. *
  1378. SCORB MX1 1
  1379. LX1 8 SET UPPER BIT
  1380. SCORST SA2 TBSCORE
  1381. MX0 -8 SCORE IS IN LOWER 8 BITS
  1382. BX2 X0*X2 CLEAR OUT CURRENT SCORE
  1383. BX6 X1+X2 ADD IN NEW SCORE
  1384. SA6 TBSCORE
  1385. EQ PROC
  1386. *
  1387. *
  1388. * -STATUS- COMMAND FOR LONG-TERM RESTART INFO
  1389. ENTRY STLSTAT
  1390. STLSTAT NGETVAR
  1391. BX6 X1
  1392. SA6 LSTATUS
  1393. EQ PROC
  1394. *
  1395. * /--- BLOCK GRAFS 00 000 75/10/17 23.18
  1396. TITLE VARIOUS GRAPHING SUBROUTINES
  1397. * /--- BLOCK SCALXY 00 000 75/08/10 02.46
  1398. *
  1399. *
  1400. * SUBROUTINE TO CONVERT SCALED XDATA, YDATA VALUES
  1401. * TO RELATIVE DOTS IN XDOT,YDOT (+X3,X4),
  1402. * AND TO ABSOLUTE SCREEN DOTS IN X6,X7.
  1403. * (X6,7 ALSO MASKED TO 9BITS IN X1,2)
  1404. * MAY USE ALL AVAILABLE REGISTERS
  1405. *
  1406. ENTRY SCALXY,XDOT,YDOT
  1407. *
  1408. SCALXY EQ *
  1409. SA2 GDATA2
  1410. LX2 59 SHIFT POLAR FLAG TO TOP
  1411. NG X2,PSCAL JUMP IF POLAR FLAG SET
  1412. SCALXY2 RJ X2DOT X6=ROUNDED XDOT VALUE
  1413. UX7 B2,X6 FIX
  1414. LX7 B2,X7 TO INTEGER
  1415. SA7 XDOT SAVE IT
  1416. RJ Y2DOT X6=ROUNDED YDOT VALUE
  1417. UX7 B2,X6 INTEGER FIX
  1418. LX7 B2,X7
  1419. SA7 YDOT SAVE IT
  1420. BX4 X7 IN X4 TOO
  1421. SA1 GDATA GET GRAF DATA
  1422. MX0 51
  1423. LX1 20 POSITION YORG
  1424. BX2 -X0*X1 YORG
  1425. LX1 51
  1426. BX1 -X0*X1 XORG
  1427. SA3 XDOT
  1428. IX6 X1+X3 X+XORG
  1429. IX7 X7+X2 Y+YORG
  1430. BX2 -X0*X7
  1431. BX1 -X0*X6
  1432. EQ SCALXY
  1433. *
  1434. PSCAL SA1 YDATA IS ANGLE IN RADIANS
  1435. CALL TSINX SIN(ANGLE) INTO X1
  1436. BX7 X1
  1437. SA1 YDATA GET ANGLE AGAIN
  1438. SA7 A1 AND SAVE SINE
  1439. CALL TCOSX COS(ANGLE) INTO X1
  1440. SA2 YDATA SIN INTO X2
  1441. SA3 XDATA RADIUS IN X3
  1442. RX6 X3*X1 R COS A
  1443. RX7 X3*X2 R SIN A
  1444. SA6 A3 FOR X CONVERSION
  1445. SA7 A2 FOR Y CONVERSION
  1446. EQ SCALXY2
  1447. *
  1448. XDOT BSS 1
  1449. YDOT BSS 1
  1450. * /--- BLOCK X2DOT 00 000 76/01/23 23.01
  1451. EJECT
  1452. *
  1453. * SUBROUTINE TO CONVERT FLOATING X (IN XDATA)
  1454. * TO FLOATING DOT VALUE RELATIVE TO ORIGIN (IN X6)
  1455. * LEAVES (XMAX-XOFFSET) IN X2 FOR LABLXY
  1456. *
  1457. ENTRY X2DOT,X2DOT2
  1458. X2DOT EQ *
  1459. SA1 GDATA GET AXES INFO
  1460. NG X1,X2DOTL JUMP IF LOG SCALE
  1461. X2DOT2 LX1 60-2*PFIELD
  1462. AX1 60-PFIELD EXTEND SIGN OF (X+)
  1463. NZ X1,X2DOT5 USUALLY X+ IS NONZERO
  1464. SA1 GDATA IF NOT, USE X-
  1465. LX1 60-4*PFIELD
  1466. AX1 60-PFIELD
  1467. X2DOT5 PX1 X1
  1468. NX1 X1 FLOAT (X+)
  1469. SA2 GXMAX
  1470. SA3 XOFFSET
  1471. RX2 X2-X3 XMAX-XOFFSET
  1472. NX2 X2
  1473. RX2 X1/X2 (X+)/(XMAX-XOFFSET)
  1474. SA1 XDATA
  1475. RX1 X1-X3 X-XOFFSET
  1476. NX1 X1
  1477. RX6 X1*X2 (X-XOFFSET)(X+)/(XMAX-XOFFSET)
  1478. SA1 =.5
  1479. BX3 X6 ROUND ACCORDING TO SIGN
  1480. AX3 60
  1481. BX1 X1-X3 +.5 OR -.5
  1482. FX6 X6+X1 ROUND IT
  1483. NX6 X6
  1484. EQ X2DOT
  1485. *
  1486. *
  1487. X2DOTL SA1 XDATA
  1488. CALL TLOGX
  1489. BX7 X1
  1490. SA7 XDATA
  1491. SA1 GDATA
  1492. EQ X2DOT2
  1493. EJECT
  1494. *
  1495. * SUBROUTINE TO CONVERT FLOATING Y (IN YDATA)
  1496. * TO FLOATING DOT VALUE RELATIVE TO ORIGIN (IN X6)
  1497. * LEAVES (YMAX-YOFFSET) IN X2 FOR LABLXY
  1498. *
  1499. ENTRY Y2DOT,Y2DOT2
  1500. Y2DOT EQ *
  1501. SA1 GDATA GET (Y+)
  1502. LX1 1 CHECK LOG SCALE FLAG
  1503. NG X1,Y2DOTL JUMP IF LOG SCALE
  1504. AX1 1
  1505. Y2DOT2 LX1 60-PFIELD
  1506. AX1 60-PFIELD EXTEND SIGN
  1507. NZ X1,Y2DOT5 USUALLY Y+ IS NONZERO
  1508. SA1 GDATA IF Y+=0, USE Y-
  1509. LX1 60-3*PFIELD
  1510. AX1 60-PFIELD
  1511. Y2DOT5 PX1 X1
  1512. NX1 X1 FLOAT (Y+)
  1513. SA2 GYMAX
  1514. SA3 YOFFSET
  1515. FX2 X2-X3 YMAX-YOFFSET
  1516. NX2 X2
  1517. RX2 X1/X2 (Y+)/(YMAX-YOFFSET)
  1518. SA1 YDATA
  1519. FX1 X1-X3 Y-YOFFSET
  1520. NX1 X1
  1521. RX6 X1*X2 (Y-YOFFSET)(Y+)/(YMAX-YOFFSET)
  1522. SA1 =.5
  1523. BX3 X6 ROUND ACCORDING TO SIGN
  1524. AX3 60
  1525. BX1 X1-X3 +.5 OR -.5
  1526. FX6 X6+X1 ROUND IT
  1527. NX6 X6
  1528. EQ Y2DOT
  1529. *
  1530. *
  1531. *
  1532. Y2DOTL SA1 YDATA
  1533. CALL TLOGX
  1534. BX7 X1
  1535. SA7 YDATA
  1536. SA1 GDATA
  1537. EQ Y2DOT2
  1538. *
  1539. * /--- BLOCK NUSETX 00 000 78/04/04 18.32
  1540. TITLE GRAFS SUBROUTINES
  1541. *
  1542. *
  1543. *
  1544. * SUBROUTINE TO EXPAND GRAFDATA
  1545. * PUTS X-,Y-,X+,Y+,XORG,YORG INTO
  1546. * TBINTSV, TBINTSV+1, ......, TBINTSV+5
  1547. *
  1548. ENTRY GDATAX
  1549. GDATAX EQ *
  1550. SB1 1
  1551. MX0 51
  1552. SA1 GDATA
  1553. LX1 20 2 FLAG BITS AND ORIGIN
  1554. BX6 -X0*X1
  1555. SA6 YORGIN SAVE ORIGIN
  1556. LX1 51
  1557. BX6 -X0*X1
  1558. SA6 A6-B1 SAVE XORG
  1559. LX1 4*PFIELD+9 POSITION Y+ AT RIGHT
  1560. MX0 60-PFIELD
  1561. SB2 XMINUS SAVE X- THRU Y+ IN ORDER
  1562. GDLOOP BX6 -X0*X1 GET NEXT ARG
  1563. LX6 60-PFIELD
  1564. AX6 60-PFIELD EXTEND SIGN
  1565. SA6 A6-B1 PLANT
  1566. LX1 60-PFIELD
  1567. SB3 A6
  1568. GT B3,B2,GDLOOP
  1569. EQ GDATAX
  1570. *
  1571. *
  1572. * SUBROUTINE TO PUT OUT LINE FROM X1,X2,X3,X4
  1573. *
  1574. ENTRY LINIT
  1575. LINIT EQ *
  1576. ZR X0,LINIT1 JUMP IF NO WINDOWING
  1577. CALL WINDOW
  1578. NZ X0,LINIT JUMP IF LINE HAS BEEN DRAWN
  1579. LINIT1 MX0 51
  1580. BX1 -X0*X1
  1581. BX2 -X0*X2 MASK ALL X,Y TO 9 BITS
  1582. BX3 -X0*X3
  1583. BX4 -X0*X4
  1584. LX1 9
  1585. BX1 X1+X2 X1,Y1
  1586. OUTPUT WFCODE
  1587. BX1 X3
  1588. LX1 9
  1589. BX1 X1+X4 X2,Y2
  1590. OUTPUT LFCODE
  1591. BX6 X3
  1592. SA6 NX UPDATE X
  1593. BX7 X4
  1594. SA7 NY UPDATE Y
  1595. MX0 0 SIGNAL THAT LINE NOT WINDOWED
  1596. EQ LINIT
  1597. *
  1598. *
  1599. * SUBROUTINE TO PUT OUT LINER FROM X3,X4
  1600. *
  1601. ENTRY LINRIT
  1602. LINRIT EQ *
  1603. SA1 TBWNDOW
  1604. BX0 X1
  1605. SA1 NX
  1606. SA2 NY
  1607. ZR X0,LINRIT1 JUMP IF NO WINDOWING
  1608. CALL WINDOW
  1609. NZ X0,LINRIT JUMP IF LINE HAS BEEN DRAWN
  1610. LINRIT1 MX0 -9
  1611. BX3 -X0*X3
  1612. BX4 -X0*X4
  1613. BX1 X3
  1614. LX1 9
  1615. BX1 X1+X4 X2,Y2
  1616. OUTPUT LFCODE
  1617. BX6 X3
  1618. SA6 NX UPDATE X
  1619. BX7 X4
  1620. SA7 NY UPDATE Y
  1621. MX0 0 SIGNAL LINER WAS NOT WINDOWED
  1622. EQ LINRIT
  1623. *
  1624. * /--- BLOCK NUSETX 00 000 78/04/04 18.32
  1625. TITLE -SET- COMMAND EXECUTION ROUTINE
  1626. *
  1627. * SET ARRAY_ARG1,ARG2,ARG3,...
  1628. * SET ARRAY(R,C)_ARGI,ARGJ,ARGK,...
  1629. * SET V1_ARG1,ARG2,...
  1630. *
  1631. * FILLS CONSECUTIVE VARIABLES WITH ITEMS IN LIST
  1632. * BEGINNING AT FIRST ARGUMENT AND GOING UP
  1633. * GIVES ERROR MSG AT CONDENSE TIME (IF POSSIBLE)
  1634. * OR EXEC TIME IF LIST RUNS OVER PERMISSIBLE BOUNDS
  1635. * OF ARRAY OR STUDENT VARIABLES
  1636. *
  1637. ENTRY SETX
  1638. EXT ARAYFLG,ARAYERR,TOOMUCH
  1639. *
  1640. SETX LX5 XCODEL
  1641. MX0 -XCODEL GET NUMBER OF ARGUMENTS
  1642. BX6 -X0*X5
  1643. SX6 X6-3 NUMBER OF -SET- LIST ITEMS -1
  1644. SA6 ITEMS
  1645. *
  1646. LX5 XCODEL
  1647. BX7 -X0*X5
  1648. SA7 MAXADDR SAVE MAX BANK/ARRAY ADDR
  1649. *
  1650. LX5 60-2*XCODEL-XCMNDL
  1651. MX0 2*XCODEL+XCMNDL
  1652. BX6 -X0*X5 POINTER TO XTRA STORAGE
  1653. SA6 XPTR
  1654. SA2 B5+X6 1ST XSTOR WD HAS START GETVAR
  1655. BX5 X2
  1656. *
  1657. SX7 0
  1658. SA7 ARAYFLG PRESET ARRAY TEST
  1659. SB3 SETX02 SETUP
  1660. NGET EQ NGETVAR
  1661. SETX02 SX6 A1 INITIAL ADDRESS
  1662. SB1 A1 SAVE HERE FOR BANK LIMIT TEST
  1663. SA6 SADDR
  1664. * MODIFY LOOP FOR I/F TYPE OF RESULT
  1665. SX6 0
  1666. SA1 ARAYFLG
  1667. ZR X1,SETX04 JUMP IF NOT WHOLE ARRAY
  1668. SA2 X1 GET ARAY INFO WORD
  1669. LX2 3
  1670. PL X2,SETX03 JUMP IF NOT SEGMENTED
  1671. SA3 A2+1 GET 2D ARAY INFO WD
  1672. BX6 X3 NONZERO FOR SEGMENTED FLAG
  1673. LX3 1
  1674. PL X3,ERXHSEG NO HORIZ SEGMENTS YET
  1675. SETX03 LX2 60-XCODEL-3 ROTATE GETVAR TO TOP
  1676. EQ SETX06
  1677. SETX04 SA1 XPTR
  1678. SA2 B5+X1 1ST XSTOR WD HAS START GETVAR
  1679. SETX06 LX2 XFBIT PUT I/F BIT AT TOP
  1680. SA3 NGET
  1681. SA6 ARAYWRD SAVE SEGMENT FLAG
  1682. PL X2,SETX08
  1683. SA3 FGET
  1684. * /--- BLOCK NUSETX08 00 000 79/02/09 12.14
  1685. *
  1686. SETX08 BX6 X3 PLANT NGETVAR/FGETVAR
  1687. SA6 SETX30 IN EVALUATION LOOP
  1688. *
  1689. SX7 20
  1690. SA7 BYTE *CLS*20 TO GET NEXT GETVAR
  1691. SA2 MAXADDR
  1692. NZ X2,SETLOOP JUMP IF MAXADDR SET AT CONDEN
  1693. * MUST DETERMINE BANK LIMIT FROM START ADDRESS
  1694. SB2 STUDVAR
  1695. LT B1,B2,ARAYERR ERROR IF BELOW STUD BANK
  1696. SB2 STUDVAR+VARLIM
  1697. LT B1,B2,SETX15 JUMP IF IN STUD BANK
  1698. SB2 RVARBUF
  1699. LT B1,B2,ARAYERR ERROR IF BELOW ROUTER BANK
  1700. SB2 RVARBUF+RVARLIM
  1701. LT B1,B2,SETX15 JUMP IF IN ROUTER BANK
  1702. SB2 NCVRBUF NC VARS
  1703. LT B1,B2,ARAYERR ERROR IF BELOW COMMON BANK
  1704. SB2 NCVRBUF+NCVRLIM NC VARS
  1705. GE B1,B2,ARAYERR ERROR IF PAST COMMON LIMIT
  1706. SETX15 SX7 B2 COME HERE WITH B2=BANK LIMIT+1
  1707. SA7 MAXADDR SAVE FOR LIMIT TEST
  1708. *
  1709. * /--- BLOCK SETLOOP 00 000 78/04/04 18.32
  1710. *
  1711. SETLOOP SA1 ITEMS
  1712. NG X1,PROCESS QUIT WHEN ALL ITEMS GONE
  1713. SX7 X1-1 DECREMENT COUNT
  1714. SA7 A1
  1715. SA1 XPTR
  1716. SA2 BYTE
  1717. SB1 X2
  1718. SA3 X1+B5
  1719. LX5 X3,B1 PUT PROPER BYTE AT TOP OF X5
  1720. SB2 60
  1721. SB1 B1+20 INCREMENT BYTE
  1722. LT B1,B2,SETX25
  1723. SB1 B0 IF PROCESSED 3 BYTES IN WORD
  1724. SX1 X1+1 RESET BYTE AND INCREMENT XPTR
  1725. SETX25 SX7 B1
  1726. SA7 A2
  1727. SX6 X1 RESTORE BYTE AND XPTR
  1728. SA6 A1
  1729. SB3 SETX31 SETUP RETURN FROM GETVAR
  1730. SETX30 EQ NGETVAR (OR FGETVAR IF FLOATING RESULT)
  1731. *
  1732. SETX31 SA2 MAXADDR RETURN WITH X1=RESULT
  1733. SA3 SADDR
  1734. *
  1735. IX4 X3-X2
  1736. PL X4,ARAYERR JUMP IF INDEX EXCEEDS DOMAIN
  1737. BX6 X1 RESULT
  1738. SA2 ARAYWRD
  1739. ZR X2,SETX40 JUMP IF NOT SEGMENTED
  1740. MX0 -6 MUST PRESERVE A3,X3,X6=RESULT
  1741. AX2 42
  1742. BX5 -X0*X2 STARTBIT
  1743. AX2 6
  1744. BX4 -X0*X2 BITS/BYTE
  1745. SA1 X3 GET DESTINATION WORD
  1746. MX0 1
  1747. SB1 X4-1 BB-1
  1748. AX0 X0,B1 FORM BB MASK
  1749. IX7 X5+X4 SB+BB
  1750. BX7 -X7
  1751. SB1 X7+61 60-(SB-1)-BB=POSITION SHIFT
  1752. LX6 X6,B1 POSITION RESULT
  1753. SB1 B1+X4 ADD BB TO GET 60-(SB-1)
  1754. LX0 X0,B1 POSITION MASK
  1755. BX6 X0*X6 CLEAR OUT JUNK IN RESULT
  1756. BX1 -X0*X1 AND DESTINATION WORD
  1757. BX6 X1+X6 MERGE IN RESULT
  1758. SETX40 SA6 X3 STORE IT IN SADDR
  1759. SX7 X3+1 INCREMENT SADDR
  1760. SA7 A3
  1761. EQ SETLOOP
  1762. *
  1763. * SERXSEG EXECERR CALCERR,118 HORIZONTAL TYPE SEGMENT ILLEGAL
  1764. *
  1765. ITEMS EQU VARBUF
  1766. MAXADDR EQU VARBUF+1
  1767. SADDR EQU VARBUF+2
  1768. BYTE EQU VARBUF+3
  1769. XPTR EQU VARBUF+4
  1770. ARAYWRD EQU VARBUF+5
  1771. *
  1772. FGET EQ FGETVAR
  1773. *
  1774. * /--- BLOCK LSNX 00 000 78/10/12 17.33
  1775. TITLE -LESSON- COMMAND
  1776. *
  1777. * LESSON -COMPLETED-, -INCOMPLETE-, -NO END-
  1778. * SETS RESERVED WORD -LDONE- (ACTUALLY SOMEWHAT
  1779. * INDIRECTLY, BY SETTING A 5-BIT FIELD IN
  1780. * TBSCORE WHICH IS INTERPRETED WHEN LDONE
  1781. * IS REFERENCED)
  1782. *
  1783. *
  1784. ENTRY LSNCX
  1785. ENTRY LSNX
  1786. LSNCX CALL GETTAG GET TAG
  1787. LSNX MX0 XJDGL
  1788. BX0 X0*X5 EXTRACT RESULT
  1789. ZR X0,PROC -X-
  1790. LX0 XJDGL PLACE LOWER (VALUES 1,2,3)
  1791. SX0 X0-1 0 INCOMPLETE, 1 COMPLETED, 3 NO END
  1792. * (LDONE VALUES ARE 0 INCOMPLETE, -1 COMPLETED, 1 NO END)
  1793. *
  1794. * WOULD MAKE MORE SENSE TO USE XJDGL FOR POSITIONING OF
  1795. * LDONE INFO IN TBSCORE, BUT EXISTING DISK RECORDS FOR
  1796. * STUDENTS HAVE THE 5-BIT FORMAT --
  1797. SA1 TBSCORE
  1798. MX6 5
  1799. BX1 -X6*X1 CLEAR UPPER 5 BITS
  1800. LX0 -5 SHIFT TO UPPER 5 BITS
  1801. BX6 X1+X0
  1802. SA6 A1
  1803. EQ PROC
  1804. * /--- BLOCK KERMIT 00 000 79/02/12 17.08
  1805. *
  1806. * * * KERMIT COMMAND EXECUTION ROUTINE
  1807. *
  1808. ENTRY KERMITX
  1809. KERMITX SX6 -1
  1810. SA6 TRETURN
  1811. EQ PROC -- EXIT
  1812. *
  1813. * /--- BLOCK END 00 000 79/02/12 17.08
  1814. TITLE TRANSFR EXECUTION
  1815. *
  1816. * TRANSFR (FROM);(TO);LENGTH
  1817. * TRANSFERS DATA FROM THE (FROM) VARIABLES/ECS TO
  1818. * THE (TO) VARIABLES/ECS.
  1819. * 'ANY CENTRAL MEMORY LOCATIONS ARE GUARANTEED TO
  1820. * BE PROTECTED BY A CURRENT COMLOAD/STOLOAD.
  1821. *
  1822. TRLENG EQU SHOWOUT
  1823. TRTO EQU TRLENG+1
  1824. TRFROM EQU TRTO+1
  1825. *
  1826. ENTRY TRANSX
  1827. TRANSX BSS 0
  1828. NGETVAR 3 GET LENGTH
  1829. ZR X1,PROC ALL DONE IF ZERO
  1830. NG X1,ERXBADL DO NOT ALLOW NEGATIVE LENGTHS
  1831. BX6 X1
  1832. SA6 TRLENG STORE LENGTH
  1833. SA5 A5 RE-FETCH COMMAND
  1834. MX0 2*XCODEL+XCMNDL
  1835. AX5 XCMNDL
  1836. BX5 -X0*X5 GET EXTRA ARGUMENT POINTER
  1837. SA1 B5+X5 GET NEXT TWO ARGUMENTS
  1838. BX6 X1 SAVE IT LOCALLY
  1839. SA6 TRTO
  1840. BX5 X1 MOVE INTO PLACE
  1841. NGETVAR 1 GET -FROM- ARGUMENT
  1842. SA5 A5 GET COMMAND WORD AGAIN
  1843. LX5 2*XCODEL TO RIGHT END
  1844. MX0 -3
  1845. BX0 -X0*X5 GET TRANSFER TYPE (FROM)
  1846. SB1 X0
  1847. EQ B1,B0,TRANFM
  1848. BX6 X1 STORE VALUE OF ECS
  1849. SA6 TRFROM RELATIVE ADDRESS
  1850. SA1 TBCOMLS-1+B1
  1851. CALL SETSTOR INFO IN *STORWRD* AND X6
  1852. CALL ECSBNDS,TRFROM,TRLENG USES STORWRD
  1853. * AND RESETS TRFROM TO THE STARTING ECS ADD
  1854. EQ TRANSF2
  1855. *
  1856. * /--- BLOCK TRANSFER 00 000 78/07/05 01.23
  1857. TRANFM SX6 A1 SAVE CM -FROM-
  1858. SA6 TRFROM IN TRFROM
  1859. SA0 A1
  1860. SA1 TRLENG GET LENGTH
  1861. CALL BOUNDS ERRORS DO NOT RETURN
  1862. *
  1863. TRANSF2 SA1 TRTO GET EXTRA STORAGE ARGUMENTS
  1864. BX5 X1
  1865. LX5 XCODEL 4TH ARGUMENT (-TO-)
  1866. NGETVAR INC GET -TO-
  1867. SA5 A5 GET TRANSFER TYPE AGAIN
  1868. LX5 2*XCODEL-3
  1869. MX0 -3
  1870. BX0 -X0*X5 GET TRANSFER CODE (TO)
  1871. SB1 X0
  1872. EQ B1,B0,TRANTM
  1873. *
  1874. BX6 X1 REL ECS LOC
  1875. SA6 TRTO SAVED IN TRTO
  1876. SA1 TBCOMLS-1+B1
  1877. JP B1+*
  1878. *
  1879. + EQ TRC COMMON
  1880. + EQ TR10 STORAGE
  1881. + NG X1,ERXROLV ROUTER/ READ ONLY VARIABLES
  1882. EQ TR10
  1883. + EQ ERXROLV ROUTER VARS/ READ ONLY
  1884. *
  1885. TRC BX2 X1 CHECK READ-ONLY BIT
  1886. LX2 1
  1887. NG X2,ERXROLC ERROR IF READ-ONLY COMMON
  1888. *
  1889. TR10 CALL SETSTOR INFO IN *STORWRD* AND X6
  1890. *
  1891. CALL ECSBNDS,TRTO,TRLENG USES STORWRD;
  1892. * AND RESETS TRTO TO THE ECS ADDRESS
  1893. EQ TRANSXX
  1894. *
  1895. * /--- BLOCK TRANSFER 00 000 79/04/19 00.18
  1896. *
  1897. TRANTM SX6 A1 CM ADDRESS -TO-
  1898. SA6 TRTO
  1899. SA0 A1
  1900. SA1 TRLENG
  1901. CALL BOUNDS ERRORS DO NOT RETURN
  1902. *
  1903. TRANSXX SA5 A5 PICK UP TRANSFER TYPE AGAIN
  1904. LX5 2*XCODEL
  1905. MX0 -3
  1906. BX6 -X0*X5 (FROM)
  1907. AX5 3 (TO)
  1908. BX7 -X0*X5
  1909. IX0 X6+X7 ADD THEM TO TEST FOR ZERO
  1910. ZR X0,TRANMM CM TO CM
  1911. ZR X6,TRANMC CM TO ECS
  1912. ZR X7,TRANCM ECS TO CM
  1913. *
  1914. * REST ARE ECS TO ECS
  1915. *
  1916. * MUST UNLOAD ANY COMMON/STORAGE BEFORE DOING AN
  1917. * EM TO EM TRANSFER. MUST UPDATE EM COPY OF
  1918. * COMMON AND/OR STORAGE BEFORE TRANSFER, AND
  1919. * RELOAD AFTER TRANSFER TO UPDATE CM COPY.
  1920. *
  1921. CALL ULOADCS UNLOAD ANY COMMON/STORAGE
  1922. SA1 TRTO
  1923. SA2 TRFROM
  1924. SA3 TRLENG
  1925. MX7 -1 MARK NO ECS ERROR RECOVERY
  1926. CALL MVECS USES ENTIRE WORK BUFFER
  1927. CALL LOADCS RELOAD ANY COMMON/STORAGE
  1928. EQ PROC -- EXIT
  1929. *
  1930. * CM TO CM TRANSFER
  1931. *
  1932. TRANMM SA4 ATEMPEC ADDRESS OF TEMP BUFFER
  1933. BX0 X4 SET X0
  1934. SX6 1
  1935. SA6 ERXARGN SET EXECERR ARGUMENT NUMBER
  1936. SA1 TRTO
  1937. SA2 TRFROM
  1938. SA3 TRLENG
  1939. SA0 X2
  1940. SB1 X3 LENGTH INTO B1
  1941. RJ CSBNDS (INPUT A0,X3; SAVES X1-X3)
  1942. * NO RETURN IF ERRORS
  1943. SB2 B1-TEMPLTH-1 MUST FIT IN BUFFER
  1944. PL B2,TERXLNG
  1945. + WE B1
  1946. RJ ECSPRTY
  1947. SX6 2
  1948. SA6 ERXARGN SET EXECERR ARGUMENT NUMBER
  1949. SA0 X1 -TO- ADDRESS
  1950. SB1 X3
  1951. RJ CSBNDS NO RETURN IF ERROR
  1952. + RE B1
  1953. RJ ECSPRTY
  1954. EQ PROC TRANSFER DONE
  1955. *
  1956. TERXLNG SX1 B1
  1957. EQ ERXBADL
  1958. *
  1959. * /--- BLOCK TRANSFER 00 000 79/04/19 00.18
  1960. *
  1961. * THIS CORRESPONDS TO UNLOADC
  1962. *
  1963. * CM TO ECS TRANSFER
  1964. *
  1965. * MUST UNLOAD ANY COMMON/STORAGE BEFORE DOING AN
  1966. * CM TO EM TRANSFER. MUST UPDATE EM COPY OF
  1967. * COMMON AND/OR STORAGE BEFORE TRANSFER, AND
  1968. * RELOAD AFTER TRANSFER TO UPDATE CM COPY.
  1969. *
  1970. TRANMC CALL ULOADCS UNLOAD ANY COMMON/STORAGE
  1971. SX6 1 SET EXECERR ARGUMENT NUMBER
  1972. SA6 ERXARGN
  1973. SA1 TRTO
  1974. SA2 TRFROM
  1975. SA3 TRLENG
  1976. SA0 X2
  1977. SB1 X3
  1978. BX0 X1
  1979. RJ CSBNDS (INPUT A0,X3) NO RETURN IF ERR
  1980. *
  1981. + WE B1 WRITE FROM A0 TO X0, FOR B1
  1982. RJ ECSPRTY
  1983. CALL LOADCS RELOAD ANY COMMON/STORAGE
  1984. EQ PROC -- EXIT
  1985. *
  1986. * THIS CORRESPONDS TO LOADC
  1987. *
  1988. * ECS TO CM TRANSFER
  1989. *
  1990. ** FOLLOWING LINE ADDED SO THAT THE SOURCE
  1991. ** OF DATA IS THE ',CURRENT', COPY
  1992. TRANCM CALL ULOADCS UNLOAD ANY COMMON/STORAGE
  1993. CALL LOADCS RELOAD ANY COMMON/STORAGE
  1994. SX6 2 SET EXECERR ARGUMENT NUMBER
  1995. SA6 ERXARGN
  1996. SA1 TRTO
  1997. SA2 TRFROM
  1998. SA3 TRLENG
  1999. SA0 X1
  2000. SB1 X3 LENGTH
  2001. BX0 X2 ECS ADDRESS
  2002. RJ CSBNDS (A0,X3 INPUT) NO RETURN IF ERR
  2003. + RE B1 READ FROM X0 TO A0, FOR B1
  2004. RJ ECSPRTY
  2005. EQ PROC -- EXIT
  2006. *
  2007. *
  2008. *
  2009. *
  2010. * CSBNDS EXPECTS THE CM ADDRESS IN A0, AND THE
  2011. * LENGTH IN X3. B1 IS PRESERVED
  2012. *
  2013. *
  2014. CSBNDS EQ * USES B2,B3,A4,X4,X7
  2015. SB3 A0
  2016. SA4 LVUCNT
  2017. SB2 X4+LVARBUF
  2018. SB3 X3+B3
  2019. LE B3,B2,CSBNDS
  2020. SX7 5
  2021. SA4 TCOMSET
  2022. CKLP ZR X4,ENDLP
  2023. SB3 A0
  2024. SB2 X4
  2025. LT B3,B2,ENDLP
  2026. AX4 18+18
  2027. SB2 X4+B2 STO/COM LOAD LENGTH+START
  2028. SB3 X3+B3
  2029. LE B3,B2,CSBNDS
  2030. ENDLP SX7 X7-1
  2031. SA4 A4+1
  2032. PL X7,CKLP
  2033. * CHECK ERROR
  2034. EXECERR 61 *MUST BE COMLOADED/STOLOADED*
  2035.  
  2036. * /--- BLOCK MOVE 00 000 79/04/19 07.47
  2037. TITLE MOVE
  2038. * -MOVE-
  2039. *
  2040. * MOVE CHARACTERS A 60-BIT WORD AT A TIME VERSES
  2041. * CHARACTER BY CHARACTER
  2042. *
  2043. * COMMAND WORD HOLDS TWO 20 BIT CODES AND
  2044. * XTRA STORAGE POINTER.
  2045. *
  2046. * SINGLE XTRA STORAGE WORD HOLDS 2 20 BIT CODES,
  2047. * LEFT JUSTIFIED.
  2048. *
  2049. * PLUS FLAG FOR 4-ARGUMENT MOVE, LENGTH FOR 5-ARG.
  2050. * 1ST ARG = FROM WORD ADDRESS
  2051. * 2ND ARG = FROM CHAR POSITION
  2052. * 3RD ARG = TO WORD ADDRESS
  2053. * 4TH ARG = TO CHAR POSITION
  2054. * 5TH ARG = LENGTH , OR FLAG THAT LENGTH IS 1
  2055. *
  2056. * LONG MOVE (FIVE ARGUMENT MOVE)
  2057. * 5TH ARG = NUMBER OF CHARS TO MOVE
  2058. *
  2059. EXT WORDS
  2060. EXT PROCESS,PROCESX
  2061. *
  2062. EXT ERXLIT,ERXBADL ERROR EXITS, -EXEC2-
  2063. *
  2064. *
  2065. * CHECK -MOVE- PARAMETERS
  2066.  
  2067. ENTRY MOVEX
  2068. MOVEX NG X5,MOVLIT
  2069. NGETVAR 1 *FROM* ADDRESS
  2070. SX6 A1 INADD
  2071. EQ MOVE2
  2072. *
  2073. MOVLIT MX0 1
  2074. BX5 -X0*X5 REMOVE FLAG
  2075. MX6 -1 MARK *INFO* BUFFER USED
  2076. SA6 JJSTORE
  2077. NGETVAR 1
  2078. BX6 X1
  2079. SA6 SHOWVAL STORE HERE FOR THIS TIMESLICE
  2080. SX6 A6
  2081. *
  2082. MOVE2 SA6 FROMWRD RE-ENTER FOR NON-STORABLE
  2083. SA5 A5
  2084. LX5 XCODEL
  2085. NGETVAR 2 *FROM CHAR POSITION
  2086. SA5 A5 RETRIEVE ORIGINAL COMMAND WORD
  2087. * CHECK THAT INPOS BETWEEN 1 AND 10 (INCLUSIVE)
  2088. * FOR NON-STOREABLE FIRST ARG
  2089. PL X5,MOVE3 SKIP IF STOREABLE
  2090. SX0 X1-11
  2091. *NOTE'; X1 TO EXECERR
  2092. PL X0,ERXLIT IF GT 10, ERROR EXIT
  2093. SX0 X1-1 NOT LESS THAN 1
  2094. NG X0,ERXLIT
  2095. BX6 X0 0 TO N-1
  2096. EQ MOVE4
  2097. *
  2098. MOVE3 SA2 FROMWRD *FROM* BUFFER ADDRESS
  2099. SA0 X2 *FROM* BASE ADDRESS
  2100. RJ WORDS
  2101. SX7 B1-1 (B1) RETURNED END ADDRESS +1
  2102. SA7 FROMWRD SAVE IT
  2103. SX2 10
  2104. SX0 X0 CLEAN OUT EXPONENT
  2105. IX0 X0*X2
  2106. SX6 X1-1 *INTERNAL CHAR 0 TO N-1*
  2107. IX6 X6-X0 ACTUAL CHAR NUMBER
  2108. *
  2109. * /--- BLOCK MOVE 00 000 79/04/19 00.30
  2110. MOVE4 SA6 FROMCHR SAVE *FROM* CHAR
  2111. * GET EXTRA ARG POINTER
  2112. SA5 A5 RE-FETCH COMMAND WORD
  2113. MX0 2*XCODEL
  2114. BX5 -X0*X5 CLEAN OFF TWO -GETVAR- CODES
  2115. AX5 XCMNDL SHIFT OFF COMMAND CODE
  2116. SA1 B5+X5 X1 = 1ST EXTRA STORAGE WORD
  2117. BX6 X1
  2118. SA6 XFERLEN SAVE EXTRA WORD
  2119. BX5 X1
  2120. NGETVAR 3 *DESTINATION* ADDRESS
  2121. SX6 A1 INTO X6
  2122. SA6 TOWRD AND STORE
  2123. SA1 XFERLEN FETCH ARGS
  2124. BX5 X1
  2125. LX5 XCODEL
  2126. NGETVAR 4 GET *DESTINATION CHAR POSITION*
  2127. SA2 TOWRD FETCH DESTINATION ADDRESS IN X2
  2128. SA0 X2
  2129. RJ WORDS CHECK IN BOUNDS
  2130. SX7 B1-1 (B1) CONTAINS END ADDRESS +1
  2131. SA7 TOWRD FINAL *DESTINATION* ADDRESS
  2132. SX2 10
  2133. SX0 X0 CLEAN OUT EXPONENT (FROM WORDS)
  2134. IX0 X0*X2
  2135. SX6 X1-1 CHAR POSITION FROM 0 TO N-1
  2136. IX6 X6-X0 ACTUAL CHAR NUMBER
  2137. SA6 TOCHR *TO* CHAR POINTER
  2138. SA1 XFERLEN FETCH ARG. WORD AGAIN
  2139. LX1 2*XCODEL
  2140. NG X1,MOVE4A 4-ARGUMENT FLAG
  2141. BX5 X1
  2142. NGETVAR 5 LENGTH OF STRING TO BE MOVED
  2143. ZR X1,PROC QUIT IF MOVING NO CHARACTERS
  2144. EQ MOVE4B CHECK VALUE OF ARG 5
  2145. *
  2146. MOVE4A SX1 1 DEFAULT MOVE TO 1 CHARACTER
  2147. EQ MOVE4C GO SAVE LENGTH
  2148. *NOTE'; X1 TO EXECERR
  2149. MOVE4B NG X1,ERXBADL ERROR IF NEGATIVE LENGTH
  2150. SX0 5000
  2151. IX6 X6-X0
  2152. *NOTE'; X0,X1 TO EXECERR
  2153. ZR X6,MOVE4C IF EQUAL TO 5000, GO ON...
  2154. PL X6,MERXMAX ONLY MOVE 500 WORDS MAX
  2155. *
  2156. MOVE4C SX6 X1 SAVE LENGTH OF TRANSFER
  2157. SA6 XFERLEN
  2158. SA5 A5
  2159. PL X5,MOVE5 IF NOT LITERAL, GO CHECK *F*
  2160. SA1 FROMCHR FETCH *FROM* CHAR POSITION
  2161. IX1 X6+X1
  2162. SX0 11
  2163. IX1 X1-X0 (FROMCHR + LENGTH -11
  2164. PL X1,MERXL1 OUT OF SOURCE BOUNDS
  2165. EQ MOVE6
  2166. *
  2167. *CHECK LAST WORDS IN BOUNDS
  2168. MOVE5 SA1 FROMWRD *FROM* BUFFER ADDRESS
  2169. SA0 X1 SOURCE BASE ADDRESS
  2170. SA1 FROMCHR *FROM* CHAR POINTER
  2171. IX1 X1+X6 SOURCE CHARS
  2172. RJ WORDS CHECK LAST WORD *SOURCE*
  2173. *
  2174. * /--- BLOCK MOVE 00 000 79/04/19 00.30
  2175. MOVE6 SA1 TOWRD *TO* BUFFER ADDRESS
  2176. SA0 X1 DESTINATION BA
  2177. SA1 TOCHR *TO* CHAR POINTER
  2178. IX1 X1+X6
  2179. RJ WORDS
  2180.  
  2181. * SAVE *A5*, *B4*, *B5*, *B6*, AND *B7*
  2182. * (REQUIRED BY -EXEC1- SEE NOTES IN -EXEC1-)
  2183.  
  2184. SX6 A5 SAVE *A5* COMMAND WORD ADDRESS
  2185. SA6 MBSAVA5
  2186. SX6 B4 SAVE *B4* (STUD VARS V0 ADDR)
  2187. SA6 MBSAVB4
  2188. SX6 B5 SAVE *B5* (EXTRA STORAGE ADDR)
  2189. SA6 MBSAVB5
  2190. SX6 B6 SAVE *B6* (COMMON VARS V0 ADDR)
  2191. SA6 MBSAVB6
  2192. SX6 B7 SAVE *B7* CONTINGENCY FLAGS
  2193. SA6 MBSAVB7
  2194.  
  2195. * MOVE CHARACTERS
  2196.  
  2197. RJ MOVBITS MOVE CHARS
  2198.  
  2199. * RESTORE REQUIRED REGISTERS
  2200.  
  2201. SA1 MBSAVA5 GET ORIGINAL ADDRESS OF *A5*
  2202. SA5 X1 GET COMMAND WORD (RESTORE *A5*)
  2203. SA1 MBSAVB4 GET STUDENT VARS BASE ADDR
  2204. SB4 X1 RESTORE *B4*
  2205. SA1 MBSAVB5 GET EXTRA STORAGE BASE ADDR
  2206. SB5 X1 RESTORE *B5*
  2207. SA1 MBSAVB6 GET COMMON VARS BASE ADDR
  2208. SB6 X1 RESTORE *B6*
  2209. SA1 MBSAVB7 GET CONTINGENCY FLAGS
  2210. SB7 X1 RESTORE *B7*
  2211. SB1 1 *B1* MUST BE SET TO *1*
  2212. *
  2213. EQ PROC ALL DONE
  2214. *
  2215. MERXL1 BX1 X6
  2216. EQ ERXBADL
  2217. *
  2218. MERXMAX BX2 X0
  2219. EXECERR 73 TOO MANY CHARS TO MOVE
  2220. *
  2221. MVBUF EQU INFO
  2222. 1 ERRPL 500-INFOLTH-1 INFO BUFFER TOO SMALL
  2223. *
  2224. FROMWRD BSS 1 *FROM* BUFFER ADDRESS
  2225. FROMCHR BSS 1 *FROM* CHAR POINTER
  2226. TOWRD BSS 1 *TO* BUFFER ADDRESS
  2227. TOCHR BSS 1 *TO* CHAR POINTER
  2228. XFERLEN BSS 1 LENGTH OF TRANSFER IN CHARS
  2229.  
  2230. MBSAVA5 BSS 1 SAVE *A5* ADDRESS
  2231. MBSAVB4 BSS 1 SAVE *B4* STUD VARS BASE ADDR
  2232. MBSAVB5 BSS 1 SAVE *B5* EXTRA STORAGE ADDR
  2233. MBSAVB6 BSS 1 SAVE *B6* COMMON VARS ADDR
  2234. MBSAVB7 BSS 1 SAVE *B7* CONTINGENCY FLAGS
  2235. *
  2236. * /--- BLOCK MOVBITS 00 000 79/04/19 00.09
  2237. MOVBITS SPACE 4,20
  2238. *** MOVBITS - MOVE BITS FROM ONE LOCATION TO ANOTHER
  2239. *
  2240. * USED BY -MOVE- COMMAND
  2241. *
  2242. * USES X - 0, 1, 2, 3, 4, 5, 6, 7.
  2243. * A - 1, 2, 3, 6, 7.
  2244. * B - 1, 2, 3, 4, 5, 6, 7.
  2245. *
  2246. * DO *NOT* CHANGE *A5*
  2247. *
  2248. *
  2249. MOVBITS PS ENTRY/EXIT
  2250.  
  2251. SA1 FROMWRD *FROM* BUFFER ADDRESS
  2252. SA2 FROMCHR STARTING CHARACTER IN LINE
  2253. RJ MBSETUP SET UP POINTERS
  2254. RJ MOVMASK SET UP WORD MASKING
  2255. SA1 B1 (A1) = FROM LINE ADDRESS
  2256. SA2 MVBUF-1 GET DATA IN *MVBUF*-1
  2257. BX6 X2 MOVE TO WRITE REGISTER
  2258. SA6 A2 SET *A6* AND RESTORE VALUE
  2259. SA2 XFERLEN GET LENGTH OF TRANSFER
  2260. SB5 X2 (B5) = LENGTH OF TRANSFER
  2261. SB4 0 (B4) = CHARS COPIED
  2262. SB2 B2+1 (B2) = STARTING CHAR WITHIN WD
  2263.  
  2264. MBFFULL BX6 X0*X1
  2265. LX6 B6 POSITION TO TOP OF WORD
  2266. SA6 A6+1 SAVE PARTIAL WORD
  2267. SA1 A1+1 GET NEXT WORD FROM *FROM*
  2268. SB4 B4+10 INCREMENT A WORD
  2269. SB4 B4-B2 COMPUTE NUMBER OF CHARS COPIED
  2270. GE B4,B5,MBXFER IF AT END, MOVE IT
  2271. ZR X0,MBFFULL FULL WORD TRANSFERRED
  2272. BX7 -X0*X1 GET TOP PART OF WORD
  2273. LX7 B6 POSITION TO LOWER PART OF WORD
  2274. BX6 X6+X7 ADD NEW CHARACTERS TO WORD
  2275. SA6 A6 SAVE OTHER PART OF WORD
  2276. SB4 B4+B2 ADD NUMBER OF CHARS COPIED
  2277. LT B4,B5,MBFFULL -- RELOOP
  2278.  
  2279. MBXFER SA1 TOWRD STARTING ADDRESS OF *TO* WORD
  2280. SA2 TOCHR STARTING CHARACTER IN LINE
  2281. RJ MBSETUP SET UP POINTERS
  2282. RJ MOVMASK SET UP WORD MASKING
  2283. SA1 B1 (A1) = FROM LINE ADDRESS
  2284. SA2 MVBUF (A2) = START ADDRESS OF COPY
  2285. LX2 B7 POSITION TO MATCH MASK
  2286. SA3 XFERLEN (X3) = LENGTH OF TRANSFER
  2287. SB5 X3 (B5) = LENGTH OF TRANSFER
  2288. SB3 -B2 (B2) = CHARS ON LEFT SIDE
  2289. SB3 B3+10 (B3) = CHARS ON RIGHT SIDE
  2290.  
  2291. * /--- BLOCK MOVBITS 00 000 79/04/19 00.09
  2292. MBMOVE SA1 A1 GET LASTEST COPY OF WORD
  2293. SB4 B5+B2 SEE IF MOVE IN MIDDLE OF WORD
  2294. SB1 10D SEE IF GREATER THAN 10 CHARS
  2295. LT B4,B1,MBSAME IF IN THE MIDDLE, DEVIATE
  2296. BX7 X0*X2 MASK OFF NEW CHARACTERS TO MASK
  2297. BX6 -X0*X1 MASK OFF CHARACTERS TO BE SAVED
  2298. BX6 X6+X7 ADD CHARACTERS
  2299. SA6 A1 REPLACE WORD WITH NEW CHARS
  2300. SB5 B5-B3 SUBTRACT CHARS MOVED
  2301. LE B5,B0,MOVBITS IF ALL CHARS MOVED, EXIT
  2302. GE B5,B2,MBLEFT IF MORE CHARS LEFT SIDE
  2303. SB4 B6 REMEMBER SHIFT COUNT
  2304. SA1 A1+1 ADVANCED TO NEXT WORD
  2305. BX2 -X0*X2 MASK OUT TOP PART OF WORD
  2306. SB2 10D CHARS/WORD
  2307. SB2 B2-B5 (SIZE OF MASK) * 6
  2308. RJ MOVMASK SET UP WORD MASKING
  2309. LX0 B6 LEFT JUSTIFY MASK
  2310. EQ MBFIN4
  2311.  
  2312. MBSAME BX2 X0*X2 MASK OFF NEW CHARACTERS TO MASK
  2313. LX2 B6 LEFT JUSTIFY THE DATA
  2314. SB4 B7 REMEMBER SHIFT COUNT
  2315. EQ MBFIN2
  2316.  
  2317. MBFIN1 BX2 X0*X2 MASK OUT LOWER PART OF WORD
  2318. LX2 B6 LEFT JUSTIFY THE DATA
  2319. MBFIN2 SB2 10D CHARS/WORD
  2320. SB2 B2-B5 (SIZE OF MASK) * 6
  2321. RJ MOVMASK SET UP WORD MASKING
  2322. SB4 B4-B7 COMPUTE NEW MASK POSITION
  2323. PL B4,MBFIN3 IF POSITIVE, CONTINUE
  2324. SB4 B4+60D MAKE POSITIVE
  2325. MBFIN3 LX0 B4 POSITION MASK TO CORRECT CHAR
  2326. LX2 B7 RIGHT JUSTIFY DATA
  2327. LX2 B4 POSITION WITH MASK
  2328. MBFIN4 BX2 X0*X2 MASK OUT JUST REQUIRED DATA
  2329. SA1 A1 RETRIEVE MODIFIED WORD
  2330. BX6 -X0*X1 GET REMAINING CHARACTERS
  2331. BX6 X6+X2 ADD NEW CHARACTERS
  2332. SA6 A1 REPLACE WORD
  2333. EQ MOVBITS END OF MOVE
  2334.  
  2335. MBLEFT BX7 -X0*X2 RETRIEVE LOWER CHARS FROM WORD
  2336. SA1 A1+1 ADVANCE TO NEXT WORD
  2337. BX1 X0*X1 MASK OFF LOWER PORTION OF WORD
  2338. BX7 X7+X1 UPDATE WORD
  2339. SA7 A1 REPLACE WORD
  2340. SB4 B7 REMEMBER SHIFT COUNT
  2341. SB5 B5-B2 SUBTRACT REMAINING CHARACTERS
  2342. SA2 A2+1 GET NEXT WORD OF *INFO* BUFFER
  2343. LX2 B7 POSITION TO MATCH MASK
  2344. ZR B5,MOVBITS IF ALL DONE, EXIT
  2345. LT B5,B3,MBFIN1 FINAL MOVE ROUTINE
  2346. GT B5,B0,MBMOVE IF MORE, GO TO IT
  2347. EQ MOVBITS -- EXIT
  2348.  
  2349. * /--- BLOCK MOVMASK 00 000 79/04/19 00.30
  2350. MOVMASK SPACE 4,20
  2351. *** MOVMASK - SETS UP MASK FOR -MOVBITS- ROUTINE
  2352. *
  2353. * DO *NOT* CHANGE *A5*
  2354. *
  2355. *
  2356. MOVMASK EQ * ENTRY/EXIT
  2357. SX4 6D BITS/CHARACTER
  2358. SX3 B2 STARTING CHARACTER POS (0-9)
  2359. IX5 X3*X4 NUMBER OF BITS TO SHIFT TO TOP
  2360. SB6 X5 (B6) = BITS TO SHIFT TO TOP
  2361. SB7 -B6
  2362. SB7 B7+60D (B7) = SIZE OF MASK
  2363. MX0 60 USE THE WHOLE WORD
  2364. ZR B7,MOVMASK -- IF FULL MASK, EXIT
  2365. MX0 59
  2366. LX0 59
  2367. AX0 B6 DROP OFF UNNECESSARY BITS
  2368. MX7 1 RESET MISSING BIT
  2369. LX7 B7 POSITION
  2370. BX0 X0+X7 SET MISSING BIT
  2371. EQ MOVMASK -- EXIT
  2372.  
  2373. MBSETUP SPACE 4,20
  2374. *** MBSETUP - SETS UP INPUT AND OUTPUT POINTERS
  2375. *
  2376. * DO *NOT* CHANGE *A5*
  2377. *
  2378. * *X1* = TO/FROM WORD ADDRESS
  2379. * *X2* = TO/FROM CHAR POINTER
  2380. *
  2381. *
  2382. MBSETUP EQ * ENTRY/EXIT
  2383. SB1 X1 COPY TO *B1* REGISTER
  2384. SB2 X2+1 CHANGE (0 TO N-1) TO (1 TO N)
  2385. SB3 10D CHARACTERS PER WORD
  2386. MBLOOP SB2 B2-B3 SUBTRACT 10 CHARACTERS
  2387. ZR B2,MBOUTL IF ON WORD BOUNDARY, OUTLOOP
  2388. NG B2,MBOUTL IF LESS THAN LIMIT
  2389. SB1 B1+1
  2390. EQ MBLOOP -- RELOOP
  2391.  
  2392. MBOUTL SB7 1
  2393. SB2 B2+B3 MAKE A POSITIVE NUMBER AGAIN
  2394. SB2 B2-B7 CALCULATE STARTING CHAR IN WORD
  2395. EQ MBSETUP -- RETURN
  2396.  
  2397. * /--- BLOCK COLOR 00 000 79/04/23 09.17
  2398. TITLE -COLOR- COMMAND EXECUTION
  2399. *
  2400. * -COLOR- COMMAND EXECUTION
  2401. *
  2402. * RETRIEVE COMMAND WORD
  2403. *
  2404. ENTRY COLORXX
  2405. COLORXX BSS 0
  2406. SX6 -1 PRESTORE ZRETURN WITH OK
  2407. SA6 TRETURN
  2408. SA5 A5
  2409. NGETVAR RETURN WITH VALUE IN X1
  2410. SB1 X1 0 = DEFINE, 1 = DISPLAY
  2411. JP B1+*+1
  2412.  
  2413. + EQ CDEFINE
  2414. + EQ CDISP
  2415.  
  2416. CDEFINE BSS 0
  2417. *
  2418. * -COLOR DEFINE-
  2419. *
  2420. * DEFINE A NEW COLOR GIVEN 3 COLOR INTENSITIES.
  2421. * INTENSITIES MUST BE IN THE RANGE 0..1 INCLUSIVE.
  2422. * IF AN OUT-OF-RANGE VALUE IS FOUND, SET *ZRETURN*
  2423. * TO 0 AND LEAVE.
  2424. *
  2425. AX5 XCMNDL SHIFT EXTRA STORAGE ADDRESS
  2426. MX0 -11D FORM ADDRESS MASK
  2427. BX1 -X0*X5 GET EXTRA STORAGE ADDRESS
  2428. SA1 X1+B5 READ GETVAR CODES
  2429.  
  2430. BX5 X1 MOVE TO X5 FOR FGETVAR
  2431. FGETVAR READ RED VALUE INTO X1
  2432. BX6 X1
  2433. LX5 XCODEL MOVE TO NEXT GETVAR CODE
  2434. SA6 REDVAL STORE FOR LATER
  2435. FGETVAR READ GREEN VALUE INTO X1
  2436. BX6 X1
  2437. LX5 XCODEL MOVE TO LAST GETVAR CODE
  2438. SA6 GRNVAL STORE FOR LATER
  2439. FGETVAR X1 = BLUE VALUE
  2440. SA3 REDVAL X3 = RED VALUE
  2441. SA4 GRNVAL X4 = GREEN VALUE
  2442. SA2 KONEP0 X2 = 1.0 FOR RANGE CHECK
  2443. FX5 X2-X1 CHECK BLUE .GT. 1.0
  2444. * /--- BLOCK COLOR 00 000 83/03/11 11.01
  2445. FX6 X2-X3 CHECK RED .GT. 1.0
  2446. FX7 X2-X4 CHECK GREEN .GT. 1.0
  2447. BX5 X5+X1 ADD BLUE + RANGED BLUE
  2448. BX6 X6+X3 ADD RED + RANGED RED
  2449. BX7 X7+X4 ADD GREEN + RANGED GREEN
  2450. BX5 X5+X6 ADD BLUE + RED
  2451. BX5 X5+X7 ADD BLUE, RED + GREEN
  2452. NG X5,BADCOLR --- ONE OF THE TAGS WAS OOR
  2453. SA2 K255 X2 - 255.0
  2454. FX1 X1*X2 SCALE BLUE TO 0..255
  2455. FX3 X3*X2 SCALE RED
  2456. FX4 X4*X2 SCALE GREEN
  2457. UX1 X1,B1 FIX BLUE
  2458. UX3 X3,B2 FIX RED
  2459. UX4 X4,B3 FIX GREEN
  2460. LX6 X1,B1 INTEGERIZE BLUE IN X6
  2461. LX3 X3,B2 INTEGERIZE RED
  2462. LX4 X4,B3 INTEGERIZE GREEN
  2463. LX3 16D MOVE RED TO POSITION
  2464. LX4 8D MOVE GREEN TO POSITION
  2465. BX6 X6+X3 ADD RED+BLUE
  2466. BX6 X6+X4 ADD RED, BLUE + GREEN
  2467. SA5 A5 RESTORE COMMAND WORD
  2468. LX5 XCODEL MOVE PUTVAR CODE TO POSITION
  2469. NPUTVAR STORE RESULTING RGB
  2470. EQ PROCESS --- FINISH COMMAND
  2471.  
  2472. BADCOLR SX6 0 0 = BAD COLOR INTENSITY
  2473. SA6 TRETURN SET *ZRETURN*
  2474. EQ PROCESS --- EXIT COMMAND
  2475.  
  2476. *
  2477. * EXECUTION FOR -COLOR DISPLAY-
  2478. * IF A NUMBER IS SPECIFIED THAT IS .GT. 24 BITS,
  2479. * SET *ZRETURN* TO 1 AND LEAVE.
  2480. *
  2481. CDISP BSS 0
  2482. *
  2483. * FIRST CHECK TO MAKE SURE 12 MOUT CODES WILL
  2484. * FIT IN THE MOUT BUFFER.
  2485. *
  2486. SA1 MOUTLOC
  2487. SX6 X1-MOUTLTH-12D CHECK FOR OVERFLOW
  2488. PL X6,RETRNZ --- BACK UP AND END TIMESLICE
  2489. SX7 -1 SET BOTH COLORS TO OMITTED
  2490. SA7 BGNDVAL
  2491. SA7 FGNDVAL
  2492. LX5 2*XCODEL MOVE GETVAR CODE TO LOW ORDER
  2493. MX0 -XCODEL
  2494. BX1 -X0*X5 X1 = FOREGROUND GETVAR CODE
  2495. LX5 11D MOVE EXTRA STORAGE ADDRESS
  2496. MX2 -11D
  2497. BX7 -X2*X5 X7 = EXTRA STORAGE ADDRESS
  2498. SA2 X7+B5 X2 = EXTRA STORAGE WORD
  2499. LX2 XCODEL MOVE GETVAR CODE TO LOW ORDER
  2500. SA7 GRNVAL SAVE EXTRA STORAGE ADDRESS
  2501. BX2 -X0*X2 X2 = BACKGROUND GETVAR CODE
  2502. MX0 1
  2503. LX0 XCODEL X0 = OMITTED FLAG
  2504. BX3 X0-X1 X3 = 0 IF FOREGROUND OMITTED
  2505. BX6 X0-X2 X6 = 0 IF BACKGROUND OMITTED
  2506. LX5 XCODEL+XCMNDL MOVE FOREGROUND GETVAR CODE
  2507. SA6 REDVAL SAVE BACKGROUND CODE FOR LATER
  2508. ZR X3,BGNDTAG --- FOREGROUND OMITTED
  2509. NGETVAR
  2510. MX0 -24
  2511. * /--- BLOCK COLOR 00 000 79/04/23 14.18
  2512. BX0 X0*X1 TEST FOR 24-BIT OVERFLOW
  2513. NZ X0,BADTAG --- VALUE .GT. 24 BITS
  2514. BX6 X1 SAVE FOREGROUND VALUE
  2515. SA6 FGNDVAL
  2516.  
  2517. BGNDTAG BSS 0
  2518. SA1 REDVAL X1 = BACKGROUND FLAG
  2519. ZR X1,COLROUT BACKGROUND OMITTED; SEND OUTPUT
  2520. SA1 GRNVAL X1 = EXTRA STORAGE ADDRESS
  2521. SA1 X1+B5 X1 = BACKGROUND GETVAR CODE
  2522. BX5 X1 MOVE GETVAR CODE TO X5
  2523. NGETVAR X1 = BACKGROUND COLOR VALUE
  2524. MX0 -24
  2525. BX0 X0*X1 TEST FOR 24-BIT OVERFLOW
  2526. NZ X0,BADTAG --- VALUE .GT. 24 BITS
  2527. BX6 X1 SAVE FOR OUTPUT CHECKS
  2528. SA6 BGNDVAL
  2529.  
  2530. COLROUT BSS 0
  2531. SA1 FGNDVAL X1 = FOREGROUND VALUE
  2532. NG X1,BGNDOUT --- FOREGROUND OMITTED
  2533. SA2 XCOLORS GET EXECUTOR COLOR SETTINGS
  2534. MX0 -24 SET MASK TO CLEAR OLD COLOR
  2535. BX6 X0*X2 CLEAR FOREGND COLOR
  2536. BX6 X6+X1 SET NEW COLOR
  2537. SA6 A2 RESTORE EXECUTOR COLORS
  2538. OUTCODE RBGCODE 12/0,24/COLOR,24/RBGCODE
  2539.  
  2540. BGNDOUT BSS 0
  2541. SA1 BGNDVAL X1 = BACKGROUND VALUE
  2542. NG X1,PROCO --- BACKGROUND OMITTED
  2543. SA2 XCOLORS GET EXECUTOR COLOR SETTINGS
  2544. MX0 -24 SET MASK TO CLEAR OLD COLOR
  2545. LX0 24 POSITION FOR BGND COLOR
  2546. BX6 X0*X2 CLEAR COLOR
  2547. BX0 X1 MAKE A COPY OF THE COLOR
  2548. LX0 24 POSITION TO BACKGND COLOR
  2549. BX6 X6+X0 SET NEW COLOR
  2550. SA6 A2 RESTORE EXECUTOR COLORS
  2551. MX0 1
  2552. LX0 25D X0 = BACKGROUND FLAG
  2553. BX1 X1+X0 ADD FLAG TO COLOR
  2554. OUTCODE RBGCODE 12/0,24/COLOR,24/RBGCODE
  2555. EQ PROCO --- COMMAND DONE
  2556.  
  2557. BADTAG SX6 1 1 = BAD COLOR VALUE
  2558. SA6 TRETURN SET *ZRETURN*
  2559. EQ PROCESS --- COMMAND DONE
  2560.  
  2561. K255 DATA 255.0
  2562. KONEP0 DATA 1.0
  2563. REDVAL BSS 1
  2564. GRNVAL BSS 1
  2565. BGNDVAL BSS 1
  2566. FGNDVAL BSS 1
  2567.  
  2568. * /--- BLOCK FONT 00 000 79/07/30 22.46
  2569. TITLE -FONT- COMMAND EXECUTION
  2570. *
  2571. * RETRIEVE COMMAND WORD
  2572. *
  2573. ENTRY FONTX
  2574. FONTX BSS 0
  2575. NGETVAR GET FONT SLOT NUMBER
  2576. SX6 X1 SET FONT TYPE
  2577. SA6 FONTTYP
  2578.  
  2579. SA5 A5 RESTORE COMMAND WORD
  2580. LX5 XCODEL SHIFT TO NEXT ARG
  2581. NGETVAR GET FONT SIZE
  2582. NG X1,FONTNOR IF NEGATIVE, USE NORMAL SIZE
  2583. ZR X1,FONTNOR IF ZERO, USE NORMAL SIZE
  2584. SX0 X1-77B-1 MAX FONT SIZE
  2585. PL X0,FONTNOR IF GREATER THAN LIMIT, DEFAULT
  2586. SX6 X1 SET FONT SIZE
  2587. EQ FCONT2
  2588.  
  2589. FONTNOR SX6 0 DEFAULT FONT SIZE
  2590. FCONT2 SA6 FONTSIZ
  2591.  
  2592. SA5 A5 RESTORE COMMAND WORD
  2593. AX5 XCMNDL SHIFT EXTRA STORAGE ADDRESS
  2594. MX0 -11D FORM ADDRESS MASK
  2595. BX1 -X0*X5 GET EXTRA STORAGE ADDRESS
  2596. SA1 X1+B5 READ GETVAR CODES
  2597. BX5 X1
  2598. NGETVAR GET FONT SLOT NUMBER
  2599. SX6 X1 SET FONT MODE
  2600. SA6 FONTMOD
  2601.  
  2602. SA5 A5 RESTORE COMMAND WORD
  2603. SA1 FONTTYP GET FONT TYPE
  2604. BX7 X1 FONT
  2605. LX7 12 POSITION
  2606. CALL CLIENT,5000B,X1 FONT TYPE CODE
  2607.  
  2608. SA1 FONTSIZ GET FONT SIZE
  2609. BX0 X1 FONT/0/0
  2610. LX0 6 POSITION
  2611. BX7 X7+X0 FONT/SIZE/0
  2612. MX6 1 SET/CLEAR NON-DEFAULT FONT BIT
  2613. LX6 21 POSITION TO CORRECT BIT LOCAL
  2614. ZR X1,SENDSIZ IF DEFAULT, CLEAR NON-DEFAULT
  2615. BX7 X7+X6 SET NON-DEFAULT BIT
  2616. SENDSIZ CALL CLIENT,5100B,X1 FONT SIZE CODE
  2617.  
  2618. SA1 FONTMOD GET FONT MODE
  2619. BX7 X7+X1 FONT/SIZE/MODE
  2620. CALL CLIENT,5200B,X1 FONT MODE CODE
  2621.  
  2622. MX0 18 SET MASK TO CLEAR FONT INFO
  2623. LX0 FNTINFO MOVE MASK START TO FONT INFO
  2624. SA1 CWSINFO GET TERMINAL WORD
  2625. BX1 -X0*X1 MASK OUT OLD FONT INFO
  2626. LX7 41 POSITION FONT INFO
  2627. BX7 X1+X7 ADD FONT INFO
  2628. SA7 A1 SAVE NEW FONT INFO
  2629. EQ PROCESS
  2630. *
  2631. FONTTYP BSS 1 TYPE OF FONT
  2632. FONTSIZ BSS 1 SIZE OF FONT
  2633. FONTMOD BSS 1 MODE OF FONT
  2634. *
  2635. * /--- BLOCK END 00 000 79/02/12 17.08
  2636. END
plato.source/plaopl/exec3.txt ยท Last modified: 2021/02/06 16:22 by 127.0.0.1