1 / 2 / New instructions with known symbolic names 3 / 4 FEXT=0000 / Floating Point Instructions 5 FIXMRI FGET=AND 6 FIXMRI FADD=TAD 7 FIXMRI FSUB=ISZ 8 FIXMRI FDIV=DCA 9 FIXMRI FMUL=JMS 10 FIXMRI FXPN=JMP 11 FIXMRI FPUT=FXPN+1000 12 FNOR=7000 13 14 DYL=6063 / Set Display Y co-ordinate 15 DXS=6057 / Set Display X co-ordinate and intensify 16 DSB=6074 / Set VC8 brightness 17 DCTA=6762 / Clear Dectape status register A 18 DTRB=6772 / Read DECTape status register B 19 20 LINC=6141 / Switch to LINC co-processor 21 TEXTP=0017 / LINC instruction to complement AC 22 PDP=0002 / Return to PDP-8 Mode 23 24 / 25 / Interrupt service, autoindex registers, and various variables and 26 / pointers. 27 / 28 *0001 29 INTRPT=0000 / PDP-8 ISR Entry, PDP-5 PC 30 00001 5403 JMP I .+2 / PDP-5 ISR Entry point 31 00002 5403 PDP, JMP I .+1 32 RESTAR, 33 00003 2603 WORDS, MBREAK+1 34 00004 0004 DDTJP, 0004 / ODD: This is never used 35 00005 0013 P13, 13 / Handy constant 36 C100, 37 00006 0100 DIGITS, 100 / Handy constant 38 FINT=JMS I . 39 00007 6400 FPNT / Floating Point Package 40 AXIN, 41 BETA, 42 00010 0000 XR10, .-. / Where to encode 6-bit text 43 XR11, 44 00011 0000 XRT, .-. / General autoindex register 45 XR12, 46 00012 0000 XRT2, .-. / General autoindex register 47 POPA=TAD I PDLXR 48 PDLXR, 49 00013 4370 XR13, BEGIN-1 / Push-down stack with initial value 50 00014 3117 FLTXR, IOBUF-1 / FPNT autoindex, Used by BEGIN to clear TOBUF 51 00015 0000 FLTXR2, .-. / FPNT autoindex 52 00016 7402 TELSW, 7402 / TTY output busy ODD: Why is this non-zero? 53 / Next three are saved/restored as a block 54 AXOUT, 55 COM, 56 00017 3215 TEXTP, 3215 / Where to get 6-bit chars ODD: Why is this non-zero? 57 00020 0000 XCT, 0 / Which side to get from 58 00021 0000 GTEM, .-. / Saves current packed word 59 00022 2407 PC, FLTZER / Pointer to current line of the program 60 LISTL, 61 SETWI, 62 00023 0000 THISLN, .-. / Pointer to "next" line of the program 63 CNTRM, 64 00024 0000 THISOP, .-. / Right operator when deciding precedence 65 LASTLN, 66 00025 0000 TEMPM, .-. / "Previous" line of the program 67 CHARM, 68 00026 0001 DEBGSW, 1 / Quote flag, inhibits tracing ODD: Why initially 1? 69 PACKST, 70 00027 0000 TEMPT, .-. / Start of put buffer (Rubout protection) 71 PT1, 72 00030 0000 TEMPX, .-. / Pointer temporary 73 LASTV, 74 00031 3760 PNTR, SAVE+7 / End of defined variables 75 CNTRT, 76 T1, 77 00032 0000 VAL, .-. / Temporary save area 78 SAC, 79 00033 0000 T3, 0 / Negation flag used by "F"unctions 80 INBUF, 81 00034 0000 SLK, .-. / Input buffer for TTY 82 BOTTOM, 83 00035 4370 MQ, BEGIN-1 / Last address, from which stack grows down 84 HOLD, 85 00036 0000 INSUB, 0 / Input from memory or TTY? 86 ACTIVE, 87 00037 0000 HINBUF, .-. / Negative or character from HSR while HSR in use 88 / These are saved/restored as a block 89 ADDH, 90 DECK, 91 00040 0000 EX1, .-. / Floating point operand during FPNT operations 92 AC1H, 93 D, 94 00041 0000 USERNO, .-. 95 AC1L, 96 E, 97 00042 0000 NEWU, .-. 98 F, 99 MDECK, 100 00043 0000 OVER1, .-. 101 / These are saved/restored as a block 102 CODET, 103 EXP, 104 00044 0000 FLAC, .-. / Floating point result register for/from FPNT 105 A, 106 HORD, 107 00045 0000 P77M, .-. 108 B, 109 LORD, 110 00046 0000 P1000, .-. 111 C, 112 OVER2, 113 00047 0000 P7000, .-. 114 P6777, 115 00050 0000 SIGNF, 0 / Remembers the original/desired sign of the result 116 MINSKI, 117 00051 6603 P7757, ITABLE+10 / Negate the FAC 118 RET=JMP I . 119 EP7, 120 00052 2004 FISW, 2004 / Output format (initially 8.4) 121 INTEGE, 122 00053 6724 P10, FIX / Return the integer part of FAC 123 P17M, 124 00054 0000 SORTCN, .-. / Temporary save area 125 LASTOP, 126 00055 0000 P20, .-. / Old (left) operator for precedence decisions 127 ATSW, 128 EFOP, 129 00056 0000 M20M, .-. / Flag indicated which of Ask, Type being performed 130 00057 7760 CNTR, -20 / Counter, -20 used by BEGIN to clear TOBUF 131 BUFR, 132 P4, 133 00060 3760 STARTV, SAVE+7 / Pointer to current end of program text 134 ADD, 135 00061 1354 M4M, OUTL / ODD: Initial value bogus pointer to unused routine 136 P37, 137 00062 2414 XCTIN, I33 / Polled Keyboard Input Routine 138 00063 2676 OUTDEV, XOUTL / Current output routine 139 INDEV, 140 00064 2666 M200, XI33 / Current input routine 141 C200M, 142 00065 0001 NAGSW, 1 / Line number switches ODD: Why initial value 143 CHAR, 144 00066 0215 UPAR, 215 / Current character ODD: Why this initial value 145 LINENO, 146 00067 0000 MZERO, .-. / Line number 147 DTABLE, 148 00070 0005 GINC, 5 / Length of a variable in symbol table 149 BDUMP, 150 00071 0000 T2, .-. / Short-term storage temp 151 ALISTP, 152 00072 0214 LIST6, 214 / Control-L 153 00073 0207 NOUSRS, 207 / Control-G 154 L1ST7, 155 00074 0203 TEXTPM, 203 / Control-C 156 P337, 157 00075 0337 TEXTC, 337 / Back Arrow 158 CLF, 159 00076 0212 CONTN, 212 / LF 160 CCR, 161 LIST3, 162 00077 0215 MLISTP, 215 / CR 163 DLISTP, 164 00100 7402 DMPSW, HLT / Nonzero unless tracing, HLT used by BEGIN 165 M100, 166 P7700, 167 00101 7700 PCM, 7700 / Negative 100, and mask for high 6 bits 168 OBUFO, 169 00102 0256 PER, ". / ASCII decimal point 170 00103 7701 OBUF1, -77 / Check for 6-bit control indicator 171 OBUF0, 172 00104 7600 P7600, 7600 / Handy mask for line numbers, etc. 173 IBUFO, 174 00105 7760 M20, -20 / Output buffer ring size 175 IBUFI, 176 00106 0177 P177, 177 / Mask for parity, line numbers 177 DECKP, 178 00107 0017 P17, 17 / Output buffer ring mask 179 IOTX, 180 00110 0277 P277, 277 / ASCII Question mark 181 00111 7776 M2, 7776 / Negative 2 182 00112 7477 MINUSA, -"A / ASCII A, negated 183 00113 0260 C260, "0 / Digit zero 184 00114 7540 M240, -" / ASCII space, negated 185 00115 7522 MPER, -". / ASCII Dot, negated 186 00116 7563 MCR, -215 / A CR character, negated 187 00117 7775 MFLT, -3 / Length of a floating point value 188 00120 7773 M5, -5 / Operator number of first left pren-1, negated 189 00121 7767 M11, -11 / Operator number of last left pren, negated 190 00122 0077 P77, 77 / Handy mask/constant 191 00123 0200 C200, 200 / Handy mask/constant 192 00124 4000 P4000, 4000 / Handy mask/constant 193 00125 2030 FLARGP, FLARG / Pointer to hold area 194 00126 2155 PTCH, CHIN / Input character and echo it 195 00127 5715 DOUBLE, MULT2 / Shift FAC left 196 00130 6000 FOUTPU, FLOUTP / Output floating point number 197 00131 6200 FLINTP / Input a floating point number 198 00132 3140 COMBUF, COMEIN / Command line input buffer 199 00133 3206 CFRS, COMEOU / Beginning of the text (program) storage 200 00134 3140 END, COMEIN / ODD: How is this used? 201 00135 3217 ENDT, BUFBEG / The beginning of user program storage 202 RETURN=JMP I . 203 00136 2017 EFUN31, EFUN3 / End of function call 204 00137 2407 CFRSX, FLTZER / Pointer to 0.0 in floating point 205 PUSHJ=JMS I . 206 00140 0521 XPUSHJ / Recursive call 207 POPJ=JMP I . 208 00141 1565 XPOPJ / Recursive return (End of program line) 209 PUSHA=JMS I . 210 00142 0477 XPUSHA / Push AC onto the stack 211 PUSHF=JMS I . 212 00143 0534 PD2 / Push 3 words (FP value) onto the stack 213 POPF=JMS I . 214 00144 0554 PD3 / Pop 3 words (FP value) from the stack 215 GETC=JMS I . 216 00145 2274 UTRA / Decode 6-bit to ASCII 217 PACKC=JMS I . 218 00146 2502 PACBUF / Pack ASCII to 6-bit 219 SORTJ=JMS I . 220 00147 1314 SORTB / Do table lookup-and-go 221 SORTC=JMS I . 222 00150 0721 XSORTC / Check for characters in list 223 PRINTC=JMS I . 224 00151 2465 OUT / Output character, LF if CR 225 READC=JMS I . 226 00152 2155 RDIV, CHIN / Input character and echo it 227 PRNTLN=JMS I . 228 00153 2425 XPRNT / Output a line number 229 GETLN=JMS I . 230 00154 0302 XGETLN / Parse a line number 231 FINDLN=JMS I . 232 00155 2242 XFIND / Find the requested line number 233 ENDLN=JMS I . 234 00156 2360 XENDLN / Link a new line into the program 235 RTL6=JMS I . 236 00157 0413 XRTL6 / CLL RTL RTL RTL 237 SPNOR=JMS I . 238 00160 1517 SUBS / Ignore spaces 239 TESTN=JMS I . 240 00161 1533 XTESTN / Check whether Dot, Other, or Numeric 241 TSTLPR=JMS I . 242 00162 2035 LPRTST / Check for valid left pren 243 TSTGRP=JMS I . 244 00163 0744 TEXIT / Skip if AC in the same group of line numbers 245 TESTC=JMS I . 246 00164 0700 XTESTC / Operator, numeric, "F", or other? 247 DELETE=JMS I . 248 00165 2062 PSIN, XDELET / Delete program line(s) 249 ERROR4=JMS I . 250 00166 2726 ERR2 251 252 *0176 253 00176 4371 BEGIN / Pointer to Intro. Dialog or Control-C handler 254 00177 7610 START, SKP CLA / Restart 255 256 *0200 257 00200 5576 JMP I .-2 / Deal with initialization or manual restart 258 00201 1137 INTRPM, TAD CFRSX / We are not executing 259 00202 3022 DCA PC 260 00203 7001 IAC / We are not tracing 261 00204 3100 DCA DMPSW 262 00205 3026 DCA CHARM / We are not quoted 263 00206 1226 TAD COMBOT / Initialize stack 264 00207 3013 DCA XR13 265 00210 1225 TAD CSTAB / Print an asterisk 266 00211 4551 PRINTC 267 00212 1132 IBAR, TAD COMBUF / Set up the encode to scratch buffer 268 00213 3010 DCA BETA 269 00214 3062 DCA XCTIN 270 00215 1132 OTHER, TAD COMBUF / Set up RUBOUT guard 271 00216 3027 DCA TEMPT 272 00217 4552 IGNOR, READC / Get input 273 00220 4547 SORTJ / Deal with immediate action characters 274 00221 0073 L1ST7-1 275 00222 0474 INLIST-L1ST7 276 00223 4546 PACKC / Others, we encode 277 00224 5217 JMP IGNOR / and keep going 278 00225 0252 CSTAB, "* 279 00226 3220 COMBOT, BUFBEG+1 280 00227 4546 IRETN, PACKC / Encode carriage return 281 00230 4546 PACKC / Again for good measure 282 00231 1132 TAD COMBUF / Get scratch buffer pointer 283 00232 3017 GONE, DCA TEXTP / Set up Get pointer 284 00233 3020 DCA XCT / New pointer, first side 285 00234 4545 GETC / Get a character 286 00235 1035 TAD BOTTOM / Get last free address 287 00236 3013 DCA XR13 / Set up recursion stack 288 00237 4560 SPNOR / Ignore spaces 289 00240 4561 TESTN / Dot, Other, or Numeric? 290 00241 5362 JMP GZERR / Dot, go report the error 291 00242 5271 JMP INPUTX / Other implies direct command 292 00243 2026 ISZ CHARM / Numeric, Inhibit trace 293 00244 4554 GETLN / interpret line number 294 00245 1124 TAD P4000 / Check argument properties 295 00246 1065 TAD NAGSW 296 00247 7640 SZA CLA / Have both group and line in group? 297 00250 4566 ERROR4 / Line number needs both group and line 298 00251 1060 TAD P4 / Yes, get end of text buffer 299 00252 3010 DCA BETA / Set to append new line 300 00253 3062 DCA XCTIN / Start on first side 301 00254 1067 TAD MZERO / Get line number 302 00255 3410 DCA I BETA / Store it 303 00256 4560 SPNOR / Kill leading spaces 304 00257 7410 SKP / Have first character to move 305 00260 4545 GETC / Get a character 306 00261 4546 SRETN, PACKC / Put a character 307 00262 1066 TAD CHAR / Get the character 308 00263 1116 TAD MCR / Is it carriage return? 309 00264 7640 SZA CLA / Yes 310 00265 5260 JMP SRETN-1 / No, Keep Moving 311 00266 4565 DELETE / Delete the old copy 312 00267 4556 ENDLN / Insert the new copy 313 00270 5177 JMP START / We are done 314 00271 4540 INPUTX, PUSHJ / Recursive call 315 00272 0611 PROC / To PROC 316 HSP, 317 00273 1422 HSR, TAD I PC / Get address of next line 318 00274 7450 SNA / Done? 319 00275 5177 TELSW1, JMP START / Yes, quit 320 00276 3022 TELSW2, DCA PC / No, Store new pointer 321 00277 1022 TELSW3, TAD PC / Get pointer 322 00300 7001 TELSW4, IAC / Skip over the line number 323 00301 5232 TELSW5, JMP GONE / Go execute it 324 PARITY, 325 00302 0000 XGETLN, .-. / Get line number argument 326 00303 4560 SPNOR / Skip spaces 327 00304 1066 RESTOR, TAD CHAR / Is character "A? 328 00305 1112 TAD MINUSA 329 00306 7650 SNA CLA 330 00307 5322 JMP TTY / Yes, "All", start with zero 331 00310 3036 DCA INSUB / No, Set ot input from memory 332 00311 4771 JMS I LCON / Parse a floating point number 333 00312 1047 XRSTAR, TAD OVER2 / Get low FAC 334 00313 0372 AND P7740 / Get correct bits 335 00314 1046 TAD LORD / Get middle FAC 336 00315 7640 SZA CLA / Result zero? 337 00316 4566 ERROR4 / No, choke 338 00317 1047 TAD OVER2 / Get low FAC 339 00320 4557 RTL6 / Shift into low bits 340 00321 7004 KEY, RAL 341 TESTA, 342 00322 3067 TTY, DCA MZERO / Store line number result 343 00323 4561 TESTN / Dot, Other, or Numeric? 344 00324 4545 CNTRLC, GETC / Dot, get next 345 00325 4561 TESTN / Dot, Other, or Numeric? 346 00326 5340 JMP GERR / Another dot is error 347 00327 5352 JMP GEXIT / Other 348 00330 1054 TAD P17M / Numeric, Multiply digit by 10 349 00331 7106 CNTRLX, CLL RTL 350 00332 1054 TAD P17M 351 00333 7004 RAL 352 00334 1067 TAD MZERO / Add to line number 353 00335 3067 DCA MZERO 354 00336 4545 GETC / Look at next character 355 00337 4561 TESTN / Dot, Other, or Numeric? 356 00340 4566 GERR, ERROR4 / Dot is error 357 00341 5352 JMP GEXIT / Other 358 00342 1054 P100, TAD P17M / Numeric, add in new digit 359 00343 1067 SILENT, TAD MZERO 360 00344 3067 DCA MZERO 361 00345 4545 GETC / Get next character 362 00346 4561 TESTN / Dot, Other, or Numeric? 363 00347 5340 TTYPE, JMP GERR / Dot is still error 364 00350 7410 SKP / Hoping for terminator 365 00351 4566 ERROR4 / Now so is digit 366 00352 7100 GEXIT, CLL / Check out the result 367 00353 1067 CTABS, TAD MZERO / Have group non-zero? 368 00354 0104 AND OBUF0 369 00355 7640 SZA CLA 370 00356 7020 CML / Yes, set link 371 00357 1067 TAD MZERO / Have line-in-group zero? 372 00360 0106 AND P177 373 00361 7460 SNL SZA / Must have group or be zero 374 00362 4566 GZERR, ERROR4 / No, Error 375 00363 7640 SZA CLA / Have line-in-group? 376 00364 1373 TAD P2000 / Yes, set flag 377 00365 7020 CML / Complement group flag 378 00366 7004 RAL / Shift to get both flags 379 00367 3065 DCA NAGSW / and remember them 380 00370 5702 JMP I XGETLN / Return 381 00371 5600 LCON, DECONV / Signed decimal input routine 382 00372 7740 P7740, 7740 / 177 (low line number) shifted over 383 00373 2000 P2000, 2000 / 4000 (have line in group), shifted right 384 00374 2014 FNTARF, XABS / FABS 385 00375 2010 XSGN / FSGN 386 00376 1160 XINT / FITR 387 00377 1142 EXSWP / FDIS 388 389 00400 1553 XRAN / FRAN 390 00401 1343 XADC / FADC 391 00402 5000 ARTN / FATN / First deletable function 392 00403 4620 FEXP / FEXP 393 00404 5040 FLOG / FLOG 394 00405 5205 FSIN / FSIN 395 00406 5200 FCOS / FCOS 396 00407 7400 XSQRT / FSQT 397 00410 2725 ERROR5 / FNEW 398 00411 2725 ERROR5 / FCOM 399 00412 2725 XKEY, ERROR5 / FX 400 00413 0000 XRTL6, .-. 401 00414 7106 CLL RTL / Shift AC 6 bits left 402 00415 7006 RTL 403 00416 7006 RTL 404 00417 5613 JMP I XRTL6 405 00420 4554 DO, GETLN / Interpret Argument 406 00421 1022 TAD PC / Get pointer to current line 407 00422 4542 PUSHA / Save it 408 00423 4543 PUSHF / Save all decode info for current point 409 00424 0017 TEXTP 410 00425 4543 DGRP, PUSHF / Save all current line number stuff 411 00426 0065 NAGSW 412 00427 1065 TAD NAGSW / Do single line? 413 00430 7710 SPA CLA 414 00431 5263 JMP DOONE / Yes, go do it 415 00432 4555 FINDLN / No, find the group 416 00433 7000 NOP / Group seek returns here 417 00434 1023 TAD LISTL / Prepare to fetch line number 418 00435 3011 DCA XRT 419 00436 1411 TAD I XRT / Get the line number found 420 00437 4563 TSTGRP / In the group? 421 00440 4566 ERROR4 / No, no such group 422 00441 4540 DGRP1, PUSHJ / Yes, do a "GOTO", but come back here 423 00442 0606 PROCES-2 424 00443 4544 POPF / Restore line number stuff 425 00444 0065 MPO, NAGSW 426 00445 1422 MP177, TAD I PC / Get the next line number 427 00446 7450 SNA 428 IGNORE, 429 00447 5271 KEYX, JMP SING / Zero, no next line 430 00450 7001 IAC 431 00451 3030 GOCR, DCA PT1 / Point to next line's number 432 00452 1065 TAD NAGSW / Are we doing all? 433 00453 7740 SZA SMA CLA 434 00454 5260 ECHO, JMP DOONE-3 / Yes, just do it 435 00455 1430 TAD I PT1 / No, get line number 436 00456 4563 TSTGRP / In correct group? 437 00457 5271 JMP SING / No, we are done 438 00460 1430 TAD I PT1 / Get next line number 439 00461 3067 DCA MZERO / as current line number 440 00462 5225 JMP DGRP / Do another 441 00463 4555 DOONE, FINDLN / Find the line 442 00464 4566 ERROR4 / No such line 443 00465 4540 NOECHO, PUSHJ / Execute it 444 00466 0610 PROCES 445 00467 4544 POPF / Pop line number switches, character, and line number 446 00470 0065 NAGSW 447 DCONT, 448 00471 4544 SING, POPF / Finished a DO, pop decode pointer, side, and temp 449 00472 0017 TEXTP 450 00473 1413 POPA / Pop old line pointer 451 00474 3022 EOUT, DCA PC 452 00475 5676 JMP I .+1 / Go execute from there 453 00476 0611 PROC 454 00477 0000 XPUSHA, .-. / Save the value in AC onto the stack 455 00500 3071 DCA BDUMP / Save the value 456 00501 7040 CMA / Get -1 (size of AC) 457 00502 4310 JMS PCHK / Make room 458 00503 1071 TAD BDUMP / Store the value 459 00504 3413 DCA I XR13 460 00505 7040 CMA / Adjust stack pointer 461 00506 4310 JMS PCHK 462 00507 5677 JMP I XPUSHA / Return 463 00510 0000 PCHK, .-. / Adjust stack, check for overflow 464 00511 1013 TAD XR13 / Adjust the stack pointer 465 00512 3013 EBELL, DCA XR13 466 00513 1013 TAD XR13 / Stack crossing into variable space? 467 00514 7141 CLL CIA 468 00515 1031 TAD PNTR 469 00516 7630 XBUF, SZL CLA 470 00517 4566 ERROR4 / Yes, error 471 00520 5710 JMP I PCHK / No, return 472 00521 0000 XPUSHJ, .-. / Call using stack 473 00522 1721 TAD I XPUSHJ / Where are we going? 474 00523 3071 DCA BDUMP / Remember it 475 00524 7040 CMA / Make room on stack 476 00525 4310 JMS PCHK 477 00526 1321 TAD XPUSHJ / Compute return address 478 00527 7001 SETW, IAC 479 00530 3413 DCA I XR13 / Put in stack 480 00531 7040 CMA 481 00532 4310 P140, JMS PCHK / Make room again 482 00533 5471 MX, JMP I BDUMP / Go where we're going 483 BELLX, 484 00534 0000 PD2, .-. / Push a floating point value 485 00535 7240 XTDUMP, CLA CMA 486 00536 1734 TAD I PD2 / Get Pointer to FP data 487 00537 3011 DCA XRT / In autoindex register 488 00540 2334 ISZ PD2 / Skip argument on return 489 00541 1117 TAD MFLT / Get floating point length 490 00542 4310 JMS PCHK / Make room for floating point 491 00543 1117 TAD MFLT / Initialize counter 492 00544 3071 DCA BDUMP 493 00545 1411 TAD I XRT / Move a word 494 00546 3413 DCA I XR13 495 00547 2071 ISZ BDUMP / All moved? 496 00550 5345 JMP PD3-7 / No, move another 497 00551 1117 TAD MFLT / Readjust stack 498 00552 4310 JMS PCHK 499 00553 5734 JMP I PD2 / Return 500 00554 0000 PD3, .-. / Pop floating point value 501 00555 7240 CLA CMA 502 00556 1754 TAD I PD3 / Get Destination address 503 00557 2354 ISZ PD3 / (and skip it) 504 00560 3011 DCA XRT / into autoindex register 505 00561 1117 TAD MFLT / Get Size of FP data 506 00562 3071 DCA BDUMP 507 00563 1413 POPA / Move a word 508 00564 3411 DCA I XRT 509 00565 2071 ISZ BDUMP / Until done 510 00566 5363 JMP INLIST-5 511 00567 5754 JMP I PD3 / return 512 00570 2740 INLIST, RECOVR / Control-C 513 00571 0212 IBAR / Back Arrow 514 00572 0217 IGNOR / LF 515 00573 0227 IRETN / CR 516 00574 1075 FLIST2, FLIMIT / Comma, has limit 517 00575 1137 MP11, FINFIN / Semicolon, assume increment of one 518 00576 2725 ERROR5 / CR, error 519 00577 1065 FLIST1, FINCR / Comma, must be For command 520 521 *0600 522 00600 0610 XDECK, PROCES / Semicolon, end of statement 523 00601 0614 PC1 / CR, end of line 524 00602 7472 MF, -"F / F character, negated 525 00603 4554 GOTO, GETLN / Parse the line number 526 00604 4555 FINDLN / Find the line 527 00605 4566 ERROR4 / No such line 528 00606 1023 TAD LISTL / Get pointer to new line 529 00607 3022 DCA PC / Make that line current 530 00610 4545 PROCES, GETC / Decode a character 531 00611 1066 PROC, TAD CHAR / Is it a carriage return? 532 00612 1116 TAD MCR 533 00613 7650 SNA CLA 534 COMMFN, 535 00614 5541 PC1, POPJ / ODD: Why the silly jmp to jmp stuff? 536 00615 4550 SORTC / No, check for terminator 537 00616 1376 BASEP, GLIST-1 538 00617 5210 BASEX, JMP PROCES / Terminator, try again 539 00620 1066 XCOM, TAD CHAR / Mask the character 540 00621 0075 AND P337 / ODD: Why the masking? 541 00622 4542 PUSHA / and stack it 542 00623 4545 GETC / Get next character 543 00624 4550 SORTC / Check for terminator 544 00625 1376 GLIST-1 545 00626 7410 SKP 546 00627 5223 JMP .-4 / Keep looking for terminator 547 00630 1413 POPA / Get saved character 548 00631 4547 SORTJ / Dispatch Command 549 00632 0773 COMLST-1 550 00633 0167 UNDECK, COMGO-COMLST 551 00634 4566 ERROR4 / No such command 552 00635 4554 WRITE, GETLN / Get argument 553 00636 2026 ISZ CHARM / Set quote mode to inhibit tracing 554 00637 4555 FINDLN / Find the first matching line 555 00640 5267 JMP WTESTG / Can't find it, must be group write 556 00641 1067 TAD MZERO / Get the line number 557 00642 7640 SZA CLA / Is it zero? 558 00643 4553 XACTIO, PRNTLN / No, output the line number 559 00644 4545 GETC / Get a character and output it 560 00645 4551 PRINTC 561 00646 1066 TAD CHAR / Was it the carriage return? 562 00647 1116 TAD MCR 563 00650 7640 SZA CLA 564 00651 5244 JMP .-5 / No, keep outputting 565 00652 1423 TAD I LISTL / Yes, get pointer to next line 566 00653 7450 WTEST2, SNA / Is it zero? 567 00654 5271 JMP WTESTG+2 / Yes, we are done 568 00655 7001 IAC / Point at the line number 569 00656 3030 DCA PT1 570 00657 1065 TAD NAGSW / Are we doing write all? 571 00660 7700 SMA CLA 572 00661 1430 TAD I PT1 / No, get new line number 573 00662 4563 TSTGRP / Is it also in the group? 574 00663 5273 JMP WX / No, we are done 575 00664 1430 WALL, TAD I PT1 / Yes, get line number 576 00665 3067 DCA MZERO / Set as line to find 577 00666 5237 JMP WRITE+2 / and go find it 578 00667 1023 WTESTG, TAD LISTL / Get pointer to first greater line 579 00670 5253 JMP WTEST2 / and try that 580 00671 3026 DCA CHARM / Unquote to resume tracing 581 00672 5541 POPJ / End processing for this line (ODD: why?) 582 00673 1065 WX, TAD NAGSW / New group, are we doing write all? 583 00674 7750 SNA SPA CLA 584 00675 5271 JMP WTESTG+2 / No, we are all done 585 00676 4551 PRINTC / Yes, print the CR-LF again 586 00677 5264 JMP WALL / and keep going 587 00700 0000 XTESTC, .-. / Determine if operator, numeric, "F", or other 588 00701 4560 ACTING, SPNOR / Ignore spaces 589 00702 4550 SORTC / Arithmetic operator or terminator? 590 00703 1767 TERMS-1 591 00704 5700 JMP I XTESTC / Yes, return (no skip) 592 00705 1066 TAD CHAR / Get character 593 00706 2300 P14, ISZ XTESTC / Arrange for skip return 594 00707 1202 P2M, TAD MF / Is it "F? 595 00710 7650 XTTY, SNA CLA 596 00711 5317 JMP XT3 / Yes, go take skip 2 return 597 00712 4561 TESTN / Dot, Other, or Numeric? 598 00713 5700 JMP I XTESTC / Dot, take numeric (skip 1) return 599 00714 7410 SKP / Other, treat as other 600 00715 5700 JMP I XTESTC / Numeric, skip 1 return 601 00716 2300 ISZ XTESTC / Other, skip 3 return 602 00717 2300 XT3, ISZ XTESTC / "F", Skip 2 return 603 00720 5700 JMP I XTESTC 604 00721 0000 XSORTC, .-. / Table scan routine 605 00722 1721 TAD I XSORTC / Get table address 606 00723 3012 DCA XR12 / Save in autindex 607 00724 1412 TAD I XR12 / Get a character to check for 608 00725 7510 SPA / End of table? 609 00726 5340 JMP SEXC / Yes, take skip 2 return 610 00727 7041 XTTX, CIA / Subtract from character 611 00730 1066 TAD CHAR 612 00731 7640 SZA CLA / Equal? 613 00732 5324 JMP XTTX-3 / No, try again 614 00733 1721 TAD I XSORTC / Yes, get table address 615 00734 7040 CMA / Form offset into table 616 00735 1012 TAD XR12 617 00736 3054 DCA P17M / Save it for the caller 618 00737 7410 SKP / Take skip 1 return 619 00740 2321 SEXC, ISZ XSORTC / Adjust return address 620 00741 2321 ISZ XSORTC / Skip over table address 621 00742 7300 XXTTY, CLA CLL / return 0 622 00743 5721 JMP I XSORTC 623 GRPTST, 624 00744 0000 TEXIT, .-. / Skip if AC in same group 625 00745 0104 AND OBUF0 / Mask for group number 626 00746 7041 CIA / Make negative 627 00747 3071 DCA BDUMP / and save 628 00750 1067 TAD MZERO / Get current line number 629 00751 0104 AND OBUF0 / Get current group number 630 00752 1071 TAD BDUMP / Equal? 631 00753 7650 SNA CLA 632 00754 2344 ISZ TEXIT / Yes, skip 1 on return 633 00755 5744 JMP I TEXIT / return 634 00756 0000 INPUT, .-. / Input from TTY or memory 635 00757 1036 TAD INSUB / Input from memory? 636 00760 7640 SZA CLA 637 00761 5364 JMP .+3 / No, go input from TTY 638 00762 4545 GETC / Yes, get the character 639 00763 5756 P7750, JMP I INPUT / and return it 640 00764 4552 P7576, READC / Get character from TTY 641 00765 4547 SORTJ / Check for edit character 642 00766 6776 SPECIA-1 643 00767 3402 INFIX-SPECIA 644 00770 5756 JMP I INPUT / Return the character 645 00771 1035 ILIST, IF1 / Comma, go again in skip chain 646 00772 0610 PROCES 647 00773 0614 PC1 648 00774 0323 COMLST, 323 / "S Set 649 00775 0306 306 / "F For 650 00776 0311 311 / "I If 651 00777 0304 304 / "D Do 652 653 *1000 654 01000 0307 FXPRNT, 307 / "G Go, Goto 655 01001 0303 303 / "C Comment 656 01002 0301 301 / "A Ask, Accept 657 01003 0324 324 / "T Type 658 01004 0314 314 / "L Locations, Library, Leave 659 01005 0305 305 / "E Erase, End 660 01006 0327 327 / "W Write 661 01007 0315 EXGO, 315 / "M Modify, Move 662 01010 0321 321 / "Q Quit 663 01011 0322 322 / "R Return 664 01012 0212 212 / LF 665 / ODD: Why use TESTC, if answer is assumed? 666 IF, 667 01013 4564 XPRNTI, TESTC / Operator, numeric, "F", or other? 668 01014 4637 EXRQ, JMS I EXCHCK / Operator, as expected 669 01015 2013 ISZ XR13 / Numeric, unstack cruft from SEGSLV 670 01016 4640 JMS I IPART / "F", Check for right pren?? 671 01017 1111 TAD M2 / Other, Set up counter 672 01020 3032 DCA VAL 673 01021 1045 TAD HORD / Result positive? 674 01022 7510 SPA 675 01023 2032 ISZ VAL / Negative, bump counter 676 01024 7750 SNA SPA CLA 677 01025 2032 IF3, ISZ VAL / Zero, bump counter 678 01026 7410 SKP / Not time to goto, check for terminator 679 01027 5767 JMP I FCONT-2 / Do a goto 680 01030 4547 SORTJ / Dispatch based on terminator 681 01031 1377 TLIST-1 682 01032 7371 ILIST-TLIST 683 01033 4545 GETC / Not a terminator, get next character 684 01034 5230 JMP .-4 / and try again 685 01035 4545 IF1, GETC / Get next character 686 01036 5225 JMP IF3 / Try again 687 EXCHCK, 688 01037 1601 IECALL, ECALL 689 01040 2047 IPART, PARTES 690 FOR, 691 01041 4540 SET, PUSHJ / Require a variable and look it up 692 01042 1403 GETARG 693 01043 4560 SPNOR / Ignore spaces 694 01044 1066 TAD CHAR / Check for equal sign 695 01045 1335 GETSGN, TAD MEQ 696 01046 7440 SZA 697 01047 4566 ERROR4 / No equal sign 698 01050 1030 TAD PT1 / Save pointer to variable on stack 699 01051 4542 PUSHA 700 01052 4540 CHKCON, PUSHJ / Evaluate initial value 701 01053 1612 CHKCNT, EVAL-1 702 01054 1413 EXRED, POPA / Get pointer to variable 703 01055 3030 DCA PT1 704 01056 4407 FINT 705 01057 6430 FPUT I PT1 / Store initial value 706 01060 0000 EXPRN, FEXT 707 01061 4547 SORTJ / Check for comma, semicolon, or CR 708 01062 1377 XPR, TLIST-1 709 01063 7177 FLIST1-TLIST 710 01064 4566 XPR2, ERROR4 / Not found, error 711 01065 1030 FINCR, TAD PT1 / For command, Save pointer to variable 712 01066 4542 PUSHA 713 01067 4540 PUSHJ / Evaluate the increment/limit 714 01070 1612 EVAL-1 715 01071 4547 SORTJ / Look at the terminator 716 01072 1377 EXCHE, TLIST-1 717 01073 7174 FLIST2-TLIST 718 01074 4566 ERROR4 / Not a valid terminator 719 01075 4543 FLIMIT, PUSHF / Save the increment 720 01076 2030 FLARG 721 01077 4540 PUSHJ / Get the limit 722 01100 1612 EVAL-1 723 01101 4543 PUSHF / Push the limit 724 01102 2030 FLARG 725 01103 4543 PUSHF / Push the decode pointer 726 01104 0017 TEXTP 727 01105 4540 PUSHJ / Execute the command(s) 728 01106 0610 PROCES 729 01107 4544 POPF / Pop the decode pointer 730 01110 0017 TEXTP 731 01111 4544 POPF / Pop the limit 732 01112 2030 FLARG 733 01113 4544 POPF / Pop the increment 734 01114 7470 BUFFER 735 01115 1413 POPA / Pop the variable reference 736 01116 3030 DCA PT1 737 01117 4407 FINT 738 01120 0430 FGET I PT1 / Get the variable's value 739 01121 1733 FADD I FINKP / Add the Increment 740 01122 6430 FPUT I PT1 / Store new value 741 01123 2525 FSUB I FLARGP / Subtract the limit 742 01124 0000 FEXT 743 01125 1045 TAD HORD / Done yet? 744 01126 7740 SZA SMA CLA 745 01127 5541 POPJ / Yes, end of the line 746 01130 1030 TAD PT1 / No, push variable reference 747 01131 4542 PUSHA 748 01132 4543 PUSHF / Push the increment 749 01133 7470 FINKP, BUFFER 750 01134 5301 JMP FLIMIT+4 / Go again 751 01135 7503 MEQ, -"= / ASCII equal sign, negated 752 01136 7524 MCOM, -", / ASCII Comma, negated 753 01137 4543 FINFIN, PUSHF / Push 1.0 as increment 754 01140 2405 FLTONE 755 01141 5301 JMP FLIMIT+4 / Go push limit and proceed 756 EXSWP, 757 01142 4453 XDYS, JMS I INTEGE / Get argument as integer 758 01143 4542 ACTVP, PUSHA / Save it 759 01144 1066 PM2000, TAD CHAR / Is there a comma? 760 01145 1336 NEXTU, TAD MCOM 761 01146 7640 NEXT0, SZA CLA / Yes, proceed 762 01147 4566 CONTIN, ERROR4 / No, error 763 01150 4540 PUSHJ / Get second argument 764 01151 1612 EVAL-1 765 01152 4453 JMS I INTEGE / Convert to integer 766 01153 6063 DYL / Load Y coordinate 767 01154 7200 CLA 768 01155 1413 POPA / Pop X coordinate 769 01156 6057 DXS / Load X coordinate, intensify 770 01157 7410 SKP / Done 771 01160 4453 XINT, JMS I INTEGE / Get argument as integer 772 01161 7200 CLA / Clear AC 773 01162 5536 M6M, RETURN / return 774 COMGO, 775 01163 1041 TRC1, FOR / Set 776 01164 1041 TRC2, FOR / For 777 01165 1013 LISTP, IF / If 778 01166 0420 DO / Do 779 01167 0603 GOTO / Go/Goto 780 01170 0614 PC1 / Comment 781 01171 1202 FCONT, ASK / Ask 782 01172 1203 TYPE / Type 783 01173 7503 LIBRAR / Locations 784 01174 2204 ERASE / Erase 785 01175 0635 WRITE / Write 786 01176 1256 MODIFY / Modify 787 01177 0177 START / Quit 788 789 *1200 790 01200 1563 RETRN / Return 791 01201 6361 HSPX / LF 792 01202 7240 ASK, CLA CMA / Remember whether ask or type command 793 01203 3056 TYPE, DCA M20M 794 01204 3026 TASK, DCA CHARM / Not in quotes yet 795 01205 4547 SORTJ / Do lookup and go 796 01206 1371 ALIST-1 / Among chars special to ask/type 797 01207 0176 ATLIST-ALIST 798 01210 2056 USERTS, ISZ M20M / Expression, doing Ask or Type? 799 01211 5226 JMP TYPE2 / Type, go do it 800 01212 4540 PUSHJ / Ask, require a variable and look it up 801 01213 1403 GETARG 802 01214 1066 TAD CHAR / Save terminator 803 01215 4542 EXGON, PUSHA 804 01216 1255 TAD BMOVE / Print a colon 805 01217 4551 PRINTC 806 01220 2036 ISZ INSUB / Set up for TTY input 807 01221 7001 IAC / Tell input routine we have first character 808 01222 4531 JMS I COMBUF-1 / Input a floating point number into the variable 809 01223 1413 POPA / Pop the terminator 810 01224 3066 DCA CHAR 811 01225 5202 JMP ASK / Continue with Ask 812 01226 4540 TYPE2, PUSHJ / Evaluate the expression 813 01227 1613 EVAL-1+1 814 01230 4530 JMS I FOUTPU / And print the result 815 01231 5203 JMP TYPE / Keep going 816 MOVE15, 817 01232 2026 TQUOT, ISZ CHARM / Got a quote, set quote flag 818 01233 4545 GETC / Get next character 819 01234 4547 SORTJ / Terminate quotes? 820 01235 1403 TLIST2-1 821 01236 0773 TLIST3-TLIST2 822 01237 4551 PRINTC / No, print the quoted text 823 01240 5233 JMP MOVE15+1 / Go get the next character 824 01241 4545 TINTR, GETC / Get next character 825 01242 4554 GETLN / Parse line number style 826 01243 1067 MOVE20, TAD MZERO / Get result 827 01244 3052 DCA FISW / Store as output format 828 01245 5204 JMP TYPE+1 / and continue 829 01246 1077 TCRLF2, TAD CCR / Pound sign, carriage return (form-feed?) 830 01247 4463 JMS I OUTDEV 831 01250 7040 CMA / Set up to print form-feed 832 01251 1077 TCRLF, TAD CCR / Get CR or not 833 01252 4551 PRINTC / Print it 834 835 01253 4545 TASK4, GETC / Get next character 836 01254 5204 JMP TYPE+1 / Continue with Ask/Type 837 BMOVE, 838 01255 0272 COL, ": / Prompt character 839 01256 4554 MODIFY, GETLN / Interpret the argument 840 01257 4555 FINDLN / Find the line to modify 841 01260 4566 ERROR4 / No such line 842 01261 1060 TAD P4 / Set up to store new version 843 01262 3010 DCA BETA 844 01263 3062 DCA XCTIN / Encode left 845 01264 1067 TAD MZERO / Get line number 846 01265 3410 DCA I BETA / Store it 847 01266 1010 TAD BETA / Remember where the beginning is for RUBOUT 848 01267 3027 DCA TEMPT 849 01270 4464 SCONT, JMS I INDEV / Get a character 850 01271 3100 DCA DLISTP / Store search character 851 01272 2026 ISZ CHARM / Set quote switch to prevent tracing 852 01273 4545 SCHAR, GETC / Decode a character 853 01274 4551 PRINTC / and print it 854 01275 4547 SORTJ / Dispatch based on search character 855 01276 0076 HOLDI, CCR-1 856 01277 1271 HOLDO, LISTGO-CCR 857 01300 4546 BUFRS, PACKC / Wasn't CR or search character, copy it 858 01301 5273 JMP SCHAR / and keep going 859 01302 1060 SBAR, TAD P4 / Erase to beginning and wait for input 860 01303 7001 IAC 861 01304 3010 DCA BETA 862 01305 3062 DCA XCTIN 863 01306 4552 SFOUND, READC / Get an edit character 864 01307 4547 SORTJ / Dispatch based on it 865 01310 0071 ALISTP-1 866 01311 1271 SRNLST-ALISTP 867 01312 4546 SGOT, PACKC / Copy the character 868 01313 5306 JMP .-5 / Go wait for more editing 869 01314 0000 SORTB, .-. 870 01315 7450 SNA / Look for AC? 871 01316 1066 TAD CHAR / No, look for char 872 01317 7041 CIA / Negate 873 01320 3071 DCA BDUMP / Save for later 874 01321 1714 TAD I SORTB / Get table address 875 01322 2314 ISZ SORTB / Skip table address 876 01323 3012 DCA XR12 / Store table address 877 01324 1412 TAD I XR12 / Get table entry 878 01325 7510 SPA / Positive? 879 01326 5340 JMP SEX / No, go take skip return 880 01327 1071 TAD BDUMP / This the one? 881 01330 7640 SZA CLA 882 01331 5324 JMP SORTB+10 / No, try again 883 01332 1012 TAD XR12 / Yes, get table pointer 884 01333 1714 TAD I SORTB / Convert to dispatch table ptr 885 01334 3071 DCA BDUMP / Save it 886 01335 1471 TAD I BDUMP / Get dispatch routine ptr 887 01336 3071 DCA BDUMP / Save it 888 01337 5471 JMP I BDUMP / Go to dispatch routine 889 01340 2314 SEX, ISZ SORTB / Skip dispatch table ptr 890 01341 7300 CLA CLL / return 0 891 01342 5714 JMP I SORTB 892 01343 4453 XADC, JMS I INTEGE / Channel numbers are integer 893 01344 7000 NOP / ODD: Was this once an IOF? 894 01345 6375 6375 / Start the requested channel 895 01346 6332 6332 / Wait for device 896 01347 5346 JMP .-1 897 01350 6362 6362 / Read the device 898 01351 3046 DCA LORD / Store result 899 01352 6001 ION / ODD: Why this here? 900 01353 5536 RETURN / Return 901 01354 0000 OUTL, .-. 902 01355 6046 TLS / Print a character 903 01356 6026 PLS / Punch the character 904 01357 6041 TSF / Wait for TTY output 905 01360 5357 JMP .-1 / ODD: Assumes punch faster than TTY? 906 01361 7200 CLA / Return 0 907 01362 5754 JMP I OUTL 908 01363 1273 SRNLST, SCHAR / Control-L 909 01364 1270 SCONT / Control-G, switch search characters 910 01365 2740 RECOVR / Control-C, abort 911 01366 1302 SBAR / Back arrow, lose beginning text 912 01367 1271 SCONT+1 / LF, copy rest of line 913 01370 0261 LISTGO, SRETN-1+1 / CR 914 01371 1312 SGOT / Character was found 915 01372 0245 ALIST, 0245 / "% 916 01373 0242 0242 / "" 917 01374 0241 0241 / "! 918 01375 0243 0243 / "# 919 01376 0244 0244 / "$ 920 01377 0240 GLIST, 0240 / space 921 922 *1400 923 01400 0254 TLIST, 0254 / comma 924 01401 0273 0273 / semicolon 925 01402 0215 0215 / CR 926 01403 4564 GETARG, TESTC / Require a variable, then find it 927 01404 0242 TLIST2, 242 / Double Quote, harmless if we fall thru 928 01405 0215 215 / CR, harmless if we fall thru 929 01406 4566 ERROR4 / Operator, Numeric, or "F", so error 930 01407 3062 GETVAR, DCA XCTIN / Encode left 931 01410 4546 PACKC / Encode first character 932 01411 4545 GETC / Get next character 933 01412 4550 SORTC / Is it a terminator? 934 01413 1767 TERMS-1 935 01414 5226 JMP GSERCH / Yes, we have the name 936 01415 1066 TAD CHAR / No, finish the encoding 937 01416 0122 AND P77 938 01417 1061 TAD M4M 939 01420 3061 DCA M4M / Remember the first two letters 940 01421 4545 GETC / Get another character 941 01422 4550 SORTC / Terminator yet? 942 01423 1767 TERMS-1 943 01424 5226 JMP GSERCH / Yes, we have the name 944 01425 5221 JMP GSERCH-5 / No, keep scanning 945 01426 4562 GSERCH, TSTLPR / Is there a subscript? 946 01427 5237 JMP GS1 / No, proceed 947 01430 1061 TAD M4M / Get variable name 948 01431 3056 DCA M20M / Arrange its salvation 949 01432 4660 JMS I GECALL / Evaluate subscript 950 01433 1413 POPA / Pop the variable name 951 01434 3061 DCA M4M 952 01435 4657 JMS I PTEST / Check that right pren is ok 953 01436 4453 ALPHA, JMS I INTEGE / Subscripts are integer 954 01437 3317 GS1, DCA SUBS / Save subscript 955 01440 1060 TAD P4 / Start at end of text 956 01441 3030 GS3, DCA PT1 / Set up to look at a variable 957 01442 1030 TAD PT1 / Reached end of variables? 958 01443 7041 CIA 959 01444 1031 TAD PNTR 960 01445 7750 SNA SPA CLA 961 01446 5261 JMP GS2 / Yes, go create a variable 962 01447 1430 TAD I PT1 / No, compare variable names 963 01450 7041 CIA 964 01451 1061 TAD M4M 965 01452 7650 SNA CLA / Variable name correct? 966 01453 5305 JMP GFND1 / Yes, go compare subscripts 967 01454 1030 GS4, TAD PT1 / No, Get variable pointer 968 01455 1070 TAD DTABLE / Point to next variable 969 01456 5241 JMP GS3 / and try again 970 01457 2047 PTEST, PARTES 971 01460 1601 GECALL, ECALL 972 01461 1031 GS2, TAD PNTR / Room to create a variable? 973 01462 1005 TAD P13 974 01463 7141 CLL CIA 975 01464 1013 TAD XR13 976 01465 7620 SNL CLA 977 01466 4566 ERROR4 / No, error 978 01467 1031 TAD PNTR / Yes, get end of variable space 979 01470 1070 TAD DTABLE / Increment by size of a variable 980 01471 3031 DCA PNTR 981 01472 1061 TAD M4M / Get variable name 982 01473 3430 DCA I PT1 / Store it 983 01474 2030 ISZ PT1 / Point to subscript 984 01475 1317 TAD SUBS / Store the subscript 985 01476 3430 DCA I PT1 986 01477 2030 ISZ PT1 / Point to the value 987 01500 4407 FINT 988 01501 0537 FGET I CFRSX / Get 0.0 989 01502 6430 FPUT I PT1 / Initialize the variable 990 01503 0000 FEXT 991 01504 5541 POPJ / return 992 01505 1030 GFND1, TAD PT1 / Get pointer to variable 993 01506 3011 DCA XRT / Prepare to access subscript 994 01507 1411 TAD I XRT / Subscripts equal? 995 01510 7041 CIA 996 01511 1317 TAD SUBS 997 01512 7640 SZA CLA 998 01513 5254 JMP GS4 / No, keep looking 999 01514 2030 ISZ PT1 / Right variable, point at the value 1000 01515 2030 ISZ PT1 1001 01516 5541 POPJ / return 1002 SUBS, 1003 01517 0000 XSPNOR, .-. / Ignore spaces 1004 01520 1066 TAD CHAR / Get character 1005 01521 1114 TAD M240 / Check for space 1006 01522 7640 SZA CLA 1007 01523 5717 JMP I SUBS / Not a space, done 1008 01524 4545 GETC / Space, get next character 1009 01525 5320 JMP SUBS+1 / and try again 1010 01526 7520 M260, -"0 1011 01527 7507 M271, -"9 1012 01530 0000 RAND, 0000 / Random number seed 1013 01531 2000 2000 1014 01532 0000 0000 1015 01533 0000 XTESTN, .-. / Skip 0 for ".", 1 for alpha, 2 for num 1016 01534 1066 TAD CHAR / Get character 1017 01535 1115 TAD MPER / Is it a dot? 1018 01536 7640 SZA CLA 1019 01537 2333 ISZ XTESTN / No, skip at least one 1020 01540 1066 BASES, TAD CHAR / Get character again 1021 01541 1326 TAD M260 / Subtract for digit 1022 01542 3054 DCA P17M / Save digit 1023 01543 1054 TAD P17M / Get it back 1024 01544 7710 SPA CLA / Could it be a digit? 1025 01545 5733 JMP I XTESTN / No, return 1026 01546 1066 TAD CHAR / Possibly, check range 1027 01547 1327 TAD M271 / Is it a digit? 1028 01550 7750 SPA SNA CLA 1029 01551 2333 ISZ XTESTN / Yes, skip two 1030 01552 5733 JMP I XTESTN / Return 1031 01553 4407 XRAN, FINT 1032 01554 1330 FADD RAND / Add seed 1033 01555 4350 FMUL XRAN-3 / Multply by code 1034 01556 6330 FPUT RAND / Store seed for later 1035 01557 0000 FEXT 1036 01560 3330 DCA RAND / Clobber exponent to fix range 1037 01561 3044 DCA EXP / Clobber exponent in result too 1038 01562 5536 RETURN / return 1039 01563 1137 RETRN, TAD CFRSX 1040 01564 3022 DCA PC 1041 01565 1413 XPOPJ, POPA / Pop return address 1042 01566 3071 DCA BDUMP / Go there 1043 01567 5471 JMP I BDUMP 1044 01570 1241 ATLIST, TINTR / "%, Set output format 1045 01571 1232 MOVE15 / "", Output quoted text 1046 01572 1251 TCRLF / "!, Output CR-LF 1047 01573 1246 TCRLF2 / "#, Output CR-FF 1048 01574 3052 TDUMP / "$, Dump the symbol table 1049 01575 1253 TASK4 / Space, just skip it 1050 01576 1253 TASK4 / Comma, just skip it 1051 01577 0610 PROCES / Semicolon, end of command 1052 1053 *1600 1054 01600 0614 PC1 / CR, end of line 1055 01601 0000 ECALL, .-. 1056 01602 1054 TAD P17M / Save Current operator, if any 1057 01603 4542 PUSHA / on push-down stack 1058 01604 1055 TAD LASTOP / Save old operator 1059 01605 4542 PUSHA 1060 01606 1056 TAD M20M / Save function or variable name, if any 1061 01607 4542 PUSHA 1062 01610 1201 TEXTA, TAD ECALL / Save return address 1063 01611 4542 PUSHA 1064 01612 4545 GETC / Get a character 1065 01613 3055 EVAL, DCA LASTOP / Remember as old operator 1066 01614 4564 TESTC / Operator, numeric, "F", or other? 1067 01615 5227 JMP ETERM1 / Operator 1068 01616 5332 JMP ENUM / Numeric 1069 01617 5343 JMP EFUN / "F"unction name 1070 01620 4540 PUSHJ / Other, look up as variable 1071 01621 1407 GETVAR 1072 01622 4564 OPNEXT, TESTC / Better have an operator/terminator 1073 01623 5244 JMP ETERMN / Operator, good 1074 01624 0212 ECHOLS, 212 / Numeric, fall thru 1075 01625 0377 377 / "F", fall thru 1076 01626 4566 ERROR4 / Other, error 1077 01627 1137 ETERM1, TAD CFRSX / Segment starts with operator/terminator 1078 01630 3030 DCA PT1 / Point left operand at a zero 1079 01631 1111 TAD M2 / Is the operator unary minus? 1080 01632 1054 TAD P17M 1081 01633 7450 SNA 1082 01634 5247 JMP ETERM / Yes, allow it 1083 01635 7001 IAC / Unary plus? 1084 01636 7650 SNA CLA 1085 01637 5323 JMP ARGNXT / Yes, go ignore it 1086 01640 1054 TAD P17M / No, get operator 1087 01641 1121 TAD M11 / Possibly left pren? 1088 01642 7710 SPA CLA 1089 01643 5363 JMP ELPAR / No, 1090 01644 4562 ETERMN, TSTLPR / Yes, check it out 1091 01645 7410 SKP 1092 01646 4566 ERROR4 / Error, bad operator 1093 01647 1054 ETERM, TAD P17M / Have new operator, save it 1094 01650 3024 DCA THISOP 1095 01651 1024 TAD THISOP / Is it a terminator? 1096 01652 1121 TAD M11 1097 01653 7700 SMA CLA 1098 01654 3024 DCA THISOP / Yes, smash precedence to 0 1099 01655 1024 ETERM2, TAD THISOP / Get new operator precedence 1100 01656 7041 CIA / Subtract from old operator precedence 1101 01657 1055 TAD LASTOP 1102 01660 7710 SPA CLA / Old operator higher? 1103 01661 5310 JMP EPAR / No, go deal 1104 01662 1055 TAD LASTOP / Get old operator 1105 01663 7112 CLL RTR / Shift to create FPP opcode 1106 01664 7012 RTR 1107 01665 1331 TAD OPTABL / Build FPP instruction 1108 01666 3274 DCA FLOP / Save it 1109 01667 1055 TAD LASTOP / Was it beginning of expression? 1110 01670 7640 SZA CLA 1111 01671 4544 POPF / No, pop left operand 1112 01672 0044 EXP 1113 01673 4407 FINT 1114 01674 0000 FLOP, .-. / Do an operation (Fopr I PT1) 1115 01675 6525 FPUT I FLARGP / Store the result 1116 01676 0000 FEXT 1117 01677 1125 TAD FLARGP / Point to the stored result 1118 01700 3030 DCA PT1 1119 01701 1024 TAD THISOP / Matching begin and end of expression? 1120 01702 1055 TAD LASTOP 1121 01703 7650 SNA CLA 1122 01704 5541 POPJ / Yes, go return 1123 01705 1413 POPA / No, pop an operator 1124 01706 3055 DCA LASTOP / Make it the new first operator 1125 01707 5255 JMP ETERM2 / and check priorities again 1126 01710 4562 EPAR, TSTLPR / Left pren? 1127 01711 7410 SKP / 1128 01712 5365 JMP EPAR2 / Yes, go solve 1129 01713 1055 TAD LASTOP / No, push left operator for later 1130 01714 4542 PUSHA 1131 01715 1030 TAD PT1 / Get pointer to left operand 1132 01716 3320 DCA .+2 / Get ready to stack it 1133 01717 4543 PUSHF / Stack left operand 1134 01720 0000 .-. 1135 01721 1024 TAD THISOP / Set new operator as old operator 1136 01722 3055 DCA LASTOP 1137 01723 4545 ARGNXT, GETC / Get next character 1138 01724 4564 TESTC / Operator, number, "F", or other? 1139 01725 5363 JMP ELPAR / Operator, better be left pren 1140 01726 5332 JMP ENUM / Number 1141 01727 5343 JMP EFUN / Function name 1142 01730 5220 JMP OPNEXT-2 / Variable 1143 01731 0430 OPTABL, FGET I PT1 / Used to create FPP instructions 1144 01732 4543 ENUM, PUSHF / Push the FAC 1145 01733 0044 EXP 1146 01734 1125 TAD FLARGP / Point to left argument 1147 01735 3030 DCA PT1 1148 01736 3036 DCA INSUB / Set to input from memory 1149 01737 4531 JMS I COMBUF-1 / Parse the number 1150 01740 4544 POPF / Restore the FAC 1151 01741 0044 EXP 1152 01742 5222 JMP OPNEXT / Go look at next operator 1153 01743 3056 EFUN, DCA M20M / Store partial function name ("F") 1154 01744 4545 GETC / Get next character 1155 01745 4550 SORTC / Terminator? 1156 01746 1767 TERMS-1 1157 01747 5354 JMP EFUN2 / Yes, got function name 1158 01750 1056 TAD M20M / No, Shift hash code 1159 01751 7104 CLL RAL 1160 01752 1066 TAD CHAR / Add in new character 1161 01753 5343 JMP EFUN / Keep going 1162 01754 4562 EFUN2, TSTLPR / Expect a left pren 1163 01755 4566 ERROR4 / Oops, no left pren 1164 01756 4201 JMS ECALL / Solve for the first argument 1165 01757 1413 POPA / Pop the function name 1166 01760 4547 SORTJ / Dispatch the function call 1167 01761 2164 FNTARL-1 1168 01762 6207 FNTARF-FNTARL 1169 01763 4562 ELPAR, TSTLPR / Expect a left pren 1170 01764 4566 ERROR4 / Oops, no left pren 1171 01765 4201 EPAR2, JMS ECALL / Solve the operand 1172 01766 2013 ISZ XR13 / Discard the bogus function name 1173 01767 5536 RETURN / return 1174 01770 0240 TERMS, 0240 / Space 1175 01771 0253 0253 / Plus sign 1176 01772 0255 0255 / Minus sign 1177 01773 0257 0257 / Slash 1178 01774 0252 0252 / Asterisk 1179 01775 0336 0336 / Up Arrow 1180 01776 0250 0250 / Open parenthesis 1181 01777 0333 0333 / Left square bracket 1182 1183 *2000 1184 02000 0274 0274 / Less than 1185 02001 0251 0251 / Close parenthesis 1186 02002 0335 0335 / Right square bracket 1187 02003 0276 0276 / Greater than 1188 02004 0254 0254 / Comma 1189 02005 0273 0273 / Semicolon 1190 02006 0215 0215 / Carriage return 1191 02007 0275 0275 / Equal sign 1192 02010 4543 XSGN, PUSHF 1193 02011 2405 FLTONE 1194 02012 4544 DUMLN2, POPF 1195 02013 0044 EXP 1196 02014 1231 XABS, TAD FLARG+1 1197 02015 7710 SPA CLA 1198 02016 4451 JMS I MINSKI 1199 02017 4407 EFUN3, FINT / Store result as left operand 1200 02020 7000 FNOR 1201 02021 6230 FPUT FLARG 1202 02022 0000 FEXT 1203 02023 1125 TAD FLARGP / Set pointer to left operand 1204 02024 3030 DCA PT1 1205 02025 4247 JMS PARTES / Verify closing parenthesis 1206 02026 5627 JMP I .+1 / Go pretend successful variable reference 1207 02027 1622 OPNEXT 1208 02030 0000 FLARG, 0000 1209 02031 0000 0000 1210 02032 0000 0000 1211 02033 0000 0000 1212 02034 0003 P3, 3 / Distance between matched prens 1213 02035 0000 LPRTST, .-. / Check for left pren 1214 02036 1054 TAD P17M / Get operator 1215 02037 1121 TAD M11 / Subtract nine 1216 02040 7700 SMA CLA / Is it a pren? 1217 02041 5635 JMP I LPRTST / Definitely not (too large) 1218 02042 1054 TAD P17M / Maybe check other end of range 1219 02043 1120 TAD M5 1220 02044 7740 SZA SMA CLA / Too small? 1221 02045 2235 ISZ LPRTST / No, take skip return 1222 02046 5635 JMP I LPRTST / Return 1223 02047 0000 PARTES, .-. / See if closing pren matches opening 1224 02050 1413 POPA / Pop old operator off stack 1225 02051 3055 DCA LASTOP / and restore it 1226 02052 1234 TAD P3 / Get constant offset of 3 1227 02053 1413 POPA / Add to left pren number 1228 02054 7041 CIA / Negate 1229 02055 1054 TAD P17M / Compare to closing pren 1230 02056 7640 SZA CLA / Pren of correct type? 1231 02057 4566 M40M, ERROR4 / No, mismatched prens 1232 02060 4545 GETC / Yes, get next character 1233 02061 5647 JMP I PARTES / and return 1234 02062 0000 XDELET, .-. / Erase line(s) matching argument 1235 02063 6002 MCRM, IOF / Prevent Control-C 1236 02064 4555 FINDLN / Find the line 1237 02065 5662 JMP I XDELET / Already gone 1238 02066 2026 ISZ CHARM / Set quote mode to prevent trace 1239 02067 4545 GETC / Get next character 1240 02070 1066 TAD CHAR 1241 02071 1116 TAD MCR / End of line being deleted? 1242 02072 7640 SZA CLA 1243 02073 5267 JMP .-4 / No, keep scanning 1244 02074 1017 TAD TEXTP / Yes, get text pointer 1245 02075 7040 CMA / Subtract from line found 1246 02076 1023 TAD LISTL / to get -words-to-erase 1247 02077 3057 DCA CNTR / Remember -words-to-erase 1248 02100 1133 TAD CFRS / Get beginning-of-text 1249 02101 7041 CIA 1250 02102 1023 TAD LISTL / Trying to erase heading? 1251 02103 7650 M77, SNA CLA 1252 02104 5177 JMP START / Yes, restart 1253 02105 7000 NOP / ODD: Why NOP here 1254 02106 1423 TAD I LISTL / Get link from next line 1255 02107 3425 DCA I TEMPM / Move it to the previous line 1256 02110 1133 TAD CFRS / Start with header line 1257 02111 3071 DOK, DCA BDUMP / Save address of link word 1258 02112 1471 TAD I BDUMP / Get the link word 1259 02113 7450 SNA 1260 02114 5327 JMP DONE / Zero, the linked list is done 1261 02115 3032 DCA VAL / Save link word 1262 02116 1023 TAD LISTL / Subtract ptr to deleted from the link 1263 02117 7141 CLL CIA 1264 02120 1032 TAD VAL 1265 02121 7630 SZL CLA / Need adjustment? 1266 02122 1057 TAD CNTR / Yes, get adjustment (-words-to-erase) 1267 02123 1032 TAD VAL / Get (adjusted) pointer 1268 02124 3471 DCA I BDUMP / Update the pointer 1269 02125 1032 TAD VAL / Get unadjusted pointer 1270 02126 5311 JMP DOK / Go continue with linked list 1271 02127 7040 DONE, CMA / Set up autoindex for destination 1272 02130 1023 TAD LISTL / of the location of the deleted line 1273 02131 3011 DCA XRT 1274 02132 1057 TAD CNTR / Add words-to-erase 1275 02133 7040 CMA / to beginning of line being erased 1276 02134 1023 TAD LISTL 1277 02135 3012 DCA XR12 / To set up source pointer 1278 02136 1057 TAD CNTR / Get -words-to-erase 1279 02137 1060 TAD P4 / Compute new program end 1280 02140 3060 DCA P4 1281 02141 1010 TAD BETA / Form wrkptr-putptr-1 1282 02142 7040 CMA / Since we want to move the put area too 1283 02143 1012 TAD XR12 1284 02144 3032 DCA VAL / Save it as count 1285 02145 1010 TAD BETA / Adjust encode pointer 1286 02146 1057 TAD CNTR 1287 02147 3010 DCA BETA 1288 02150 1412 TAD I XR12 / Move a word 1289 02151 3411 DCA I XRT 1290 02152 2032 ISZ VAL / until all are moved 1291 02153 5350 JMP .-3 1292 02154 5263 JMP XDELET+1 / Delete more matches, if any 1293 02155 0000 CHIN, .-. 1294 02156 4464 JMS I INDEV / Get a character and save it 1295 02157 3066 DCA CHAR 1296 02160 4550 SORTC / Check for no-echo character 1297 02161 1623 ECHOLS-1 1298 02162 5755 JMP I CHIN / Do not echo, return 1299 02163 4551 PRINTC / Echo the character 1300 02164 5755 JMP I CHIN / Return 1301 02165 2533 FNTARL, "A^2+"B^2+"S / FABS / Table of function names, hashed 1302 02166 2650 "S^2+"G^2+"N / FSGN 1303 02167 2636 "I^2+"T^2+"R / FITR 1304 02170 2565 "D^2+"I^2+"S / FDIS 1305 02171 2630 "R^2+"A^2+"N / FRAN 1306 02172 2517 "A^2+"D^2+"C / FADC 1307 02173 2572 "A^2+"T^2+"N / FATN 1308 02174 2624 "E^2+"X^2+"P / FEXP 1309 02175 2625 "L^2+"O^2+"G / FLOG 1310 02176 2654 "S^2+"I^2+"N / FSIN 1311 02177 2575 "C^2+"O^2+"S / FCOS 1312 1313 *2200 1314 02200 2702 "S^2+"Q^2+"T / FSQT 1315 02201 2631 "N^2+"E^2+"W / FNEW 1316 02202 2567 "C^2+"O^2+"M / FCOM 1317 02203 0330 "X / FX 1318 02204 4564 ERASE, TESTC / Operator, numeric, "F", or Other? 1319 02205 5237 JMP ERVX / Operator, Erase variables only 1320 02206 5222 JMP ERL / Numeric, go parse argument 1321 02207 5213 JMP ERT-1 / "F", Error 1322 02210 1066 TAD CHAR / Other, is it an "A"? 1323 02211 1112 TAD MINUSA 1324 02212 7440 SZA 1325 02213 4566 ERROR4 / No, invalid argument 1326 02214 1135 ERT, TAD ENDT / Erase the whole program 1327 02215 3060 DCA P4 1328 02216 3533 DCA I CFRS / Clear forward link in header line 1329 02217 1060 ERV, TAD P4 / Erase the variables 1330 02220 3031 DCA PNTR 1331 02221 5177 JMP START / Restart 1332 02222 4554 ERL, GETLN / Get the line number 1333 02223 1060 TAD P4 / Prepare to copy lines?? 1334 02224 3010 DCA BETA 1335 02225 4565 ERG, DELETE / Delete the line 1336 02226 2023 ISZ LISTL / Point at next line number 1337 02227 1065 TAD NAGSW / Doing group erase? 1338 02230 7700 SMA CLA 1339 02231 1423 TAD I LISTL / Yes, check line number 1340 02232 4563 TSTGRP / Erase next line too? 1341 02233 5217 JMP ERV / No, Go erase variables and restart 1342 02234 1423 TAD I LISTL / Yes, get new line number 1343 02235 3067 DCA MZERO 1344 02236 5225 JMP ERG / Go erase it and check again 1345 02237 1060 ERVX, TAD P4 / Just erase the variables 1346 02240 3031 DCA PNTR 1347 02241 5541 POPJ / And wrap up the current line 1348 02242 0000 XFIND, .-. / Add a line to the program 1349 02243 1133 TAD CFRS / Insert line at front of program, if necessary 1350 02244 3025 DCA TEMPM 1351 02245 1133 TAD CFRS / Begin with the first line of the program 1352 02246 3023 FINDN, DCA LISTL / Store pointer to current line 1353 02247 1023 TAD LISTL / Copy pointer to an autoindex 1354 02250 3011 DCA XRT 1355 02251 1067 TAD MZERO / Get desired line number 1356 02252 7141 CLL CIA 1357 02253 1411 TAD I XRT / Is this the right line? 1358 02254 7450 SNA 1359 02255 5266 JMP FEND3-1 / Yes, go take skip return 1360 02256 7630 SZL CLA / Past it? 1361 02257 5267 JMP FEND3 / Yes (no such line), take non-skip return 1362 02260 1023 TAD LISTL / No, remember this line 1363 02261 3025 DCA TEMPM 1364 02262 1423 TAD I LISTL / and follow the link 1365 02263 7440 SZA / End of the program? 1366 02264 5246 JMP FINDN / No, Keep looking 1367 02265 7410 SKP / Yes, take non-skip return 1368 02266 2242 ISZ XFIND / Arrange for a skip return 1369 02267 1023 FEND3, TAD LISTL / Get the location of the line's text 1370 02270 7001 IAC / (less one for autoindex) 1371 02271 3017 DCA TEXTP / Set up to get text from the line 1372 02272 3020 DCA XCT 1373 02273 5642 JMP I XFIND / Return 1374 02274 0000 UTRA, .-. / Unpack 6-bit to ASCII and implement tracing 1375 02275 4330 JMS GET1 / Get 6-bit char, less 40 1376 02276 7710 UTF, SPA CLA / Add 100? 1377 02277 1006 TAD DIGITS / Yes, do it 1378 02300 1357 TAD M137 / Add -37 to check for special coding 1379 02301 1066 TAD CHAR / To character 1380 02302 7450 SNA / Is character a 137 (question mark)? 1381 02303 5316 JMP UTX / Yes, go deal with tracing 1382 02304 1075 TAD P337 / No, restore the character 1383 02305 3066 DCA CHAR / Store the character 1384 02306 1026 TAD CHARM / Are we unquoted 1385 02307 1100 TAD DLISTP / and tracing? 1386 02310 7650 SNA CLA 1387 02311 4551 PRINTC / Yes, print the character decoded 1388 02312 5674 JMP I UTRA / return 1389 02313 4330 EXTR, JMS GET1 / Get next 6-bit (control) character 1390 02314 7040 CMA / Don't add 100 1391 02315 5276 JMP UTRA+2 / Pretend we returned 1392 02316 1026 UTX, TAD CHARM / Got a 37, are we quoted? 1393 02317 7640 SZA CLA 1394 02320 5326 JMP GET1-2 / Yes, just return a question mark 1395 02321 1100 TAD DLISTP / No, complement trace switch 1396 02322 7650 SNA CLA 1397 02323 7001 IAC 1398 02324 3100 DCA DLISTP 1399 02325 5275 JMP UTRA+1 / and try again 1400 02326 1110 TAD IOTX / Get ASCII question mark 1401 02327 5305 JMP EXTR-6 / and go return it 1402 02330 0000 GET1, .-. / Unpack a 6-bit character, subtract 40 1403 02331 2020 ISZ XCT / Which side? 1404 02332 5345 JMP GET3 1405 02333 1021 TAD GTEM / Right side, get saved word 1406 02334 0122 GENO, AND P77 / Get the 6-bit 1407 02335 3066 DCA CHAR / Store as character 1408 02336 1066 TAD CHAR / Check for 77 1409 02337 1103 TAD OBUF1 1410 02340 7650 SNA CLA / OK to return it? 1411 02341 5313 JMP EXTR / No, go fix up for control character 1412 02342 1066 TAD CHAR / Yes, get 6-bit character 1413 02343 1356 TAD M40 / Subtract 40 for caller 1414 02344 5730 JMP I GET1 / and return 1415 02345 1417 GET3, TAD I TEXTP / Get next word 1416 02346 3021 DCA GTEM / Save it 1417 02347 7040 CMA / Other side next time 1418 02350 3020 DCA XCT 1419 02351 1021 TAD GTEM / Get word 1420 02352 7112 CLL RTR / Shift left side to right 1421 02353 7012 RTR 1422 02354 7012 RTR 1423 02355 5334 JMP GENO / Go finish up 1424 02356 7740 M40, -40 1425 02357 7641 M137, -137 1426 02360 0000 XENDLN, .-. / Link a new line into the program 1427 02361 7000 NOP / ODD: Why is this NOP here? 1428 02362 1425 TAD I TEMPM / Get the link from the previous line 1429 02363 3460 DCA I P4 / Store it into the new line 1430 02364 1060 TAD P4 / Get pointer to the new line 1431 02365 3425 DCA I TEMPM / Link the previous line to the new line 1432 02366 1061 TAD M4M / Was the last 6-bit character stored? 1433 02367 7440 SZA 1434 02370 3410 DCA I BETA / No, store it now 1435 02371 1010 TAD BETA / Get pointer to end of new line 1436 02372 7001 IAC / Make pointer to unused space 1437 02373 3060 DCA P4 / Store as new program end 1438 02374 1060 TAD P4 / Store also as end of variables 1439 02375 3031 UTQ, DCA PNTR / (erases all the variables) 1440 02376 5760 JMP I XENDLN / Return 1441 02377 1253 TLIST3, TASK4 / Unquote, go ignore and resume ask/type 1442 1443 *2400 1444 02400 0614 PC1 / CR, the line is done 1445 02401 6202 INFIX, FLINTP+2 / Back Arrow 1446 02402 0757 INPUT+1 / Rubout 1447 02403 0757 INPUT+1 / Line-feed 1448 02404 6250 ENDFI+5 / ALT 1449 02405 0001 FLTONE, 0001 / Floating point 1.0 1450 02406 2000 2000 1451 02407 0000 FLTZER, 0000 / Floating point 0.0 1452 02410 0000 0000 1453 02411 0000 0000 1454 02412 0000 0000 1455 02413 7766 M12, -7-3 / Negative ten 1456 02414 0000 I33, .-. 1457 02415 6031 KSF / Keyboard ready? 1458 02416 5215 JMP I33+1 / Nope, wait 1459 02417 6036 KRB / Yes, get character 1460 02420 0106 AND P177 / Mask off parity bit 1461 02421 7450 SNA / Is it a NUL? 1462 02422 5215 JMP I33+1 / Yes, ignore it 1463 02423 1123 TAD C200 / Set the parity bit 1464 02424 5614 JMP I I33 / Return the character 1465 02425 0000 XPRNT, .-. / Output AC as a line number 1466 02426 1067 TAD MZERO / Get high bits (integer part) 1467 02427 4557 RTL6 / To low bits 1468 02430 0122 AND P77 / Mask out cruft 1469 02431 4242 JMS PRNT / Print integer part 1470 02432 1102 TAD OBUFO / Print a decimal point 1471 02433 4551 PRINTC 1472 02434 1067 TAD MZERO / Now output low bits (fraction part) 1473 02435 4242 JMS PRNT 1474 02436 1356 TAD M140 / Get handy ASCII space equivalent 1475 02437 3066 DCA CHAR / and print it 1476 02440 4551 PRINTC 1477 02441 5625 JMP I XPRNT 1478 02442 0000 PRNT, .-. / Print low line number 1479 02443 0106 AND P177 / Force range 1480 02444 3032 DCA VAL / Save in work area 1481 02445 1113 TAD C260 / Get digit "0 for high digit 1482 02446 3033 MC200, DCA T3 1483 02447 5252 JMP .+3 / Go check for < ten 1484 02450 2033 ISZ T3 / >= ten, increment high digit 1485 02451 3032 XYZ, DCA VAL / Save partial result 1486 02452 1032 TAD VAL / Get partial result 1487 02453 1213 TAD M12 / Subtract ten 1488 02454 7500 SMA / Less than ten? 1489 02455 5250 JMP .-5 / No, keep subtracting 1490 02456 7200 CLA 1491 02457 1033 TAD T3 / Yes, output high digit 1492 02460 4551 PRINTC 1493 02461 1032 TAD VAL / Get remainder 1494 02462 1113 TAD C260 / Output it as low digit 1495 02463 4551 PRINTC 1496 02464 5642 JMP I PRNT / Return 1497 02465 0000 OUT, .-. / Print the character, and LF if needed 1498 02466 7450 SNA / Character in AC? 1499 02467 1066 TAD CHAR / No, get it from memory 1500 02470 1116 TAD MCR / Carriage return? 1501 02471 7450 SNA 1502 02472 5276 JMP OUTCR / Yes, go do CR-LF 1503 02473 1077 TAD CCR / No, restore character 1504 02474 4463 JMS I OUTDEV / Output it 1505 02475 5665 OUTX, JMP I OUT / Return 1506 02476 1077 OUTCR, TAD CCR / get CR 1507 02477 4463 JMS I OUTDEV / Output it 1508 02500 1076 TAD CLF / Get LF 1509 02501 5274 JMP OUTX-1 / Go output it 1510 02502 0000 PACBUF, .-. 1511 02503 1110 TAD IOTX / Is character a question mark? 1512 02504 7041 CIA 1513 02505 1066 TAD CHAR 1514 02506 7450 SNA 1515 02507 1352 TAD P40 / Yes, adjust to encode as 37 1516 02510 1101 TAD PCM / A RUBOUT (from the keyboard)? 1517 02511 7450 SNA 1518 02512 5755 JMP I RUBIT / Yes, go do a rubout 1519 02513 1353 TAD P377 / No, rebuild the character 1520 02514 3071 DCA BDUMP / Store it 1521 02515 1071 TAD BDUMP / Get character class 1522 02516 0354 AND C140 1523 02517 1356 TAD M140 / Is character in punctuation group? 1524 02520 7440 SZA 1525 02521 1354 TAD C140 / No, restore puntuation group 1526 02522 7650 SNA CLA / Control character group? 1527 02523 5332 JMP ESCA / Yes, go encode as 77 XX 1528 02524 1071 PA1, TAD BDUMP / Strip character to 6 bits 1529 02525 0122 AND P77 / Null? 1530 02526 7440 SZA 1531 02527 4335 JMS PCK1 / No, store it 1532 02530 7000 PACX, NOP / ODD: Why is this labelled NOP here? 1533 02531 5702 JMP I PACBUF / return 1534 02532 1122 ESCA, TAD P77 / Store 77 1535 02533 4335 JMS PCK1 1536 02534 5324 JMP PA1 / and then the character 1537 02535 0000 PCK1, .-. / Pack the 6-bit code in AC 1538 02536 2062 ISZ XCTIN / Which side? 1539 02537 5357 JMP ROT 1540 02540 1061 TAD M4M / Right, merge saved 6 bits 1541 02541 3410 DCA I BETA / Store and autoindex 1542 02542 3061 DCA M4M / Erase saved code 1543 02543 1013 TAD XR13 / Range check against stack pointer 1544 02544 7141 CLL CIA 1545 02545 1005 TAD P13 / 13 guard words 1546 02546 1010 TAD BETA 1547 02547 7620 SNL CLA / Out of room? 1548 02550 5735 JMP I PCK1 / No, return 1549 02551 4566 ERROR4 / Yes, error 1550 02552 0040 P40, 77-37 / Adjustment for encoding "? as 37 instead of 77 1551 02553 0377 P377, 377 1552 02554 0140 C140, 140 / ASCII character group mask 1553 02555 3004 RUBIT, RUB1 / Pointer to RUBOUT handler 1554 02556 7640 M140, -140 / ASCII punctuation group, negated 1555 02557 4557 ROT, RTL6 / Shift code left 1556 02560 3061 DCA M4M / Remember it 1557 02561 7040 CMA / Remember right side is next 1558 02562 3062 DCA XCTIN 1559 02563 5735 JMP I PCK1 / Return 1560 1561 *2600 1562 FXPRIN, 1563 02600 0000 SAVAC, .-. 1564 02601 0000 SAVLK, .-. 1565 02602 7575 MBREAK, -203 / Control-C, negated 1566 02603 3200 DCA SAVAC / Save AC 1567 02604 7010 RAR 1568 02605 3201 EXREAD, DCA SAVLK / Save L 1569 02606 6041 TSF / Teleprinter? 1570 02607 5225 JMP KINT / Nope 1571 02610 6042 TCF / Dismiss the interrupt 1572 02611 3016 DCA TELSW / Clear device busy flag 1573 02612 1665 TAD I OPTRI / Get next character 1574 02613 7450 SNA / or are we done? 1575 02614 5225 JMP KINT / Done 1576 02615 6044 EXCHEC, TPC / Not done, output the character 1577 02616 3016 DCA TELSW / Remember the device is busy 1578 02617 3665 DCA I OPTRI / Remove from ring buffer 1579 02620 1265 TAD OPTRI / Get buffer ptr 1580 02621 7001 IAC / Increment 1581 02622 0107 AND DECKP / Mask to stay in the ring 1582 02623 1263 RESUME, TAD OPTR0 / Restore high bits 1583 02624 3265 T2U, DCA OPTRI / Store buffer ptr 1584 02625 6031 KINT, KSF / Keyboard interrupt pending? 1585 02626 5246 JMP EXIT / Nope 1586 02627 6036 KRB / Yes, get the character 1587 02630 0106 ECCR, AND P177 / Lose the parity bit 1588 02631 7450 SNA / Got a null? 1589 02632 5246 JMP EXIT / Yes, ignore it 1590 02633 1123 TAD C200 / No, set parity bit 1591 02634 3262 DCA EXASK / Save the character 1592 02635 1262 TAD EXASK 1593 02636 1202 SINGLE, TAD MBREAK / Is it Control-C? 1594 02637 7650 SNA CLA 1595 02640 5340 JMP RECOVR / Yes 1596 02641 1034 TAD SLK / No, Get input buffer 1597 02642 7640 SZA CLA / Input buffer full? 1598 02643 4566 ERROR4 / Yes, choke 1599 02644 1262 TAD EXASK / No, move character 1600 02645 3034 DCA SLK / to input buffer 1601 02646 6011 EXIT, RSF / High speed reader data? 1602 02647 5252 JMP XB-3 / Nope 1603 02650 6012 RRB / Yes, read it 1604 02651 3037 DCA HINBUF / Store it, set ready state 1605 02652 6244 RMF / Restore Memory Field 1606 02653 6101 SMP / Check memory parity 1607 02654 7000 NOP / ...but ignore result 1608 02655 1201 XB, TAD SAVLK / Restore L 1609 02656 7104 XA, CLL RAL 1610 02657 1200 FXMOD, TAD SAVAC / Restore AC 1611 02660 6001 ION / Enable interrupts 1612 02661 5400 EXITJ, JMP I INTRPT / ...and return 1613 EXASK, 1614 02662 0000 SIN, .-. / Temp for input 1615 02663 3120 OPTR0, IOBUF / Output buffer address 1616 02664 3120 OPTRO, IOBUF / ENQ pointer 1617 02665 3120 OPTRI, IOBUF / DEQ pointer 1618 02666 0000 XI33, .-. 1619 02667 1034 TAD SLK / Get input buffer 1620 02670 7550 SNA SPA / Buffer empty? 1621 02671 5267 JMP .-2 / Yes, wait 1622 02672 3276 DCA XOUTL / No, save the character 1623 02673 3034 DCA SLK / Clear input buffer 1624 02674 1276 TAD XOUTL / Get the character 1625 02675 5666 JMP I XI33 / Return 1626 02676 0000 XOUTL, .-. 1627 02677 3266 DCA XI33 / Save character 1628 02700 6001 ION / Turn on interrupts 1629 02701 1664 TAD I OPTRO / Output buffer full? 1630 02702 7640 SZA CLA 1631 02703 5301 JMP .-2 / Yes, wait 1632 02704 6002 IOF / No, disable interrupts 1633 02705 1016 TAD TELSW / Output in progress? 1634 02706 7640 SZA CLA 1635 02707 5314 JMP ERROR5-11 / Yes, enque new character 1636 02710 1266 TAD XI33 / Get character 1637 02711 6046 TLS / No, Output it now 1638 02712 3016 DCA TELSW / Remember the device is busy 1639 02713 5323 JMP ERROR5-2 1640 02714 1266 TAD XI33 / Get character 1641 02715 3664 DCA I OPTRO / Add to print buffer 1642 02716 1264 TAD OPTRO / Increment ENQ buffer ptr 1643 02717 7001 IAC 1644 02720 0107 AND DECKP / Stay in buffer 1645 02721 1263 TAD OPTR0 / Add buffer base 1646 02722 3264 DCA OPTRO / Save new ENQ ptr 1647 02723 6001 ION / Enable interrupts 1648 02724 5676 JMP I XOUTL / Return 1649 02725 3326 ERROR5, DCA ERR2 / Pretend error called from 7777 1650 02726 0000 ERR2, .-. 1651 02727 7240 CLA CMA / Get -1 1652 02730 1326 TAD ERR2 / Get address of error call 1653 02731 3067 DCA MZERO / Set up to print as line number 1654 02732 6001 ION / Enable interrupts 1655 02733 1016 TAD TELSW / TTY Output busy? 1656 02734 7640 SZA CLA 1657 02735 5333 JMP .-2 / Yes, wait 1658 02736 6002 IOF / No, disable interrupts 1659 02737 5342 JMP .+3 / Go with given error number 1660 02740 1123 RECOVR, TAD C200 / Control-C, Get 01.00 as line number 1661 02741 3067 DCA MZERO / Set up to print as error number 1662 02742 2016 ISZ TELSW / Pretend output busy 1663 02743 1105 TAD IBUFO / Get -(output buffer size) 1664 02744 3057 DCA CNTR / Set up counter 1665 02745 7040 CMA / Get -1 1666 02746 1263 TAD OPTR0 / Point to output buffer-1 1667 02747 3010 DCA BETA / with autoindex register 1668 02750 7000 NOP 1669 02751 3410 DCA I BETA / Zero output buffer slot 1670 02752 2057 ISZ CNTR / Done whole buffer? 1671 02753 5351 JMP .-2 / Nope, keep going 1672 02754 3034 DCA SLK 1673 02755 1263 TAD OPTR0 / Reset DEQ Pointer 1674 02756 3265 DCA OPTRI 1675 02757 1263 TAD OPTR0 / Reset ENQ Pointer 1676 02760 3264 DCA OPTRO 1677 02761 7040 RECOVX, CMA / Sent RUBOUT to TTY 1678 02762 6046 TLS / (now device *is* busy) 1679 02763 1101 TAD PCM / Form "? 1680 02764 4551 PRINTC / Print it 1681 02765 4553 PRNTLN / Print error addr as line number 1682 02766 2022 ISZ PC / Point to line number 1683 02767 1422 TAD I PC / Get Line number 1684 02770 7450 SNA / Is it zero? 1685 02771 5377 JMP INITL-2 / Yes, don't print it 1686 02772 3067 DCA MZERO / Set up to print it 1687 02773 1101 TAD PCM / Get "@ 1688 02774 4551 PRINTC / Print it 1689 02775 4551 PRINTC / ? 1690 02776 4553 PRNTLN / Print line number 1691 02777 1077 TAD CCR / Get Carriage Return 1692 1693 *3000 1694 03000 4551 PRINTC / Print it 1695 03001 1126 INITL, TAD PTCH / Reset input routine 1696 03002 3152 DCA RDIV 1697 03003 5177 JMP START / and restart 1698 03004 1062 RUB1, TAD XCTIN / Store right next? 1699 03005 7640 SZA CLA 1700 03006 5214 JMP INITL4+3 / Yes, delete must be OK 1701 03007 1010 TAD BETA / No, at front of buffer? 1702 03010 7041 CIA 1703 03011 1027 INITL4, TAD TEMPT 1704 03012 7700 SMA CLA 1705 03013 5641 JMP I RUB5 / Yes, can't delete any more (go return) 1706 03014 1251 TAD SPLAT / OK to delete a character 1707 03015 4551 PRINTC / Print a backslash 1708 03016 1010 TAD BETA / Get pointer to last encoded word 1709 03017 3071 DCA BDUMP / Save it in non-autoindex 1710 03020 7000 NOP / ODD: Why a NOP here? 1711 03021 2062 ISZ XCTIN / Which side? 1712 03022 5242 JMP RUB2 / Go delete from right side 1713 03023 1471 TAD I BDUMP / Get 6-bit code before last 1714 03024 0122 AND P77 / Is it a control code? 1715 03025 1103 TAD OBUF1 1716 03026 7640 SZA CLA 1717 03027 5237 JMP RUB4 / No, just delete the character in PUTWRK 1718 03030 7040 RUB3, CMA / Yes, reset PUTSDE 1719 03031 3062 DCA XCTIN 1720 03032 7040 CMA / and decrement PUTPTR one full word 1721 03033 1010 TAD BETA 1722 03034 3010 DCA BETA 1723 03035 1471 TAD I BDUMP / Get the previous code word 1724 03036 0101 AND PCM / Extract the half to keep 1725 03037 3061 RUB4, DCA M4M / Store it it M4M 1726 03040 5641 JMP I RUB5 / Go return 1727 03041 2530 RUB5, PACX / Pointer to PACBUF routine return 1728 03042 1471 RUB2, TAD I BDUMP / Check encoded word 1729 03043 0101 AND PCM / Encode a control character? 1730 03044 1006 TAD DIGITS 1731 03045 7640 BUFRSP, SZA CLA 1732 03046 5230 M240M, JMP RUB3+1-1 / No, go lose right half 1733 03047 3471 DCA I BDUMP / Yes, Clear it 1734 03050 5231 JMP RUB3+1 / and go lose both sides 1735 03051 0334 SPLAT, 334 / ASCII Backslash 1736 1737 / 1738 / Dump the symbol table 1739 / 1740 03052 1060 TDUMP, TAD P4 / Start with first variable 1741 03053 3030 DCA PT1 / Remember where we are 1742 03054 1031 TAD PNTR / End of variables? 1743 03055 7041 CIA 1744 03056 1030 TAD PT1 1745 03057 7650 SNA CLA 1746 03060 5541 POPJ / Yes, we are done 1747 03061 1430 TAD I PT1 / No, get variable name 1748 03062 3316 DCA OP+1 / Store in text buffer 1749 03063 1315 TAD OP / Set up to unpack variable name 1750 03064 3017 DCA TEXTP 1751 03065 3020 DCA XCT / Unpack left 1752 03066 4545 GETC / Get first character of variable name 1753 03067 4551 PRINTC / Print it 1754 03070 4545 GETC / Get and print the second character 1755 03071 4551 PRINTC 1756 03072 4545 GETC / Decode and print a "(" 1757 03073 4551 PRINTC 1758 03074 2030 ISZ PT1 / Point at the subscript 1759 03075 1430 TAD I PT1 / Get the subscript 1760 03076 4714 JMS I PRNT2 / Output as an integer 1761 03077 4545 GETC / Get and print ")" 1762 03100 4551 PRINTC 1763 03101 2030 ISZ PT1 / Point to variable's value 1764 03102 4407 FINT 1765 03103 0430 FGET I PT1 / Get it 1766 03104 0000 FEXT 1767 03105 4530 JMS I FOUTPU / Print it 1768 03106 1077 TAD CCR / Print CR-LF 1769 03107 4551 PRINTC 1770 03110 1070 TAD DTABLE / Get variable length 1771 03111 1111 TAD M2 / Adjust by 2 words 1772 03112 1030 TAD PT1 / Form pointer to next variable 1773 03113 5253 JMP TDUMP+1 / Go output another, if any 1774 03114 2442 PRNT2, PRNT 1775 03115 3115 OP, OP+1-1 1776 03116 0000 .-. / Variable name goes here 1777 03117 5051 TEXT /()/ 03120 0000 1778 *.-1 1779 / 1780 / Terminal Output Buffer 1781 / 1782 IOBUF=. 1783 *.+20 / This is the TTY output buffer 1784 / 1785 / Command Mode input buffer 1786 / 1787 COMEIN=. 1788 *.+46 / This is the command line input buffer 1789 1790 / 1791 / Focal program space 1792 / 1793 *3206 1794 COMEOU, 1795 03206 3217 FRST, BUFBEG 1796 03207 0000 0000 / Line 00.00 (Heading) 1797 03210 0355 TEXT 'C-FOCAL,1969?M' 03211 0617 03212 0301 03213 1454 03214 6171 03215 6671 03216 7715 03217 0000 1798 *.-1 1799 BUFBEG=. 1800 / 1801 / The Focal part of the introductory dialog 1802 / 1803 BUFBEG, 1804 03217 3235 L01V10, L01V20 1805 03220 0212 0212 / 01.10 1806 03221 2440 TEXT 'T !"CONGRATULATIONS!!"?M' 03222 4142 03223 0317 03224 1607 03225 2201 03226 2425 03227 1401 03230 2411 03231 1716 03232 2341 03233 4142 03234 7715 03235 0000 1807 *.-1 1808 03235 3272 L01V20, L01V25 1809 03236 0224 0224 / 01.20 1810 03237 2440 TEXT 'T !"YOU HAVE SUCCESSFULLY LOADED ' 03240 4041 03241 4231 03242 1725 03243 4010 03244 0126 03245 0540 03246 2325 03247 0303 03250 0523 03251 2306 03252 2514 03253 1431 03254 4014 03255 1701 03256 0405 03257 0440 03260 0000 1811 *.-1 1812 03260 4706 TEXT "'FOCAL,1969' ON A ?M" 03261 1703 03262 0114 03263 5461 03264 7166 03265 7147 03266 4017 03267 1640 03270 0140 03271 7715 03272 0000 1813 *.-1 1814 03272 3330 L01V25, L01V26 1815 03273 0231 0231 / 01.25 1816 03274 2305 TEXT "SET PDP=PDP*2^11;D 1.26;DO 1.9;DO 2; T !" 03275 2440 03276 2004 03277 2075 03300 2004 03301 2052 03302 6236 03303 6161 03304 7304 03305 4061 03306 5662 03307 6673 03310 0417 03311 4061 03312 5671 03313 7304 03314 1740 03315 6273 03316 4024 03317 4041 03320 0000 1817 *.-1 1818 03320 4220 TEXT '"PROCEED."!!;R?M' 03321 2217 03322 0305 03323 0504 03324 5642 03325 4141 03326 7322 03327 7715 03330 0000 1819 *.-1 1820 03330 3354 L01V26, L01V27 1821 03331 0232 0232 / 01.26 1822 03332 1106 TEXT 'IF (PDP-6) 1.30,1.27;T "PDP-8/L";R?M' 03333 4050 03334 2004 03335 2055 03336 6651 03337 4061 03340 5663 03341 6054 03342 6156 03343 6267 03344 7324 03345 4042 03346 2004 03347 2055 03350 7057 03351 1442 03352 7322 03353 7715 03354 0000 1823 *.-1 1824 03354 3365 L01V27, L01V30 1825 03355 0233 0233 / 01.27 1826 03356 2440 TEXT 'T "PDP-12";R?M' 03357 4220 03360 0420 03361 5561 03362 6242 03363 7322 03364 7715 03365 0000 1827 *.-1 1828 03365 3403 L01V30, L01V40 1829 03366 0236 0236 / 01.30 1830 03367 1140 TEXT 'I (PDP-5)1.4;T "LAB-8"?M' 03370 5020 03371 0420 03372 5565 03373 5161 03374 5664 03375 7324 03376 4042 03377 1401 03400 0255 03401 7042 03402 7715 03403 0000 1831 *.-1 1832 03403 3421 L01V40, L01V50 1833 03404 0250 0250 / 01.40 1834 03405 1140 TEXT 'I (PDP-4)1.5;T "LINC-8?M' 03406 5020 03407 0420 03410 5564 03411 5161 03412 5665 03413 7324 03414 4042 03415 1411 03416 1603 03417 5570 03420 7715 03421 0000 1835 *.-1 1836 03421 3443 L01V50, L01V60 1837 03422 0262 0262 / 01.50 1838 03423 2440 TEXT 'T "PDP-";IF (PDP-3)1.6;T "8/I"?M' 03424 4220 03425 0420 03426 5542 03427 7311 03430 0640 03431 5020 03432 0420 03433 5563 03434 5161 03435 5666 03436 7324 03437 4042 03440 7057 03441 1142 03442 7715 03443 0000 1839 *.-1 1840 03443 3457 L01V60, L01V70 1841 03444 0274 0274 / 01.60 1842 03445 1106 TEXT 'IF (PDP-2)1.7;T "8?M' 03446 4050 03447 2004 03450 2055 03451 6251 03452 6156 03453 6773 03454 2440 03455 4270 03456 7715 03457 0000 1843 *.-1 1844 03457 3474 L01V70, L01V80 1845 03460 0306 0306 / 01.70 1846 03461 1106 TEXT 'IF (PDP-1)1.8;T "8/S?M' 03462 4050 03463 2004 03464 2055 03465 6151 03466 6156 03467 7073 03470 2440 03471 4270 03472 5723 03473 7715 03474 0000 1847 *.-1 1848 03474 3507 L01V80, L01V90 1849 03475 0320 0320 / 01.80 1850 03476 1106 TEXT 'IF (PDP)1.9;T "5?M' 03477 4050 03500 2004 03501 2051 03502 6156 03503 7173 03504 2440 03505 4265 03506 7715 03507 0000 1851 *.-1 1852 03507 3522 L01V90, L02V15 1853 03510 0332 0332 / 01.90 1854 03511 2440 TEXT 'T " COMPUTER."!!?M' 03512 4240 03513 0317 03514 1520 03515 2524 03516 0522 03517 5642 03520 4141 03521 7715 03522 0000 1855 *.-1 1856 03522 3531 L02V15, L02V20 1857 03523 0417 0417 / 02.15 1858 03524 2305 TEXT 'SET XF=1?M' 03525 2440 03526 3006 03527 7561 03530 7715 03531 0000 1859 *.-1 1860 03531 3546 L02V20, L02V25 1861 03532 0424 0424 / 02.20 1862 03533 2440 TEXT 'T !"SHALL I RETAIN "?M' 03534 4142 03535 2310 03536 0114 03537 1440 03540 1140 03541 2205 03542 2401 03543 1116 03544 4042 03545 7715 03546 0000 1863 *.-1 1864 03546 3562 L02V25, L02V30 1865 03547 0431 0431 / 02.25 1866 03550 2440 TEXT 'T "LOG, EXP, ATN _?M' 03551 4214 03552 1707 03553 5440 03554 0530 03555 2054 03556 4001 03557 2416 03560 4037 03561 7715 03562 0000 1867 *.-1 1868 03562 3601 L02V30, L02V40 1869 03563 0436 0436 / 02.30 1870 03564 0417 TEXT 'DO 10;IF (RE)2.9,2.4,2.4?M' 03565 4061 03566 6073 03567 1106 03570 4050 03571 2205 03572 5162 03573 5671 03574 5462 03575 5664 03576 5462 03577 5664 03600 7715 03601 0000 1871 *.-1 1872 03601 3632 L02V40, L02V50 1873 03602 0450 0450 / 02.40 1874 03603 0417 TEXT 'DO 2.2;T "SINE, COSINE _";DO 10;IF (RE)2.5;R?M' 03604 4062 03605 5662 03606 7324 03607 4042 03610 2311 03611 1605 03612 5440 03613 0317 03614 2311 03615 1605 03616 4037 03617 4273 03620 0417 03621 4061 03622 6073 03623 1106 03624 4050 03625 2205 03626 5162 03627 5665 03630 7322 03631 7715 03632 0000 1875 *.-1 1876 03632 3642 L02V50, L02V90 1877 03633 0462 0462 / 02.50 1878 03634 2340 TEXT 'S XF=-1; R?M' 03635 3006 03636 7555 03637 6173 03640 4022 03641 7715 03642 0000 1879 *.-1 1880 03642 3650 L02V90, L10V40 1881 03643 0532 0532 / 02.90 1882 03644 2340 TEXT 'S XF=0?M' 03645 3006 03646 7560 03647 7715 03650 0000 1883 *.-1 1884 03650 3673 L10V40, L10V45 1885 03651 2450 2450 / 10.40 1886 03652 0140 TEXT 'A RE;I (RE-0YES) 10.5,10.45,10.5?M' 03653 2205 03654 7311 03655 4050 03656 2205 03657 5560 03660 3105 03661 2351 03662 4061 03663 6056 03664 6554 03665 6160 03666 5664 03667 6554 03670 6160 03671 5665 03672 7715 03673 0000 1887 *.-1 1888 03673 3704 L10V45, L10V50 1889 03674 2455 2455 / 10.45 1890 03675 4023 TEXT ' SET RE=-1;R?M' 03676 0524 03677 4022 03700 0575 03701 5561 03702 7322 03703 7715 03704 0000 1891 *.-1 1892 03704 3721 L10V50, L10V60 1893 03705 2462 2462 / 10.50 1894 03706 1106 TEXT 'IF (RE-0NO)10.6,10.8?M' 03707 4050 03710 2205 03711 5560 03712 1617 03713 5161 03714 6056 03715 6654 03716 6160 03717 5670 03720 7715 03721 0000 1895 *.-1 1896 03721 3750 L10V60, L10V80 1897 03722 2474 2474 / 10.60 1898 03723 2440 TEXT 'T !"PLEASE ANSWER ' 03724 4142 03725 2014 03726 0501 03727 2305 03730 4001 03731 1623 03732 2705 03733 2240 03734 0000 1899 *.-1 1900 03734 4731 TEXT "'YES' OR 'NO' " 03735 0523 03736 4740 03737 1722 03740 4047 03741 1617 03742 4740 03743 0000 1901 *.-1 1902 03743 4273 TEXT '";G 10.4?M' 03744 0740 03745 6160 03746 5664 03747 7715 03750 0000 1903 *.-1 1904 03750 0000 L10V80, 0000 / Last line of program 1905 03751 2520 SAVE, 2520 / 10.80 1906 03752 2305 TEXT 'SET RE=1;R' 03753 2440 03754 2205 03755 7561 03756 7322 03757 0000 1907 *.-1 1908 03757 7715 7715 1909 1910 1911 *4370 / Introductory dialog 1912 04370 2741 O1, RECOVR+1 1913 04371 1370 BEGIN, TAD .-1 / Get Control-C handler 1914 04372 3176 DCA START-1 / Use it for restarts 1915 04373 6142 6142 1916 04374 6077 DSB 3 / Set VC8 to max brightness 1917 04375 6152 6152 1918 04376 6762 DCTA / Clear Dectape status register A 1919 04377 6012 RRB / Read high speed tape buffer 1920 04400 6346 6346 1921 04401 6772 DTRB / Read DECTape status register B 1922 04402 7300 CLA CLL 1923 04403 3414 DCA I FLTXR / Zero terminal output buffer 1924 04404 2057 ISZ CNTR / Until done 1925 04405 5203 JMP .-2 1926 04406 1362 TAD O2+1 / Look up/create "PD", the model variable 1927 04407 4371 JMS LOOKUP / Will create, so returns 0 in AC 1928 04410 1370 TAD PDP5 / Get PDP-5 setup routine address 1929 04411 3000 DCA 0000 / Branch there if PC is location 0 1930 04412 7040 O4, CMA / Get -1 1931 04413 6167 6167 1932 04414 7200 CLA / Get 0 1933 04415 6171 6171 / Have LINC hardware? 1934 04416 7650 SNA CLA 1935 04417 5226 JMP T12 / No, Keep looking 1936 04420 1365 ACTION, TAD P7 / Yes, TODO 1937 04421 6141 ONDECK, LINC 1938 04422 1366 OFFDEC, TAD P2 1939 04423 6141 LINC 1940 04424 7200 CLA 1941 04425 5310 JMP ATES-3 / Set PD for LINC 1942 04426 6141 T12, LINC / Check for LINC co-processor 1943 04427 0017 TEXTP / Use LINC to complement AC 1944 04430 0002 PDP / Swith back to PDP mode 1945 04431 7001 IAC / Did we get -1? 1946 04432 7650 SNA CLA / Got it? 1947 04433 5306 JMP ATES-5 / Yes, it is a PDP-12 1948 04434 7101 CLL IAC / Not a PDP-12, check for LAB-8 1949 04435 6344 6344 1950 04436 6331 6331 1951 04437 7700 SMA CLA / Got LAB-8 hardware? 1952 04440 5246 JMP BEND+4 / No, keep looking 1953 04441 1350 TAD L8A / Yes, get 6313 1954 04442 3752 BEND, DCA I L8AY / Patch 1153 (DYL) 1955 04443 1351 TAD L8B / Get 6307 1956 04444 3753 DCA I L8AX / Patch 1156 (DXS) 1957 04445 5307 JMP ATES-4 / Go report LAB-8 1958 04446 7354 CLA CLL CMA RAL RAR /Perform model dependent instruction 1959 04447 1367 TAD PDP8I / Got -4002? 1960 04450 7650 SNA CLA 1961 04451 5265 JMP ATEI / Yes, go check for model letter 1962 04452 7344 CLA CLL CMA RAL / No, compute -2 (Illegal on 8/S) 1963 04453 1366 TAD P2 / Did it work? 1964 04454 7650 SNA CLA 1965 04455 5312 JMP ATES-1 / Yes, it is a pre-model-letter PDP-8 1966 04456 1100 TAD DLISTP / No, Get HLT instruction 1967 04457 3764 DCA I O6 / Fix up memory parity check 1968 04460 1212 TAD O4 / Get a CMA instruction 1969 04461 3763 DCA I O5 / Set HSR timeout to 1 1970 04462 5313 JMP ATES / Go report PDP8/S 1971 04463 2761 PDP5X, ISZ I O2 / We're running on a PDP-5, fix ISR 1972 04464 5314 JMP ATES+1 / Go do Focal part 1973 04465 6046 ATEI, TLS / Start the teleprinter 1974 04466 6000 G8L, 6000 / Kill some time 1975 04467 6000 6000 1976 04470 6000 6000 1977 04471 6000 6000 1978 04472 6000 6000 1979 04473 6000 6000 1980 04474 6000 6000 1981 04475 6000 6000 1982 04476 2057 ISZ CNTR / Bump counter 1983 04477 6041 TSF / Teleprinter finished yet? 1984 04500 5266 JMP G8L / No, waste time 1985 04501 1057 TAD CNTR / Yes, check counter 1986 04502 1130 TAD FOUTPU / > 2000? 1987 04503 7710 SPA CLA 1988 04504 5311 JMP ATES-2 / No, slow old PDP-8/I 1989 04505 2430 ISZ I PT1 / Yes, is at least a PDP-8/L 1990 04506 2430 ISZ I PT1 / Is at least PDP-12 1991 04507 2430 ISZ I PT1 / Is at least LAB-8 1992 04510 2430 ISZ I PT1 / Is at least LINC-8 1993 04511 2430 ISZ I PT1 / Is at least PDP-8/I 1994 04512 2430 ISZ I PT1 / Is at least PDP-8 1995 04513 2430 ATES, ISZ I PT1 / Is at least PDP-8/S 1996 04514 6046 TLS / Start teleprinter 1997 04515 6001 ION / Got model, enable intterrupts 1998 04516 4540 PUSHJ / Run the FOCAL part of the dialog 1999 04517 0421 DO+1 2000 04520 6002 IOF / Disable interrupts 2001 04521 1360 TAD XF / Look up user's answers in variable XF 2002 04522 4371 JMS LOOKUP 2003 04523 7450 SNA / Non-zero? 2004 04524 5344 JMP OOUT / Zero, no functions to erase 2005 04525 7710 SPA CLA / Positive? 2006 04526 1366 TAD P2 / No, add 2 2007 04527 1120 TAD M5 / form -3 or -5 2008 04530 3057 DCA CNTR / Store count of functions to delete 2009 04531 1354 TAD FNPT / Set up pointer into function dispatch table 2010 04532 3011 DCA XRT 2011 04533 1355 TAD ER5 / Invalidate a function 2012 04534 3411 DCA I XRT 2013 04535 2057 ISZ CNTR / until done 2014 04536 5333 JMP .-3 2015 04537 1360 TAD XF / Get XF again 2016 04540 4371 JMS LOOKUP 2017 04541 7710 SPA CLA / Delete 3 or 5 functions? 2018 04542 1104 TAD OBUF0 / Delete 3, keep 2 pages 2019 04543 1356 TAD BFXX / Otherwise free up all the space 2020 04544 1357 OOUT, TAD BFX / Reset stack location 2021 04545 3035 DCA BOTTOM 2022 04546 5747 JMP I .+1 / Erase the program and return to command mode 2023 04547 2214 ERT 2024 04550 6313 L8A, 6313 / DYL equivalent 2025 04551 6307 L8B, 6307 / DXS equivalent 2026 04552 1153 L8AY, CONTIN+4 / Pointer to FDIS DYL instruction 2027 04553 1156 L8AX, XINT-2 / Pointer to FDIS DXS instruction 2028 04554 0401 FNPT, FNTARF+6-1 / Pointer to dispatch for deletable functions 2029 04555 2725 ER5, ERROR5 / Pointer to "No such function" error handler 2030 04556 0560 BFXX, TGO-FEXP / Distance from BOTTOM to first deletable function 2031 04557 4617 BFX, FEXP-1 / Future stack bottom, no functions deleted 2032 04560 3006 XF, 3006 / "XF", name of dialog answer variable 2033 04561 2661 O2, EXITJ / Patch location for interrupt return on PDP-5 2034 04562 2004 2004 / "PD", name of model variable 2035 04563 6322 O5, HREAD+1 / Used to adjust HSR timeout loop for the PDP-8/S 2036 04564 2654 O6, XB-1 / Patch location to HLT on memory parity errors 2037 04565 0007 P7, 7 / Handy constant 2038 04566 0002 P2, 2 / Handy constant 2039 04567 4002 PDP8I, -3776 / Result of CLA CLL CMA RAL RAR, negated 2040 04570 4462 PDP5, PDP5X-1 / Pointer to PDP-5 Initialization 2041 04571 2344 LOOKUP, 2344 / TODO: Why is this non-zero? 2042 04572 3061 DCA M4M / Store the variable name 2043 04573 4540 PUSHJ / Look up the variable, without subscript 2044 04574 1437 GS1 2045 04575 2030 ISZ PT1 / Point at the mantissa 2046 04576 1430 TAD I PT1 / Get high mantissa 2047 04577 5771 JMP I LOOKUP / return 2048 2049 *4620 2050 2051 04620 1045 FEXP, TAD HORD / E**x, positive argument? 2052 04621 7710 SPA CLA 2053 04622 4724 JMS I NEGP / No, negate 2054 04623 3033 DCA T3 / 2055 04624 4407 FINT 2056 04625 4313 FMUL LG2E / * log2(e) 2057 04626 6675 FPUT I X2 / Store argument 2058 04627 0000 FEXT 2059 04630 4453 JMS I INTEGE / Convert to integer 2060 04631 3325 DCA FLAG2 / Save integer part of exponent 2061 04632 4407 FINT 2062 04633 7000 FNOR / Normalize 2063 04634 6676 FPUT I XSQ2 / Save integer part 2064 04635 0675 FGET I X2 / Get the number 2065 04636 2676 FSUB I XSQ2 / Subtract integer part 2066 04637 6675 FPUT I X2 / Keep only fraction part 2067 04640 4675 FMUL I X2 / Form square 2068 04641 6676 FPUT I XSQ2 / and save it 2069 04642 1310 FADD DF / Add DF 2070 04643 6326 FPUT TEMP / Store 2071 04644 0305 FGET CF / Get CF 2072 04645 3326 FDIV TEMP / Divide by result 2073 04646 2675 FSUB I X2 / Subtract X 2074 04647 1277 FADD AF / Add AF 2075 04650 6326 FPUT TEMP / Store 2076 04651 0302 FGET BF / Get BF 2077 04652 4676 FMUL I XSQ2 / Multiply by x squared 2078 04653 1326 FADD TEMP / Add to stored 2079 04654 6326 FPUT TEMP 2080 04655 0675 FGET I X2 / Get X 2081 04656 3326 FDIV TEMP / Divide by stored 2082 04657 4321 FMUL TWO / * 2.0 2083 04660 1316 FADD ONE / + 1.0 2084 04661 0000 FEXT 2085 04662 1325 TAD FLAG2 / Add integer part to exponent 2086 04663 1044 TAD EXP 2087 04664 3044 DCA EXP 2088 04665 2033 ISZ T3 / Need to negate? 2089 04666 5536 RETURN / Nope, done 2090 04667 4407 FINT 2091 04670 6675 FPUT I X2 / FEXP(-x) = 1/FEXP(x) 2092 04671 0316 FGET ONE / Get 1.0 2093 04672 3675 FDIV I X2 / Form reciprocal 2094 04673 0000 FEXT 2095 04674 5536 RETURN / Return 2096 04675 5322 X2, X 2097 04676 5326 XSQ2, XSOR 2098 04677 0004 AF, 0004 2099 04700 2372 2372 2100 04701 1402 1402 2101 04702 7774 BF, 7774 2102 04703 2157 2157 2103 04704 5157 5157 2104 04705 0012 CF, 0012 2105 04706 5454 5454 2106 04707 0343 0343 2107 04710 0007 DF, 0007 2108 04711 2566 2566 2109 04712 5341 5341 2110 04713 0001 LG2E, 0001 / Log2(e) 2111 04714 2705 2705 2112 04715 2435 2435 2113 04716 0001 ONE, 0001 / 1.0 2114 04717 2000 2000 2115 04720 0000 0000 2116 04721 0002 TWO, 0002 / 2.0 2117 04722 2000 2000 2118 04723 0000 0000 2119 04724 5163 NEGP, FNEG 2120 04725 0000 FLAG2, .-. / Integer part of exponent 2121 04726 0000 TEMP, 0000 / Intermediate result 2122 04727 0000 0000 2123 04730 0000 0000 2124 04731 0000 0000 2125 04732 4407 ARCALG, FINT / TODO Part of FATN 2126 04733 0675 FGET I X2 / Form x squared 2127 04734 4675 FMUL I X2 2128 04735 6676 FPUT I XSQ2 / and store it 2129 04736 4374 FMUL BET2 / X**2+Beta2 2130 04737 1371 FADD BET1 / + Beta1 2131 04740 4676 FMUL I XSQ2 / *X**2 again 2132 04741 1366 FADD BETZ / + Beta0 2133 04742 6326 FPUT TEMP / Store it 2134 04743 0363 FGET ALF2 / Alpha2 2135 04744 4676 FMUL I XSQ2 / * X**2 2136 04745 1360 FADD ALF1 / + Alpha1 2137 04746 4676 FMUL I XSQ2 / * x**2 again 2138 04747 1355 FADD ALF1-3 / + Alpha0 2139 04750 4675 FMUL I X2 / * X**2 2140 04751 3326 FDIV TEMP / Divide by Beta term 2141 04752 0000 MULTY, FEXT 2142 04753 5754 JMP I .+1 / go continue FATN 2143 04754 5024 ARCRTN 2144 04755 0000 0000 / Alpha0 2145 04756 2437 2437 2146 04757 1643 1643 2147 04760 7777 ALF1, 7777 / Alpha1 2148 04761 3304 3304 2149 04762 4434 4434 2150 04763 7773 ALF2, 7773 / Alpha2 2151 04764 3306 3306 2152 04765 5454 5454 2153 04766 0000 BETZ, 0000 / Beta0 2154 04767 2437 2437 2155 04770 1646 1646 2156 04771 0000 BET1, 0000 / Beta1 2157 04772 2427 2427 2158 04773 2323 2323 2159 04774 7775 BET2, 7775 / Beta2 2160 04775 3427 3427 2161 04776 7052 7052 2162 2163 *5000 2164 05000 1045 ARTN, TAD HORD / FATN, Check sign of argument 2165 05001 7710 SPA CLA / Negative? 2166 05002 4363 JMS FNEG / Yes, Negate, return flag 2167 05003 3033 DCA T3 / Store negation flag 2168 05004 4407 FINT 2169 05005 6635 FPUT I X1 / Save argument 2170 05006 2637 FSUB I CON1 / Subtract 1.0 2171 05007 0000 FEXT 2172 05010 1045 TAD HORD / Argument > 1? 2173 05011 7710 SPA CLA 2174 05012 5221 JMP GO / No, proceed 2175 05013 4407 FINT 2176 05014 0637 FGET I CON1 / Yes, reciprocate X 2177 05015 3635 FDIV I X1 2178 05016 6635 FPUT I X1 2179 05017 0000 FEXT 2180 05020 7240 CLA CMA / Remeber we did it 2181 05021 3362 GO, DCA FLAG1 / Save reciprocal flag 2182 05022 5623 JMP I .+1 / Go do the work 2183 05023 4732 ARCALG 2184 05024 2362 ARCRTN, ISZ FLAG1 / Was argument reciprocated? 2185 05025 5634 JMP I EXIT1 / No, Go finish up 2186 05026 4407 FINT 2187 05027 6635 FPUT I X1 / Subtract result from PI/2 2188 05030 0636 FGET I PI2 2189 05031 2635 FSUB I X1 2190 05032 0000 FEXT 2191 05033 5634 JMP I EXIT1 / Go restore sign and return 2192 05034 5302 EXIT1, EXIT2 2193 05035 5322 X1, X 2194 05036 5316 PI2, PIOT 2195 05037 4716 CON1, ONE 2196 05040 1045 FLOG, TAD HORD / FLOG, Argument zero? 2197 05041 7450 SNA 2198 05042 4566 ERROR4 / Yes, error 2199 05043 7710 SPA CLA / Argument positive? 2200 05044 4451 JMS I MINSKI / No, negate 2201 05045 4407 FINT 2202 05046 6756 FPUT I TEM / Store argument as partial result 2203 05047 2637 FSUB I CON1 / Subtract 1.0 2204 05050 0000 FEXT 2205 05051 1045 TAD HORD / Zero now? 2206 05052 7450 SNA 2207 05053 5536 RETURN / Yes, we are done 2208 05054 7700 SMA CLA / Argument > 1.0? 2209 05055 5264 JMP STARTL / Yes, Skip negate 2210 05056 4407 FINT / Yes, FLOG(X) = -FLOG(1/X) 2211 05057 0637 FGET I CON1 / Reciprocate argument 2212 05060 3756 FDIV I TEM 2213 05061 6756 FPUT I TEM 2214 05062 0000 FEXT 2215 05063 7240 CLA CMA / Set negation switch 2216 05064 3033 STARTL, DCA T3 / Store negation switch 2217 05065 1005 TAD P13 / Craft exponent of 11 2218 05066 3044 DCA EXP 2219 05067 7040 CMA / Subtract 1 from exponent part of X 2220 05070 1756 TAD I TEM 2221 05071 3045 DCA HORD / And convert that to floating point 2222 05072 3046 DCA LORD 2223 05073 3047 DCA OVER2 2224 05074 7001 IAC / Set X exponent to 1 2225 05075 3756 DCA I TEM 2226 05076 4407 FINT 2227 05077 4357 FMUL LOG2 / Take former power of 2 * loge(2) 2228 05100 6635 FPUT I X1 / Store it 2229 05101 0756 FGET I TEM / Get argument 2230 05102 2637 FSUB I CON1 / Subtract 1.0 2231 05103 6756 FPUT I TEM / Store partial result 2232 05104 4353 FMUL LOG8 / Evaluate polynomial 2233 05105 1350 FADD LOG7 2234 05106 4756 FMUL I TEM 2235 05107 1345 FADD LOG6 2236 05110 4756 FMUL I TEM 2237 05111 1342 FADD LOG5 2238 05112 4756 FMUL I TEM 2239 05113 1337 FADD L4 2240 05114 4756 FMUL I TEM 2241 05115 1334 FADD L3 2242 05116 4756 FMUL I TEM 2243 05117 1331 FADD L2 2244 05120 4756 FMUL I TEM 2245 05121 1326 FADD L1 2246 05122 4756 FMUL I TEM 2247 05123 1635 FADD I X1 / Add exponent adjustment 2248 05124 0000 FEXT 2249 05125 5634 JMP I EXIT1 / We are done 2250 05126 0000 L1, 0000 2251 05127 3777 3777 2252 05130 7742 7742 2253 05131 7777 L2, 7777 2254 05132 4000 4000 2255 05133 4100 4100 2256 05134 7777 L3, 7777 2257 05135 2517 2517 2258 05136 0307 0307 2259 05137 7776 L4, 7776 2260 05140 4113 4113 2261 05141 7211 7211 2262 05142 7776 LOG5, 7776 2263 05143 2535 2535 2264 05144 3301 3301 2265 05145 7775 LOG6, 7775 2266 05146 4746 4746 / ODD: changed from 5466 2267 05147 0771 0771 2268 05150 7774 LOG7, 7774 2269 05151 2236 2236 2270 05152 4304 4304 2271 05153 7771 LOG8, 7771 2272 05154 4544 4544 2273 05155 1735 1735 2274 05156 4726 TEM, TEMP 2275 05157 0000 LOG2, 0000 2276 05160 2613 2613 2277 05161 4414 4414 2278 05162 0000 FLAG1, .-. / FATN took the reciprocal 2279 05163 0000 FNEG, .-. 2280 05164 4451 JMS I MINSKI 2281 05165 7240 CLA CMA 2282 05166 5763 JMP I FNEG 2283 2284 *5200 2285 05200 4407 FCOS, FINT / FCOS(X) = FSIN(PI/2-X) 2286 05201 6322 FPUT X / Save argument 2287 05202 0316 FGET PIOT / Form PI/2-X 2288 05203 2322 FSUB X 2289 05204 0000 FEXT / Fall into FSIN 2290 05205 1045 FSIN, TAD HORD / Argument positive nonzero? 2291 05206 7740 SZA SMA CLA 2292 05207 5215 JMP MOD / Yes, proceed 2293 05210 1045 TAD HORD / Argument negative? 2294 05211 7700 SMA CLA 2295 05212 5536 RETURN / No, return FSIN(0.0)=0.0 2296 05213 4451 JMS I MINSKI / Yes, negate: FSIN(-X)=-FSIN(X) 2297 05214 7040 CMA / Remenber to negate result 2298 05215 3033 MOD, DCA T3 / Store negation flag 2299 05216 4407 FINT / Compute X/(2*PI) 2300 05217 3306 FDIV TWOPI 2301 05220 6326 FPUT XSOR / and save it 2302 05221 0000 FEXT 2303 05222 4453 JMS I INTEGE / Get integer value of result 2304 05223 4407 FINT 2305 05224 7000 FNOR / Normalize 2306 05225 6322 FPUT X / Store FITR(X/(2*PI)) 2307 05226 0326 FGET XSOR / Get X/(2*PI) 2308 05227 2322 FSUB X / Get fractional part 2309 05230 4306 FMUL TWOPI / Get X modulo 2*PI 2310 05231 6322 FPUT X / and save argument 2311 05232 2312 FSUB PI / Subtract PI 2312 05233 0000 FEXT 2313 05234 1045 TAD HORD / X < PI? 2314 05235 7710 SPA CLA 2315 05236 5245 JMP PCHECK / Yes, proceed (Q1 or Q2) 2316 05237 4407 FINT / No, FSIN(X-PI)=-FSIN(X) 2317 05240 6322 FPUT X / Store X - PI 2318 05241 0000 FEXT 2319 05242 1033 TAD T3 / Toggle negation flag 2320 05243 7040 CMA 2321 05244 3033 DCA T3 2322 05245 4407 PCHECK, FINT / X < PI/2? 2323 05246 0322 FGET X 2324 05247 2316 FSUB PIOT / Subtract PI/2 2325 05250 0000 FEXT 2326 05251 1045 TAD HORD / Still positive? 2327 05252 7710 SPA CLA 2328 05253 5261 JMP PALG / No, range adjusted 2329 05254 4407 FINT / FSIN(X)=FSIN(PI-X) 2330 05255 0312 FGET PI / Yes, form PI-X 2331 05256 2322 FSUB X 2332 05257 6322 FPUT X 2333 05260 0000 FEXT 2334 05261 4407 PALG, FINT / Now in Q1 (range 0 to PI/2) 2335 05262 0322 FGET X 2336 05263 3316 FDIV PIOT / Scale 0..1 2337 05264 6322 FPUT X 2338 05265 4322 FMUL X / Square 2339 05266 6326 FPUT XSOR / and save 2340 05267 0332 FGET C9 / Constant 2341 05270 4326 FMUL XSOR / a*x^2 2342 05271 1336 FADD C7 / a*x^2+b 2343 05272 4326 FMUL XSOR / (a*x^2+b)x^2 2344 05273 1342 FADD C5 / (ax^2+b)x^2+c 2345 05274 4326 FMUL XSOR / ((ax^2+b)x^2+c)x^2 2346 05275 1346 FADD C3 / ((ax^2+b)x^2+c)x^2+d 2347 05276 4326 FMUL XSOR / (((ax^2+b)x^2+c)x^2+d)x^2 2348 05277 1316 FADD PIOT / Add PI/2 2349 05300 4322 FMUL X / Multply by X 2350 05301 0000 FEXT 2351 05302 2033 EXIT2, ISZ T3 / Result need negation? 2352 05303 5536 RETURN / No, we are done 2353 05304 4451 JMS I MINSKI / Yes, do it 2354 05305 5536 RETURN / We are done 2355 05306 0003 TWOPI, 0003 / 2*PI 2356 05307 3110 3110 2357 05310 3756 3756 2358 05311 3235 3235 2359 05312 0002 PI, 0002 / PI 2360 05313 3110 3110 2361 05314 3756 3756 2362 05315 3235 3235 2363 05316 0001 PIOT, 0001 / PI/2 2364 05317 3110 3110 2365 05320 3756 3756 2366 05321 3235 3235 2367 05322 0000 X, 0000 / Saves (mangled) argument 2368 05323 0000 0000 2369 05324 0000 0000 2370 05325 0000 0000 2371 05326 0000 XSOR, 0000 2372 05327 0000 0000 2373 05330 0000 0000 2374 05331 0000 0000 2375 05332 7764 C9, 7764 2376 05333 2401 2401 2377 05334 7015 7015 2378 05335 1042 1042 2379 05336 7771 C7, 7771 2380 05337 5464 5464 2381 05340 5514 5514 2382 05341 6150 6150 2383 05342 7775 C5, 7775 2384 05343 2431 2431 2385 05344 5361 5361 2386 05345 4736 4736 2387 05346 0000 C3, 0000 2388 05347 5325 5325 2389 05350 0414 0414 2390 05351 3167 3167 2391 2392 *5400 2393 05400 0000 TGO, .-. / Output the digits in the requested format 2394 05401 3334 DCA SCOUNT / Save digit count 2395 05402 1052 TAD FISW / Get format 2396 05403 4557 RTL6 / Get integer part 2397 05404 0122 AND P77 2398 05405 3032 DCA VAL / Save total digits 2399 05406 1032 TAD VAL / Get total digits 2400 05407 7041 CIA / Negate 2401 05410 7450 SNA / Zero? 2402 05411 1326 TAD MD / Yes, assume 6 digits 2403 05412 3335 DCA FCOUNT / Set up counter 2404 05413 1052 TAD FISW / Get format 2405 05414 7450 SNA / %0.0? 2406 05415 5241 JMP R6 / Yes, go do scientific notation rounding 2407 05416 0122 AND P77 / No, get fraction digits 2408 05417 3333 DCA DECP / Save digits to the right 2409 05420 1335 TAD FCOUNT / Get -total digits 2410 05421 1333 TAD DECP / Add digits to the right 2411 05422 7510 SPA / All digits to the right? 2412 05423 5230 JMP .+5 / No, proceed 2413 05424 7240 CLA CMA / Yes, make that all but one 2414 05425 1032 TAD VAL 2415 05426 3333 DCA DECP 2416 05427 7040 CMA / Add a digit 2417 05430 1033 TAD T3 / Get number of digits 2418 05431 7500 SMA / Negative? 2419 05432 7200 CLA / No, choose 0 2420 05433 1032 TAD VAL / Subtract from total digits 2421 05434 7510 SPA / Printing all digits? 2422 05435 5263 JMP FPRNT-2 / Yes, no rounding needed 2423 05436 1326 TAD MD / No, Compute -number being printed 2424 05437 7500 SMA / Chose zero if positive 2425 05440 7200 CLA 2426 05441 1327 R6, TAD RND2 / Add seven, get digits to round 2427 05442 3071 DCA BDUMP / Save digit count 2428 05443 1731 TAD I BUFST / Get pointer to output buffer 2429 05444 1071 TAD BDUMP / Add work 2430 05445 3336 DCA PLCE / Store end pointer 2431 05446 1071 TAD BDUMP / Negate digit count 2432 05447 7041 CIA 2433 05450 3071 DCA BDUMP / Set up rounding counter 2434 05451 1325 TAD K5 / get 5 (initial bump value) 2435 05452 2736 ISZ I PLCE / Increment current digit 2436 05453 1736 TAD I PLCE / Add digit 2437 05454 1330 TAD OM12 / Digit > 9? 2438 05455 7710 SPA CLA / Time to carry? 2439 05456 5265 JMP FPRNT / No, done rounding 2440 05457 3736 DCA I PLCE / Yes, set digit to zero 2441 05460 2071 ISZ BDUMP / bump count, done rounding? 2442 05461 5321 JMP DECR / No, Go adjust pointer and carry as needed 2443 05462 2736 ISZ I PLCE / Fudge carry from first digit 2444 05463 2033 ISZ T3 / Done a digit?? 2445 05464 7200 CLA 2446 05465 1052 FPRNT, TAD FISW / Get output format 2447 05466 7650 SNA CLA / Scientific notation? 2448 05467 5356 JMP FLOUT-1+1 / Yes, Go output x.xxxxx 2449 05470 1335 TAD FCOUNT / No, get total digits 2450 05471 1033 TAD T3 / Will it fit the requested format? 2451 05472 7540 SZA SMA 2452 05473 5355 JMP FLOUT-1 / No, go do as scientific notation 2453 05474 1333 TAD DECP / Add digits to the right 2454 05475 7500 SMA / Still fits? 2455 05476 7200 CLA / No, get a zero 2456 05477 7041 CIA / subtract from digits to the right 2457 05500 1033 TAD T3 2458 05501 7041 CIA / Negate 2459 05502 3032 DCA VAL / Save effective digits to the right 2460 05503 1033 BACK, TAD T3 / Get digits 2461 05504 1032 TAD VAL / Subtract total digits 2462 05505 7650 SNA CLA / Equal? 2463 05506 5343 JMP DIG / Yes, go output digits and zeroes 2464 05507 1032 TAD VAL / No, This ones digit or later? 2465 05510 7001 IAC 2466 05511 7710 SPA CLA 2467 05512 1105 TAD IBUFO / No, Convert '0' to space 2468 05513 4336 IN, JMS PLCE / Output digit 2469 05514 2032 ISZ VAL / Time for the dot? 2470 05515 5303 JMP BACK / No, keep going 2471 05516 1102 TAD OBUFO / Yes, output the dot 2472 05517 4551 PRINTC 2473 05520 5303 JMP BACK / Keep going 2474 05521 7040 DECR, CMA / Decrement the digit pointer 2475 05522 1336 TAD PLCE 2476 05523 3336 DCA PLCE / Store decremented pointer 2477 05524 5252 JMP R6+11 / Resume rounding 2478 05525 0005 K5, 5 / for rounding 2479 05526 7772 MD, -6 / Significant digits, negated 2480 05527 0007 RND2, 7 / Significant digits + 1 2481 05530 7766 OM12, -12 / Negative ten 2482 05531 6150 BUFST, SADR / Pointer to ptr to digit buffer 2483 05532 6154 OPUT, OUTDG / Output digit routine 2484 05533 0000 DECP, .-. / Digits to the right of decomal point 2485 05534 0000 SCOUNT, 0000 2486 05535 0000 FCOUNT, .-. / Total digits, negated 2487 OUTA, 2488 05536 0000 PLCE, .-. 2489 05537 4732 JMS I OPUT / Output a digit 2490 05540 2335 ISZ FCOUNT / Bump count 2491 05541 5736 JMP I PLCE / Return to output more 2492 05542 5600 JMP I TGO / Done with output 2493 05543 7040 DIG, CMA / Decrement digits 2494 05544 1033 TAD T3 2495 05545 3033 DCA T3 2496 05546 2334 ISZ SCOUNT / Done with left?? 2497 05547 5353 JMP .+4 / Nope, keep going with stored digits 2498 05550 7040 CMA / Reset to skip again 2499 05551 3334 DCA SCOUNT 2500 05552 5313 JMP IN / Proceed with a zero 2501 05553 1414 TAD I FLTXR / Get next digit 2502 05554 5313 JMP IN / Proceed with a real digit 2503 05555 7200 CLA / Scientific notation with leading zero 2504 05556 4732 FLOUT, JMS I OPUT / Output a digit 2505 05557 1102 TAD OBUFO / Output a dot 2506 05560 4551 PRINTC 2507 05561 2200 ISZ TGO / Arrange skip return for scientific notation 2508 05562 1414 TAD I FLTXR / Get next digit 2509 05563 4336 JMS PLCE / Ouput a digit 2510 05564 2334 ISZ SCOUNT / Done with digits? 2511 05565 5362 JMP .-3 / No, keep going 2512 05566 7040 CMA / Arragnge to skip again 2513 05567 3334 DCA SCOUNT 2514 05570 5363 JMP FLOUT+5 / Go print '0', relies on PUTNUM to return to our caller 2515 05571 0000 ABSOLV, .-. 2516 05572 1045 TAD HORD / Get FAC sign bit 2517 05573 3050 DCA SIGNF / Remember it 2518 05574 1045 TAD HORD / FAC negative? 2519 05575 7710 SPA CLA 2520 05576 4451 JMS I MINSKI / Yes, make it positive 2521 05577 5771 JMP I ABSOLV / Return 2522 2523 *5600 2524 05600 0000 DECONV, .-. 2525 05601 3046 DCA LORD / Store/zero middle FAC 2526 05602 3044 DCA EXP / Zero rest of FAC 2527 05603 3045 DCA HORD 2528 05604 3047 DCA OVER2 2529 05605 3314 DCA DNUMPR / Clear digit count 2530 05606 3050 DCA SIGNF / Clear sign of result 2531 05607 1066 TAD CHAR / Got plus sign? 2532 05610 1264 TAD MPLUS 2533 05611 7450 SNA 2534 05612 5220 JMP DECON-7 / Yes, expect a digit 2535 05613 1111 TAD M2 / Minus sign? 2536 05614 7640 SZA CLA 2537 05615 5221 JMP DECON-7+1 / No, must have a digit 2538 05616 7040 CMA / Remember to negate result for return 2539 05617 3050 DCA SIGNF 2540 05620 4666 JMS I XINPUT / Get a digit or space 2541 05621 1066 TAD CHAR / Got a space? 2542 05622 1265 TAD MSPACE 2543 05623 7650 SNA CLA 2544 05624 5220 JMP DECON-7 / Yes, ignore it 2545 05625 4227 JMS DECON / No, parse digit string 2546 05626 5600 JMP I DECONV / and return 2547 05627 0000 DECON, .-. / Input a string of digits as a number 2548 05630 1066 TAD CHAR / Is the character an E? 2549 05631 1262 TAD MINE 2550 05632 7650 SNA CLA 2551 05633 5627 JMP I DECON / Yes, return 2552 05634 4561 TESTN / Dot, Other, or Numeric? 2553 05635 5627 JMP I DECON / Dot, return 2554 05636 5247 JMP DTST / Other 2555 05637 1054 TAD P17M / Numeric, process new digit 2556 05640 3313 DSAVE, DCA DIGIT 2557 05641 4267 JMS MULT10 2558 05642 2314 ISZ DNUMPR / We have a digit 2559 05643 7640 SZA CLA 2560 05644 4566 ERROR4 / Overflow during input 2561 05645 4666 JMS I XINPUT / Get next character 2562 05646 5230 JMP DECON+1 / and process it 2563 05647 1066 DTST, TAD CHAR / Not a numeric digit 2564 05650 1112 TAD MINUSA / Possibly alphabetic? 2565 05651 7710 SPA CLA 2566 05652 5627 JMP I DECON / No, return 2567 05653 1066 TAD CHAR / Yes, get character 2568 05654 1263 TAD MINUSZ / Alphabetic? 2569 05655 7740 SZA SMA CLA 2570 05656 5627 JMP I DECON / No, return 2571 05657 1066 TAD CHAR / Yes, treat as digit 2572 05660 0122 AND P77 2573 05661 5240 JMP DSAVE 2574 05662 7473 MINE, -"E / "E for scientific notation 2575 05663 7446 MINUSZ, -"Z / Range check for alphabetic 2576 05664 7525 MPLUS, -"+ / ASCII plus sign, negated 2577 05665 7540 MSPACE, -" / ASCII space, negated 2578 05666 0756 XINPUT, INPUT / Get a character 2579 05667 0000 MULT10, .-. / FAC = FAC*10 + Digit 2580 05670 1047 TAD OVER2 / Copy FAC to operand 2581 05671 3043 DCA F 2582 05672 1046 TAD LORD 2583 05673 3042 DCA E 2584 05674 1045 TAD HORD 2585 05675 3041 DCA USERNO 2586 05676 3312 DCA REMAIN / Clear FAC overflow 2587 05677 4315 JMS MULT2 / *2 2588 05700 4315 JMS MULT2 / *4 2589 05701 4333 JMS DUBLAD / *5 2590 05702 4315 JMS MULT2 / *10 2591 05703 1313 TAD DIGIT / Set up new digit on operand 2592 05704 3043 DCA F 2593 05705 3042 DCA E / Zero mid and high mantissa 2594 05706 3041 DCA USERNO 2595 05707 4333 JMS DUBLAD / Add in new digit 2596 05710 1312 TAD REMAIN / Get overflow 2597 05711 5667 JMP I MULT10 / Return Overflow, if any 2598 05712 0000 REMAIN, .-. 2599 05713 0000 DIGIT, .-. 2600 05714 0000 DNUMPR, 0000 2601 05715 0000 MULT2, .-. / Shift FAC left (double it) 2602 05716 1047 TAD OVER2 / Get low FAC 2603 05717 7104 CLL RAL / Double it 2604 05720 3047 DCA OVER2 / Store result 2605 05721 1046 TAD LORD / Shift middle with carry 2606 05722 7004 RAL 2607 05723 3046 DCA LORD 2608 05724 1045 TAD HORD / Shift high with carry 2609 05725 7004 RAL 2610 05726 3045 DCA HORD 2611 05727 1312 TAD REMAIN / Shift overflow with carry 2612 05730 7004 RAL 2613 05731 3312 DCA REMAIN 2614 05732 5715 JMP I MULT2 / Return 2615 05733 0000 DUBLAD, .-. 2616 05734 7300 CLA CLL 2617 05735 1047 TAD OVER2 / Get FAC low 2618 05736 1043 TAD F / Add operand 2619 05737 3047 DCA OVER2 / Store result 2620 05740 7004 RAL / Get carry 2621 05741 1046 TAD LORD / + FAC mid 2622 05742 1042 TAD E / + operand mid 2623 05743 3046 DCA LORD / Store result 2624 05744 7004 RAL / Get carry 2625 05745 1045 TAD HORD / + FAC high 2626 05746 1041 TAD USERNO / + operand high 2627 05747 3045 DCA HORD / Store result 2628 05750 7004 RAL / Get carry 2629 05751 1312 TAD REMAIN / Add to overflow word 2630 05752 3312 DCA REMAIN 2631 05753 5733 JMP I DUBLAD / Return 2632 05754 0000 DIV1, .-. 2633 05755 7300 CLA CLL 2634 05756 1041 TAD USERNO / Get high operand mantissa 2635 05757 7510 SPA / Copy sign bit 2636 05760 7120 CLL CML 2637 05761 7010 RAR / Shift right 2638 05762 3041 DCA USERNO 2639 05763 1042 TAD E / Shift into mid-mantissa 2640 05764 7010 RAR 2641 05765 3042 DCA E 2642 05766 1043 TAD F / and low mantissa 2643 05767 7010 RAR 2644 05770 3043 DCA F 2645 05771 2040 ISZ ADDH / Adjust exponent 2646 05772 5754 JMP I DIV1 / Return (non-zero exponent) 2647 05773 5754 JMP I DIV1 / Return (zero exponent) 2648 2649 *6000 2650 06000 0000 FLOUTP, .-. 2651 06001 1335 TAD PEQ / Print equals sign 2652 06002 4551 PRINTC 2653 06003 1045 TAD HORD / FAC negative? 2654 06004 7700 SMA CLA 2655 06005 1334 TAD SMSP / No, make a space 2656 06006 1336 TAD SMIN / Add "- 2657 06007 4551 PRINTC / Print "- or space 2658 06010 4753 JMS I ABSOL2 / Take absolute value 2659 06011 3033 FGO2, DCA T3 / 2660 06012 1044 TAD EXP / Look at exponent 2661 06013 7510 SPA / Positive? 2662 06014 5227 RFC, JMP FGO3 / No, printing a fraction 2663 06015 7440 SZA / Zero? 2664 06016 1341 TAD LINC / No, subtract 4 2665 06017 7750 SNA SPA CLA / Still >= 0? 2666 06020 5234 JMP FGO4 / No, we have scaled the number 2667 06021 4407 FINT 2668 06022 4744 FMUL I PPTEN / Multiply by 0.1 2669 06023 0000 FEXT 2670 06024 7001 IAC / Increment power of 10 2671 06025 1033 TAD T3 2672 06026 5211 PLS, JMP FGO2 / and try again 2673 06027 4407 FGO3, FINT / Too small, scale up 2674 06030 4752 FMUL I TENPT / Multiply by 10 2675 06031 0000 FEXT 2676 06032 7040 CMA / Decrement power of 10 2677 06033 5225 JMP .-6 / and try again 2678 06034 3745 FGO4, DCA I DPT / Clear new digit 2679 06035 3746 DCA I REPT 2680 06036 1350 TAD SADR / Set up pointer to output buffer 2681 06037 3014 DCA FLTXR 2682 06040 1044 TAD EXP 2683 06041 7140 CLL CMA 2684 06042 3354 DCA OUTDG 2685 06043 1343 TAD DCOUNT / -7 is the buffer size 2686 06044 3044 DCA EXP 2687 06045 4527 JMS I DOUBLE / Denormalize 2688 06046 2354 ISZ OUTDG 2689 06047 5245 JMP .-2 2690 06050 1746 TAD I REPT / Any overflow bits? 2691 06051 7450 SNA 2692 06052 5270 JMP FGO5 / No, go do digits 2693 06053 1342 TAD FM12 / Yes, subtract ten 2694 06054 7710 SPA CLA / Positive? 2695 06055 5264 JMP DYL+1 / No, output digit 2696 06056 7001 IAC / Get a one 2697 06057 3414 DXS, DCA I FLTXR / Store the digit 2698 06060 2044 ISZ EXP / Bump digit count 2699 06061 1342 TAD FM12 / Subtract ten already output 2700 06062 2033 ISZ T3 / Bump power of 10 2701 06063 7000 DYL, NOP 2702 06064 1746 TAD I REPT / Get digit from overflow area 2703 06065 2033 ISZ T3 / Bump power of 10 2704 06066 7000 NOP 2705 06067 7410 SKP / Store the digit 2706 06070 4747 FGO5, JMS I H10PT / Get next digit 2707 06071 3414 DCA I FLTXR / Store the digit 2708 06072 2044 ISZ EXP / Bump digit count 2709 06073 5270 JMP FGO5 / Until done seven digits 2710 06074 1350 DSB, TAD SADR / Reset buffer pointer 2711 06075 3014 DCA FLTXR 2712 06076 1343 TAD DCOUNT / Get digit count 2713 06077 4751 JMS I ROUND / Output the digits 2714 06100 5600 JMP I FLOUTP / Return unless scientific notation 2715 06101 1333 TAD CHRT / Print an "E 2716 06102 4551 PRINTC 2717 06103 1033 TAD T3 2718 06104 7510 SPA 2719 06105 7041 CIA 2720 06106 3045 DCA HORD 2721 06107 1033 TAD T3 2722 06110 7700 SMA CLA / Negative? 2723 06111 1111 TAD M2 / No, Set up to print "+ 2724 06112 1336 TAD SMIN / Print "+ or "- 2725 06113 4551 PRINTC 2726 06114 1045 TAD HORD 2727 06115 2044 ISZ EXP 2728 06116 1337 TAD M144 / Subtract one-hundred 2729 06117 7500 SMA 2730 06120 5315 JMP .-3 / Positive, subtract again 2731 06121 1340 TAD C144 / Add one-hundred 2732 06122 3045 DCA HORD / Finished mod one-hundred 2733 06123 7040 CMA / Decrement hundreds and check 2734 06124 1044 TAD EXP 2735 06125 7440 SZA / Zero hundreds? 2736 06126 4354 JMS OUTDG / No, output the first digit of the power 2737 06127 1045 TAD HORD / Get last two digits 2738 06130 4732 JMS I PRNTI / Print them 2739 06131 5600 JMP I FLOUTP / Return 2740 06132 2442 PRNTI, PRNT / Print two digits 2741 06133 0305 CHRT, "E / ASCII "E for scientific notation 2742 06134 7763 SMSP, " -"- / ASCII space less ASCII minus sign 2743 06135 0275 PEQ, "= / ASCII equal sign 2744 06136 0255 SMIN, "- / ASCII minus sign 2745 06137 7634 M144, -144 / one hundred, negated 2746 06140 0144 C144, 144 / one hundred 2747 LINC, 2748 06141 7774 M4, -4 / 0 < 10 < 2**4, used to rangecheck exponent 2749 06142 7766 FM12, -12 / -ten 2750 06143 7771 DCOUNT, -7 / -7, used to initialize digit counter 2751 06144 6275 PPTEN, PTEN / pointer to 0.1 2752 06145 5713 DPT, DIGIT / New digit holder for NXTDIG 2753 06146 5712 REPT, REMAIN / High bits of NXTDIG result 2754 06147 5667 H10PT, MULT10 / Routine to multiply mantissa by 10 2755 06150 7467 SADR, BUFFER-1 / Used as an output buffer 2756 06151 5400 ROUND, TGO / Round and print in requested format 2757 06152 6271 TENPT, TEN / Pointer to 10.0 2758 06153 5571 ABSOL2, ABSOLV / Absolute value routine 2759 06154 0000 OUTDG, .-. / Output AC as a digit 2760 06155 1113 TAD C260 2761 06156 4551 PRINTC 2762 06157 5754 JMP I OUTDG 2763 2764 *6200 2765 06200 0000 FLINTP, .-. 2766 06201 7640 SZA CLA / Have first character? 2767 06202 4706 JMS I XIN / Input from TTY, also come here on user back-arrow 2768 06203 1066 TAD CHAR / Get the character 2769 06204 1114 TAD M240 / Is it a space? 2770 06205 7650 SNA CLA 2771 06206 5202 JMP .-4 / Yes, ignore it 2772 06207 4702 JMS I DPCVPT / No, parse a signed number 2773 06210 1066 TAD CHAR 2774 06211 1115 TAD MPER 2775 06212 7640 SZA CLA 2776 06213 5221 JMP FIGO1 2777 06214 4706 JMS I XIN / Get a character 2778 06215 3705 DCA I DPN 2779 06216 4703 JMS I DCONP / Get string of digits 2780 06217 1705 TAD I DPN / Get digit count 2781 06220 7041 CIA / Negate 2782 06221 3033 FIGO1, DCA T3 / Store division counter 2783 06222 1310 TAD P43 / Get decimal 35 (bit count) 2784 06223 3044 DCA EXP / Set as exponent 2785 06224 4704 JMS I RESOL5 / Get signed result 2786 06225 4707 JMS I INORM / Normalize 2787 06226 4407 FINT / Store result 2788 06227 6430 FPUT I PT1 2789 06230 0000 FEXT 2790 06231 1066 TAD CHAR / Get character 2791 06232 1301 TAD MINUSE / Got "E? 2792 06233 7640 SZA CLA 2793 06234 5246 JMP ENDFI+3 / No, not scientific notation 2794 06235 4706 JMS I XIN / Yes, Get next character 2795 06236 4702 JMS I DPCVPT / Parse a signed number 2796 06237 4704 JMS I RESOL5 / Get signed result 2797 06240 1047 TAD OVER2 / Get the number as integer 2798 06241 1033 TAD T3 / Add our power of ten 2799 06242 3033 DCA T3 / Store for scaling 2800 06243 4407 ENDFI, FINT 2801 06244 0430 FGET I PT1 / Get the result back 2802 06245 0000 FEXT 2803 06246 1033 TAD T3 / Get power of ten 2804 06247 7450 SNA / Is power zero? 2805 06250 5600 JMP I FLINTP / Yes, just return (Also come here on user ALTMODE) 2806 06251 7700 SMA CLA / Multiply or divide? 2807 06252 5261 JMP FIGO4 / Go multiply 2808 06253 4407 FINT / Divide, so multiply by 0.1 2809 06254 4275 FMUL PTEN 2810 06255 6430 FPUT I PT1 2811 06256 0000 FEXT 2812 06257 7001 IAC / Increment power 2813 06260 5266 JMP TEN-3 / and set up next iteration 2814 06261 4407 FIGO4, FINT / Multiply by ten 2815 06262 4271 FMUL TEN 2816 06263 6430 FPUT I PT1 2817 06264 0000 FEXT 2818 06265 7040 CMA / Decrement power 2819 06266 1033 TAD T3 / Adjust power for next loop 2820 06267 3033 DCA T3 2821 06270 5246 JMP ENDFI+3 / Go loop again 2822 06271 0004 TEN, 0004 / TODO 2823 06272 2400 2400 2824 06273 0000 0000 2825 06274 0000 0000 2826 06275 7775 PTEN, 7775 / TODO 2827 06276 3146 3146 2828 06277 3147 3147 2829 06300 3150 3150 2830 06301 7473 MINUSE, -"E / Scientific notation indicator 2831 06302 5600 DPCVPT, DECONV / Signed decimal input routine 2832 06303 5627 DCONP, DECON / Unsigned decimal input routine 2833 06304 7173 RESOL5, RESOLV / Copy sign to result 2834 06305 5714 DPN, DNUMPR / Pointer to input routine's digit counter 2835 06306 0756 XIN, INPUT / Get a character 2836 06307 7335 INORM, DNORM / Normalize 2837 06310 0043 P43, 43 / Decimal 35 2838 2839 *6321 / To just fit below FPNT 2840 06321 0000 HREAD, .-. / HSR Input routine 2841 06322 1105 TAD IBUFO / Get -20 in high timeout counter 2842 06323 3343 DCA HSWITC 2843 06324 1037 HREAD2, TAD HINBUF / Check HSR input buffer 2844 06325 7700 SMA CLA 2845 06326 5364 JMP HSGO / Input ready, go read it 2846 06327 2032 ISZ VAL / Increment low timeout counter 2847 06330 5324 JMP HREAD+3 / OK to try again 2848 06331 2343 ISZ HSWITC / Increment high timeout counter 2849 06332 5324 JMP HREAD+3 / OK to try again 2850 06333 4343 JMS HSWITC / Switch back to TTY input 2851 06334 1013 TAD XR13 / Check for command mode stack 2852 06335 1376 TAD HTST 2853 06336 7620 SNL CLA 2854 06337 5742 JMP I HSWITC-1 / Yes, Return to command mode 2855 06340 2013 ISZ XR13 / No, Pop stack 2856 06341 5541 POPJ / return using stack 2857 06342 0212 IBAR 2858 06343 0000 HSWITC, .-. / Toggles between TTY and HSR 2859 06344 1375 TAD HSPSW / Complement the "use HSR" flag 2860 06345 7040 CMA 2861 06346 3375 DCA HSPSW 2862 06347 7140 CLL CMA / Set input-not-ready 2863 06350 3037 DCA HINBUF 2864 06351 1375 TAD HSPSW / Using HSR? 2865 06352 7440 SZA 2866 06353 6014 RFC / Yes, kick-start HSR I/O 2867 06354 7640 SZA CLA / No, set up for TTY input 2868 06355 1377 TAD RESTP / Adjust input routine pointer 2869 06356 1126 TAD PTCH / for HSR or TTY 2870 06357 3152 DCA RDIV 2871 06360 5743 JMP I HSWITC / Return 2872 06361 4343 HSPX, JMS HSWITC / Toggle to use HSR 2873 06362 5763 JMP I .+1 / End of this command 2874 06363 0611 PROC / ODD: Silly jmp to jmp 2875 06364 7040 HSGO, CMA / Set input-not-ready for next time 2876 06365 3037 DCA HINBUF 2877 06366 6016 RRB RFC / Read character initiate fetch 2878 06367 0106 AND P177 / Strip parity bit 2879 06370 7450 SNA / Got leader? 2880 06371 5322 JMP HREAD+1 / Yes, try again 2881 06372 1123 TAD C200 / No, force parity bit on 2882 06373 3066 DCA CHAR / Store character 2883 06374 5721 JMP I HREAD / and return 2884 06375 0000 HSPSW, 0 / Toggle for HSR or TTY 2885 06376 4557 HTST, RTL6 / TODO 2886 06377 4144 RESTP, HREAD-CHIN / Pointer adjustment to switch input routines 2887 2888 *6400 2889 06400 0000 FPNT, .-. 2890 06401 7300 CLA CLL 2891 06402 3047 DCA OVER2 2892 06403 3043 DCA F 2893 06404 1600 TAD I FPNT / Get FP Instruction 2894 06405 7450 SNA / FEXT (0)? 2895 06406 5600 JMP I FPNT / Yes, Return 2896 06407 3262 DCA JUMP 2897 06410 1262 TAD JUMP 2898 06411 0123 AND C200 / Get page bit 2899 06412 7650 SNA CLA / Page bit set? 2900 06413 5216 JMP .+3 / No, skip page part 2901 06414 1104 TAD OBUF0 / No, get page mask 2902 06415 0200 AND FPNT / Get page base 2903 06416 3040 DCA ADDH / Store base address 2904 06417 1106 TAD P177 / Get offset mask 2905 06420 0262 AND JUMP / Get offset 2906 06421 1040 TAD ADDH / Add to page base 2907 06422 3040 DCA ADDH / Store referenced address 2908 06423 1263 TAD INDRCT / Get indirect bit 2909 06424 0262 AND JUMP / Set in the instruction? 2910 06425 7650 SNA CLA 2911 06426 5231 JMP .+3 / No, skip indirection 2912 06427 1440 TAD I ADDH / Yes, Get referenced address 2913 06430 3040 DCA ADDH / and save it 2914 06431 2200 LOOP01, ISZ FPNT / Skip instruction on return or loop 2915 06432 7040 CMA / Get -1 2916 06433 1040 TAD ADDH / Get pointer to operand 2917 06434 3015 DCA FLTXR2 / Set up source autoindex 2918 06435 1262 TAD JUMP / Get instruction 2919 06436 7106 CLL RTL / Shift for opcode bits 2920 06437 7006 RTL 2921 06440 0107 AND DECKP / Mask for just opcode 2922 06441 7450 SNA / Opcode 0 is GET 2923 06442 5267 JMP FLGT / Go do a GET 2924 06443 1264 TAD TABLE / Index into table 2925 06444 3262 DCA JUMP / Save table pointer 2926 06445 1662 TAD I JUMP / Get address of handler 2927 06446 7450 SNA / Special entry for PUT? 2928 06447 5265 JMP FLPT / Yes, go do a PUT 2929 06450 3262 DCA JUMP / No, save handler pointer 2930 / Need to fetch operand 2931 06451 1304 TAD CEX1 / Get pointer to operand 2932 06452 3014 DCA FLTXR / Set up destination autoindex 2933 06453 1117 TAD MFLT / Get length of FP number 2934 06454 3057 DCA CNTR / Set up counter 2935 06455 1415 TAD I FLTXR2 / Get next word 2936 06456 3414 DCA I FLTXR / Copy to operand area 2937 06457 2057 ISZ CNTR / Done yet? 2938 06460 5255 JMP .-3 / No, Keep copying 2939 06461 5662 JMP I JUMP / Yes, go to opcode handler 2940 06462 0000 JUMP, .-. 2941 06463 0400 INDRCT, 400 2942 06464 6573 TABLE, ITABLE+1-1 2943 06465 1303 FLPT, TAD CEXP / Get pointer to FAC 2944 06466 5273 JMP FLGT+4 / Jump to copy loop 2945 06467 1303 FLGT, TAD CEXP / Set up FAC 2946 06470 3015 DCA FLTXR2 / as destination 2947 06471 7040 CMA / get pointer to operand 2948 06472 1040 TAD ADDH 2949 06473 3014 DCA FLTXR / store source address 2950 06474 1117 TAD MFLT / Get FAC size 2951 06475 3057 DCA CNTR / Initialize count 2952 06476 1414 TAD I FLTXR / Fetch a word 2953 06477 3415 DCA I FLTXR2 / and copy it 2954 06500 2057 ISZ CNTR / Done yet? 2955 06501 5276 JMP .-3 / No, Keep going 2956 06502 5201 JMP FPNT+1 / Yes, on to next instruction 2957 06503 0043 CEXP, EXP-1 2958 06504 0037 CEX1, ADDH-1 2959 06505 4765 FLSU, JMS I OPMINS / Negate the operand, then ADD 2960 06506 4770 FLAD, JMS I RAR1-1 / Attempt alignment 2961 06507 5201 JMP FPNT+1 / Operand too small, we're done 2962 06510 4772 JMS I ALGN / Shift FAC right one bit 2963 06511 4771 JMS I RAR1 / ...and operand too 2964 06512 4773 JMS I ITABLE / Add aligned mantissas 2965 06513 4767 NORF, JMS I NORM / Normalize the result in FAC 2966 06514 5201 JMP FPNT+1 / Done, onward to next instruction 2967 06515 1045 FLEX, TAD HORD / Get high FAC bits 2968 06516 7640 SZA CLA / FAC == 0.0? 2969 06517 5325 JMP ZERO+5 / No, Go look at exponent 2970 06520 3044 ZERO, DCA EXP / Set result to 0.0 2971 06521 3045 DCA HORD 2972 06522 3046 DCA LORD 2973 06523 3047 DCA OVER2 2974 06524 5201 JMP FPNT+1 / Done 2975 06525 4543 PUSHF / Push FAC 2976 06526 0044 EXP 2977 06527 4543 PUSHF / PUSH Operand (exponent) 2978 06530 0040 ADDH 2979 06531 4544 POPF / Pop exponent 2980 06532 0044 EXP 2981 06533 4453 JMS I INTEGE / Convert to integer 2982 06534 7510 SPA / Negative? 2983 06535 5342 JMP FLMY-21 / Yes, go Bail 2984 06536 7040 CMA / No, negate and subract one 2985 06537 3262 DCA JUMP / Save counter 2986 06540 3043 DCA F / Truncate low FAC bits 2987 06541 1045 TAD HORD / Get high mantissa 2988 06542 7640 SZA CLA / FAC > 2047? 2989 06543 4566 ERROR4 / Yes, Bail 2990 06544 4543 PUSHF / No, Push a one 2991 06545 2405 FLTONE 2992 06546 4544 POPF / Pop into FAC 2993 06547 0044 EXP 2994 06550 4544 POPF / Unstack base 2995 06551 7470 BUFFER 2996 06552 5360 JMP FLMY-3 / Go return one 2997 06553 4543 PUSHF / Copy multiplicand 2998 06554 7470 BUFFER 2999 06555 4544 POPF / to operand 3000 06556 0040 ADDH 3001 06557 4766 JMS I MULT / Multiply 3002 06560 2262 ISZ JUMP / Done yet? 3003 06561 5353 JMP FLMY-10 / No, multiply again 3004 06562 5201 JMP FPNT+1 / Yes, on to next instruction 3005 06563 4766 FLMY, JMS I MULT / Multiply by operand 3006 06564 5201 JMP FPNT+1 / onward to next instruction 3007 06565 7153 OPMINS, MINUS2 3008 06566 7004 MULT, DMULT 3009 06567 7335 NORM, DNORM 3010 06570 6623 ALIGN 3011 06571 5754 RAR1, DIV1 3012 ALGN, 3013 06572 6757 RAR2, DIV2 3014 ITABLE, 3015 06573 5733 TRAD, DUBLAD 3016 06574 6506 FLAD 3017 06575 6505 FLSU 3018 06576 7107 FLDV 3019 06577 6563 FLMY 3020 3021 *6600 3022 06600 6515 FLEX / Include 0^N = 0 rule 3023 06601 0000 0000 3024 06602 6513 NORF 3025 06603 0000 .-. / Negate floating point number 3026 06604 7300 CLA CLL 3027 06605 1047 TAD OVER2 / Get low mantissa 3028 06606 7041 CIA / Complement, increment 3029 06607 3047 DCA OVER2 3030 06610 1046 TAD LORD / Carry into mid-mantissa 3031 06611 7040 CMA 3032 06612 7430 SZL 3033 06613 7101 CLL IAC 3034 06614 3046 DCA LORD 3035 06615 1045 TAD HORD / Carry into high mantissa 3036 06616 7040 CMA 3037 06617 7430 SZL 3038 06620 7101 CLL IAC 3039 06621 3045 DCA HORD 3040 06622 5603 JMP I ITABLE+10 / Return 3041 06623 0000 ALIGN, .-. / Align FAC and operand for addition 3042 06624 1045 TAD HORD / Get FAC high mantissa 3043 06625 7450 SNA / Non-zero? 3044 06626 1046 TAD LORD / No, check mid-mantissa 3045 06627 7650 SNA CLA / Still zero? 3046 06630 5311 JMP NOX1 / Yes, return operand (failure) 3047 06631 1041 TAD USERNO / Check operand high mantissa 3048 06632 7450 SNA / Zero? 3049 06633 1042 TAD E / Yes, check mid-mantissa 3050 06634 7450 SNA / Still zero? 3051 06635 1043 TAD F / Yes, check low mantissa 3052 06636 7650 SNA CLA / Still zero? 3053 06637 5623 JMP I ALIGN / Yes, return FAC (failure) 3054 06640 1040 TAD ADDH / Check exponents 3055 06641 7041 CIA 3056 06642 1044 TAD EXP / Exponents equal? 3057 06643 7450 SNA 3058 06644 5273 JMP ADONE / Yes, done (success) 3059 06645 3203 DCA ITABLE+10 / No, save shift count 3060 06646 1203 TAD ITABLE+10 / Get shift count 3061 06647 7500 SMA / Form negative of absolute value 3062 06650 7041 CIA 3063 06651 3322 DCA AMOUNT / Store as loop counter 3064 06652 1322 TAD AMOUNT / Get loop counter 3065 06653 1336 TAD TEST2 / Range check 3066 06654 7710 SPA CLA / Shift too large? 3067 06655 5275 JMP NOX / Yes, fail 3068 06656 1203 TAD ITABLE+10 / Get difference of exponents 3069 06657 7700 SMA CLA / Shift FAC or operand? 3070 06660 5265 JMP ASHFT / Go shift operand 3071 06661 4357 JMS DIV2 / Shift FAC 3072 06662 2322 ISZ AMOUNT / Done yet? 3073 06663 5261 JMP .-2 / No, again 3074 06664 5273 JMP ADONE / Yes, return success 3075 06665 7040 ASHFT, CMA / Form -1 3076 06666 1040 TAD ADDH / Decrement operand exponent 3077 06667 3040 DCA ADDH 3078 06670 4723 JMS I TAG1 / Shift operand right 3079 06671 2322 ISZ AMOUNT / Done yet? 3080 06672 5270 JMP .-2 / No, again 3081 ACMINS, 3082 06673 2223 ADONE, ISZ ALIGN / Skip for success return 3083 06674 5623 JMP I ALIGN / Return 3084 06675 1040 NOX, TAD ADDH / Get operand exponent 3085 06676 7700 SMA CLA / Negative? 3086 06677 5304 JMP NOX2 / No, go check FAC 3087 06700 1044 TAD EXP / Check FAC exponent 3088 06701 7700 SMA CLA / Also negative? 3089 06702 5623 JMP I ALIGN / No, return FAC (failure) 3090 06703 5306 JMP NOX2+2 / Both negative, go compare 3091 06704 1044 NOX2, TAD EXP / FAC exponent also positive? 3092 06705 7700 SMA CLA / Yes, force zero 3093 06706 1203 TAD ITABLE+10 / No, get difference of exponents 3094 06707 7740 SZA SMA CLA / Operand larger than FAC? 3095 06710 5623 JMP I ALIGN / No, return FAC (failure) 3096 06711 1040 NOX1, TAD ADDH / Copy the operand exponent 3097 06712 3044 DCA EXP 3098 06713 1041 TAD USERNO / Copy high mantissa 3099 06714 3045 DCA HORD 3100 06715 1042 TAD E / Copy mid-mantissa 3101 06716 3046 DCA LORD 3102 06717 1043 TAD F / and low mantissa 3103 06720 3047 DCA OVER2 3104 06721 5623 JMP I ALIGN / Return (failure) 3105 06722 0000 AMOUNT, .-. 3106 06723 5754 TAG1, DIV1 3107 06724 0000 FIX, .-. / Return the integer part of the FAC 3108 06725 4751 JMS I ABSOL / Get absolute value 3109 06726 1044 TAD EXP / Exponent zero imlies <0.5 3110 06727 7750 SNA SPA CLA 3111 06730 5353 JMP FIXM / Yes, go zero result 3112 06731 7001 IAC / No, increment it 3113 06732 3043 DCA F / Store as operand 3114 06733 1350 TAD P27 / Get 23 3115 06734 3040 DCA ADDH / Set as operand exponent 3116 06735 4223 JMS ALIGN / Align for addition 3117 06736 0027 TEST2, 27 / Number of mantissa bits (w/o sign) 3118 / (also harmless AND instruction) 3119 06737 2047 ISZ OVER2 / Bump low FAC 3120 06740 5344 JMP P27-4 / No carry, finish up 3121 06741 2046 ISZ LORD / Propogate carry 3122 06742 7410 SKP / No middle carry, finish up 3123 06743 2045 ISZ HORD / Propogate carry 3124 06744 3047 DCA OVER2 / Truncate low result 3125 06745 4752 JMS I RESOL / Restore sign of result 3126 06746 1046 TAD LORD / Return mid-mantissa 3127 06747 5724 JMP I FIX 3128 06750 0027 P27, 27 3129 06751 5571 ABSOL, ABSOLV 3130 06752 7173 RESOL, RESOLV 3131 06753 3044 FIXM, DCA EXP / Zero the FAC 3132 06754 3045 DCA HORD 3133 06755 3046 DCA LORD 3134 06756 5344 JMP P27-4 / Go return 3135 06757 0000 DIV2, .-. 3136 06760 7300 CLA CLL 3137 06761 1045 TAD HORD / Get high mantissa 3138 06762 7510 DCTA, SPA / Copy sign bit 3139 06763 7020 CML 3140 06764 7010 RAR / Rotate right 3141 06765 3045 DCA HORD 3142 06766 1046 TAD LORD / Shift into mid-mantissa 3143 06767 7010 RAR 3144 06770 3046 DCA LORD 3145 06771 1047 TAD OVER2 / and low mantissa 3146 06772 7010 DTRB, RAR 3147 06773 3047 DCA OVER2 3148 06774 2044 ISZ EXP / Increment exponent to preserve value 3149 06775 5757 JMP I DIV2 / Return (non-zero exponent) 3150 06776 5757 JMP I DIV2 / Return (zero exponent) 3151 06777 0337 SPECIA, 337 / Back Arrow 3152 3153 *7000 3154 07000 0377 SPL, 377 / RUBOUT 3155 07001 0212 IAC, 212 / Line-feed 3156 07002 0375 375 / ALT 3157 07003 7777 7777 / Terminate list 3158 07004 0000 DMULT, .-. / Floating Pint Multiply Routine 3159 07005 7001 IAC / Add 1 3160 07006 1040 TAD ADDH / Add operand exponent 3161 07007 4324 JMS SIGN / Compute sign of result 3162 07010 7710 SPA CLA / Operand positive? 3163 07011 4353 JMS MINUS2 / No, fix it 3164 07012 3301 DCA MULDIV / TODO 3165 07013 3300 DCA MULDIV-1 3166 07014 3277 DCA MULDIV-2 3167 07015 3276 DCA MULDIV-3 3168 07016 1045 TAD HORD 3169 07017 3751 DCA I DIVIDE+1 3170 07020 1041 TAD USERNO 3171 07021 4752 JMS I MINUS2-1 3172 07022 0002 2 3173 07023 1042 TAD E 3174 07024 4752 JMS I MINUS2-1 3175 07025 0003 3 3176 07026 1046 TAD LORD 3177 07027 3751 DCA I DIVIDE+1 3178 07030 1041 TAD USERNO 3179 07031 4752 JMS I MINUS2-1 3180 07032 0003 3 3181 07033 1042 TAD E 3182 07034 4752 JMS I MINUS2-1 3183 07035 0004 4 3184 07036 5263 DMULT4, JMP DMDONE 3185 07037 3274 DCA MULDIV-5 / TODO: Is this code reachable? 3186 07040 1043 TAD F / Looks like extended precision? 3187 07041 3751 DCA I DIVIDE+1 3188 07042 1045 TAD HORD 3189 07043 4752 JMS I MINUS2-1 3190 07044 0004 4 3191 07045 1046 TAD LORD 3192 07046 4752 JMS I MINUS2-1 3193 07047 0005 5 3194 07050 1047 TAD OVER2 3195 07051 3751 DCA I DIVIDE+1 3196 07052 1041 TAD USERNO 3197 07053 4752 JMS I MINUS2-1 3198 07054 0004 4 3199 07055 1042 TAD E 3200 07056 4752 JMS I MINUS2-1 3201 07057 0005 5 3202 07060 1043 TAD F 3203 07061 4752 JMS I MINUS2-1 3204 07062 0006 6 3205 07063 1301 DMDONE, TAD MULDIV 3206 07064 3045 DCA HORD 3207 07065 1300 TAD MULDIV-1 3208 07066 3046 DCA LORD 3209 07067 1277 TAD MULDIV-2 3210 07070 3047 DCA OVER2 3211 07071 4301 JMS MULDIV 3212 07072 3047 DCA OVER2 3213 07073 5604 JMP I DMULT 3214 *.+1 3215 *.+1 3216 *.+1 3217 *.+1 3218 *.+1 3219 3220 07101 0000 MULDIV, .-. / Restore sign of FAC 3221 07102 2050 DATUM, ISZ SIGNF / Need to negate? 3222 07103 4451 JMS I MINSKI / Yes, do it 3223 07104 4747 JMS I NORMF 3224 07105 2047 ISZ OVER2 / Round if low mantissa all ones 3225 07106 5701 JMP I MULDIV / No, return 3226 07107 1041 FLDV, TAD USERNO / Floating point divide 3227 07110 7650 SNA CLA / Denominator zero? 3228 07111 4566 ERROR4 / Yes, report error 3229 07112 1040 TAD ADDH / No, get exponent 3230 07113 7041 CIA / Negate 3231 07114 7001 IAC / add one 3232 07115 4324 JMS SIGN / Adjust exponent and sign of result 3233 07116 7700 SMA CLA / Operand negative? 3234 07117 4353 JMS MINUS2 / No, negate it for subtractions 3235 07120 4750 JMS I DIVIDE / Do high speed divide 3236 07121 4301 JMS MULDIV / Restore sign of result 3237 07122 5723 JMP I .+1 / Done, get next FP instruction 3238 07123 6401 FPNT+1 3239 07124 0000 SIGN, .-. / Update Exponent and set sign of result 3240 07125 1044 TAD EXP / Adjust exponent 3241 07126 3044 DCA EXP 3242 07127 1124 TAD P4000 / Get sign mask 3243 07130 0045 AND HORD / Get FAC sign 3244 07131 1041 FINPUT, TAD USERNO / Add Operand sign 3245 07132 7700 SMA CLA / Result negative? 3246 07133 7040 CMA / No, Get -1 3247 07134 3050 DCA SIGNF / Set sign switch for later 3248 07135 1045 TAD HORD / Check FAC 3249 07136 7450 SNA / Zero? 3250 07137 5746 JMP I REVIT / Yes, go zero result 3251 07140 7710 SPA CLA / No, Positive? 3252 07141 4451 JMS I MINSKI / No, Fix it 3253 07142 1041 TAD USERNO / Check operand 3254 07143 7450 SNA / Zero? 3255 07144 5746 JMP I REVIT / Yes, go zero result 3256 07145 5724 JMP I SIGN / No, return 3257 07146 6520 REVIT, ZERO / Set FAC to 0.0 3258 07147 7335 NORMF, DNORM / Normalize FAC 3259 07150 7261 DIVIDE, DUBDIV / High speed divide 3260 07151 7256 MP2 / Save area for multiplicand 3261 07152 7200 MP4 / High speed multiply 3262 07153 0000 MINUS2, .-. 3263 07154 7300 CLA CLL 3264 07155 1043 TAD F / Negate Low word 3265 07156 7041 CIA 3266 07157 3043 DCA F 3267 07160 1042 TAD E / Complement middle word 3268 07161 7040 CMA 3269 07162 7430 SZL / Have a carry? 3270 07163 7101 CLL IAC / Yes, do it 3271 07164 3042 DCA E 3272 07165 1041 TAD USERNO / Complement high word 3273 07166 7040 CMA 3274 07167 7430 SZL / Still have a carry? 3275 07170 7101 CLL IAC / Yes, do it 3276 07171 3041 DCA USERNO 3277 07172 5753 JMP I MINUS2 / Return 3278 07173 0000 RESOLV, .-. 3279 07174 1050 TAD SIGNF / Need to negate? 3280 07175 7710 SPA CLA 3281 07176 4451 JMS I MINSKI / Yes, do it 3282 07177 5773 JMP I RESOLV / Return 3283 3284 *7200 3285 07200 0000 MP4, .-. / Integer high speed multiply 3286 07201 7450 SNA / Multiply be zero? 3287 07202 5600 JMP I MP4 / Yes, return 3288 07203 3254 DCA MP1 / Set result to multiplier 3289 07204 3253 DCA MP5 3290 07205 1257 TAD THIR / Get -12 (bit count) 3291 07206 3255 DCA MP3 3292 07207 7100 CLL / No carry yet 3293 07210 1254 MP6, TAD MP1 / Get low answer 3294 07211 7010 RAR / Shift a bit 3295 07212 3254 DCA MP1 3296 07213 1253 TAD MP5 / Get high answer 3297 07214 7420 SNL / Need to add multiplicand? 3298 07215 5220 JMP .+3 / No 3299 07216 7100 CLL / Yes, Add in multiplicand 3300 07217 1256 TAD MP2 3301 07220 7010 RAR / Shift right 3302 07221 3253 DCA MP5 / Store high answer 3303 07222 2255 ISZ MP3 / Done 12 bits? 3304 07223 5210 JMP MP6 / No, again 3305 07224 1254 TAD MP1 / Get low result 3306 07225 7010 RAR / Divide by 2 3307 07226 3255 DCA MP3 / Save for now 3308 07227 1600 TAD I MP4 / Get argument 3309 07230 7041 CIA / Negate 3310 07231 1252 TAD DATUMA / Compute destination pointer 3311 07232 3254 DCA MP1 / Save dest. pointer 3312 07233 1255 TAD MP3 / Get Low result/2 3313 07234 7100 CLL 3314 07235 1654 TAD I MP1 / Add to result 3315 07236 3654 DCA I MP1 3316 07237 2254 ISZ MP1 / Bump dest. pointer 3317 07240 7004 RAL / Get carry 3318 07241 1253 TAD MP5 / Add high result 3319 07242 1654 TAD I MP1 / Add to result 3320 07243 3654 DCA I MP1 3321 07244 7420 SNL / More carry? 3322 07245 5600 JMP I MP4 / No, return 3323 07246 2254 ISZ MP1 / Yes, bump pointer 3324 07247 2654 ISZ I MP1 / Increment next result word 3325 07250 5600 JMP I MP4 / No more carry, return 3326 07251 5246 JMP .-3 / More carry 3327 07252 7102 DATUMA, MULDIV+1 3328 07253 0000 MP5, .-. 3329 07254 0000 MP1, .-. 3330 07255 0000 MP3, .-. 3331 07256 0000 MP2, .-. 3332 07257 7764 THIR, -14 3333 07260 7751 MIF, -27 3334 07261 0000 DUBDIV, .-. / High speed divide 3335 07262 3200 DCA MP4 / Clear high order result 3336 07263 3254 DCA MP1 / Clear low order result 3337 07264 1260 TAD MIF / Get -23 3338 07265 3255 DCA MP3 / Set up bit counter 3339 07266 7410 SKP / Skip the shift 3340 07267 4527 DV3, JMS I DOUBLE / Shift FAC left 3341 07270 7100 CLL 3342 07271 1042 TAD E / Get medium order operand 3343 07272 1046 TAD LORD / Subtract from medium FAC 3344 07273 3256 DCA MP2 / Remember the difference 3345 07274 7004 RAL / Get borrow 3346 07275 1045 TAD HORD / Add high FAC 3347 07276 1041 TAD USERNO / Subtract high operand 3348 07277 7420 SNL / Borrow? 3349 07300 5304 JMP DV3+15 / Yes, skip subtraction 3350 07301 3045 DCA HORD / Yes, store high difference 3351 07302 1256 TAD MP2 / Get medium difference 3352 07303 3046 DCA LORD / Store in FAC 3353 07304 7200 CLA 3354 07305 1254 TAD MP1 / Shift low result, include new bit 3355 07306 7004 RAL 3356 07307 3254 DCA MP1 3357 07310 1200 TAD MP4 / Shift high result too 3358 07311 7004 RAL 3359 07312 3200 DCA MP4 3360 07313 2255 ISZ MP3 / Done all the bits? 3361 07314 5267 JMP DV3 / No, keep going 3362 07315 1254 TAD MP1 / Yes, copy low result to FAC 3363 07316 3046 DCA LORD 3364 07317 1200 TAD MP4 / Copy high result to FAC 3365 07320 3045 DCA HORD 3366 07321 5661 JMP I DUBDIV / Return 3367 07322 7004 RAL / More unreachable cruft? 3368 07323 3335 DCA DNORM 3369 07324 2255 ISZ MP3 3370 07325 5267 JMP DV3 3371 07326 1335 TAD DNORM 3372 07327 3045 DCA HORD 3373 07330 1200 TAD MP4 3374 07331 3046 DCA LORD 3375 07332 1254 TAD MP1 3376 07333 3047 DCA OVER2 3377 07334 5661 JMP I DUBDIV 3378 07335 0000 DNORM, .-. / Floating pint Normalize 3379 07336 4775 JMS I ABSOL3 / Get absolute value 3380 07337 4366 JMS TEST4 / Check for negative zero 3381 07340 1045 TAD HORD / High FAC zero? 3382 07341 7450 SNA 3383 07342 1047 TAD OVER2 / Yes, check low FAC 3384 07343 7450 SNA / Still zero? 3385 07344 1046 ML7776, TAD LORD / Yes, check middle FAC 3386 07345 7650 SNA CLA / Still zero? 3387 07346 5363 JMP FXIT3 / Yes, finish up 3388 07347 1045 TAD HORD / Nonzero, see if we can shift 3389 07350 7104 CLL RAL 3390 07351 7710 SPA CLA / Shift hit the sign bit? 3391 07352 5360 JMP FXIT3-3 / Yes, cant shift any more 3392 07353 4527 JMS I DOUBLE / Not yet, shift again 3393 07354 7140 CLL CMA / Decrement exponent 3394 07355 1044 TAD EXP 3395 07356 3044 DCA EXP 3396 07357 5347 JMP ML7776+3 / Loop until normalized 3397 07360 4776 JMS I RESOL3 / Restore sign of result 3398 07361 4366 JMS TEST4 / Check for negative zero 3399 07362 5735 JMP I DNORM / Return 3400 07363 3044 FXIT3, DCA EXP / Normalized zero has zero exponent 3401 07364 5735 JMP I DNORM / Return normalized 0.0 3402 07365 6757 XRAR2, DIV2 3403 07366 0000 TEST4, .-. / Deal with negative zero 3404 07367 1045 TAD HORD / Get high FAC 3405 07370 7510 SPA / Positive? 3406 07371 7041 CIA / No, negate 3407 07372 7710 SPA CLA / Positive now? 3408 07373 4765 JMS I XRAR2 / No, Shift negative zero right 3409 07374 5766 JMP I TEST4 / Yes, return 3410 07375 5571 ABSOL3, ABSOLV 3411 07376 7173 RESOL3, RESOLV 3412 3413 / 3414 / This function computes the square root of the argument. 3415 / 3416 *7400 3417 07400 4407 XSQRT, FINT / FSQT, compute the square root 3418 07401 6274 FPUT FPAC1 / Save the argument 3419 07402 0000 HLT, FEXT 3420 07403 1045 TAD HORD / Is the argument negative? 3421 07404 7710 SPA CLA 3422 07405 4566 ERROR4 / Yes, choke 3423 07406 1044 TAD EXP / No, is power of 2 negative? 3424 07407 7510 SPA 3425 07410 7020 CML / Yes, preserve sign 3426 07411 7010 RAR / Halve power of 2 for first approximation 3427 07412 3270 DCA BUFFER 3428 07413 7430 SZL / Round? 3429 07414 2270 ISZ BUFFER / Yes, do it 3430 07415 7000 NOP 3431 07416 1267 TAD SQCON1 / Set up high mantissa for initial approximation 3432 07417 3271 DCA BUFFER+1 / Set up rest of initial approximation 3433 07420 3272 DCA BUFFER+2 3434 07421 3273 DCA FPAC1-1 3435 07422 1275 TAD FPAC1+1 / Is argument zero? 3436 07423 7450 SNA / 3437 07424 1276 TAD FPAC1+2 3438 07425 7650 SNA CLA 3439 07426 5265 JMP SQEND / Yes, go return 3440 07427 4407 CLCU, FINT 3441 07430 0274 FGET FPAC1 / Compute Guess + N/Guess 3442 07431 3270 FDIV BUFFER 3443 07432 1270 FADD BUFFER 3444 07433 0000 FEXT 3445 07434 7240 CLA CMA / Get -1 3446 07435 1044 TAD EXP / Divide FAC by 2 3447 07436 3044 DCA EXP 3448 07437 1044 TAD EXP / Guess = (Guess + N/Guess)/2? 3449 07440 7041 CIA / Start with Exponents 3450 07441 1270 TAD BUFFER 3451 07442 7640 SZA CLA 3452 07443 5261 JMP ROOTGO / Not equal, go try again 3453 07444 1045 TAD HORD / High mantissas equal? 3454 07445 7041 CIA 3455 07446 1271 TAD BUFFER+1 3456 07447 7640 SZA CLA 3457 07450 5261 JMP ROOTGO / No, try again 3458 07451 1046 TAD LORD / Subtract mid-mantissas 3459 07452 7041 CIA 3460 07453 1272 TAD BUFFER+2 3461 07454 7500 SMA / Take -absolute value 3462 07455 7041 CIA 3463 07456 7001 IAC / Increment 3464 07457 7700 SMA CLA / Mid-mantissas close enough? 3465 07460 5536 RETURN / Yes, close enough 3466 07461 4407 ROOTGO, FINT / Not quite there yet 3467 07462 6270 FPUT BUFFER / Store new guess 3468 07463 0000 FEXT 3469 07464 5227 JMP CLCU / and go again 3470 07465 3044 SQEND, DCA EXP / Return 3471 07466 5536 RETURN 3472 07467 3015 SQCON1, 3015 3473 BUFFER, 3474 07470 0000 ITER1, .-. 3475 07471 0000 .-. 3476 07472 0000 .-. 3477 07473 0000 .-. 3478 07474 0000 FPAC1, .-. 3479 07475 0000 .-. 3480 07476 0000 .-. 3481 07477 7503 LIBRAR / ODD: This is initialized but unreferenced 3482 3483 / 3484 / The Locations command reports on the addresses of text and variables and 3485 / attempts to return to the operating system. This is used to save an image 3486 / of the program using the host operating system. 3487 / 3488 *7503 3489 07503 1133 LIBRAR, TAD CFRS / Output CFRS in octal 3490 07504 4327 JMS PRNT8 3491 07505 1060 TAD STARTV / Output STARTV in octal 3492 07506 4327 JMS PRNT8 3493 07507 1031 TAD LASTV / Output LASTV in octal 3494 07510 4327 JMS PRNT8 3495 07511 1035 TAD BOTTOM / Output BOTTOM in octal 3496 07512 4327 JMS PRNT8 3497 07513 5316 JMP .+3 / Go check for locs text 3498 07514 4545 GETC / Get a character 3499 07515 4551 PRINTC / and print it 3500 07516 1066 TAD CHAR / Get character 3501 07517 1116 TAD MCR / Carriage return? 3502 07520 7640 SZA CLA 3503 07521 5314 JMP .-5 / No, keep going 3504 07522 1016 TAD TELSW / Output busy? 3505 07523 7640 SZA CLA / No, proceed 3506 07524 5322 JMP .-2 / Yes, keep waiting 3507 07525 6002 IOF / Disable interrupts 3508 07526 5504 JMP I OBUF0 / Return to monitor 3509 07527 0000 PRNT8, .-. 3510 07530 3032 DCA VAL / Save the number 3511 07531 1032 TAD VAL / Get the number 3512 07532 7006 RTL / Shift high octal digit into low 3513 07533 7006 RTL 3514 07534 4350 JMS PRINTO / Print it 3515 07535 4557 RTL6 / Rotate 6 left 3516 07536 7004 RAL / One more for link 3517 07537 4350 JMS PRINTO / Print second digit 3518 07540 7012 RTR / Shift third digit down 3519 07541 7010 RAR 3520 07542 4350 JMS PRINTO / Output it 3521 07543 4350 JMS PRINTO / Now output fourth digit 3522 07544 7200 CLA 3523 07545 1077 TAD CCR / Output a carriage return 3524 07546 4551 PRINTC 3525 07547 5727 JMP I PRNT8 / Return 3526 07550 0000 PRINTO, .-. / Output octal digit helper 3527 07551 0356 AND LP7 / Mask for octal digit 3528 07552 1113 TAD C260 / Convert to ASCII 3529 07553 4551 PRINTC / Print it 3530 07554 1032 TAD VAL / Get the number we're printing 3531 07555 5750 JMP I PRINTO / Return 3532 07556 0007 LP7, 10-1 / Mask for single octal digit 3533 3534 $