home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / pdp8 / os278-src.tar.Z / os278-src.tar / brts.pa < prev    next >
Text File  |  1992-09-18  |  178KB  |  7,760 lines
  1. /BRTS.PA  EXTENDED VERSION
  2. /ORIGINALLY:
  3. /Commercial Basic Runtime System, V EX
  4. /
  5. /
  6. /
  7. /
  8. /
  9. /
  10. /
  11. /
  12. /
  13. /
  14. /
  15. /COPYRIGHT (C) 1972, 1973, 1974, 1975, 1977, 1978, 1979, 1981, 1982, 1983, 1984
  16. /Digital Equipment Corporation, Maynard, Ma.
  17. /
  18. /
  19. /
  20. /This software is furnished under a license for use only on a
  21. /single computer system and may be copied only with the inclu-
  22. /sion of the above copyright notice.  This software, or any other
  23. /copies thereof, may not be provided or otherwise made available
  24. /to any other person except for use on such system and to one who
  25. /agrees to these license terms.  Title to and ownership of the
  26. /software shall at all times remain in DEC.
  27. /
  28. /
  29. /The information in this software is subject to change without
  30. /notice and should not be construed as a commitment by Digital
  31. /Equipment Corporation.
  32. /
  33. /DEC assumes no responsibility for the use or reliability of its
  34. /software on equipment which is not supplied by DEC.
  35. /
  36. /
  37. /
  38. /
  39. /
  40. /
  41.  
  42. /AUGUST 19, 1972
  43. /    21-APR-77    ADDED EXTENDED DATE CODE, CLEANED UP LISTING
  44. /    26-APR-77    TIGHTENED UP STRING ROUTINES
  45. /    28-APR-77    ADD SOURCE FIX FOR SEVERAL KNOWN BUGS
  46. /    04-MAY-77    REWROTE FLOATING POINT OUTPUT ROUTINE TO INCREASE ACCURACY
  47. /    26-JAN-78    REMOVE TTY RING BUFFER, ADD 8 BIT ASCII
  48. /    03-FEB-78    ADD STRING ARITHMETIC INTERFACE
  49. /    22-FEB-78    ADD PRINT USING
  50. /    28-FEB-78    ADD TEXT ERROR MESSAGES
  51. /    22-MAR-78    ADD GENERAL 2 PAGE SYSTEM HANDLER RELOCATION
  52. /    28-MAR-78    INSTALL EXTENDED FIELD 1 CODE
  53. /    01-APR-78    TIGHTEN UP FILE I/O ROUTINES, RELOCATE TTY HANDLER
  54. /    02-APR-78    PUT IN DIRECT ACCESS PRIMITIVES
  55. /    09-APR-78    EXTEND OVERLAYS TO 3 BLKS, MOVE JMP TABLES TO OVERLAYS
  56. /    14-APR-78    CLEAN UP LOGIC IN FILE OPEN/CLOSE ROUTINES
  57. /    15-APR-78    ADD CAP$ FN, MAKE DATE RETURN DD-MMM-YY FORMAT
  58. /    18-APR-78    FIXUP LOGIC IN CHAINING ROUTINE
  59. /    20-APR-78    ADD IFOPEN STMT, NON FATAL ENTER/LOOKUP ERROR FEATURE
  60. /            FIX BUG WITH LARGE PRE COMPILED PROGRAMS UNDER BATCH
  61. /    07-MAY-78    ADD OCT, BIN, KEY$, CCL$, AND PMT$ FUNCTIONS
  62. /            PUT IN IN-CORE OVERLAY SHUFFLER, EXPAND TO 7 I/O FILES
  63. /    15-MAY-78    ADDED ON-GOTO/GOSUB FEATURE, CLOSE ALL FEATURE
  64. /    23-MAY-78    REWROTE FFIN ROUTINE FOR GREATER ACCURACY
  65. /    2-FEB-79    CHANGES MADE FOR HANDLER ENHANCEMENT:
  66. /            1. VERSION CHANGED TO V7.
  67. /            2. FIELD ZERO LOAD CONSTANTS CHANGED
  68. /            3. FIELD ONE LOAD CONSTANTS CHANGED
  69. /            4. I/O BUFFERS REDUCED TO FIVE (TWO PAGERS)
  70. /            5. LINKAGES TO FFXXX INSERTED AND TWO SMALL ROUTINES
  71. /               MOVED TO FIELD ONE.
  72. /            6. PAGE ZERO FIELD 1 REFERENCES RESESTABLISHED
  73. /            7. HANDLER BUFFFER AREA INCREASED TO SIX PAGES
  74. /            8. MOVED FFOUT, FFIN (FFXXX) TO FIELD ONE
  75. /
  76. /    5-MAR-79    INSTALL SOURCE FIX FOR INITIALIZATION BUG
  77. /    17-FEB-81    MODIFICATION FOR OS78 V4 (VT278)
  78. /    01-JAN-82    CHANGES AND ENHANCEMENTS
  79. /            1. ADDED GRAPHIC COMMANDS
  80. /               ADDED EXIT, AND SLEEP
  81. /            2. REMOVED BASIC.UF CAPABILITIES
  82. /            3. CREATED BASIC.EX, BASIC.SR OVERLAYS
  83. /               AND INSTALLED THEM INTO BASIC.OV
  84. /    02-APR-82    1. CHANGED THE KEY COMMAND TO TIMED INPUT
  85. /               ADDED TIME DELAY IN BASIC.EX/SR FOR VT278
  86. /               SCREEN SETTLING TIME
  87. /    07-APR-82    1. FIXED IF OPEN & IF END FOR CMB LINE STATEMENTS
  88. /    19-APR-82    1. ADDED ON ERROR GOTO, RESUME, TRAP
  89. /            2. RE-WRITE OF ERROR OVERLAY
  90. /            3. REMOVED EAE AND VT278 CONDITIONALS
  91. /    04-OCT-82    1. MOVED KEY FUNCTION FOR ESC KEY INPUT
  92. /    18-JAN-83    WRITE 200 CODE (NULL) AS FILLER FOR REC.
  93. /            I/O FILED FILLERS TO ALLOW REMOVAL ON GET COMMAND
  94. /    27-JAN-83    ADDED CALL COMMAND IN STORE/RECALL
  95. /
  96. /    16-JUL-84    Fixed CAL, RECALL error if file crash if file not found
  97. /            Fixed Store error if empty is > 4000 blocks
  98. /    30-AUG-84    Add time out loop for KEY$ command
  99. /            ON ERROR GOTO 0 now realy turns it off
  100. /    20-SEP-84    Fix SSI to work on DECmate II
  101.  
  102.  
  103.     VERSON=    "B    /VERSION OF BRTS LOCATED AT TAG "VERLOC"
  104.     SUBVER=    0    /SUBVERSION OF BRTS
  105.  
  106.     SUBVAF=    0    /SUBVERSION OF MATH FUNCTIONS OVERLAY
  107.     SUBVSF=    1    /SUBVERSION OF STRING FUNCTIONS OVERLAY
  108.     SUBVEF=    1    /SUBVERSION OF BASIC ERROR MESSAGE OVERLAY
  109.     SUBVFF=    1    /SUBVERSION OF FILE FUNCTIONS OVERLAY
  110.     SUBVEX= 5    /SUBVERSION OF GRAPHIC FUNCTION OVERLAY
  111.     SUBVSR= 4    /SUBVERSION OF STORE AND RECALL OVERLAY
  112.             /FIRST WORD OF EACH OVERLAY CONTAINS
  113.             /6 BIT VERSON IN LEFT HALF AND 60+SUBVERSION OF OVERLAY
  114.             /IN RIGHT HALF.
  115.  
  116.     /OS/8 SYSTEM DEFINES
  117.  
  118.     MDATE=    7666    /CONTAINS OS/8 DATE IN FIELD 1
  119.     BIPCCL=    7777    /CONTAINS YEAR EXTENSION BITS, BATCH FLAG AND BATCH FIELD
  120.     JSW=    7746    /OS/8 JSW IN FIELD 0
  121.     CDOPT2=    7642    /HIGH ORDER CD = OPTION AND ALTMODE FLAG
  122.     CDOPT3=    7643    /CD SWITCHES [ABC DEF GHI JKL]
  123.     CDOPT4=    7644    /CD SWITCHES [MNO PQR STU VWX]
  124.     CDOPT5=    7645    /CD SWITCHES [YZ0 123 456 789]
  125.     CDOPT6=    7646    /LOW ORDER CD = OPTION
  126.     SCOPWD=    7726    /WORD CONTAINING SCOPE FLAG IN 200 BIT
  127.     V278WD=    7771    /WORD CONTAINING VT278 FLAG IN 4 BIT - FIELD 1
  128.     USRDHT=    0037    /POINTER TO USR DEVICE HANDLER TABLE IN FIELD 1
  129.     RESTBL=    7647    /ADDR OF DEVICE RESIDENCY TABLE IN FIELD 1
  130.     CCLMAX=    47    /MAX SIZE COMMAND STRING FOR CCL
  131.  
  132.     /BRTS SYSTEM DEFINES
  133.  
  134.     EDBLK=    7604    /CONTAINS BLOCK NUMBER OF EDITOR
  135.     WIDTH=    204    /WIDTH OF PRINTER
  136.     COLWID=    16    /WIDTH OF ONE PRINT COLUMN
  137.     SACLIM=    205    /DEFINE WIDTH OF STRING ACCUMULATOR
  138.     SAC=    200    /DEFINE ADDR OF SAC IN FIELD 1
  139.     OVERLAY=3400    /ADDRESS OF START OF 6 PAGE OVERLAY BUFFER
  140.     BRTSZ0=    3100    /HANDLER SIZE CONTROL WORD FOR FIELD 0 OF BRTS
  141.     BCSIZ1=    1000    /BCOMP SIZE CONTROL WORD FOR FIELD 1 LOAD DURING CHAIN
  142.     BCLOD1=    2000    /BCOMP LOAD ADDR IN FIELD 1 FOR CHAIN STATEMENT
  143.     CCHAIN=    3201    /ENTRY POINT OF BCOMP IN FIELD 1 FOR CHAIN STATEMENT
  144.     EDTBGN=    0201    /ENTRY POINT FOR EDITOR RESTART
  145.     EDTSIZ=    2400    /HANDLER SIZE CONTROL WORD FOR EDITOR READ
  146.     BUFAREA=5400    /I/O BUFFER AREA IN FIELD 1 (MUST BE ON EVEN BOUNDRY)
  147.     HAREA=    6200    /BASE ADDR OF HANDLER LOAD AREA IN FIELD 0
  148.     MAXFIL=    5    /MAXIMUM FILE NUMBER ALLOWED
  149.     MAGIC=    1234    /MAGIC CD = OPTION TELLS BASIC .SV PROGRAMS
  150.             /THEY'RE BEING CHAINED TO FROM BRTS
  151.     INFO=    7604    /BASIC SYSTEM INFORMATION AREA IN FIELD 1
  152.  
  153. /INFO    STARTING BLOCK +1 OF BASIC.SV
  154. /INFO+1  STARTING BLOCK +1 OF BCOMP.SV
  155. /INFO+2  STARTING BLOCK +1 OF BLOAD.SV
  156. /INFO+3  STARTING BLOCK +1 OF BRTS.SV
  157. /INFO+4  STARTING BLOCK +1 OF BASIC.OV
  158. /INFO+5  *UNUSED*
  159. /INFO+6  *UNUSED*
  160. /INFO+7  *UNUSED*
  161. /INFO+10 STARTING BLOCK OF BASIC.TM
  162. /INFO+11 SIZE IN BLOCKS OF BASIC.TM
  163. /INFO+12 INPUT HANDLER ENTRY ADDRESS
  164. /INFO+13 SIZE AND DEVICE NUMBER OF INPUT FILE
  165. /INFO+14 STARTING BLOCK OF INPUT FILE
  166. /INFO+15 THROUGH
  167. /INFO+20 NAME OF WORKSPACE
  168.  
  169.     RECPAK=    400    /ORIGIN IN FIELD 1 OF RECORD I/O CODE
  170.  
  171.     /STRING ARITHMETIC LINKAGES
  172.  
  173.     STPACK=    2000    /ORIGIN IN FIELD 1 OF STRING ARITHMETIC PACKAGE
  174.  
  175.     ABUF=    STPACK+2001
  176.     BBUF=    STPACK+2023
  177.     SBUF=    STPACK+2103
  178.     FMTBUF=    STPACK+2142
  179.     SADD=    STPACK
  180.     SSUB=    STPACK+2
  181.     SISUB=    STPACK+4
  182.     SMUL=    STPACK+6
  183.     SDIV=    STPACK+10
  184.     SIDIV=    STPACK+12
  185.     USING=    STPACK+1232
  186.     SINTEG=    STPACK+707
  187.     UINIT=    STPACK+2000
  188.  
  189.     DI=    STPACK+242
  190.     DP=    STPACK+245
  191.     DM=    STPACK+250
  192.     OVS=    STPACK+326
  193.     DVS=    STPACK+1011
  194. /WHEN ASSEMBLED AND LOADED VIA THE ABS. LOADER,THE
  195. /CORE LAYOUT IS AS FOLLOWS:
  196. /
  197. /BRTS IS AT 0-6177,10000-15377
  198. /
  199. /        OVERLAY BREAKDOWN
  200. /
  201. /MATH FUNCTIONS        ARE AT 03400-04777
  202. /STRING FUNCTIONS    ARE AT 22000-23377
  203. /ERROR MESSAGES        ARE AT 23400-24777
  204. /GRAPHIC FUNCTIONS    ARE AT 32000-33377
  205. /FILE FUNCTIONS        ARE AT 33400-34777
  206. /STORE AND RECALL    ARE AT 35000-36377
  207. /
  208. /TO CREATE SAVE IMAGE FILES PRIOR TO RUNNING BASIC,
  209. /ASSEMBLE THIS SOURCE IN A 16K OR MORE MACHINE,THEN
  210. /PERFORM THE FOLLOWING SEQUENCE OF OS/8 COMMANDS
  211. /
  212. /
  213. /        ASSEMBLY INSTRUCTIONS
  214. /.PAL BRTS.BN<BRTS/W
  215. /.PAL MATH
  216. /.LOAD BRTS,MATH
  217. /.SAVE SYS:BRTS 0-6177,10000-15377;7605
  218. /.SAVE SYS BASIC.OV 3400-4777,22000-24777,32000-36377;7605
  219. /
  220. /
  221. /V4 FIXES
  222. /.EAE ADD FOR NUMS <.00001 TO 0
  223. /.FILE INPUT FROM TTY
  224. /.OUTPUT OF NUMS > 80,000
  225. /.STRING FETCH WHEN COUNT IS IN ONE FLD &
  226. /   TEXT IS IN THE NEXT
  227.     AC4000=    CLA STL RAR
  228.     AC2000=    CLA STL RTR
  229.     AC0002=    CLA STL RTL
  230.     AC7775=    CLL STA RTL
  231.     AC7776=    CLL STA RAL
  232.     AC3777=    CLL STA RAR
  233.     AC5777=    CLL STA RTR
  234.  
  235.  
  236.     /PAGE 0 LOCATIONS
  237.  
  238.     *1
  239. ERRNUM,    0
  240. ERLINL,    0
  241. ERLINH,    0
  242. ERRCOD,    0
  243. ERRFLD,    0
  244.     *6
  245. USECON,    0        /USE CONSTANT GENERATED BY "USE" STATEMENT
  246. FSTOP1,    CCTRAP        /POINTER TO RTS EXIT ROUTINE USED
  247.             /BY ^C HOOKS IN SYSTEM HANDLER.
  248.  
  249.     *10
  250. SACXR,    0        /INDEX REGISTER FOR STRING ROUTINES
  251. XR1,    0
  252. XR2,    0
  253. XR3,    0
  254. XR4,    0        /INDEX REGISTERS
  255. XR5,    0
  256. DATAXR,    0        /POINTER FOR IN-CORE DATA LIST
  257. LWIDTH,    -WIDTH        /COMMON WIDTH FOR PRINTER
  258.  
  259.     *20
  260.  
  261. /COMPILER-INTERPRETER CONTROL BLOCK. LOCATIONS MARKED BY
  262. /A /* ARE EXPECTED TO CONTAIN VALUES SUPPLIED BY THE COMPILER PRIOR
  263. /TO THE BRTS LOAD
  264.  
  265. CDFIO,    0        /* CDF FOR I/O TABLE AND SYMBOL TABLES
  266. SCSTRT,    0        /* POINTER TO START OF SCALAR SYMBOL TABLE
  267. ARSTRT,    0        /* POINTER TO START OF ARRAY SYMBOL TABLE-1
  268. STSTRT,    0        /* POINTER TO START OF STRING SYMBOL TABLE-1
  269. SASTRT,    0        /* POINTER TO START OF STRING ARRAY TABLE-1
  270. CDFPS,    0        /* CDF FOR START OF PSEUDO-CODE
  271. PSSTRT,    0        /* POINTER TO START OF PSEUDO CODE-1
  272. DLSTOP,    0        /* POINTER TO TOP OF DATA LIST
  273. DLSTRT,    0        /* POINTER TO BOTTOM OF INCORE DATA LIST-1
  274. PSFLAG,    0        /* OS/8 SWAPPING FLAGS WORD
  275.             /BIT 0 SET IF OS/8 SAVED IN N7400 INSTEAD OF N7600
  276.             / FOR 2 PAGE SYSTEM HANDLER
  277.             /BIT 11 SET IF 17600 IS IN 17600. BIT 11 TOGGLED BY
  278.             /PSWAP ROUTINE
  279.  
  280.     /SYSTEM REGISTERS
  281.  
  282. SACLEN,    0        /LENGTH OF STRING IN SAC
  283. S1,    0        /SUBSCRIPT 1 (MUST BE FOLLOWED BY S2!)
  284. S2,    0        /SUBSCRIPT 2 (MUST BE PRECEDED BY S1!)
  285. DMAP,    0        /MAP OF DRIVER PAGES
  286. BUFSTK,    BSTACK        /STACK OF FREE I/O BUFFERS
  287.  
  288.     *37
  289.  
  290.     /FLOATING POINT PACKAGE LOCATIONS, CONSIDERED VOLATILE
  291.  
  292. FF,    0        /SPECIAL MODE FLIP-FLOP
  293. AC0,    0        /VOLATILE TEMPORARY
  294. AC1,    0        /VOLATILE TEMPORARY
  295. AC2,    0        /VOLATILE TEMPORARY
  296. TM,    0
  297. ACX,    0        /FAC EXPONENT
  298. ACH,    0        /FAC HIGH ORDER FRACTION
  299. ACL,    0        /FAC LOW ORDER FRACTION
  300. OPX,    0        /OPERAND EXPONENT
  301. OPH,    0        /OPERAND HIGH ORDER FRACTION
  302. OPL,    0        /OPERAND LOW ORDER FRACTION
  303. CHAR,    0        /LAST CHAR READ FROM ASCII FILE
  304.  
  305.     /SYSTEM REGISTERS USED OFTEN BY INTERPRETER CODE
  306.  
  307. MODESW,    0        /0 FOR ARTHIMETIC MODE,1 FOR STRING MODE
  308. INSAV,    0        /CURRENT PSEUDO-INSTRUCTION BEING EXECUTED
  309. LINEHI,    0        /HI ORDER BITS OF LINE # CURRENTLY BEING EXECUTED
  310. LINELO,    0        /LOW ORDER BITS OF CURRENT LINE NUMBER
  311. STRMAX,    0        /MAXIMUM # OF CHARS ALLOWED IN CURRENT STRING
  312. STRCNT,    0        /- # OF CHARACTERS IN CURRENT STRING
  313. STRPTR,    0        /POINTER TO SIZE WORD OF CURRENT OPERAND STRING
  314. IOMASK,    177        /MASK WORD FOR 7 OR 8 BIT I/O
  315.  
  316. TEMP1,    0
  317. TEMP2,    0
  318.  
  319.     DECEXP=    TM
  320. /I/O TABLE POINTER AREA-THIS BLOCK HOLDS POINTERS TO THE I/O TABLE
  321. /ENTRY FOR THE CURRENT FILE.THE POINTERS ARE CHANGED EVERY TIME AN
  322. /SFN IS EXECUTED. A TAD I OFF ONE OF THE POINTERS WILL GET THE INFORMATION
  323. /NOTED IN THE COMMENT FOR THE CURRENT I/O DEVICE
  324. /THIS BLOCK IS INITIALIZED FOR TTY
  325.  
  326.  
  327.     /THE FORMAT OF THE HEADER WORD IS AS FOLLOWS
  328.     /BITS    USAGE
  329.     /0-3    OS/8 DEVICE NUMBER
  330.     /4    FLAG SET IF NEXT CHAR IS 3RD CHAR IN PREV DOUBLEWORD
  331.     /5    UNUSED
  332.     /6    SET IF BUFFER HAS BEEN MODIFIED AND NEEDS TO BE WRITTEN
  333.     /7    SET IF NOT FILE STRUCTURED DEVICE
  334.     /8    SET IF HANDLER IS 2 PAGES LONG
  335.     /9    SET IF VARIABLE LENGTH (OUTPUT) FILE
  336.     /10    SET IF EOF
  337.     /11    SET IF ASCII FILE, CLEAR IF NUMERIC IMAGE FILE
  338.  
  339.  
  340. ENTNO,    0        /ENTRY NUMBER NOW IN AREA 
  341. IOTHDR,    TTYF        /HEADER WORD
  342. IOTBUF,    TTYF+1        /BUFFER ADDRESS
  343. IOTBLK,    TTYF+2        /CURRENT BLOCK IN BUFFER
  344. IOTPTR,    TTYF+3        /READ\WRITE POINTER
  345. IOTHND,    TTYF+4        /HANDLER ENTRY POINT
  346. IOTLOC,    TTYF+5        /FILE STARTING BLOCK #
  347. IOTLEN,    TTYF+6        /ACTUAL FILE LENGTH
  348. IOTRSZ,    TTYF+7        /PHYSICAL RECORD LENGTH (INCLUDES CR/LF, ETC)
  349.             /ZERO IF NOT RANDOM ACCESS
  350. IOTSUB,    TTYF+10        /POINTER TO CURRENT RECORD FIELD LENGTH
  351. IOTNRH,    TTYF+11        /HIGH ORDER MAX RECORD SO FAR
  352. IOTNRL,    TTYF+12        /LOW ORDER MAX (NUMBER LT 384*2**12)
  353. IOTMAX,    TTYF+13        /    DEVICE / (FILE MAXIMUM LENGTH)
  354. IOTPOS,    TTYF+14        /    NAME / (POSITION OF PRINT HEAD)
  355. IOTFIL,    TTYF+15        /
  356. /    TTYF+16        /    FILE
  357. /    TTYF+17        /    NAME
  358. /    TTYF+20        /    .EX
  359.  
  360. IOTDEV=    IOTMAX
  361. IOTEND=    IOTFIL+4    /END OF FILENAME AND LAST WORD IN IOTABLE
  362.  
  363. IOTSIZ=    IOTEND+1-IOTHDR    /CURRENT SIZE OF IO TABLE
  364.  
  365. SAVCHR,    0        /CHARACTER SAVE BUFFER
  366. V278FG,    0        /VT278 FLAG
  367. K4,    4
  368. K60,    60
  369. KBRACK,    "[&177        /BRACKET
  370. KESC,    "[&77        /ESCAPE
  371. KSEMI,    ";&177        /SEMICOLON
  372. CUR4K,    CUR4
  373. PVH52,    JMS I CUR4K    /VT52 CURSOR POSITIONING
  374. LOADOV,    OVLOAD        /INDIRECT TO 'OVLOAD'
  375. FIX23I,    FIX23        /INDIRECT TO 'FIX23'
  376. SCSLOC,    0        /GRAPHICS TYPE INDICATOR FOR SCD, LCD.
  377. CURROW,    0        /ROW POSITION OF LAST CUR COMMAND
  378. CURCOL,    0        /LAST COL POSITION OF LAST CUR COMMAND
  379. ERRFLG,    0
  380. RESCOD,    0
  381. RESFLD,    0
  382. TRPCHR,    0        /TWO'S COMP OF CHARACTER TO BE TRAPED
  383.  
  384.     *200
  385.  
  386.     /FETCH NEXT PSEUDO WORD
  387.  
  388. PWFECH,    0
  389.     ISZ    INTPC    /BUMP PSEUDO-CODE PROGRAM COUNTER
  390.     JMP    CDFPSU    /NO-SKIP;JUST GET NEXT PSEUDO-CODE WORD
  391.     TAD    CDFPSU    /SKIP MEANS WE HAVE TO INCREMENT PS-CODE FIELD
  392.     TAD    [10
  393.     DCA    CDFPSU
  394. CDFPSU,    HLT        /SET DF TO FIELD OF PSEUDO-CODE
  395.     TAD I    INTPC    /GET NEXT WORD OF CODE
  396.     CDF 0        /SET DATA FIELD BACK TO INTERPRETER FIELD
  397.     JMP I    PWFECH    /RETURN
  398.  
  399. SSMODE,    IAC        /SET INTERPRETER TO STRING MODE
  400. AMODE,    DCA    MODESW    /SET INTERPRETER TO ARITH MODE
  401.             /FALL BACK INTO I-LOOP
  402.  
  403.     /BRTS I-LOOP
  404.  
  405. ILOOP,    CLA CLL        /FLUSH
  406.     DCA    FF    /PUT FPP IN SI MODE
  407.     JMS    PWFECH    /GET NEXT PSEUDO-INSTRUCTION
  408.     DCA    INSAV    /SAVE FOR LATER
  409.     JMS I    (CTCCHK    /TEST IF ^C STRUCK
  410.     TAD    INSAV
  411.     AND    [7400    /STRIP TO OPCODE BITS
  412.     CLL RTL
  413.     RTL
  414.     RAL        /OPCODE NOW IN BITS 8-11
  415.     TAD    (7770    /SUBTRACT 10
  416.     SMA         /IS OPCODE <10?
  417.     JMP    SCASE    /CALL TO INSTRUCTION COMMON TO SMODE AND AMODE
  418.     DCA    AC0    /YES-SAVE THE OFFSET
  419.     TAD    MODESW    /WHICH MODE?
  420.     SZA CLA
  421.     JMP    SMODE    /STRING MODE
  422.     TAD    AC0    /ARITHMETIC MODE-GET OFFSET
  423.     TAD    JMSI    /MAKE JMS TO FP PACKAGE ROUTINE
  424.     DCA    .+2    /PUT IN LINE
  425.     JMS    ARGPRE    /SET UP ARGUMENT FROM SYMBOL TABLE
  426. ILOOPF,    HLT        /JMS TO THE FLOATING POINT PACKAGE ROUTINE
  427.     NOP        /FPP SOMETIMES RETURNS TO CALL+2
  428.     JMP    ILOOP    /DONE
  429.  
  430. SCASE,    TAD    JMPI    /JUST DISPATCH TO ROUTINE CALLED FOR
  431.     DCA    .+1
  432.     HLT        /JUMP TO APPROPRIATE ROUTINE
  433.  
  434. JMSI,    JMS I    SEP1    /JMS USED FOR CALLS TO FPP BY AMODE INST
  435. JMPI,    JMP I    SEP1    /JMP USED TO CALL ROUTINES COMMON TO AMODE AND SMODE
  436.     /JUMP TABLE FOR AMODE INSTRUCTIONS
  437.  
  438. AJTAB,    FFADD        /FAC_C(A)+FAC        OPCODE 0000
  439.     FFSUB        /FAC_FAC-C(A)        OPCODE 0400
  440.     FFMPY        /FAC_FAC*C(A)        OPCODE 1000
  441.     FFDIV        /FAC_FAC/C(A)        OPCODE 1400
  442.     FFGET        /FAC_C(A)        OPCODE 2000
  443.     FFPUT        /C(A)_FAC        OPCODE 2400
  444.     FFSUB1        /FAC_C(A)-FAC        OPCODE 3000
  445.     FFDIV1        /FAC_C(A)/FAC        OPCODE 3400
  446.  
  447. /ALL INSTRUCTIONS BEYOND THIS POINT ARE COMMON TO AMODE AND SMODE
  448.  
  449. SEP1,    LS1I        /S1_C(A)        OPCODE 4000
  450.     LS2I        /S2_C(A)        OPCODE 4400
  451.     FJOCI        /IF TRUE, PC_C(PC,PC+1)    OPCODE 5000
  452.     ILOOP        /NOP             OPCODE 5400
  453.     LINEI        /LINE NUMBER        OPCODE 6000
  454.     ARRAYI        /ARRAY INST        OPCODE 6400
  455.     ILOOP        /NOP            OPCODE 7000
  456.     OPERI        /OPERATE INST        OPCODE 7400
  457.  
  458.  
  459. SMODE,    TAD    AC0    /INST OFFSET
  460.     TAD    JMSSI    /BUILD JMP OFF STRING TABLE
  461.     DCA    SDIS    /PUT IN LINE
  462.     CLL        /CLEAR LINK FOR SCALAR STRING
  463.     JMS I    (STFIND    /SET UP ARGUMENT ADDRESS
  464. SDIS,    HLT        /CALL STRING ROUTINE REQUESTED
  465.  
  466.     /JUMP TABLE FOR SMODE INSTRUCTIONS
  467.  
  468. SJTAB,    SCON1        /SAC_SAC&C(A$)            OPCODE 0000
  469.     SCOMP        /IF SAC .NE. C(A$),PC_PC+2    OPCODE 0400
  470.     SREAD        /C(A$)_DEVICE            OPCODE 1000
  471.     SARITH        /STRING ARITHMETIC LINKAGE    OPCODE 1400
  472.     SLOAD        /SAC_C(A$)            OPCODE 2000
  473.     SSTORE        /C(A$)_SAC            OPCODE 2400
  474. INTPC,    0        /* INTERPRETER PC        OPCODE 3000
  475. JMSSI,    JMP I    .+1    /* SMODE DISPATCH JMP        OPCODE 3400
  476.     /OPERATE CLASS INSTRUCTIONS
  477.  
  478. OPERI,    TAD    INSAV    /GET OPERATE INSTRUCTION
  479.     AND    [17    /MASK OFF OPERATE OPCODE
  480.     TAD    JMPI3    /BUILD JUMP OFF OPERATE JUMPTABLE
  481.     DCA    .+1    /STORE THE JUMP IN LINE
  482.     HLT        /DISPATCH TO PROPER OPERATE ROUTINE
  483.  
  484. JMPI3,    JMP I    .+1    /JUMP TO OPERATE ROUTINE CALLED FOR
  485.  
  486.     /OPERATE JUMP TABLE
  487.  
  488.     FUNC3I        /CALL RESIDENT FUNCTION    OPCODE 7400
  489.     SPFUNC        /SPECIAL FUNCTIONS    OPCODE 7401
  490.     SFN        /SET FILE NUMBER    OPCODE 7402
  491.     FNEGI        /NEGATE FAC        OPCODE 7403
  492.     RETRNI        /GOSUB RETURN        OPCODE 7404
  493.     FUNC7I        /CALL STORE&RECALL    OPCODE 7405
  494.     LSUB1I        /LOAD S1 FROM FAC    OPCODE 7406
  495.     LSUB2I        /LOAD S2 FROM FAC    OPCODE 7407
  496.     FUNC6I        /CALL FIELD 1 FUNCTIONS    OPCODE 7410
  497.     READI        /READ DEVICE        OPCODE 7411
  498.     WRITEI        /WRITE DEVICE        OPCODE 7412
  499.     SWRITE        /STRING WRITE        OPCODE 7413
  500.     FUNC5I        /CALL FILE FUNCTION    OPCODE 7414
  501.     FUNC4I        /CALL EXTENDED FUNCTION    OPCODE 7415
  502.     FUNC1I        /CALL FUNCTIONS 1    OPCODE 7416
  503.     FUNC2I        /CALL FUNCTIONS 2    OPCODE 7417
  504. /ARGPRE-ROUTINE TO TRANSLATE OPERAND FIELD INTO 12 BIT POINTER
  505. /INTO SCALAR TABLE FOR USE IN FPP CALLS.
  506.  
  507. ARGPRE,    0
  508.     TAD    INSAV    /GET INSTRUCTION
  509.     AND    [377    /STRIP TO OPERAND FIELD
  510.     DCA    AC0    /SAVE
  511.     TAD    AC0
  512.     CLL RAL        /*2
  513.     TAD    AC0    /PTR*3
  514.     TAD    SCSTRT    /MAKE 12 BIT ADDR
  515. SCALDF,    HLT        /DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER)
  516.     JMP I    ARGPRE    /RETURN
  517.  
  518.     /ROUTINE TO ZERO FAC
  519.  
  520. FACCLR,    0
  521.     CLA
  522.     DCA    ACX    /ZERO EXPONENT
  523.     DCA    ACL    /ZERO LOW FRACTION
  524.     DCA    ACH    /ZERO HIGH FRACTION
  525.     JMP I    FACCLR
  526.  
  527.     /SPECIAL FUNCTIONS
  528.  
  529. SPFUNC,    JMS I    [FBITGT    /ISOLATE FUNCTION BITS
  530.     TAD    JMPSPC    /MAKE A JUMP OFF SPECIAL FUNCTION TABLE
  531.     DCA    .+1    /PUT IN LINE
  532.     HLT
  533.  
  534. JMPSPC,    JMP I    .+1    /JUMP TO SPECIAL FUNCTION ROUTINE
  535.  
  536.     /SPECIAL FUNCTION JUMP TABLE
  537.  
  538.     SETF        /SET FSWITCH            000
  539.     FRANDM        /RANDOMIZE            020
  540.     ONPFX        /ON-GOTO PREFIX            040
  541.     SRLIST        /STRING READ FROM DATA LIST    060
  542.     CSFN        /SET FILE # TO TTY        100
  543.     RDLIST        /READ DATA LIST            120
  544.     AMODE        /SWITCH TO A MODE        140
  545.     SSMODE        /SWITCH TO S MODE        160
  546.     EXIT        /FORCE EXIT IN GOSUB BUMP POINTER TABLE 200
  547.  
  548.     PAGE
  549.     /ON <EXPR> GOTO OR GOSUB <LINE NUMBER LIST>
  550.  
  551. ONPFX,    TAD    ACH    /TEST SIGN OF ACH
  552.     SMA SZA CLA    /IF LE TREAT AS 0
  553.     JMS I    [UNSFIX
  554.     CIA        /SET NEGATIVE COUNT
  555.     DCA    AC0
  556. ONSRCH,    JMS I    [PWFECH    /GET GOTO/GOSUB OPCODE
  557.     SNA        /SKP IF NOT END OF VECTOR
  558.     JMP    ON    /GIVE WARNING AND CONTINUE
  559.     DCA    INSAV    /SAVE IT
  560.     JMS I    [PWFECH    /GET ADDRESS WITHIN FIELD
  561.     DCA    NEWPC    /SAVE IT
  562.     ISZ    AC0    /TEST COUNT
  563.     JMP    ONSRCH    /GET ANOTHER
  564. ONFLSH,    JMS I    [PWFECH    /NOW FLUSH TO END OF LIST
  565.     SNA CLA
  566.     JMP    JMPGO    /JMP IF FLUSH DONE
  567.     JMS I    [PWFECH
  568.     CLA
  569.     JMP    ONFLSH
  570.  
  571. ON,    JMS I    [ERROR    /PRINT WARNING
  572.     JMP I    [ILOOP    /EXIT TO ILOOP
  573.  
  574.     /JUMP ON CONDITION
  575.  
  576. FJOCI,    JMS I    [PWFECH    /GET JMP ADDRESS
  577.     DCA    NEWPC    /SAVE IT
  578. JMPGO,    TAD    INSAV    /PICK UP OPCODE
  579.     AND    [17    /MASK OFF JUMP CONDITION
  580.     SNA        /IS IT GOSUB?
  581.     JMP    GOSUB    /YES-PUSH PC ON STACK THEN JUMP
  582.     TAD    SKPTAD    /BASE TAD FOR BUILD OF TAD INSTRUCTION
  583.     DCA    .+1    /PUT IN LINE
  584.     HLT        /GET PROPER SKIP
  585.     DCA    FSKIP    /SET UP PROPER SKIP CONDITION
  586.     TAD    ACH    /GET HIGH ORDER FAC
  587.     JMP    FSKIP
  588.  
  589.     /JMP IF FILE IS OPEN
  590.  
  591. JXOPEN,    CLL CLA        /FLUSH ACH FROM AC
  592.     TAD    GSP+6    /GET A SNA CLA
  593.     JMP     .+3
  594. JFOPEN,    CLA        /FLUSH ACH FROM AC
  595.     TAD    GSP+3    /GET A SZA CLA
  596.     DCA    FSKIP
  597.     TAD I    IOTHND    /SEE IF HANDLER EP IS PRESENT
  598.     JMP    FSKIP    /GO TEST FILE CONDITION
  599.  
  600.     /JUMP ON END OF FILE
  601.  
  602. JXEOFI,    CLL CLA        /CLEAR ACH
  603.     TAD    GSP+6    /GET A SNA CLA
  604.     JMP    .+3
  605. JEOFI,    CLA        /CLEAR HORD FROM AC
  606.     TAD    GSP+3    /GET A SZA CLA
  607.     DCA    FSKIP
  608.     JMS I    [IDLE    /SEE IF FILE OPEN
  609.     AC0002        /MASK FOR EOF BIT IN HEADER
  610.     AND I    IOTHDR    /GET THAT BIT
  611. FSKIP,    HLT        /GET A SKIP OR JMP
  612.     JMP    SUCJMP
  613.     JMP I    [ILOOP    /ELSE EXIT TO ILOOP
  614.  
  615. SUCJMP,    TAD    INSAV    /GET JUMP INSTRUCTION
  616.     AND    [340    /MASK OFF DESTINATION FIELD
  617.     CLL RTR        /SLIDE OVER
  618.     TAD    CDFINL    /MAKE A CDF INSTRUCTION
  619.     DCA I    [CDFPSU    /AND SET NEW PC INSTRUCTION FIELD
  620.     TAD    NEWPC    /PICK UP NEW PC
  621.     JMP    SETPC    /SET INTERPRETER PC AND EXIT
  622.  
  623.     /GOSUB
  624.  
  625. GOSUB,    TAD I    GSP
  626.     SMA CLA
  627. GS,    JMS I    [ERROR    /ERROR IF STACK OVERFLOW
  628.     TAD I    [CDFPSU    /ELSE GET CDF INSTR
  629.     DCA I    GSP
  630.     ISZ    GSP
  631.     TAD I    (INTPC
  632.     DCA I    GSP    /STORE INT PC
  633.     ISZ    GSP
  634.     JMP    SUCJMP    /EXEC AS NORMAL GOTO NOW
  635.  
  636.     /GOSUB RETURN
  637.  
  638. RETRNI,    JMS    GSPTST    /CHECK TO SEE IF THERE IS A RETURN ADDRESS
  639.     DCA I    [CDFPSU
  640. SKPTAD,    TAD    GSP    /SET PTR TO ADDR
  641.     DCA    XR1
  642.     TAD I    XR1
  643. SETPC,    DCA I    (INTPC    /SET PC
  644.     JMP I    [ILOOP    /NOW RESUME EXECUTION
  645. NEWPC,    0
  646.  
  647.     /FOR-LOOP JUMP ROUTINE
  648.     /ENTER WITH AC = HORD
  649.  
  650. JFOR,    SNA        /IS FAC=0?
  651.     JMP I    [ILOOP    /YES-DO NOT JUMP
  652.     TAD    FSWITC    /ADD FSWITCH
  653.     SPA CLA        /ARE SIGN BIT=FSWITCH?
  654.     JMP I    [ILOOP    /NO-DO NOT JUMP
  655.     JMP    SUCJMP    /YES-DO JUMP
  656.  
  657.     /ROUTINE TO INITIALIZE FSWITCH
  658.  
  659. SETF,    AC4000
  660.     AND    ACH    /ISOLATE SIGN OF MANTISSA
  661.     DCA    FSWITC    /STORE IN FSWITCH
  662.     JMP I    [ILOOP    /DONE
  663. FSWITC,    0
  664.  
  665.     /SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS
  666.  
  667. GSP,    GSTCK        /0 PUSHJ (STACK POINTER MUST PRECEDE SKIP TABLE)
  668.     CLA        /1 JUMPA
  669.     SMA CLA        /2 JUMPGE
  670.     SZA CLA        /3 JUMPN
  671.     SMA SZA CLA    /4 JUMPG
  672.     SPA CLA        /5 JUMPL
  673.     SNA CLA        /6 JUMPE
  674.     SPA SNA CLA    /7 JUMPLE
  675.     JMP    JFOR    /10 FORLOOP JUMP ROUTINE
  676.     JMP    JFOPEN    /11 NORMAL IF OPEN COMMAND
  677.     JMP    JEOFI    /12 NORMAL IF OPEN COMMAND
  678.     JMP    JXOPEN    /13 IF OPEN CMB LINE COMMAND
  679.     JMP    JXEOFI    /14 IF END CMB LINE COMMAND
  680.     /CALL TO DEVICE DRIVER FOR FILE I/O
  681.     /ENTRY AC = FUNCTION WORD FOR READ OR WRITE
  682.     /IOTABLE FOR CURRENT FILE HAS BLOCK, BUFFER ADDR, AND HANDLER ENTRY PT
  683.  
  684. DRCALL,    0
  685.     DCA    DRFUN    /FUNCTION WORD INTO DRIVER CALL
  686. CDFINL,    CDF        /DF TO CURRENT FIELD
  687.     TAD I    IOTBUF    /GET BUFFER ADDRE FROM I/O TABLE ENTRY
  688.     DCA    DRBUF    /PUT IN DRIVER CALL
  689.     TAD I    IOTBLK    /GET BLOCK NUMBER FROM I/O TABLE
  690.     DCA    DRBLK    /PUT IN DRIVER CALL
  691.     TAD I    IOTHND    /GET DRIVER ENTRY
  692.     DCA    DRIVER    /SAVE
  693.     JMS I    DRIVER    /CALL DRIVER
  694. DRFUN,    0        /FUNCTION CONTROL WORD
  695. DRBUF,    0        /BUFFER ADDRESS
  696. DRBLK,    0        /BLOCK #
  697.     SMA CLA        /DEVICE ERROR-IS IT FATAL?
  698.     JMP I    DRCALL    /ALLS WELL
  699. DE,    JMS I    [ERROR    /FATAL
  700. DRIVER,    0
  701.  
  702. GSPTST,    0
  703.     AC7776        /SET THE AC = -2
  704.     TAD    GSP    /AND ADD STACK POINTER
  705.     DCA    GSP    /PUT IT BACK
  706.     TAD I    GSP    /DO WE HAVE A CDF FOR A RETURN ADDR.
  707.     SMA
  708. GR,    JMS I    [ERROR    /FATAL ERROR IF NOT
  709.     JMP I    GSPTST    /OK
  710.  
  711.     PAGE
  712.  
  713. EXIT,    JMS I    (GSPTST    /CHECK TO SEE IF A GOSUB HAS BEEN EXECUTED
  714.     JMP I    [ILOOP    /NOW DO A GOTO 
  715.  
  716.     /HANDLE SUBSCRIPTED NUMERIC AND STRING VARIABLES
  717.  
  718. ARRAYI,    TAD    INSAV    /FIRST GET OPCODE
  719.     AND    [340
  720.     CLL RTR
  721.     RTR
  722.     TAD    MODESW    /SHIFT MODE SWITCH TO LINK
  723.     RAR
  724.     TAD    (AJTAB    /ASSUME ARITHMETIC MODE
  725.     SZL        /SKP IF ARITH MODE
  726.     TAD    (SJTAB-AJTAB /CORRECT ADDR OF DISPATCH TABLE
  727.     DCA    ARAYOP    /LINK MUST NOT TOGGLE ON ABOVE ADD
  728.     TAD I    ARAYOP    /PICK UP DISPATCH ADDR
  729.     DCA    ARAYOP    /SAVE IT
  730.     SZL        /SKP IF ARITH MODE
  731.     JMP    SARRY    /ELSE DO STRING ARRAY OPERATION
  732.     TAD    INSAV    /GET ARRAY INSTRUCTION
  733.     AND    (37    /MASK OFF ARRAY OPERAND
  734.     CLL RTL        /MULTIPLY BY 4 (ENTRY LENGTH)
  735.     TAD    ARSTRT    /MAKE POINTER INTO ARRAY TABLE
  736.     DCA    XR1    /POINTS TO ARRAY FOR THIS OPERATION
  737. ATABDF,    HLT        /CHANGE DF TO ARRAY TABLE FIELD (SET BY START)
  738.     TAD I    XR1    /GET POINTER TO FIRST ARRAY ELEMENT
  739.     DCA    TEMP2    /SAVE FOR LATER
  740.     TAD I    XR1    /GET DF FOR VARIABLE
  741.     DCA    ADFC    /PUT IN LINE AT END OF ROUTINE
  742.     TAD I    XR1    /GET ARRAY DIMENSION 1
  743.     DCA    AC2    /SAVE
  744.     TAD    S1    /GET SUBSCRIPT 1
  745.     CLL CMA        /SET UP 12 BIT COMPARE
  746.     TAD    AC2    /DIMENSION 1 +1
  747.     SNL CLA        /S1 TOO BIG?
  748. SU,    JMS I    [ERROR    /YES-SUBSCRIPT OUT OF BOUNDS ERROR
  749.     DCA    OPH    /CLEAR TEMPORARY
  750.     TAD I    XR1    /GET DIMENSION 2
  751.     SNA        /IS SECOND DIMENSION 0?(ARRAY UNIDIMENSIONAL)
  752.     JMP    ADCALC    /YES-DON'T CHECK S2 FOR OUT OF BOUNDS
  753.     CLL CIA        /COMPARE TO SUBSCRIPT 2
  754.     TAD    S2
  755.     SZL CLA        /SKP IF S2 LO DIM2+1
  756.     JMP    SU    /ELSE TAKE ERROR EXIT
  757.     TAD    S2    /MULTIPLY DIM1+1 BY S2
  758.     JMS I    (MPY    /12 BY 12 MULTIPLY ROUTINE
  759. ADCALC,    CLL
  760.     TAD    S1    /LORD OF S1+(DIM1+1)*S2
  761.     DCA    OPX    /SAVE
  762.     RAL        /CARRY TO BIT 11
  763.     TAD    OPH    /HORD OF S1+(DIM1+1)*S2
  764.     DCA    OPH    /SAVE
  765.     TAD    OPX    /LORD OF S1+(DIM1+1)*S2
  766.     CLL RAL        /*2
  767.     DCA    OPL    /LORD OF [S1+(DIM1+1)*S2]*2
  768.     TAD    OPH    /HORD OF S1+(DIM1+1)*S2
  769.     RAL        /*2
  770.     DCA    AC2    /HORD OF [S1+(DIM1+1)*S2]*2
  771.     CLL
  772.     TAD    OPX    /LORD OF S1+(DIM1+1)
  773.     TAD    OPL    /LORD OF [S1+(DIM1+1)*S2]
  774.     DCA    OPL    /LORD OF 3*[S1+(DIM1+1)*S2]
  775.     RAL        /CARRY TO BIT 11
  776.     TAD    OPH    /HORD OF [S1+(DIM1+1)*S2)*2
  777.     TAD    AC2    /HORD OF S1+(DIM1+1)*S2
  778.     DCA    OPH    /HORD OF 3*[S1+(DIM1+1)*S2]
  779.     CLL
  780.     TAD    OPL    /INDEX TO ELEMENT
  781.     TAD    TEMP2    /AC POINTS TO CORRECT ARRAY ELEMENT
  782.     DCA    XR1    /SAVE POINTER
  783.     RAL        /CARRY TO BIT 11
  784.     TAD    OPH    /COMBINE TO MAKE TOTAL # OF FIELD OVERLAPS
  785.     CLL RTL
  786.     RAL        /SLIDE OVERLAPS TO FIELD BITS (6-8)
  787.     TAD    ADFC    /ADD ANY CHANGE IN DATA FIELD TO CDF
  788.     DCA    ADFC    /PUT ABSOLUTE CDF IN LINE
  789.     IAC
  790.     DCA    FF    /PUT FPP IN "SPECIAL MODE"
  791. ADFC,    HLT        /CHANGE DF TO DF OF ARRAY ELEMNT
  792.     TAD    XR1    /AC POINTS TO ARRAY ELEMENT
  793.     JMS I    ARAYOP    /PERFORM REQUIRED OPERATION
  794.     JMP I    [ILOOP    /FPP SOMETIMES RETURNS TO CALL+2
  795.     JMP I    [ILOOP    /DONE
  796.  
  797. SARRY,    JMS I    (STFIND    /INIT STRING ROUTINES (LINK ON)
  798.     JMP I    ARAYOP    /JMP TO STRING ROUTINE
  799.  
  800. ARAYOP,    0
  801. /SUBROUTINE FBITGT-ROUTINE TO PUT FUNCTION BITS FROM INSTRUCTION INTO AC
  802.  
  803. FBITGT,    0
  804.     TAD    INSAV
  805.     CLL RTR
  806.     RTR        /PUT FUNCTION BITS IN BITS 8-11
  807.     AND    [17    /MASK THEM OFF
  808.     JMP I    FBITGT    /RETURN
  809.  
  810. /SUBROUTINE FTYPE-RETURNS TO CALL+1 IF FILE NUMERIC,CALL+2 IF ASCII
  811.  
  812. FTYPE,    0
  813.     TAD I    IOTHDR    /GET HEADER
  814.     CLL RAR        /TYPE TO LINK
  815.     SZL CLA        /IS IT NUMERIC?
  816.     ISZ    FTYPE    /NO-BUMP RETURN
  817.     JMP I    FTYPE    /RETURN
  818.  
  819.     /CALL FOR RESIDENT FUNCTION
  820.  
  821. FUNC3I,    JMS I    [FBITGT    /ISOLATE FUNCTION #
  822.     TAD    JMPRES    /MAKE A JUMP OFF JUMP TABLE
  823.     DCA    .+1
  824.     HLT
  825.  
  826. JMPRES,    JMP I    .+1
  827.  
  828.     /JUMP TABLE FOR RESIDENT FUNCTIONS
  829.  
  830.     XABSVL        /FUNCTION BITS    000
  831.     COMMA        /        020
  832.     CRFUNC        /        040
  833.     ILOOPF        /        060 UNUSED
  834.     TAB        /        100
  835.     PNT        /        120
  836.     ONERR        /        140
  837.     PUINIT        /        160 PRINT USING INIT
  838.     PUEXEC        /        200 PRINT USING OUTPUT
  839.     CURSOR        /        220 CURSOR POSITIONING FUNCTION
  840.     OFFERR        /        240 TURN "ON ERROR" OFF
  841.     RESUME        /        260
  842.     COL        /        300 IO CHANNEL PRINT COLUMN NUMBER
  843.     RESTOR        /        320 RESTORE
  844.     RESUM0        /        340
  845.  
  846.     /CALL FOR FIELD 1 FUNCTIONS
  847.  
  848. FUNC6I,    JMS I    [FBITGT    /GET FUNCTION BITS
  849.     CIF CDF    10    /JMP TO FIELD 1 DISPATCHER WITH AC = FUNCTION NUMBER
  850.     JMP I    (F1DISP
  851.  
  852.     PAGE
  853.     /ERROR TRAPS
  854.  
  855. O0,    JMS I    [ERROR    /OVERFLOW
  856. DV,    JMS I    [ERROR    /DIVISION ERROR
  857.     JMS I    [FACCLR    /RETURN 0 IN FAC
  858.     JMP I    [ILOOP
  859. LM,    JMS I    [ERROR    /ILLEGAL ARGUMENT
  860.  
  861. ONERR,    AC4000
  862.     DCA    ERRFLG
  863.     JMS I    (PWFECH
  864.     DCA    ERRFLD
  865.     JMS I    (PWFECH
  866.     DCA    ERRCOD
  867.     JMP I    [ILOOP
  868.  
  869. RESUME,    CLL CLA IAC    /DO WE HAVE AN ERROR
  870.     AND    ERRFLG
  871.     SNA CLA
  872. RS,    JMS I    [ERROR    /WE HAVE NO ERROR TO CLEAR SO REPORT IT
  873. RESUM0,    AC4000        /CLEAR ERROR FLAG
  874.     AND    ERRFLG
  875.     SKP
  876. OFFERR,    CLL CLA        / Turn on error off
  877.     DCA    ERRFLG
  878.     JMP I    [ILOOP
  879.  
  880.     /CUR$(V,H) FUNCTION FOR VT52 & VT278
  881.     //CURRENTLY SET UP TO VT278 - MODIFIED FOR VT52 BY 'CHK52'
  882.     /DIRECTLY OUTPUTS TO CURRENT I/O CHANNEL AND SETS NEW PRINT COLUMN
  883.     /ADDR 0,0 IS UPPER LEFT CORNER OF SCREEN
  884.     /SHOULD NORMALLY BE CALLED FROM PRINT STATEMENTS ONLY
  885.     
  886.  
  887. CURSOR,    JMS    FIXRGS    /FIX THE ARGUMENTS
  888.     DCA    SACLEN    /RETURN NULL STRING (SO PRINT POSITION WILL NOT ALTER)
  889.     JMS I LOADOV    /CALL IN THE ARITH. OVERLAY
  890.     TAD    TEMP1    /STORE LAST CURSOR POSITION OF CUR(X,Y)
  891.     DCA    CURROW
  892.     TAD    ACL
  893.     DCA    CURCOL
  894.     JMS I     [CHK52    /CHECK IF VT52 OR NOT
  895.     TAD    KESC
  896.     JMS I    [PUTCH    /OUTPUT ESC
  897.     TAD CUR3    /GET CHARACTER TO OUTPUT.
  898.     JMS I    [PUTCH    /OUTPUT "[" FOR VT278, "Y" FOR VT52
  899.     TAD    TEMP1
  900. CUR1,    JMS     CUR5    /OUTPUT THE VERTICAL POSITION, USE 'CUR6' FOR VT52
  901.     TAD    ACL
  902. CUR2,    JMS CUR6    /OUTPUT HOROZONTAL ADDR
  903.     TAD    ACL    /NOW SET NEW HOROZONTAL PRINT POSITION
  904.     AND    IOMASK
  905.     DCA I    IOTPOS
  906.     JMP I    [SSMODE    /RETURN IN SMODE
  907. CUR3,    "[        /"[" CHANGED TO "Y" FOR VT52
  908.  
  909.         //OUTPUT THE POSITION FOR THE CURSOR
  910.         //FIRST TIME FOR VERTICAL POSITION
  911.         //SECOND TIME FOR HORIZONTAL POSITION
  912. CUR4,    0
  913.     AND    IOMASK    /MASK TO 7 BITS
  914.     TAD    [40    /ADD TERMINAL BIAS
  915.     JMS I    [PUTCH    /OUTPUT CURSOR ADDR
  916.     JMP I    CUR4
  917.  
  918.         //OUTPUT THE VERTICAL POSITION FOR THE VT278
  919.         //AND THEN OUTPUT THE DELIMITER ';'
  920. CUR5,    0
  921.     JMS I    [TWODEC    /OUTPUT THE VERTICAL POSITION
  922.     TAD     KSEMI    /OUTPUT ";" FOR VT278
  923.     JMS I    [PUTCH
  924.     JMP I     CUR5
  925.  
  926.         //OUTPUT THE HORIZONTAL POSITION FOR THE VT278
  927.         //AND THEN OUTPUT THE TERMINATING CHARACTER 'H'
  928. CUR6,    0
  929.     JMS I    [TWODEC    /OUTPUT THE HORIZONTAL POSITION
  930.     TAD    ("H&177    /OUTPUT "H" FOR VT278
  931.     JMS I    [PUTCH
  932.     JMP I    CUR6
  933.  
  934.     /COL(N) - RETURN PRINT COLUNM NUMBER FOR I/O CHANNEL N
  935.  
  936. COL,    JMS I    (SETIOT    /PICK UP RELATIVE ADDR OF IO CHANNEL N
  937.     TAD    (TTYF+IOTPOS-IOTHDR /MAKE ABSOLUTE PRINT POSITION ADDR
  938.     DCA    AC0
  939.     TAD I    AC0    /GET IT
  940.             /FALL INTO FLOAT ROUTINE
  941.  
  942. FLOT12,    DCA    ACL    /STORE 12 BIT INTEGER
  943. FLOTHI,    DCA    ACH    /CLEAR HIGH ORDER BITS
  944. FLOT23,    DCA    AC1    /CLEAR OVERFLOW BITS
  945.     TAD    (27    /SET EXPONENT
  946.     DCA    ACX
  947.     JMS I    [FFNOR    /NORMALIZE THE INTEGER
  948.     JMP I    [ILOOP    /RETURN TO ILOOP
  949.  
  950.     /FIX TWO REAL ARGUMENTS TO 23 BITS
  951.  
  952. FIXRGS,    0
  953.     JMS I    FIX23I    /FIX THE FAC
  954.     TAD    ACH    /SAVE THE INTEGER
  955.     DCA    TEMP2
  956.     TAD    ACL
  957.     DCA    TEMP1
  958.     DCA    INSAV    /GET TEMP0
  959.     JMS I    PARGPRE
  960.     JMS I    [FFGET
  961. PARGPRE,ARGPRE
  962.     JMS I    FIX23I    /FIX IT TOO
  963.     JMP I    FIXRGS    /RETURN
  964. CALL1,    JMS I    (7607    /CALL SYSTEM HANDLER
  965.     0600        /READ 3 BLOCKS
  966. CALL2,    OVERLAY        /INTO OVERLAY AREA
  967. CALL3,    HLT        /BLOCK # OF FILE
  968. CALL4,    JMS I    [ERROR    /ERROR
  969.     JMS I    (PSWAP    /SWAP SYSTEM OUT
  970.     JMP I    CALL2    /START USER CODE
  971.  
  972.     /LINE NUMBERS
  973.  
  974. LINEI,    TAD    INSAV    /GET INSTRUCTION
  975.     DCA    LINEHI    /SAVE
  976.     JMS I    [PWFECH    /GET WORD FOLLOWING LINE # INST
  977.     DCA    LINELO    /SAVE  AS LOW ORDER LINE #
  978. TRHOOK,    JMP I    [ILOOP    /RETURN TO I-LOOP
  979.     TAD    (5    /CALL ERROR OVERLAY
  980.     JMS I    LOADOV
  981.     JMP I    [TPRINT    /NOW JMP TO PRINT ROUTINE
  982.  
  983.     /INTERMEDIATE CHAR BUFFER FOR "FFOUT"
  984.     /AND A FEW FPP TEMPORARIES
  985.  
  986. INTERB,    ZBLOCK    7
  987. FPPTM5,    ZBLOCK    3
  988. FPPTM4,    ZBLOCK    3
  989. FPPTM3,    ZBLOCK    3
  990. NUMBUF,
  991. FPPTM2,    ZBLOCK    3
  992. FPPTM1,    ZBLOCK    3
  993.  
  994.     PAGE
  995.     /VT52 DELAY PARAMETERS (MUST BE AT BEGINNING OF PAGE)
  996.  
  997. HEIGHT,    0        /NEGATIVE SCREEN HEIGHT
  998. DELAY,    0        /NEGATIVE DELAY VALUE
  999.     IFNZRO HEIGHT-1200 <__FIX SET COMMAND__>
  1000. HCTR,    0        /HEIGHT COUNTER INITIALIZED BY SET
  1001. DCTR,    0        /DELAY COUNTER INITIALIZED BY SET
  1002.  
  1003.     /LOW LEVEL ROUTINE TO TYPE A CHAR
  1004.  
  1005. PCH,    0
  1006.     TLS        /TYPE THE CURRENT ONE
  1007. PCHLP,    ISZ    SPINNR    /SPIN RND NUMBER SEED WHILE WAITING
  1008.     TSF        /WAIT FOR THE CHAR
  1009.     JMP    PCHLP
  1010.     AND    IOMASK    /MASK TO 7BIT
  1011.     TAD    (-15    /TEST IF LINE FEED WILL BE SENT NEXT
  1012.     SZA CLA
  1013.     JMP    PCHXIT    /RETURN IF NOT
  1014.     ISZ    HCTR    /TEST SCREEN HEIGHT IF LF
  1015.     JMP    PCHXIT    /RETURN IF NOT AT BOTTOM OF SCREEN
  1016.     TAD    HEIGHT
  1017.     DCA    HCTR    /RESET HEIGHT COUNTER NOW
  1018.     TAD    DELAY
  1019.     SNA        /TEST FOR ZERO DELAY
  1020.     JMP    PCHXIT    /RETURN IF SO
  1021.     DCA    DCTR    /ELSE SET DELAY COUNTER
  1022. DLOOP,    ISZ    GCH    /NOW EXEC INNER LOOP 4096 TIMES (USUALLY)
  1023.     JMP    .-1
  1024.     KSF        /TEST IF KEY STRUCK
  1025.     SKP
  1026.     JMP    PCHXIT    /RETURN AT ONCE IF YES
  1027.     ISZ    DCTR    /TEST DELAY TIMER
  1028.     JMP    DLOOP    /REITERATE
  1029. PCHXIT,    JMS    CTCCHK    /TEST FOR ^C HIT
  1030.     KCC        //ENABLE THE KEYBOARD FOR VT278
  1031.     TAD    XFLAG
  1032.     SZA CLA
  1033.     JMP    PCHXIT    /LOOP IF ^S HIT
  1034.     JMP I    PCH    /NOW ALLOW PRINTING TO CONTINUE
  1035.  
  1036.  
  1037.     /LOW LEVEL ROUTINE TO WAIT FOR A CHAR FROM THE CONSOLE
  1038.  
  1039. GCH,    0
  1040. GCHLP,    KSF
  1041.     JMP    SPIN    /SPIN RND SEED WHILE WE WAIT
  1042.     JMS    CLOOK
  1043.     JMP I    GCH
  1044. SPIN,    ISZ    SPINNR
  1045.     NOP
  1046.     JMP    GCHLP
  1047.  
  1048.     /CHECK FOR CONTROL C STRUCK
  1049.  
  1050. CTCCHK,    0
  1051. CTCNOP,    KSF        /SEE IF A CHARCTER HAS BEEN STRUCK
  1052.     JMP I    CTCCHK    /NO, RETURN
  1053.     JMS CLOOK    /GET THE CHARACTER
  1054.     CLL CLA
  1055.     JMP I     CTCCHK    /RETURN
  1056.  
  1057.     /GET A CHARACTER
  1058. CLOOK,    0
  1059.     KRB        /SAMPLE CHAR
  1060.     AND    IOMASK    /REMOVE PARITY BIT
  1061.     DCA SAVCHR    /SAVE THE CHARACTER
  1062.     TAD SAVCHR
  1063.     TAD    TRPCHR    /GET TRAP CHARACTER
  1064.     SNA CLA        /AC = 0 IF THIS IS TRAP CHARACTER
  1065. TR,    JMS I    [ERROR    /SET ERROR FLAG, WE FOUND TRAP CHARACTER
  1066.     AC7775        /SET AC=-3
  1067.     TAD SAVCHR
  1068.     SNA
  1069.     JMP    CCTRAP    /YES, ABORT EXECUTION
  1070.     TAD    (3-21    /SEE IF ^Q (XON) OR ^S (XOFF) HIT
  1071.     CLL RTR
  1072.     SZA CLA        /SKP IF EITHER
  1073.     JMP     CLOKXT    /ELSE GET THE CHAR AND RETURN
  1074.     RAL        /LINK ON IF ^S
  1075.     DCA    XFLAG    /SET FLAG APPROPRIATELY
  1076.     JMP I    CLOOK    /RETURN
  1077.  
  1078. CLOKXT,    TAD SAVCHR    /RETURN WITH THE CHARACTER
  1079.     JMP I CLOOK    /RETURN
  1080.  
  1081. CCTRAP,    CLA IAC        /SET COLUMN NONZERO TO FORCE CRLF BEFORE MESSAGE
  1082.     DCA I    (TTYF+IOTPOS-IOTHDR
  1083. CC,    JMS I    [ERROR    /TAKE ERROR ABORT WITH MESSAGE
  1084.  
  1085.  
  1086. XFLAG,    0        /^S FLAG (ALSO MARKS START OF GOSUB STACK)
  1087. SPINNR,    0        /NEW RANDOM NUMBER SEED FOR RANDOMIZE (HIGH 12 BITS)
  1088.  
  1089.     /GOSUB STACK
  1090.  
  1091. GSTCK,    6000;0
  1092.     6000;0
  1093.     6000;0
  1094.     6000;0
  1095.     6000;0
  1096.     6000;0
  1097.     6000;0
  1098.     6000;0
  1099.     6000;0
  1100.     6000;0
  1101.     6000;0
  1102.     6000;0
  1103.     6000;0
  1104.     6000;0
  1105.     6000;0
  1106.     6000;0
  1107.     6000;0
  1108.     6000;0
  1109.     6000;0
  1110.     6000;0
  1111.     6000;0
  1112.     6000;0
  1113.     6000;0
  1114.     6000;0
  1115.     6000;0
  1116. O2525,    2525        /POSITIVE TO MARK THE END OF THE GOSUB STACK
  1117.  
  1118.     PAGE
  1119.     /INTERPRETER ERROR ROUTINE
  1120.     /ENTRY DF = CALLING FIELD IF NON FATAL ERROR
  1121.     /ACHTUNG! NON FATAL ERRORS FROM WITHIN OVERLAYS SWAP THEM OUT
  1122.  
  1123. ERROR,    0
  1124.     CLA CLL        /ENTRY AC RANDOM
  1125.     RDF        /READ DF OF CALLER 
  1126.     TAD    (CIF CDF 00 /STORE RETURN IN CASE NON FATAL
  1127.     DCA    XERRRET
  1128.     CDF 00
  1129.     CLA CLL IAC
  1130.     AND    PSFLAG    /TEST IF OS/8 17600 RESIDENT
  1131.     SZA CLA        /SKP IF NOT
  1132.     JMS I    [PSWAP    /ELSE FORCE IT OUT
  1133.     TAD I    (OVRLAY    /SAVE PREVIOUS OVERLAY
  1134.     DCA    OVSAVE
  1135.     TAD    (5    /BRING IN ERROR OVERLAY
  1136.     JMS    OVLOAD
  1137.     JMS I    (ERRORR    /JMP TO ERROR HANDLER
  1138.     TAD    OVSAVE    /NOW RESTORE PREV OVERLAY
  1139.     JMS    OVLOAD
  1140. XERRRET,HLT
  1141.     JMP I    ERROR    /RETURN TO CALLER IF NON FATAL ERROR
  1142. OVSAVE,    0
  1143.  
  1144.     /LOAD SUBSCRIPT 1 OR 2 FROM FAC OR MEMORY
  1145.  
  1146. LSUB2I,    ISZ    DCASUB
  1147.     JMP    LSUB1I
  1148. LS2I,    ISZ    DCASUB
  1149. LS1I,    JMS I    [FFPUT    /SAVE THE FAC
  1150.     INTERB
  1151.     JMS I    (ARGPRE    /GET ARG POINTER INTO AC
  1152.     JMS I    [FFGET    /LOAD ARG INTO FAC (SKIPS NEXT INST ON RETURN)
  1153. DCAS1,    DCA    S1
  1154.     JMP    .+3
  1155. LSUB1I,    JMS I    [FFPUT    /SAVE THE FAC
  1156.     INTERB
  1157.     JMS I    [UNSFIX    /GET INT(FAC)
  1158. DCASUB,    DCA    S1    /SET RESULT AS SUBSCRIPT 1
  1159.     JMS I    [FFGET    /RESTORE THE FAC
  1160.     INTERB
  1161.     TAD    DCAS1
  1162.     DCA    DCASUB    /FUDGE INSTR BACK
  1163.     JMP I    [ILOOP    /NEXT INSTRCUTION
  1164.  
  1165.     /FUNCTION OVERLAY DRIVER
  1166.  
  1167. FUNC4I,    IAC        /EXTENDED FUNCTIONS
  1168. FUNC5I,    IAC        /FILE FUNCTIONS
  1169. FUNC7I,    IAC        /STORE RECALL
  1170. FUNC2I,    IAC        /STRING FUNCTIONS
  1171. FUNC1I,    JMS    OVLOAD    /MATH FUNCTIONS
  1172.     JMP I    (OVDISP    /JMP TO OVERLAY DISPATCHER
  1173.     /ROUTINE FOR CROSS FIELD SUBROUTINE CALLS
  1174.  
  1175. CALLF0,    0
  1176.     CDF    10    /ALWAYS SET DF TO 1
  1177.     DCA    ACARG    /SAVE THE AC
  1178.     TAD I    CALLF0    /GET ROUTINE ADDR
  1179.     ISZ    CALLF0    /BUMP PAST ROUTINE ADDR
  1180.     DCA    SUBRTN
  1181.     CDF        /SET DF TO OUR FIELD
  1182.     TAD    ACARG    /GET CALLING AC
  1183.     JMS I    SUBRTN    /CALL THE ROUTINE
  1184.     SKP        /ALLOW SKIP RETURNS
  1185.     ISZ    CALLF0
  1186.     CIF CDF    10    /RETURN TO CALLER
  1187.     JMP I    CALLF0
  1188. ACARG,    0
  1189. SUBRTN,    0
  1190.     /OVERLAY LOAD ROUTINE
  1191.  
  1192. OVLOAD,    0
  1193.     DCA    AC0    /STORE OVERLAY NUMBER PASSED IN AC
  1194.     CDF        /DF TO THIS FIELD
  1195.     TAD    AC0    /GET OVERLAY # AGAIN
  1196.     CIA        /NEGATE
  1197.     TAD    OVRLAY    /COMPARE AGAINST OVERLAY FLAG
  1198.     SNA CLA        /IS THE ONE WE WANT ALREADY RESIDENT?
  1199.     JMP I    OVLOAD    /YES-JUST JUMP TO FUNCTION
  1200.     TAD    AC0    /NO-GET NUMBER OF OVERALY DESIRED
  1201.     TAD    (ARITHA    /USE AS OFFSET TO BUILD STARTING BLOCK TAD
  1202.     DCA    TEMP2    /POINTS TO PROPER STARING BLOCK #
  1203.     TAD I    TEMP2    /GET STARTING BLOCK FOR THIS OVERLAY
  1204.     SNA        /SKP IF NON RESIDENT IN FIELD 2
  1205.     JMP    INCORE    /ELSE DO FAST CORE SHUFFLE
  1206.     DCA    OVADD    /PUT IN DRIVER CALL
  1207.     JMS I    (7607    /CALL SYSTEM HANDLER
  1208.     0600        /OVERLAY 3400-4777
  1209.     OVERLAY
  1210. OVADD,    0        /STARTING BLOCK # OF OVERLAY
  1211. OE,    JMS I    [ERROR    /I/O ERROR
  1212.     JMP    OVREDY    /ALL SET, EXIT
  1213. INCORE,    TAD    AC0    /CONVERT NEW OVERLAY NUMBER TO POINTER
  1214.     CLL RAR
  1215.     TAD    AC0    /*3
  1216.     RTR
  1217.     RTR        /SHIFT TO PAGE BITS
  1218.     TAD    (-1    /THEY START AT *20000
  1219.     DCA    XR1
  1220.     TAD    (OVERLAY-1 /NOW SET FIELD 0 PTR
  1221.     DCA    XR2
  1222.     TAD    [7400    /MOVE 6 PAGES
  1223.     DCA    TEMP2
  1224. OVMOVE,    CDF    20    /GET A WORD FROM FIELD 2
  1225.     TAD I    XR1
  1226.     CDF
  1227.     DCA I    XR2    /STORE HERE IN OUR FIELD
  1228.     CDF    20    /DO 3 TIMES IN LINE
  1229.     TAD I    XR1
  1230.     CDF
  1231.     DCA I    XR2    /SAVES 512 ISZ/JMP'S
  1232.     CDF    20
  1233.     TAD I    XR1
  1234.     CDF
  1235.     DCA I    XR2
  1236.     ISZ    TEMP2
  1237.     JMP    OVMOVE
  1238. OVREDY,    TAD    AC0
  1239.     DCA    OVRLAY    /CHANGE RESIDENT FLAG
  1240.     JMP I    OVLOAD    /--RETURN--
  1241.  
  1242. OVRLAY,    0        /# OF CURRENTLY RESIDENT OVERLAY
  1243.             /0=ARITHMETIC,1=STRING,2=STORE, RECALL
  1244.             /3=FILE, 4=EXTENDED, 5=ERROR
  1245.  
  1246. /OVERLAY TABLE-CONTAINS STARTING BLOCK # OF SYSTEM OVERLAYS
  1247. /INITIALIZED BY LOADER.  ENTRY SET TO ZERO INDICATES OVERLAY RESIDENT IN FIELD 2
  1248.  
  1249. ARITHA,    0        /STARTING BLOCK OF ARITHMETIC OVERLAY
  1250. STRNGA,    0        /STARTING BLOCK OF STRING OVERLAY
  1251. STRREC,    0        /STARTING BLOCK OF STORE AND RECALL
  1252. FILEFA,    0        /STARTING BLOCK OF FILE OVERLAY
  1253. USRA,    0        /STARTING BLOCK OF EXTENDED FUNCTIONS
  1254. ERRA,    0        /STARTING BLOCK OF ERROR MESSAGE PROCESSOR
  1255.     /STRING ARITHMETIC INTERFACE
  1256.  
  1257. SARITH,    CLA IAC        /CALL IN OVERLAY 1
  1258.     JMS I    LOADOV
  1259.     JMP I    [XSARITH /NOW JMP TO STRING DISPATCH ROUTINE
  1260.  
  1261.     PAGE
  1262.     /ERROR EXIT FOR USER FUNCTIONS
  1263.  
  1264. IA,    JMS I    [ERROR
  1265.  
  1266.     /ROUTINE TO FIX A POSITIVE 23 BIT INTEGER FROM FAC
  1267.     /RESULT IN ACH;ACL
  1268.     /ERROR IF NEGATIVE NUMBER OR OUT OF RANGE EXPONENT
  1269.  
  1270. FIX23,    0
  1271.     TAD    ACH    /FIRST TEST IF POSITIVE
  1272.     SPA CLA
  1273. FM,    JMS I    [ERROR    /JMP OUT IF ERROR
  1274.     TAD    ACX    /SEE IF LT 1
  1275.     SPA SNA
  1276.     CLA        /TRUNCATE TO ZERO IF YES
  1277.     TAD    (-30
  1278.     SMA        /SKP IF RESULT LT 2**23
  1279. FO2,    JMS I    [ERROR    /ELSE TAKE ERROR EXIT
  1280.     DCA    ACX    /SET SHIFT COUNTER
  1281.     TAD    ACX    /TEST IF MORE THAN 12. SHIFTS
  1282.     TAD    (14
  1283.     SMA
  1284.     JMP    LT12    /JMP IF NO
  1285.     DCA    ACX    /DROP COUNTER DOWN IF YES
  1286.     TAD    ACH    /DO FAST WORD SHIFT
  1287.     DCA    ACL
  1288.     DCA    ACH
  1289. LT12,    CLA
  1290.     JMP    FIXGO    /JMP INTO LOOP
  1291. FIXLUP,    TAD    ACH    /NOW SHIFT DOUBLE WORD RIGHT
  1292.     CLL RAR
  1293.     DCA    ACH
  1294.     TAD    ACL
  1295.     RAR
  1296.     DCA    ACL
  1297. FIXGO,    ISZ    ACX    /TEST IF DONE YET
  1298.     JMP    FIXLUP    /NO, ITERATE
  1299.     JMP I    FIX23    /OK, RETURN
  1300.  
  1301.     /ROUTINE TO FIX A POSITIVE 12 BIT NUMBER FROM FAC
  1302.     /RETURN RESULT IN AC
  1303.     /SPECIAL CASE OF FIX23
  1304.  
  1305. UNSFIX,    0
  1306.     CDF        /RESET DF ON ENTRY
  1307.     JMS    FIX23    /FIX THE FAC
  1308.     TAD    ACH    /SEE IF GE 2**12
  1309.     SZA CLA        /SKP IF NO
  1310. FO,    JMS I    [ERROR    /ELSE TAKE ERROR EXIT
  1311.     TAD    ACL    /OK, RETURN LOW 12 BITS
  1312.     JMP I    UNSFIX    /--RETURN--
  1313.     /RESTORE ROUTINE
  1314.  
  1315. RESTOR,    TAD    ENTNO    /GET CURRENT FILE #
  1316.     SNA CLA        /IS IT 0?
  1317.     JMP    RESDLS    /YES-RESTORE DATA LIST
  1318.     JMS I    (WRBLK    /NO-WRITE CURRENT BUFFER
  1319.     STA        /-1
  1320.     TAD I    IOTLOC    /STARTING BLOCK-1
  1321.     DCA I    IOTBLK    /SET CURRENT BLOCK #
  1322.     TAD I    IOTBUF    /GET BUFFER ADDRESS
  1323.     DCA I    IOTPTR    /USE IT TO RESET READ\WRITE POINTER
  1324.     TAD I    IOTHDR    /GET HEADER WORD
  1325.     AND    (7535    /CLEAR EOF BIT, BUFFER WRITTEN BIT, AND CHAR #3 FLAG
  1326.     DCA I    IOTHDR
  1327.     JMS I    (NEXREC    /READ FIRST BLOCK INTO BUFFER
  1328.     JMP I    [ILOOP    /DONE
  1329. RESDLS,    TAD    DLSTRT    /ADDRESS OF START OF INCORE DATA LIST
  1330.     DCA    DATAXR    /USE IT TO RESET DATA LIST POINTER
  1331.     JMP I    [ILOOP    /THATS ALL!
  1332. /SUBROUTINE STFIND-WHEN CALLED,IF LINK=1 STRING ARRAY TABLE IS
  1333. /USED,IF LINK=0 STRING SYMBOL TABLE IS USED. RETURNS WITH AC SET
  1334. /TO CDF OF OPERAND STRING,STRPTR POINTING TO THE FIRST WORD
  1335. /IN THE STRING, AND THE MAX LENGTH OF THE STRING IS IN STRMAX. ALSO,
  1336. /THE ACTUAL LENGTH OF THE STRING IS IN STRCNT
  1337.  
  1338. STFIND,    0
  1339.     SZL        /IS THIS AN ARRAY INST?
  1340.     JMP    SAFIND    /YES-POINTER IS INTO ARRAY TABLE
  1341.     TAD    INSAV    /GET INST AGAIN
  1342.     AND    [377    /ISOLATE OPERAND POINTER
  1343.     DCA    AC0    /NO-SAVE OPERAND POINTER
  1344.     TAD    AC0    /N
  1345.     CLL RAL        /2N
  1346.     TAD    AC0    /3N (3 WORDS/ENTRY)
  1347.     TAD    STSTRT    /ADD BASE ADR OF STRING TABLE
  1348. STCOM,    DCA    XR2    /POINTER TO THIS ENTRY IN STRING TABLE
  1349. STDF,    HLT        /DF TO THAT OF SYMBOL TABLES (SET BY START)
  1350.     TAD I    XR2    /GET POINTER TO STRING
  1351.     DCA    STRPTR
  1352.     TAD I    XR2    /GET CDF FOR OPERAND STRING
  1353.     DCA    STRCDF    /SAVE
  1354.     TAD I    XR2    /GET NUMBER OF WORDS PER STRING
  1355.     DCA    STRMAX    /SAVE
  1356.     SNL        /ARRAY ELEMENT?
  1357.     JMP    STRCDF    /NO-SKIP THIS SUBSCRIPT CALCULATION
  1358.     TAD    S1    /GET SUBSCRIPT
  1359.     STL CMA        /SET UP 12 BIT COMPARE
  1360.     TAD I    XR2    /GET DIMENSION
  1361.     SZL CLA        /IS S1>DIMENSION?
  1362.     JMP I    (SU    /YES
  1363.     TAD    STRMAX    /GET NUMBER OF WORDS PER ELEMENT
  1364.     DCA    AC2    /# OF WORDS IN EACH ARRAY ELEMENT
  1365.     TAD    S1    /GET SUBSCRIPT
  1366.     JMS I    (MPY    /S1*ELEMENT LENGTH (ASSUMES LINK UNCHANGED ON RETURN)
  1367.     TAD    STRPTR    /ARRAY OFFSET+POINTER TO A(0)
  1368.     DCA    STRPTR    /FINAL STRING POINTER
  1369.     RAL        /CARRY TO BIT 11
  1370.     TAD    OPH    /ADD TO ACCUMLATED OVERLAPS FROM MULTIPLY
  1371.     CLL RTL
  1372.     RAL        /PUT OVERLAP # INTO BITS 6-8
  1373.     TAD    STRCDF    /ADD TO CDF IF NECESSARY
  1374.     DCA    STRCDF    /SAVE AGAIN
  1375. STRCDF,    0        /DF TO STRING FIELD
  1376.     TAD I    STRPTR
  1377.     CDF
  1378.     DCA    STRCNT    /STORE -(CURRENT LENGTH OF STRING)
  1379.     TAD    STRCDF    /CDF TO OPERAND IN AC
  1380.     DCA I    (SSTEX    /SETUP STRING STORE EXIT DF HERE
  1381.     STA        /NOW SET MAX SIZE OF STRING IN CHARS
  1382.     TAD    STRMAX
  1383.     CLL RAR
  1384.     TAD    STRMAX
  1385.     CIA        /NEGATE
  1386.     IAC        /COMPENSATE FOR SIZE WORD
  1387.     DCA    STRMAX
  1388.     JMS I    (BYTSET    /ENTER FUNCTIONS WITH BYTE POINTERS SETUP
  1389.     JMP I    STFIND    /RETURN
  1390.  
  1391. SAFIND,    TAD    INSAV    /GET INST
  1392.     AND    (37    /ISOLATE OPERAND POINTER
  1393.     CLL RTL        /4N (4 WORDS/ENTRY)
  1394.     TAD    SASTRT    /USE STRING ARRAY TABLE
  1395.     STL        /SET LINK FOR ARRAY INST
  1396.     JMP    STCOM    /RETURN TO SUBROUTINE MAINLINE
  1397.  
  1398.     /PRINT USING INTERFACE
  1399.  
  1400. PUINIT,    CLA IAC        /CALL OVERLAY 1
  1401.     JMS I    LOADOV
  1402.     JMP I    [XPUINIT
  1403.  
  1404.     PAGE
  1405. /ROUTINE SFN-ROUTINE TO RESET POINTERS IN PAGE ZERO FILE POINTER
  1406. /AREA TO REFLECT A CHANGE IN THE CURRENT FILE NUMBER
  1407.  
  1408. CSFN,    DCA    ACL    /RESET CHANNEL NUMBER TO CONSOLE
  1409.     SKP
  1410. SFN,    JMS    SETIOT    /GO GET ADDRESS OF IOTABLE FOR THIS CHANNEL
  1411.     TAD    (TTYF    /MAKE ABSOLUTE POINTER TO HEADER WORD
  1412.     DCA    XR1    /STORE IN TEMP
  1413.     TAD    ACL    /SET ENTRY NUMBER FROM LOW FAC
  1414.     DCA    ENTNO
  1415.     TAD    (IOTHDR-1 /NOW POINT AT PAGE 0 AREA
  1416.     DCA    XR2
  1417.     TAD    (IOTHDR-IOTFIL-1 /SETUP ALL BUT FILENAME
  1418.     DCA    TEMP2
  1419. SFNLUP,    TAD    XR1
  1420.     DCA I    XR2
  1421.     ISZ    XR1
  1422.     ISZ    TEMP2
  1423.     JMP    SFNLUP    /SET UP THE POINTERS NOW
  1424.     AC7776        /NOW GET USER RECORD SIZE (PHYS RECORD SIZE-2)
  1425.     TAD I    IOTRSZ
  1426.     SZL        /SKP IF HAVE A SIZE
  1427.     CLA        /ELSE ASSUME 0, NOT DIRECT ACCESS
  1428.     CDF    10
  1429.     DCA I    (REMSIZ    /STORE INITIAL REMAINING SIZE IN RECORD
  1430.     DCA I    (EOLPTR    /ZERO THE ONCE ONLY FLAG
  1431.     CDF
  1432.     TAD I    IOTSUB    /NOW SET THE FIELD POINTER
  1433.     CDF    10
  1434.     DCA I    (NXTFLD
  1435.     JMP I    [ILOOP    /--RETURN--
  1436.  
  1437.     /ROUTINE TO PICK UP AND RANGE CHECK AN I/O CHANNEL NUMBER FROM FAC
  1438.  
  1439. SETIOT,    0
  1440.     JMS I    [UNSFIX    /FIX FAC TO GET FILE #
  1441.     STL
  1442.     TAD    (-MAXFIL /IS RESULT A LEGAL FILE #?
  1443.     SNL SZA CLA
  1444. FN,    JMS I    [ERROR    /NO-ERROR
  1445.     TAD    ACL    /PICK UP FILE NUMBER
  1446.     CLL RAL        /*2
  1447.     CLL RTL        /*10
  1448.     TAD    ACL    /*11
  1449.     CLL RAL        /*22
  1450.     IFNZRO    IOTSIZ-22 <__ASSEMBLY ERROR__>
  1451.     JMP I    SETIOT    /RETURN WITH AC INDEXING INTO IOTABLE
  1452.     /ROUTINE TO RETURN RECORD FIELD DEFINITIONS TO FREELIST
  1453.  
  1454. RTNDEF,    0
  1455.     TAD I    IOTSUB    /GET HEAD OF USER DEFINED FIELDS
  1456.     CDF    10
  1457. RTNLUP,    SNA        /SKP IF HAVE ONE
  1458.     JMP    EORETN    /ELSE DONE
  1459.     DCA    AC0    /SAVE IT
  1460.     TAD I    AC0    /GET ITS LINK
  1461.     DCA    AC1    /SAVE IT
  1462.     TAD I    (FREHD    /NOW GET THE CURRENT FREELIST PTR
  1463.     DCA I    AC0    /STORE IN CURRENT FIELD BUFFER
  1464.     TAD    AC0    /UPDATE FREELIST
  1465.     DCA I    (FREHD
  1466.     TAD    AC1    /REPEAT FOR NEXT ONE
  1467.     JMP    RTNLUP
  1468. EORETN,    CDF
  1469.     DCA I    IOTSUB    /ZERO THE RECORD FIELD LIST NOW
  1470.     JMP I    RTNDEF    /--RETURN--
  1471. /ROUTINE TO SWAP PG 17600 WITH N7400 OR N7600 (WHICHEVER THE CASE MAY BE)
  1472. /WHERE N IS THE HIGH CORE FIELD
  1473.  
  1474. PSWAP,    0
  1475.     TAD    P7600    /POINTER TO 17600 AND COUNTER
  1476.     DCA    AC0
  1477.     TAD    PSFLAG    /GET SWAPPING FLAGS
  1478.     RAR
  1479.     CML RAL        /TOGGLE THE INPLACE BIT
  1480.     DCA    PSFLAG    /STORE IT BACK
  1481.     TAD    HICORE    /PICK UP ADDR OF HIGH CORE
  1482.     DCA    TEMP2    /POINTER TO HIGH CORE
  1483. P1CDF,    HLT        /DF TO HI CORE
  1484.     TAD I    TEMP2    /GET WORD FROM HI CORE
  1485.     DCA    TM    /SAVE IT
  1486. P2CDF,    CDF 10
  1487.     TAD I    AC0    /GET WORD FROM 17600
  1488. P1CDF1,    HLT        /DF TO HI CORE AGAIN
  1489.     DCA I    TEMP2    /PUT 17600 WORD IN HI CORE
  1490. P2CDF1,    CDF 10
  1491.     TAD    TM    /GET SAVED HI CORE WORD
  1492.     DCA I    AC0    /AND PUT IN 17600
  1493.     ISZ    TEMP2    /BUMP HI CORE POINTER
  1494. P7600,    7600        /CLA
  1495.     ISZ    AC0    /BUMP 17600 POINTER AND CHECK FOR DONE
  1496.     JMP    P1CDF    /NO DONE-MOVE NEXT WORD
  1497.     CDF
  1498.     JMP I    PSWAP    /DONE-RETURN
  1499. HICORE,    0        /POINTS TO LOCATION OF 17600 SAVE AREA
  1500.     /STRING COMPARE
  1501.     /COMPARE SAC WITH MEMORY, BLANK EXTENDING THE
  1502.     /SHORTER STRING ON THE RIGHT
  1503.  
  1504. SCOMP,    DCA    MODESW    /SET INTERPRETER TO ARITH MODE NOW
  1505.     JMS I    [FACCLR    /TENTATIVELY ASSUME EQUAL (FAC = 0)
  1506. SCOMLP,    TAD    STRCNT    /IS THE MEMORY STRING EMPTY NOW?
  1507.     SNA CLA
  1508.     TAD    L40    /PAD WITH SPACE IF YES
  1509.     SNA
  1510.     JMS I    (LDB    /LOAD NEXT BYTE IF NOT
  1511.     DCA    TEMP2
  1512.     TAD    SACLEN    /NOW IS THE SAC EMPTY
  1513.     SNA CLA
  1514.     TAD    L40    /YES, PAD IT
  1515.     CDF    10    /GET INTO SAC FIELD
  1516.     SNA
  1517.     TAD I    SACXR    /NO GET IT
  1518.     CDF
  1519.     CLL CIA        /COMPARE TO MEMORY
  1520.     TAD    TEMP2
  1521.     SZA CLA
  1522.     JMP    SNEQ    /JMP IF NOT EQUAL, L=SENSE OF COMPARE
  1523.     TAD    STRCNT    /IS MEMORY STRING DONE
  1524.     SZA CLA
  1525.     ISZ    STRCNT    /NO, BUMP COUNT
  1526. L40,    40        /EFFECTIVE NOP
  1527.     TAD    SACLEN    /IS THE SAC EMPTY
  1528.     SZA CLA
  1529.     ISZ    SACLEN    /NO BUMP COUNT
  1530.     TAD    SACLEN    /GET SAC REMAINDER (SKP IF IS JUST ZERO)
  1531.     TAD    STRCNT    /ADD ARG REMAINDER
  1532.     SZA CLA
  1533.     JMP    SCOMLP    /LOOP IF BOTH NOT EMPTY
  1534.     JMP I    [ILOOP    /OTHERWISE EQUAL
  1535. SNEQ,    STA RAR
  1536.     DCA    ACH    /STORE SIGN BIT
  1537.     JMP I    [ILOOP    /--RETURN--
  1538.  
  1539.     /FLOATING NEGATE
  1540. FNEGI,    JMS I    [FFNEG
  1541.     JMP I    [ILOOP
  1542.  
  1543.     PAGE
  1544.     /STRING DATA LIST READ, STRING LOAD AND STRING CONCATENATE
  1545.  
  1546.     NOP        /PAD TO CHANGE VALUE OF TAG "SC"
  1547. SRLIST,    JMS    DLREAD    /FIRST READ NEG BYTE COUNT
  1548.     DCA    STRCNT    /STORE IT
  1549.     TAD    DATAXR    /NOW KLUDGE UP LDB ROUTINE
  1550.     DCA I    (BYTPTR
  1551.     TAD    (LDBL
  1552.     DCA I    (GIVB
  1553.     TAD    DLCDF
  1554.     DCA I    (BYTCDF
  1555.     DCA    SACLEN    /CLEAR LENGTH OF CURRENT STRING
  1556.     JMS    SCOMN    /CALL COMMON CODE
  1557.     TAD I    (BYTPTR    /NOW RESTORE DATA LIST POINTER
  1558.     DCA    DATAXR
  1559.     JMP I    [ILOOP    /DONE
  1560.  
  1561. SLOAD,    DCA    SACLEN    /CLEAR SAC LENGTH IF LOAD
  1562. SCON1,    JMS    SCOMN    /CALL COMMON CODE
  1563.     JMP I    [ILOOP    /DONE
  1564.  
  1565. SCOMN,    0
  1566.     TAD    STRCNT
  1567.     SNA CLA
  1568.     JMP I    SCOMN    /NOTHING TO DO IF NULL STRING
  1569.     TAD    SACLEN    /COMPUTE OFFSET INTO SAC
  1570.     CIA
  1571.     TAD    [SAC-1
  1572.     DCA    SACXR    /TO STORE AFTER END OF PREV STRING
  1573. SEGCOM,    JMS I    (LDB    /GET A BYTE
  1574.     CDF    10
  1575.     DCA I    SACXR    /STORE IT
  1576.     CDF
  1577.     STA
  1578.     TAD    SACLEN    /NOW BUMP SIZE OF SAC
  1579.     DCA    SACLEN
  1580.     TAD    SACLEN    /CHECK IF ROOM LEFT
  1581.     TAD    (SACLIM
  1582.     SPA CLA
  1583. SC,    JMS I    [ERROR    /FATAL ERROR IF SAC OVERFLOW
  1584.     ISZ    STRCNT
  1585.     JMP    SEGCOM    /ITERATE IF MORE
  1586.     JMP I    SCOMN    /--RETURN--
  1587. /SUBROUTINE MPY- 12 BIT BY 12 BIT MULTIPLY. MULTIPLIES THE CONTENTS
  1588. /OF AC2 BY THE CONTENTS OF THE AC,LEAVING THE HI RESULT IN OPH
  1589. /AND THE LOW RESULT IN THE AC
  1590.  
  1591. MPY,    0
  1592.     DCA    TEMP1
  1593.     DCA    OPH
  1594.     TAD    (-14
  1595.     DCA    OPX
  1596. MP12LP,    TAD    AC2
  1597.     RAR
  1598.     DCA    AC2
  1599.     TAD    OPH
  1600.     SNL
  1601.     JMP    .+3    /12 BIT MULTIPLY USED TO FIND (DIM1+1)*S2
  1602.     CLL
  1603.     TAD    TEMP1
  1604.     RAR
  1605.     DCA    OPH
  1606.     ISZ    OPX
  1607.     JMP    MP12LP
  1608.     TAD    AC2    /LORD OF (DIM1+1)*S2 IN AC
  1609.     RAR        /HORD OF (DIM1+1)*S2 IN OPH
  1610.     JMP I    MPY    /RETURN
  1611.  
  1612.     /ROUTINE TO CHECK IF FILE IDLE
  1613.  
  1614. IDLE,    0
  1615.     TAD I    IOTHND    /GET HANDLER ENTRY
  1616.     SNA CLA        /IS IT EMPTY?
  1617. FI,    JMS I    [ERROR    /YES-USER TRIED TO DO SOMETHING TO AN UNOPEN FILE
  1618.     JMP I    IDLE    /NO-RETURN
  1619. /ROUTINE TO READ NEXT WORD IN DATALIST INTO AC
  1620.  
  1621. DLREAD,    0
  1622.     TAD    DATAXR    /DATA LIST POINTER
  1623.     CLL CMA        /SET UP 12 BIT COMPARE
  1624.     TAD    DLSTOP    /ADDR OF END OF DATA LIST
  1625.     SNL CLA        /POINTER AT END OF LIST?
  1626. DA,    JMS I    [ERROR    /YES
  1627. DLCDF,    .        /NO-DF TO DATA LIST
  1628.     TAD I    DATAXR    /FETCH WORD FROM DATA LIST
  1629.     CDF
  1630.     JMP I    DLREAD    /DONE
  1631.  
  1632.     /RANDOMIZE STATEMENT
  1633.  
  1634. FRANDM,    TAD I    (SPINNR    /LOAD NEW VALUE INTO HIGH ORDER 12 BITS OF SEED
  1635.     DCA    SEEDH
  1636.     JMP I    [ILOOP    /RETURN TO ILOOP
  1637. SEEDH,    0        /31 BIT RANDOM NUMBER SEED FOR RND(0)
  1638. SEEDL,    1000
  1639. SEED1,    140
  1640.  
  1641.     /SUBROUTINE CR,LF
  1642.  
  1643. CRLFR,    0
  1644.     TAD    [15
  1645.     JMS I    [PUTCH
  1646.     TAD    (12
  1647.     JMS I    [PUTCH    /PRINT A CR,AND LF
  1648. /    DCA I    IOTPOS    /ZERO NUMBER OF CHARS PRINTED SO FAR
  1649.     JMP I    CRLFR
  1650.  
  1651. /SUBROUTINE FOTYPE
  1652. /RETURNS TO CALL+1 IF FILE FIXED LENGTH,CALL+2 IF VARIABLE
  1653.  
  1654. FOTYPE,    0
  1655.     TAD I    IOTHDR    /GET HEADER
  1656.     AND    K4    /ISOLATE TYPE BIT
  1657.     SZA CLA        /IS IT FIXED LENGTH?
  1658.     ISZ    FOTYPE    /NO-BUMP RETURN
  1659.     JMP I    FOTYPE    /RETURN
  1660.  
  1661.     /ABS(X) FUNCTION
  1662.  
  1663. XABSVL,    JMS    ABSVAL    /NEGATE FAC IF NEGATIVE
  1664.     JMP I    [ILOOP    /--RETURN--
  1665.  
  1666.     /SUBROUTINE TO TAKE ABS VALUE OF FAC
  1667.  
  1668. ABSVAL,    0
  1669.     TAD    ACH
  1670.     SPA CLA        /IS FAC<0?
  1671.     JMS I    [FFNEG    /YES-NEGATE IT
  1672.     JMP I    ABSVAL    /RETURN
  1673.  
  1674.     /PNT(X)
  1675.     /SEND 8BIT CHAR TO THE CURRENT FILE
  1676.  
  1677. PNT,    JMS I    [UNSFIX    /FIX X
  1678.     AND    [377    /MASK TO 8 BITS
  1679.     JMS I    [PUTCH    /PUT IN FILE BUFFER
  1680.     JMP I    [ILOOP    /DONE
  1681.  
  1682.     /ROUTINE TO ZERO THE CURRENT I/O BUFFER
  1683.  
  1684. BLZERO,    0
  1685.     STA
  1686.     TAD I    IOTBUF
  1687.     DCA    XR1    /POINT INTO THE BUFFER
  1688.     TAD    [7400
  1689.     DCA    XR2    /SET COUNT TO 400 WORDS
  1690.     TAD    (32    /INSERT A ^Z IN THE BUFFER FIRST
  1691.     CDF 10
  1692.     DCA I    XR1
  1693.     ISZ    XR2
  1694.     JMP    .-2    /LOOP FOR THE REST
  1695.     CDF
  1696.     JMP I    BLZERO    /--RETURN--
  1697.  
  1698.  
  1699.     PAGE
  1700.     /STRING STORE
  1701.  
  1702. SSTORE,    TAD    SACLEN
  1703.     SNA
  1704.     JMP I    (SSTEX    /EXIT IF NULL STRING IN SAC
  1705.     DCA    AC0    /SET COUNT
  1706.     TAD    SACLEN    /SEE IF WILL FIT
  1707.     CIA
  1708.     TAD    STRMAX
  1709.     SMA SZA CLA    /SKP IF LEN.LE.MAX LEN
  1710. SL,    JMS I    [ERROR    /ERROR IF TARGET STRING TOO SMALL
  1711. SSTLP,    CDF    10
  1712.     TAD I    SACXR    /PICK UP SAC BYTE
  1713.     CDF
  1714.     JMS I    (DPB    /STORE IT
  1715.     ISZ    AC0
  1716.     JMP    SSTLP
  1717.     JMP I    (SSTEX    /--RETURN--
  1718.  
  1719.     /STRING READ FROM FILE TO MEMORY
  1720.  
  1721. SREADL,    TAD    CHAR    /DEPOSIT THE CHAR
  1722.     JMS I    (DPB
  1723. SREAD,    JMS I    (GETCH    /GET CHAR FROM FILE
  1724.     TAD    CHAR
  1725.     TAD    (-15    /IS IS CR?
  1726.     SNA
  1727.     JMP I    (SSTEX    /YES, EXIT
  1728.     CLL        /TEST IF FF, VT OR LF
  1729.     TAD    (3
  1730.     SZL CLA        /SKP IF NO
  1731.     JMP    SREAD    /YES, IGNORE IT
  1732.     TAD I    (BYTCNT    /SEE IF THIS CHAR WILL FIT
  1733.     TAD    STRMAX
  1734.     SPA CLA
  1735.     JMP    SREADL
  1736. ST,    JMS I    [ERROR
  1737.     JMP I    (SSTEX    /SET STRING SIZE AND EXIT
  1738.     /STRING WRITE FROM SAC TO DEVICE
  1739.  
  1740. SWRITE,    DCA    COMMAS
  1741.     TAD    SACLEN    /SEE IF NULL STRING
  1742.     SNA
  1743.     JMP I    [ILOOP    /RETURN IF SO
  1744.     CIA
  1745.     TAD I    IOTPOS    /ADD TO NUMBER OF CHARS PRINTED SO FAR
  1746.     TAD    LWIDTH
  1747.     SMA SZA CLA    /SKP IF LE WIDTH OF LINE
  1748.     JMS I    [CRLFR    /ELSE RESET CARRAIGE
  1749.     TAD    SACLEN
  1750.     DCA    STRCNT    /SET LOOP COUNTER
  1751.     TAD    [SAC-1
  1752.     DCA    SACXR    /POINT AT SAC
  1753. SWRLP,    CDF    10
  1754.     TAD I    SACXR
  1755.     CDF
  1756.     JMS I    [PUTCH
  1757.     ISZ    STRCNT
  1758.     JMP    SWRLP    /ITERATE IF MORE
  1759.     JMP I    [ILOOP    /--RETURN--
  1760.  
  1761. /COMMA FUNCTION (KNOWN ONLY TO COMPILER FOR FORMATTING PRINT
  1762. /STATEMENTS)
  1763.  
  1764. COMMA,    JMS I    [FTYPE    /SKP IF FILE IS ASCII
  1765.     JMP I    [ILOOP    /NO-COMMA FUNCTION IS A NOP
  1766.     TAD    COMMAS    /GET COMMA SWITCH
  1767.     SNA CLA        /WAS LAST THING PRINTED A COMMA?
  1768.     JMP    .+3    /NO-WE ARE OK
  1769.     TAD    [40    /YES-PRINT A SPACE BEFORE DOING COMMA CALCULATION
  1770.     JMS I    [PUTCH
  1771.     IAC
  1772.     DCA    COMMAS    /SET COMMA SWITCH
  1773.     JMP    COMGO    /JMP INTO TAB LOOP
  1774. COMLUP,    TAD    TEMP2    /SEE IF PAST THIS TAB STOP
  1775.     CIA
  1776.     TAD I    IOTPOS
  1777.     SPA
  1778.     JMP    SLOVER    /IF NUMBER OF CHARS SO FAR LT TAB STOP, TAB OUT
  1779.     SNA CLA
  1780.     JMP I    [ILOOP    /RETURN IF EXACTLY ON A COLUMN
  1781.     TAD    TEMP2
  1782. COMGO,    TAD    (COLWID    /MOVE UP TO NEXT COLUMN
  1783.     DCA    TEMP2
  1784.     TAD    TEMP2    /SEE IF END OF THIS COL FITS ON OUR LINE
  1785.     TAD    LWIDTH
  1786.     SPA SNA CLA    /SKP IF NO, GIVE CRLF
  1787.     JMP    COMLUP    /TRY NEXT STOP
  1788.  
  1789. /CARRIAGE RETURN FUNCTION (KNOWN ONLY TO COMPILER FOR TERMINATING
  1790. /PRINT STATEMENTS)
  1791.  
  1792. CRFUNC,    STA
  1793.     TAD I    IOTHDR
  1794.     CLL RTR
  1795.     SMA SNL CLA    /SKP CRLF IF EOF SET OR NON ASCII FILE
  1796.     JMS I    [CRLFR    /DO AS WE ARE TOLD
  1797.     JMP I    [ILOOP    /NEXT INST
  1798.  
  1799.     /TAB FUNCTION
  1800.  
  1801. TAB,    JMS I    [UNSFIX    /FIX X TO INTEGER
  1802.     STL        /REDUCE MODULO LINE WIDTH
  1803.     TAD    LWIDTH
  1804.     SNL
  1805.     JMP    .-3
  1806.     CIA
  1807.     TAD    LWIDTH    /COL 0 IS LEFT MARGIN
  1808.     TAD I    IOTPOS    /COMPARE DESIRED COLUMN TO REAL COLUMN
  1809.     SMA        /IS X>=CURRENT COLUMN?
  1810.     JMP I    [ILOOP    /YES-THEN DO NOTHING
  1811.             /FALL INTO SPACE OUT ROUTINE
  1812.  
  1813. SLOVER,    DCA    COLCNT    /-# OF COLUMNS TO NEXT MARKER
  1814.     JMS I    [FTYPE    /IS FILE NUMERIC?
  1815.     JMP I    [ILOOP    /YES-THIS IS A NOP
  1816.     TAD    [40    /GET SPACE
  1817.     JMS I    [PUTCH    /PRINT IT
  1818.     ISZ    COLCNT    /THERE YET?
  1819.     JMP    .-3    /NO-TYPE ANOTHER SPACE
  1820.     JMP I    [ILOOP    /YES-DONE
  1821.  
  1822. COMMAS,    1        /SET TO 1 IF LAST PRINT WAS A COMMA MOVE
  1823. COLCNT,    0
  1824.  
  1825.     /LIST OF AVAILABLE I/O BUFFERS
  1826.  
  1827. BSTACK,    BUFAREA+2000    /ORDERED HIGH TO LOW ON ENTRY TO BRTS
  1828.     BUFAREA+1400
  1829.     BUFAREA+1000
  1830.     BUFAREA+0400
  1831.     BUFAREA
  1832.     0        /TERMINATED BY ZERO WORD
  1833.  
  1834.     /36 BIT SKIP IF FAC NONZERO
  1835.  
  1836. FFOUT,    0        /HERE TO PROVIDE FIELD ONE LINKAGE
  1837.     CIF CDF    10
  1838.     JMS I    XFER1
  1839.     JMP I    FFOUT
  1840.  
  1841. XFER1,    FFOUT1        /POINTER TO FIELD ONE FLOATING POINT ROUTINE
  1842.  
  1843. FFIN,    0        /HERE TO PROVIDE FIELD ONE LINKAGE
  1844.     CIF 10
  1845.     JMS I    XFER2
  1846.     JMP I    FFIN
  1847.  
  1848. XFER2,    FFIN1        /POINTER TO FILED ONE ROUTINE (BOTH MOVED)
  1849.  
  1850. O5000,    5000        /KLUDGE CONSTANT USED BY FIELD 1 FFOUT ROUTINE
  1851.  
  1852.     PAGE
  1853.     /INCREMENT AND LOAD 7 BIT BYTE FROM MEMORY
  1854.     /ENTRY DF MAY BE RANDOM
  1855.  
  1856. LDB,    0
  1857.     JMP I    GIVB    /COROUTINE RETURN
  1858. GIVB,    0
  1859.     CDF        /RESET DF NOW
  1860.     AND    IOMASK    /MASK TO 7 OR 8 BIT
  1861.     JMP I    LDB    /--RETURN--
  1862.  
  1863. LDBL,    JMS    BUMP    /BUMP POINTER AND SET DF
  1864.     TAD I    BYTPTR    /GET A WORD
  1865.     AND    [7400    /MASK PART OF THIRD CHAR
  1866.     DCA    BYT1    /SAVE
  1867.     TAD I    BYTPTR    /NOW GET WORD AGAIN
  1868.     JMS    GIVB    /CALL CALLER BACK
  1869.     JMS    BUMP    /BUMP POINTER AGAIN
  1870.     TAD I    BYTPTR    /GET CHAR
  1871.     AND    [7400    /SAVE HIGH 4 BITS
  1872.     DCA    BYT2
  1873.     TAD I    BYTPTR    /GET WORD AGAIN
  1874.     JMS    GIVB    /RETURN TO CALLER
  1875.     TAD    BYT2    /NOW COMBINE LOW AND HIGH NIBBLES
  1876.     CLL RTR
  1877.     RTR
  1878.     TAD    BYT1
  1879.     CLL RTR
  1880.     RTR
  1881.     JMS    GIVB    /GIVE TO CALLER
  1882.     JMP    LDBL    /LOOP FOR NEXT PAIR OF WORDS
  1883.  
  1884.     /INCREMENT AND DEPOSIT A 7BIT BYTE IN MEMORY
  1885.     /ENTRY DF MAY BE RANDOM
  1886.  
  1887. DPB,    0
  1888.     AND    IOMASK    /MASK TO 7 OR 8 BIT
  1889.     DCA    BYTE    /SAVE
  1890.     JMP I    TAKB    /RETURN TO COROUTINE
  1891. TAKB,    0
  1892.     DCA I    BYTPTR    /STORE WORD BACK NOW
  1893.     CDF        /RESET DF
  1894.     ISZ    BYTCNT    /TALLY NUMBER OF BYTES STORED
  1895.     JMP I    DPB    /--RETURN--
  1896.  
  1897. DPBL,    JMS    BUMP    /FIRST BUMP POINTER AND SET DF
  1898.     TAD    BYTCDF    /BACK UP CDF TO FIRST WORD
  1899.     DCA    BYTCD1
  1900.     TAD    BYTPTR    /SAVE POINTER TO FIRST WORD
  1901.     DCA    BYT1
  1902.     TAD    BYTE    /NOW GET THE BYTE
  1903.     JMS    TAKB    /STORE IT AND TAKE ANOTHER
  1904.     JMS    BUMP    /BUMP POINTER
  1905.     TAD    BYTCDF    /SAVE CDF TO WORD2 INLINE
  1906.     DCA    BYTCD2
  1907.     TAD    BYTE    /NOW GET BYTE
  1908.     JMS    TAKB    /STORE AND TAKE ANOTHER
  1909.     TAD    BYTE    /GET BYTE
  1910.     CLL RTL
  1911.     RTL
  1912.     AND    [7400
  1913. BYTCD1,    0
  1914.     TAD I    BYT1
  1915.     DCA I    BYT1    /RESTORE WORD1
  1916.     TAD    BYTE    /NOW ISOLATE LOW 4 BITS
  1917.     CLL RTR
  1918.     RTR
  1919.     RAR
  1920.     AND    [7400
  1921. BYTCD2,    0
  1922.     TAD I    BYTPTR    /ADD TO WORD2
  1923.     JMS    TAKB    /STORE SECOND WORD AND RETURN TO CALLER
  1924.     JMP    DPBL    /REITERATE
  1925.  
  1926.     /BUMP BYTE POINTER
  1927.  
  1928. BUMP,    0
  1929.     ISZ    BYTPTR    /FIRST INCREMENT WORD POINTER
  1930.     JMP    BYTCDF    /JMP IF FIELD BOUNDRY NOT CROSSED
  1931.     TAD    BYTCDF    /ELSE PROPAGATE CARRY INTO CDF
  1932.     TAD    [10
  1933.     DCA    BYTCDF
  1934. BYTCDF,    0
  1935.     JMP I    BUMP
  1936.  
  1937.     /BYTE LOAD/STORE INITIALIZE ROUTINE
  1938.  
  1939. BYTSET,    0
  1940.     TAD    SSTEX    /GET FIELD OF STRING
  1941.     DCA    BYTCDF    /STORE INLINE
  1942.     TAD    STRPTR    /NOW GET ADDR OF COUNT WORD
  1943.     DCA    BYTPTR    /STORE
  1944.     TAD    (LDBL    /INITIALIZE COROUTINES NWO
  1945.     DCA    GIVB
  1946.     TAD    (DPBL
  1947.     DCA    TAKB
  1948.     DCA    BYTCNT    /CLEAR DEPOSITED BYTE COUNT
  1949.     TAD    [SAC-1
  1950.     DCA    SACXR    /ALWAYS RETURN WITH SAC POINTER SET UP
  1951.     JMP I    BYTSET    /--RETURN--
  1952.  
  1953.     /STRING STORE EXIT ROUTINE
  1954.  
  1955. SSTEX,    0        /GETS SET BY STFIND TO DF OF STRING
  1956.     TAD    BYTCNT    /ENTER WITH POSITIVE LENGTH IN COUNT
  1957.     CIA
  1958.     DCA I    STRPTR    /STORE IN STRING
  1959.     JMP I    [ILOOP    /--RETURN-- (ILOOP RESETS DF)
  1960.  
  1961. BYTCNT,    0
  1962. BYTPTR,    0
  1963. BYTE,    0
  1964. BYT1=    BYTSET
  1965. BYT2=    BYTCD2
  1966.     /WRITE AC INTO FILE BUFFER AND BUMP POINTER
  1967.  
  1968. WRITFL,    0
  1969.     DCA    OPH    /SAVE WORD
  1970.     JMS I    [IDLE    /FIRST TEST IF FILE OPEN
  1971.     TAD I    IOTPTR    /IF OK, GET BUFFER POINTER
  1972.     DCA    OPL    /SAVE
  1973.     CDF    10    /GET INTO BUFFER SPACE
  1974.     TAD    OPH    /NOW STORE THE WORD
  1975.     DCA I    OPL
  1976.     CDF        /RESET DF
  1977.     ISZ I    IOTPTR    /BUMP BUFFER POINTER
  1978.     NOP        /MAY SKIP IF LAST BUFFER
  1979.     TAD I    IOTHDR    /NOW SET BUFFER DIRTY BIT
  1980.     AND    (7777-40
  1981.     TAD    [40
  1982.     DCA I    IOTHDR
  1983.     AC0002        /AFTER THE FACT, TEST IF EOF BIT SET
  1984.     AND I    IOTHDR
  1985.     SNA CLA
  1986.     JMP I    WRITFL    /OK, RETURN
  1987. WE,    JMS I    [ERROR    /ELSE GIVE WARNING
  1988.     JMP I    [ILOOP    /ABORT TO ILOOP
  1989.     /CROSS FIELD LINKAGE FOR FFIN1
  1990.  
  1991. GETCH1,    0
  1992.     JMS I    IGETCH    /CALL "GETCH" OR VAL INPUT ROUTINE
  1993.     CIF CDF    10
  1994.     JMP I    GETCH1
  1995. IGETCH,    GETCH        /ALTERED BY "VAL" ROUTINE; BE CAREFULL
  1996.  
  1997.     /PRINT USING INTERFACE
  1998.  
  1999. PUEXEC,    CLA IAC
  2000.     JMS I    LOADOV    /CALL OVERLAY 1
  2001.     JMP I    [XPUEXEC
  2002.  
  2003.     PAGE
  2004.     /ROUTINE TO SEND AN ASCII STREAM TO A FILE
  2005.     /ENTER WITH CHAR IN AC
  2006.     /PRESERVES UNUSED BITS IN 3/2 PACKED WORDS
  2007.  
  2008. PUTCH,    0
  2009.     DCA    AC0    /SAVE THE CHAR
  2010.     JMS I    [FTYPE    /SKP IF FILE IS ASCII TYPE
  2011. SW,    JMS I    [ERROR    /TAKE ERROR IF NOT
  2012.     ISZ I    IOTPOS    /BUMP COL NUMBER
  2013.     TAD    AC0    /RESET COLUMN NUMBER IF CHAR LT 40
  2014.     TAD    [-40
  2015.     SPA CLA        /SKP IF NON SPECIAL CODE
  2016.     DCA I    IOTPOS    /ELSE RESET IT (FOR ESCAPE SEQUENCES)
  2017.     TAD    ENTNO    /TEST IF FILE IS TTY
  2018.     SNA CLA
  2019.     JMP    PUTTTY    /HANDLE SEPARATELY IF YES
  2020.     JMS    TH4TWO    /SKP IF 3/2 PACKING BIT SET
  2021.     JMP    PUT3RD    /ELSE HANDLE ODD CHAR
  2022.     JMS    BUFGET    /GET CURRENT CONTENTS OF NEXT WORD
  2023.     AND    [7400    /PRESERVE HIGH 4 BITS FOR RANDOM ACCESS I/O
  2024.     TAD    AC0    /ADD THE NEW CHAR
  2025.     JMS I    (WRITFL    /WRITE BACK AND BUMP POINTER
  2026.     JMP I    PUTCH    /--RETURN--
  2027.  
  2028. PUT3RD,    TAD    AC0    /STORE HIGH 4 BITS OF ODD CHAR
  2029.     CLL RTL
  2030.     RTL
  2031.     JMS    P4BITS    /MASK AND STORE THEM
  2032.     TAD    AC0    /SHIFT LOW 4 BITS INTO PLACE
  2033.     CLL RTR
  2034.     RTR
  2035.     RAR
  2036.     JMS    P4BITS    /STORE THEM
  2037.     JMP I    PUTCH    /--RETURN--
  2038.  
  2039. PUTTTY,    TAD    AC0    /GET THE CHAR
  2040.     JMS I    [PCH    /PRINT ON THE CONSOLE
  2041.     JMP I    PUTCH    /--RETURN--
  2042.  
  2043.     /COMBINE AND STORE 4 BITS OF ODD CHAR
  2044.  
  2045. P4BITS,    0
  2046.     AND    [7400    /ISOLATE THE BITS
  2047.     DCA    TEMP2
  2048.     JMS    BUFGET    /GET CONTENTS OF BUFFER WORD
  2049.     AND    [377    /PRESERVE LOW 8 BITS
  2050.     TAD    TEMP2    /ADD HIGH BITS
  2051.     JMS I    (WRITFL    /WRITE IN FILE AND BUMP POINTER
  2052.     JMP I    P4BITS
  2053.     /ROUTINE TO GET AN ASCII STREAM FROM A FILE
  2054.     /RETURN WITH THE CHAR STORED IN "CHAR"
  2055.  
  2056. GETCH,    0
  2057.     JMS I    [FTYPE    /SKP IF FILE IS ASCII
  2058. SR,    JMS I    [ERROR    /TAKE ERROR EXIT IF NUMERIC IMAGE FILE
  2059. GETLP,    TAD    ENTNO    /TEST IF CONSOLE TTY
  2060.     SNA CLA
  2061.     JMP    GETTTY    /HANDLE SPECIALLY IF YES
  2062.     JMS    TH4TWO    /HANDLE ODD CHAR FLAG, SKP IF NOT SET
  2063.     JMP    GET3RD    /DO THE 3RD CHAR
  2064.     JMS    READFL    /READ A WORD
  2065.     JMP    GETRTN    /DO COMMON CODE
  2066. GET3RD,    JMS    READFL    /HANDLE ODD CHAR, GET HIGH 4 BITS
  2067.     AND    [7400
  2068.     DCA    AC0
  2069.     JMS    READFL    /GET LOW 4 BITS
  2070.     AND    [7400
  2071.     CLL RTR        /SHIFT AND COMBINE
  2072.     RTR
  2073.     TAD    AC0
  2074.     RTR
  2075.     RTR
  2076. GETRTN,    AND    IOMASK    /MASK TO 7 OR 8 BITS
  2077.     DCA    CHAR    /STORE
  2078.     TAD    CHAR    /REGET CHAR
  2079. GETCH2,    SNA        /Gets SKP from READSF
  2080.     JMP    GETLP    /IGNORE NULLS
  2081.     TAD    (-32    /SEE IF ^Z GOTTEN
  2082.     SZA CLA        /SKP INTO EOF ROUTINE IF YES
  2083.     JMP I    GETCH    /ELSE RETURN
  2084.  
  2085.     /ROUTINE TO SET EOF BIT IN I/O ENTRY
  2086.  
  2087. EOFSET,    TAD I    IOTHDR    /HEADER
  2088.     CLL RTR        /EOF BIT TO LINK
  2089.     STL RTL        /SET LINK
  2090.             /PUT LINK IN EOF BIT
  2091.     DCA I    IOTHDR    /STORE IN I/O TABLE ENTRY
  2092.     JMP I    [ILOOP    /EOF BIT SET-ABORT TO ILOOP
  2093.  
  2094. GETTTY,    CIF CDF    10    /CALL THE CONSOLE ROUTINE
  2095.     JMS I    (TTYGCH
  2096.     JMP    GETRTN    /RETURN THE CHAR
  2097.     /COMMON ROUTINE TO HANDLE 3/2 PACKING BIT
  2098.     /GETS NEXT RECORD IF PAST END OF BUFFER
  2099.     /ADJUSTS POINTERS AS NECESSARY
  2100.  
  2101. TH4TWO,    0
  2102.     TAD I    IOTHDR    /TEST THE FLAG
  2103.     AND    [200
  2104.     SZA
  2105.     JMP    DO3RD    /JMP IF ODD CHAR
  2106.     IAC
  2107.     JMS I    (BUFCHK    /SEE IF NEED NEW BUFFERFULL
  2108.     IAC        /SEE IF ODD CHAR WILL BE NEXT
  2109.     AND I    IOTPTR
  2110.     SZA CLA        /SKP IF NOT
  2111.     TAD    [200    /TELL OURSELVES BY SETTING FLAG
  2112.     TAD I    IOTHDR
  2113.     DCA I    IOTHDR
  2114.     ISZ    TH4TWO    /RETURN TO CALL+2
  2115.     JMP I    TH4TWO
  2116. DO3RD,    CMA
  2117.     AND I    IOTHDR
  2118.     DCA I    IOTHDR    /CLEAR THE BIT
  2119.     AC7776        /BACK UP THE POINTER FOR 3RD CHAR
  2120.     TAD I    IOTPTR
  2121.     DCA I    IOTPTR
  2122.     JMP I    TH4TWO    /RETURN TO CALL+1
  2123.  
  2124.     /ROUTINE TO READ 1 WORD FROM A FILE AND BUMP POINTER
  2125.  
  2126. READFL,    0
  2127.     TAD I    IOTRSZ    /ALLOW READS OF OUTPUT FILE IF RANDOM ACCESS
  2128.     SNA CLA
  2129.     JMS I    (FOTYPE    /SKP IF OUTPUT ONLY FILE
  2130.     SKP
  2131. VR,    JMS I    [ERROR    /TAKE ERROR EXIT IF YES
  2132.     AC0002        /SEE IF END OF FILE BIT SET
  2133.     AND I    IOTHDR
  2134.     SNA CLA
  2135.     JMP    .+3
  2136. RE,    JMS I    [ERROR    /GIVE WARNING IF YES
  2137.     JMP I    [ILOOP    /ABORT TO ILOOP
  2138.     JMS I    [IDLE    /TEST IF FILE OPEN OR NOT
  2139.     JMS    BUFGET    /OK, GET THE WORD
  2140.     ISZ I    IOTPTR    /BUMP POINTER
  2141.     JMP I    READFL    /MAY SKIP IF LAST BUFFER
  2142.     JMP I    READFL    /--RETURN--
  2143.  
  2144.     /GET WORD FROM I/O BUFFER IN FIELD 1
  2145.  
  2146. BUFGET,    0
  2147.     TAD I    IOTPTR    /GET POINTER
  2148.     DCA    BFPTR
  2149.     CDF    10    /GET INTO BUFFER SPACE
  2150.     TAD I    BFPTR    /GET WORD
  2151.     CDF
  2152.     JMP I    BUFGET    /RETURN
  2153. BFPTR,    0
  2154.  
  2155.     PAGE
  2156.     /READ FLOATING POINT NUMBERS TO FAC FROM FILE OR DATA LIST
  2157.  
  2158. READI,    JMS I    [FTYPE    /SKP IF ASCII FILE
  2159.     JMP    RIMAGE    /HANDLE IMAGE FILE
  2160.     JMS I    (FFIN    /CALL FLOATING POINT INPUT ROUTINE
  2161.     JMP I    [ILOOP    /DONE
  2162.  
  2163. RIMAGE,    JMS    BUFCHK    /SEE IF BUFFER EMPTY
  2164.     TAD    (READFL-DLREAD    /SET FOR FILE READ
  2165. RDLIST,    TAD    (DLREAD /SET FOR DATA LIST READ
  2166.     DCA    ACL    /STORE ROUTINE POINTER
  2167.     JMS I    ACL    /GET WORD
  2168.     DCA    ACX    /STORE 3 WORDS
  2169.     JMS I    ACL
  2170.     DCA    ACH
  2171.     JMS I    ACL
  2172.     DCA    ACL
  2173.     JMP I    [ILOOP    /DONE
  2174.  
  2175.     /WRITE FLOATING POINT NUMBER TO FILE FROM FAC
  2176.  
  2177. WRITEI,    JMS I    [FTYPE    /SKP IF FILE IS ASCII
  2178.     JMP    WIMAGE    /ELSE DO IMAGE WRITE
  2179.     JMS I    (FFOUT    /CONVERT INTERNAL TO ASCII
  2180.     TAD    XR1
  2181.     CIA
  2182.     TAD    (INTERB-1 /CALCULATE NUMBER OF CHARS STORED IN BUFFER
  2183.     DCA    TEMP1    /SAVE
  2184.     TAD    (INTERB-1
  2185.     DCA    SACXR    /NOW POINT SACXR INTO BUFFER
  2186.     TAD    TEMP1    /GET COUNT OF CHARS TO BE PRINTED
  2187.     CIA
  2188.     TAD I    IOTPOS    /ADD TO PRINT HEAD POSITION
  2189.     TAD    LWIDTH    /COMPARE AGAINST LINE SIZE
  2190.     SMA SZA CLA    /WILL THE NUMBER FIT ON THIS LINE?
  2191.     JMS I    [CRLFR    /NO-ISSUE A CR,LF
  2192. CPLOOP,    TAD I    SACXR    /GET CHAR FROM INTERMEDIATE BUFFER
  2193.     JMS I    [PUTCH    /PUT ON DEVICE
  2194.     ISZ    TEMP1    /BUMP COUNTER
  2195.     JMP    CPLOOP    /NEXT
  2196.     TAD    [40
  2197.     JMS I    [PUTCH    /SEND OUT A SPACE AFTER NUMBER
  2198.     JMP    WDONE    /TAKE COMMON EXIT
  2199. WIMAGE,    JMS    BUFCHK
  2200.     TAD    ACX    /EXPONENT
  2201.     JMS I    (WRITFL    /WRITE IN BUFFER
  2202.     TAD    ACH    /HIGH MANTISSA
  2203.     JMS I    (WRITFL    /WRITE IN BUFFER
  2204.     TAD    ACL    /LOW MANTISSA
  2205.     JMS I    (WRITFL    /WRITE IN BUFFER
  2206. WDONE,    DCA I    (COMMAS    /CLEAR COMMA SWITCH
  2207.     JMP I    [ILOOP    /WRITE IS DONE
  2208.  
  2209.     /END OF BUFFER TEST
  2210.     /AC = 1 IF ASCII FILE, 0 IF IMAGE FILE
  2211.  
  2212. BUFCHK,    0
  2213.     TAD I    IOTBUF
  2214.     TAD    [377    /SEE IF AT LAST WORD OF BUF
  2215.     CIA
  2216.     TAD I    IOTPTR
  2217.     SNA CLA
  2218.     JMS    NEXREC    /GET NEXT RECORD IF YES
  2219.     JMP I    BUFCHK
  2220. /ROUTINE TO GET NEXT RECORD
  2221. /IF FILE STRUCTURED DEVICE, WRITES CURRENT BLOCK (IF DIRTY)
  2222. /AND READS NEXT BLOCK IF NOT NEW FILE ENTRY. IF EOF ENCOUNTERED, SETS EOF INSTEAD
  2223. /MAY EXTEND FILE SIZE BY ONE BLOCK IF VARIABLE LENGTH OUTPUT FILE
  2224. /IF NON FILE STRUCTURED INPUT FILE, JUST READS ANOTHER BUFFERFULL
  2225. /IF NON FILE STRUCTURED OUTPUT FILE, WRITES BUFFER (IF DIRTY)
  2226.  
  2227. NEXREC,    0
  2228.     TAD I    IOTHDR    /GET HEADER
  2229.     AND    (20    /GET READ/WRITE ONLY BIT
  2230.     SNA CLA        /IS IT ON?
  2231.     JMP    FILSTR    /NO-DEVICE IS FILE STRUCTURED
  2232.     JMS I    (FOTYPE    /SKP IF VARIABLE LENGTH OUTPUT FILE
  2233.     JMP    RONLY
  2234.     JMS    WRBLK    /WRITE BLOCK (UNLESS FILE JUST OPENED OR RESTORED)
  2235.     SKP
  2236. RONLY,    JMS    BLREAD    /READ NEXT BUFFER, OR DO BLOCK 0 INITIALIZATION
  2237.     ISZ I    IOTBLK
  2238.     JMS    BLINIT    /INIT FILE TABLE ENTRIES
  2239.     JMP I    NEXREC    /DONE
  2240.  
  2241. FILSTR,    JMS    WRBLK    /WRITE THE CURRENT BLOCK IF IT HAS BEEN CHANGED
  2242.     JMS    BLINIT    /INIT FILE TABLE ENTRIES
  2243.     ISZ I    IOTBLK    /BUMP BLOCK #
  2244.     TAD I    IOTLOC    /STARTING BLOCK
  2245.     CIA        /NEGATE
  2246.     TAD I    IOTBLK    /SUBTRACT FROM CURRENT BLOCK FOR FILE LENGTH
  2247.     CLL CMA        /SET UP CURRENT FILE LENGTH FOR 12 BIT COMPARE
  2248.     TAD I    IOTLEN    /COMPARE TO ACTUAL LENGTH
  2249.     SNL CLA        /IS IT > CURRENT LENGTH?
  2250.     JMP    LASTB    /YES-EXTEND THE FILE IF IT IS OUTPUT
  2251.     JMS    BLREAD    /READ IN THE NEXT RECORD
  2252.     JMP I    NEXREC    /RETURN
  2253.  
  2254.  
  2255. LASTB,    JMS I    (FOTYPE    /IS FILE FIXED LENGTH?
  2256.     JMP I    [EOFSET    /YES-SET EOF FLAG
  2257.     TAD I    IOTLEN    /NO-GET ACTUAL LENGTH
  2258.     CLL CMA    
  2259.     TAD I    IOTMAX    /MAXIMUM LENGTH
  2260.     SNL CLA        /IS ACTUAL LENGTH >= MAXIMUM LENGTH?
  2261.     JMP I    [EOFSET    /YES-SET EOF BITS
  2262.     ISZ I    IOTLEN    /NO-BUMP ACTUAL LENGTH
  2263.     JMP I    NEXREC    /RETURN WITHOUT READING NEXT RECORD
  2264. /ROUTINE TO READ 2 PAGES FROM DEVICE
  2265.  
  2266. BLREAD,    0
  2267.     JMS I    (BLZERO
  2268.     TAD    (210    /"READ 2 PAGES"
  2269.     JMS I    (DRCALL    /HANDLER CALL
  2270.     JMP I    BLREAD
  2271.  
  2272. /ROUTINE TO WRITE 2 PAGES ONTO DEVICE
  2273.  
  2274. WRBLK,    0
  2275.     TAD I    IOTHDR    /GET FILE HEADER
  2276.     AND    [40    /GET FILE WRITTEN BIT
  2277.     SNA CLA        /HAS THIS BLOCK BEEN CHANGED?
  2278.     JMP I    WRBLK    /NO-RETURN
  2279.     TAD    (4210    /"WRITE 2 PAGES"
  2280.     JMS I    (DRCALL    /CALL TO DEVICE HANDLER
  2281.     JMS I    (BLZERO
  2282.     JMP I    WRBLK
  2283.  
  2284. /ROUTINE TO INITIALIZE I/O TABLE ENTRIES AFTER READ OR WRITE
  2285.  
  2286. BLINIT,    0
  2287.     TAD I    IOTBUF
  2288.     DCA I    IOTPTR    /INIT READ/WRITE POINTER
  2289.     TAD I    IOTHDR
  2290.     AND    (7537    /CLEAR DIRTY BIT AND CHAR #3 FLAG
  2291.     DCA I    IOTHDR
  2292.     JMP I    BLINIT
  2293.  
  2294.     PAGE
  2295.  
  2296.  
  2297.  
  2298.  
  2299.  
  2300.  
  2301. /////////////////////////////////////////////////////////////
  2302. /////////////////////////////////////////////////////////////
  2303. ////////////  OVERLAY BUFFER  3400-4777  ////////////////////
  2304. ////////////  CONTAINS FUNCTION OVERLAYS ////////////////////
  2305. ////////////  AT RUN TIME                ////////////////////
  2306. /////////////////////////////////////////////////////////////
  2307. /////////////////////////////////////////////////////////////
  2308.  
  2309.  
  2310. /////////////////////////////////////////////////////////////
  2311. /////////////////////////////////////////////////////////////
  2312. ////////////// OVERLAY 1-ARITHMETIC FUNCTIONS ///////////////
  2313. /////////////////////////////////////////////////////////////
  2314. /////////////////////////////////////////////////////////////
  2315.  
  2316.     *OVERLAY
  2317.     VERSON&77^100+SUBVAF+60    /VERSION AND PATCH LEVEL FOR ARITH FNS
  2318.  
  2319. OVDISP,    JMS I    [FBITGT    /GET FUNCTION TO USE
  2320.     TAD    JMSAF    /BUILD IN LINE JMS
  2321.     DCA    .+1    /STORE IT
  2322.     HLT
  2323.     JMP I    [ILOOP    /RETURN TO ILOOP
  2324. JMSAF,    JMS I    .+1    /CALL FOR CANNED FUNCTION SET 1
  2325.  
  2326.     /JUMP TABLE FOR FUNCTION CALL 1
  2327.  
  2328.     ATAN        /FUNCTION BITS=    000
  2329.     COS        /        020
  2330.     EXPON1        /        040
  2331.     EXPON        /        060
  2332.     INT        /        100
  2333.     LOG        /        120
  2334.     SGN        /        140
  2335.     SIN        /        160
  2336.     RND        /        200
  2337.     FROOT        /        220
  2338.     TAN        /        240
  2339.     /INTEGER FUNCTION
  2340.     /RANGE=ALL X
  2341.  
  2342. INT,    0
  2343.     JMS I    [FFPUT    /SAVE X
  2344.     FPPTM1
  2345.     TAD    ACX    /GET EXPONENT
  2346.     SMA SZA CLA    /IS EXP<0?
  2347.     JMP    INSC    /NO-GO ON
  2348.     TAD    ACH    /YES
  2349.     SPA CLA        /IS X<0?
  2350.     JMP    M1R    /YES-INT=-1
  2351.     JMS I    [FACCLR    /YES-RETURN A 0
  2352.     JMP I    INT
  2353. INSC,    TAD    ACH    /GET HI MANTISSA
  2354.     SMA CLA        /IS IT <0?
  2355.     JMP    INTPOS    /NO-USE FAC AS IS
  2356.     JMS I    [FFNEG    /YES-NEGATE FAC (MAKE IT POS)
  2357.     IAC        /AND SET FLAG
  2358. INTPOS,    DCA    AC2    /FLAG FOR NEGATIVE
  2359.     DCA    OPX    /ZERO LORD MASK
  2360.     CLL CML RAR
  2361.     DCA    TM    /INITIALIZE HORD MASK TO 4000
  2362.     TAD    ACX
  2363.     CIA        /- COUNT
  2364.     DCA    TEMP2
  2365. MASKL,    TAD    TM
  2366.     CLL CML RAR    /ROTATE 1'S THROUGH 3 WORD MASK
  2367.     DCA    TM    /
  2368.     TAD    OPX    /UNTIL THERE IS A COUNT OF ZERO
  2369.     RAR
  2370.     DCA    OPX
  2371.     ISZ    TEMP2    /DONE?
  2372.     JMP    MASKL    /NO
  2373.     TAD    ACH    /YES-MASK HORD
  2374.     AND    TM
  2375.     DCA    ACH
  2376.     TAD    ACL    /MASK LORD
  2377.     AND    OPX
  2378.     DCA    ACL
  2379.     TAD    AC2    /NEG FLAG
  2380.     SNA CLA        /WAS ORIGINAL NUMER <0?
  2381.     JMP I    INT    /NO-DONE
  2382.     JMS I    [FFPUT    /SAVE INT(X)
  2383.     FPPTM2
  2384.     JMS I    (FFADD    /-INT(X)+(X)
  2385.     FPPTM1
  2386.     TAD    ACH    /SAVE HORD
  2387.     DCA    AC2
  2388.     JMS I    [FACCLR    /FLUSH FAC
  2389.     TAD    AC2    /WAS INT(X)=X?
  2390.     SNA CLA
  2391.     JMP    JUSNEG    /YES-JUST NEGATE INT(X)
  2392.     JMS I    (FFADD    /NO-ADD 1
  2393.     ONE
  2394. JUSNEG,    JMS I    (FFADD    /GET INT(X)
  2395.     FPPTM2
  2396. JNEG,    JMS I    [FFNEG    /AND  NEGATE (INT(5.3)=-6)
  2397.     JMP I    INT    /DONE
  2398.  
  2399. M1R,    JMS I    [FFGET    /LOAD FAC WITH 1
  2400.     ONE
  2401.     JMP    JNEG    /JUST NEGATE AND RETURN
  2402.  
  2403. ONE,    1
  2404.     2000
  2405.     0
  2406.     /RND(0) RANDOM NUMBER GENERATOR
  2407.     /USES MULTIPLIER OF 2**16+3 MOD 2**31
  2408.     /RETURNS HIGH 23 BITS AS FRACTION 0<RND(0)<1
  2409.  
  2410. RND,    0
  2411.     TAD I    (SEED1    /GET CURRENT SEED TO OP FRACTION
  2412.     DCA    AC2
  2413.     TAD I    (SEEDL
  2414.     DCA    OPL
  2415.     TAD I    (SEEDH
  2416.     DCA    OPH
  2417.     TAD    OPL    /MULT BY 2**15
  2418.     RTL        /HHH HHH HHH HHH;LLL LLL LLL LLL;111 111 100 000 BECOMES
  2419.     RAL        /LLL LLL LLL 111;111 100 000 000;000 000 000 000
  2420.     AND    (7770
  2421.     DCA    ACH    /STORE IN FAC FRACTION
  2422.     TAD    AC2
  2423.     RTL
  2424.     RAL
  2425.     AND    [7400
  2426.     DCA    ACL
  2427.     TAD    AC2
  2428.     RTL
  2429.     RTL
  2430.     AND    (7
  2431.     TAD    ACH
  2432.     DCA    ACH
  2433.     DCA    AC1    /CLEAR OVERFLOW
  2434.     JMS I    (OADD    /2**15+1
  2435.     JMS I    (AL1    
  2436.     JMS I    (OADD    /2**16+3
  2437.     TAD    AC1    /NOW SAVE UPDATED SEED
  2438.     DCA I    (SEED1
  2439.     TAD    ACL
  2440.     DCA I    (SEEDL
  2441.     TAD    ACH
  2442.     DCA I    (SEEDH
  2443.     DCA    ACX    /CLEAR EXPONENT
  2444.     JMS I    (RAR1    /ADJUST FOR POSITIVE 23 BIT RESULT
  2445.     JMS I    [FFNOR    /NORMALIZE IT
  2446.     JMP I    [ILOOP    /--RETURN--
  2447.  
  2448.     PAGE
  2449. /EXPONENTIATION FUNCTION
  2450. /IF B=0,A^B=1
  2451. /IF A=0 AND B>0,A^B=0
  2452. /IF A=0 AND B<0,DIVIDE BY ZERO ERROR MESSAGE RESULTS AND A^B=0
  2453. /IF B=INTEGER > 0, A^B=A*A*A*.......*A
  2454. /IF B=INTEGER < 0, A^B=1/A*A*A*.......*A
  2455. /IF B=REAL AND A>0, A^B=EXP(B*LOG(A))
  2456. /IF B=REAL AND A<0, A FATAL ERROR RESULTS
  2457.  
  2458. EXPON,    0
  2459.     JMS I    [FFPUT    /SAVE A
  2460.     FPPTM5
  2461.     TAD    ACH    /HI ORDER OF A
  2462.     DCA    EXPON    /SAVE IT
  2463.     DCA    INSAV    /POINTER TO B IN SYMBOL TABLE
  2464.     JMS I    ARGPLL    /FIND B
  2465.     JMS I    [FFGET    /GET B
  2466. ARGPLL,    ARGPRE        /LOC SKIPPED BY FPP,SO WE USE IT FOR CONSTANT
  2467.     CDF
  2468.     TAD    ACH    /HI ORDER OF B
  2469.     SNA        /IS B=0?
  2470.     JMP    RETRN1    /YES A^B=1
  2471.     SMA CLA        /IS B<0?
  2472.     JMP    .+4    /NO
  2473.     TAD    EXPON    /YES-GET HI ORDER A
  2474.     SNA CLA        /IS A=0?
  2475.     JMP I    (DV    /YES-DIVIDE BY ZERO ERROR
  2476.     TAD    EXPON    /B>0. IS A=0?
  2477.     SNA CLA
  2478.     JMP    RET0    /YES A^B=0
  2479.     JMS I    [FFPUT    /SAVE B
  2480.     FPPTM3
  2481.     JMS I    (INT    /GET INT(B)
  2482.     TAD    ACX    /TEST IF B GE 2**23
  2483.     TAD    (-30
  2484.     SMA CLA
  2485.     JMP    USELOG    /JMP IF RIDICULOUS EXPONENT
  2486.     JMS I    (FFSUB    /INT(B)-B
  2487.     FPPTM3
  2488.     TAD    ACH    /SEE IF B INTEGER
  2489.     SZA CLA
  2490.     JMP    USELOG    /NO, USE EXP(B*LOG(A)) INSTEAD
  2491.     JMS I    [FFGET    /GET B BACK
  2492.     FPPTM3
  2493.     TAD    ACH    /SAVE SIGN OF B
  2494.     DCA    EXPON
  2495.     JMS I    (ABSVAL    /TAKE ABS(B)
  2496.     JMS I    FIX23I    /FIX TO UNSIGNED INTEGER IN ACH;ACL
  2497.     TAD    ACH    /COPY TO SHIFT REGISTER
  2498.     DCA    EXPH
  2499.     TAD    ACL
  2500.     DCA    EXPL
  2501.     JMS I    [FFGET    /INITIALIZE RUNNING PRODUCT TO ONE
  2502.     ONE
  2503.     JMS I    [FFPUT
  2504.     FPPTM4
  2505.     JMP    EXPGO    /JMP INTO LOOP
  2506. EXPLUP,    JMS I    [FFPUT    /SAVE RUNNING PRODUCT
  2507.     FPPTM4
  2508.     JMS I    [FFGET    /GET RUNNING POWER OF A
  2509.     FPPTM5
  2510.     JMS I    (FFMPY    /SQUARE IT
  2511.     FPPTM5
  2512.     JMS I    [FFPUT    /STORE BACK
  2513.     FPPTM5        /A**2**K
  2514.     JMS I    [FFGET    /GET PRODUCT AGAIN
  2515.     FPPTM4
  2516. EXPGO,    TAD    EXPH    /SHIFT EXPONENT RIGHT
  2517.     CLL RAR
  2518.     DCA    EXPH
  2519.     TAD    EXPL
  2520.     RAR
  2521.     DCA    EXPL
  2522.     SNL        /SKP IF THIS POWER OF A GOES IN
  2523.     JMP    NOMULT    /ELSE JMP BY
  2524.     JMS I    (FFMPY
  2525.     FPPTM5        /MULTIPLY A**2**K IN
  2526. NOMULT,    TAD    EXPH    /SEE IF EXPONENT REDUCED TO ZERO YET
  2527.     SNA
  2528.     TAD    EXPL
  2529.     SZA CLA
  2530.     JMP    EXPLUP    /REITERATE IF YES
  2531. EMDONE,    TAD    EXPON    /GET SIGN OF B
  2532.     SMA CLA        /WAS IT -?
  2533.     JMP I    [ILOOP    /NO-A^B=A*A*A*...*A
  2534.     JMS I    (FFDIV1    /YES-INVERT
  2535.     ONE
  2536.     JMP I    [ILOOP    /A^B=1/A:A*A*...*A
  2537.  
  2538. RET0,    JMS I    [FACCLR
  2539.     JMP I    [ILOOP
  2540.  
  2541. RETRN1,    JMS I    [FFGET
  2542.     ONE        /SET FAC TO 1
  2543.     JMP I    [ILOOP
  2544.  
  2545. USELOG,    TAD    EXPON    /SIGN OF A
  2546.     SPA CLA        /A<0?
  2547. EM,    JMS I    [ERROR    /YES-PRINT A MESSAGE
  2548.     JMS I    [FFGET    /LOAD A
  2549.     FPPTM5
  2550.     JMS I    (LOG    /LOG(A)
  2551.     JMS I    (FFMPY    /B*LOG(A)
  2552.     FPPTM3
  2553.     JMS I    (EXPON1    /EXP(B*LOG(A))
  2554.     JMP I    [ILOOP    /DONE
  2555. EXPH,    0
  2556. EXPL,    0
  2557.  
  2558.  
  2559.     /SGN FUNCTION
  2560.  
  2561. SGN,    0
  2562.     TAD    ACH    /GET HIGH MANTISSA
  2563.     SNA        /IS X=ZERO?
  2564.     JMP I    [ILOOP    /YES-THEN LEAVE IT ALONE
  2565.     SPA CLA        /IS X>0?
  2566.     JMP    .+3    /NO
  2567.     IAC        /YES-SET FAC=1
  2568.     SKP
  2569.     CMA        /NO-SET FAC=-1
  2570.     DCA    ACX    /SET UP FLOAT
  2571.     JMS I    [FFLOAT    /FLOAT VALUE OF SGN FUNCTION
  2572.     JMP I    [ILOOP    /DONE
  2573.  
  2574.     PAGE
  2575. /FLOATING SQUARE ROOT
  2576. /USES A HARDWARE TYPE ALGORITHM FOR BINARY SQUARE ROOTS
  2577. /REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES-P 409
  2578. /
  2579. FROOT,    0
  2580.     TAD    ACH
  2581.     SNA
  2582.     JMP I    [ILOOP    /ZERO FAC-NORMALIZED!-RETN. SAME
  2583.     SMA CLA        /SKP IF NEGATIVE
  2584.     JMP    .+3
  2585.     JMS I    [FFNEG    /TAKE ROOT OF ABSOLUTE VALUE
  2586. IS,    JMS I    [ERROR    /PRINT IMAGINARY SQUARE ROOT WARNING
  2587.     CLA CLL CML RTR    /SET RESULT TO 2000;0000
  2588.     DCA    AN1
  2589.     DCA    AN2
  2590.     CDF        /DF TO PACKAGE FIELD
  2591.     TAD    KM22    /SET COUNTER FOR DEVELOPING 22 BITS OF RESULT
  2592.     DCA    AC2    /ALREADY HAVE 1
  2593.     TAD    ACX    /GET EXPONENT OF FAC
  2594.     SPA        /IF NEGATIVE-MUST PROPAGATE SIGN
  2595.     CML
  2596.     RAR        /DIVIDE EXP. BY 2
  2597.     DCA    ACX    /STORE IT BACK
  2598.     SZL        /INCREMENT EXP. IF ORIGINAL EXP 
  2599.     ISZ    ACX    /WAS ODD
  2600.     NOP
  2601.     SNL        /DO A PRE-SHIFT FOR EVEN EXPONENTS
  2602.     JMS I    AL1K    /SO FIRST BIT PAIR IS 10 NOT 01
  2603.     CLA CLL CMA RAL    /SET COUNTER FOR DETECTING A
  2604.     DCA    ZCNT    /ZERO REMAINDER
  2605.     CLA CLL CML RTR    /SET UP POSITION OF TRIAL BIT
  2606.     RTR        /FOR FIRST PASS THRU LOOP
  2607.     DCA    OPH
  2608.     DCA    OPL
  2609.     TAD    K6000    /GET A FAST FIRST BIT-WE KNOW 
  2610.     TAD    ACH    /THIS WILL WORK SINCE # IS NORMALIZED
  2611.     DCA    ACH    /IF # IS A POWER OF TWO, AND A PERFECT
  2612.     TAD    ACH    /SQUARE-WE ARE DONE HERE!
  2613.     SNA        /WELL IS IT?
  2614.     TAD    ACL    /COULD BE-CHECK LOW ORDER
  2615.     SNA    CLA
  2616.     JMP    DONE    /WHOOPPEE-WE WIN BIG.
  2617.     JMP    LOP01    /NOPE-LOOP DON'T SHIFT FIRST TIME
  2618. SLOOP,    TAD    OPH    /SHIFT TRIAL BIT 1 PLACE
  2619.     CLL    RAR    /TO THE RIGHT
  2620.     DCA    OPH    /AND STORE BACK
  2621.     TAD    OPL
  2622.     RAR
  2623.     DCA    OPL
  2624.     JMS I    AL1K    /SHIFT FAC LEFT 1 PLACE
  2625. LOP01,    TAD    OPL    /ADD TRIAL BIT TO`ANSWER
  2626.     TAD    AN2    /SO FAR
  2627.     CLL CMA IAC    /NEGATE IT
  2628.     TAD    ACL    /AND ADD TO FAC (REMAINDER SO FAR)
  2629.     SNA        /IS RESULT ZERO?
  2630.     ISZ    ZCNT    /YES-INCREMENT COUNTER
  2631.     DCA    TM    /STORE RESULT IN TEMPORARY
  2632.     CML    RAL    /ADD CARRY TO HIGH ORDER FOR SUBTRACT
  2633.     TAD    OPH    /ADD TRIAL BIT
  2634.     TAD    AN1    /ADD RESULT SO FAR (HI ORDER)
  2635.     CLL CMA IAC    /AND SUBTRACT FROM HI ORDER FAC
  2636.     TAD    ACH
  2637.     SNL        /RESULT NEGATIVE?
  2638.     JMP    GON    /YES-NEXT RESULT BIT IS 0
  2639.     SZA        /NO-IS HI ORDER RESULT=0?
  2640.     JMP    LOP02    /NO-GO ON
  2641.     ISZ    ZCNT    /YES-WAS LOW ORDER =0?
  2642.     JMP    .+3    /NO-GO ON
  2643.     CMA        /YES-REM.=0-SET COUNTER SO
  2644.     DCA    AC2    /LOOKS LIKE WE'RE DONE
  2645. LOP02,    DCA    ACH    /STORE HIGH ORDER REM. IN FAC
  2646.     TAD    TM    /STORE LO ORDER REM. IN FAC
  2647.     DCA    ACL
  2648.     TAD    OPL    /TRIAL BIT SHIFTED LEFT 1 IS
  2649.     CLL    RAL    /RESULT BIT-ADD IT TO ROOT DEVELOPED
  2650.     TAD    AN2    /SO FAR
  2651.     DCA    AN2
  2652.     TAD    OPH
  2653.     RAL
  2654.     TAD    AN1
  2655.     DCA    AN1
  2656. GON,    CLA CLL CMA RAL    /RESET COUNTER FOR ZERO REM.
  2657.     DCA    ZCNT    
  2658.     ISZ    AC2    /DONE ALL 23 RESULT BITS?
  2659.     JMP    SLOOP    /NO-GO ON
  2660. DONE,    TAD    AN1    /YES-STORE ANSWER IN FAC
  2661.     DCA    ACH    /ITS NORMALIZED ALREADY
  2662.     TAD    AN2
  2663.     DCA    ACL
  2664.     JMP I    [ILOOP    /AND RETURN
  2665.  
  2666. K6000,    6000
  2667. ZCNT,    0
  2668. AL1K,    AL1
  2669. AN1,    0
  2670. AN2,    0
  2671. KM22,    -26
  2672.  
  2673.  
  2674. /PRINT THE AC AS A DECIMAL NUMBER
  2675.     DECIMAL
  2676. PRTDEC, HLT        /LIFTED FROM FUTIL, V6.
  2677.     JMS NUMOUT
  2678.     -1000
  2679.     -100
  2680.     -10
  2681.     0
  2682.     JMP I PRTDEC
  2683.     OCTAL
  2684.  
  2685. TWODEC, HLT        /TWO DIGIT DECIMAL PRINT
  2686.     AND [0177
  2687.     JMS PRTDEC
  2688.     JMP I TWODEC
  2689.  
  2690. /ACTUAL NUMBER OUTPUT ROUTINE
  2691.  
  2692. NUMOUT, HLT
  2693.     DCA NUMB    /SAVE IT
  2694. NUM01,    DCA NUMDGT    /CLEAR DIGIT COUNTER
  2695.     CLA CLL
  2696.     TAD NUMB    /GET CURRENT VALUE
  2697.     TAD I NUMOUT    /MINUS DIGIT BEING PRINTED.
  2698.     SNL        /DID IT OVERFLOW?
  2699.     JMP NUM02    /NO, TOO FAR!
  2700.     ISZ NUMDGT    /YES, BUMP DIGIT.
  2701.     DCA NUMB    /AND UPDATE VALUE
  2702.     JMP NUM01+1
  2703.  
  2704. NUM02,    CLA CLL
  2705.     TAD NUMDGT    /OUTPUT THE DIGIT
  2706.     TAD [260
  2707.     JMS I    [PUTCH
  2708.     ISZ NUMOUT    /GET NEXT ARG
  2709.     TAD I NUMOUT    /DONE ENOUGH?
  2710.     SZA CLA
  2711.     JMP NUM01    /NOPE, MORE TO DO.
  2712.     TAD NUMB    /ALL DONE - OUTPUT LAST DIGIT
  2713.     TAD [260
  2714.     JMS I    [PUTCH
  2715.     JMP I NUMOUT    /AND RETURN
  2716. NUMB,    0
  2717. NUMDGT, 0
  2718.     PAGE
  2719.  
  2720. /23-BIT EXTENDED FUNCTIONS
  2721.  
  2722. /1-31-72       R BEAN
  2723.  
  2724. /******SINE******
  2725.  
  2726. SIN,    0
  2727.     JMS    NHNDLE    /IF X<0,NEGATE X AND SET NFLAG
  2728.     JMS I    (FFMPY    /X*2/PI
  2729.     TOVPI
  2730.     JMS    FRACT    /SAVE X IN AC0,THE INTEGER PART OF X IN NUM,AND GET FRACTIONAL PART IN FAC
  2731.     TAD    NUM        /GET INTEGER PART OF (2/PI)*X
  2732.     AND    (3        /ISOLATE BITS 10,11
  2733.     TAD    JMPISN
  2734.     DCA    .+1        /MAKE JUMP TO ARGUMENT REDUCING ROUTINE
  2735.     JMP    .        /AND ADJUST ARG ACCORDING TO QUADRANT OF X
  2736. JMPISN,    JMP I    .+1
  2737.     POLYSN        /X IN QUAD1,SIN(X)=SIN(X)
  2738.     QUAD2        /X IN QUAD2,SIN(X)=SIN(1-X)
  2739.     QUAD3        /X IN QUAD3,SIN(X)=SIN(-X)
  2740.     QUAD4        /X IN QUAD4,SIN(X)=SIN(X-1)
  2741.  
  2742. QUAD2,    JMS I    (FFSUB1    /1-X
  2743.     ONE
  2744.     JMP    POLYSN    /CALCULATE SIN(1-X)
  2745. QUAD3,    JMS I    [FFNEG    /-X
  2746.     JMP    POLYSN    /CALCULATE SIN(-X)
  2747. QUAD4,    JMS I    (FFSUB    /X-1
  2748.     ONE
  2749. POLYSN,    JMS I    [FFPUT    /SAVE X
  2750.     FPPTM1
  2751.     JMS I    (FFSQ    /U=X**2
  2752.     JMS I    [FFPUT    /SAVE U
  2753.     FPPTM2
  2754.     JMS I    (FFMPY    /A7*U
  2755.     SINA7
  2756.     JMS I    (FFADD    /A5+A7*U
  2757.     SINA5
  2758.     JMS I    (FFMPY    /A5*U+A7*U**2
  2759.     FPPTM2
  2760.     JMS I    (FFADD    /A3+A5(U)+A7(U**2)
  2761.     SINA3
  2762.     JMS I    (FFMPY    /A3(U)+A5(U**2)+A7(U**3)
  2763.     FPPTM2
  2764.     JMS I    (FFADD    /A1+A3(U)+A5(U**2)+A7(U**3)
  2765.     SINA1
  2766.     JMS I    (FFMPY    /A1(X)+A3(X**3)+A5(X**5)+A7(X**7)
  2767.     FPPTM1
  2768.     JMS    NCHK    /IF NFLAG IS SET,SET SIN(X)=-SIN(X)
  2769.     JMP I    SIN    /FAC=SIN(X)
  2770.  
  2771.  
  2772. /******COSINE******
  2773. /USES SIN ROUTINE TO CALCULATE COS(X)
  2774.  
  2775. COS,    0
  2776.     JMS I    (FFADD    /COS(X)=SIN(PI/2+X)
  2777.     PIOV2
  2778.     JMS    SIN
  2779.     JMP I    COS    /RETURN
  2780. /ROUTINE TO SEPERATE THE INTEGER AND FRACTIONAL PARTS OF FAC
  2781. /ORIGINAL FAC IS SAVED IN AC0,THE INTEGER PORTION OF FAC IS
  2782. /SAVED AT NUM,AND THE FRACTIONAL FORTION OF THE FAC IS LEFT IN THE FAC
  2783.  
  2784. FRACT,    0
  2785.     JMS I    [FFPUT    /SAVE X
  2786.     FPPTM1
  2787.     JMS I    (FFIX    /INTEGER PORTION OF X
  2788.     TAD    ACX
  2789.     DCA    NUM    /SAVE FIXED FORTION OF X
  2790.     JMS I    [FFLOAT    /FAC=FLOAT(FIX(X))
  2791.     JMS I    (FFSUB1    /FAC=X-INT(X)=FRACTION (X)
  2792.     FPPTM1
  2793.     JMP I    FRACT    /RETURN
  2794.  
  2795. /ROUTINE TO CHECK IF FAC<0; IF IT IS,FAC IS NEGATED AND NFLAG IS
  2796. /SET TO 1
  2797.  
  2798. NHNDLE,    0
  2799.     TAD    ACH    /FETCH HIGH ORDER MANTISSA
  2800.     SMA CLA        /IS IT <0?
  2801.     JMP    NFLGST    /NO-CLEAR NFLAG
  2802.     JMS I    [FFNEG    /YES-NEGATE FAC
  2803.     IAC        /AND SET NFLAG
  2804. NFLGST,    DCA    NFLAG
  2805.     JMP I    NHNDLE
  2806.  
  2807. /ROUTINE TO NEGATE FAC IF NFLAG IS NOT =0
  2808.  
  2809. NCHK,    0        /LOC ALSO USED FOR TEMP STORAGE
  2810.     TAD    NFLAG
  2811.     SZA CLA        /IS NFLAG=0?
  2812.     JMS I    [FFNEG    /NO-NEGATE FAC
  2813.     JMP I    NCHK    /YES-RETURN
  2814.  
  2815.     NUM=NCHK
  2816. /******EXPONENTIAL******
  2817.  
  2818. EXPON1,    0        /LOC USED FOR TEMP STORAGE BY SIN,ARCTAN
  2819.     JMS I    (FFMPY    /Y=XLOG2(E)
  2820.     LOG2E
  2821.     JMS    FRACT    /GET FRACTIONAL PART OF Y
  2822.     JMS I    (FFMPY    /(FRACTION(Y))*(LN2/2)
  2823.     LN2OV2
  2824.     JMS I    [FFPUT    /SAVE Y
  2825.     FPPTM1
  2826.     JMS I    (FFSQ    /Y**2
  2827.     JMS I    (FFADD    /B1+Y**2
  2828.     EXPB1
  2829.     JMS I    (FFDIV1    /A1/(B1+Y**2)
  2830.     EXPA1
  2831.     JMS I    (FFADD    /A0+A1/(B1+Y**2)
  2832.     EXPA0
  2833.     JMS I    (FFSUB    /A0-Y+A1/(B1+Y**2)
  2834.     FPPTM1
  2835.     JMS I    [FFPUT    /SAVE
  2836.     FPPTM2
  2837.     JMS I    [FFGET    /GET Y
  2838.     FPPTM1
  2839.     ISZ    ACX    /MULT. BY 2=2Y
  2840.     NOP
  2841.     JMS I    (FFDIV    /2Y/(A0-Y+A1/(B1+Y**2))
  2842.     FPPTM2
  2843.     JMS I    (FFADD    /1+2Y/(AO-Y+A1/(B1+Y**2))
  2844.     ONE
  2845.     JMS I    (FFSQ    /[1+2Y/(A0-Y+A1/(B1+Y**2))]**2=EXP(Y)
  2846.     TAD    NUM
  2847.     TAD    ACX    /EXP(X)=(2**N)(EXPY)
  2848.     DCA    ACX
  2849.     JMP I    EXPON1    /FAC=EXPON(X)
  2850.  
  2851.     NFLAG=EXPON1
  2852.  
  2853. /CONSTANT THAT WOULDN'T FIT ELSEWHERE
  2854. TOVPI,    0        /.6366198
  2855.     2427
  2856.     6302
  2857.  
  2858.     /SHIFT FAC RIGHT 1
  2859.  
  2860. RAR1,    0
  2861.     TAD    ACH
  2862.     CLL RAR
  2863.     DCA    ACH
  2864.     TAD    ACL
  2865.     RAR
  2866.     DCA    ACL
  2867.     TAD    AC1
  2868.     RAR
  2869.     DCA    AC1
  2870.     JMP I    RAR1
  2871.  
  2872.     PAGE
  2873. /******ARC TANGENT******
  2874.  
  2875. ATAN,    0
  2876.     JMS I    NHNDLL    /IF X<0,SET NFLAG AND NEGATE
  2877.     JMS I    [FFPUT    /SAVE X
  2878.     FPPTM1
  2879.     JMS I    FSUBM    /X-1
  2880.     ONE
  2881.     TAD    ACH    /GET HI MANTISSA
  2882.     SPA CLA        /WAS X>1?
  2883.     JMP    ARGPOL    /NO-CLEAR GT1FLG
  2884.     JMS I    [FFGET    /YES-ATAN(X)=PI/2-ATAN(1/X)
  2885.     ONE
  2886.     JMS I    FDIVM    /1/X
  2887.     FPPTM1
  2888.     JMS I    [FFPUT
  2889.     FPPTM1
  2890.     IAC        /SET GT1FLG
  2891. ARGPOL,    DCA    GT1FLG
  2892.     JMS I    [FFGET    /GET X OR 1/X
  2893.     FPPTM1
  2894.     JMS I    FSQRM    /Y**2
  2895.     JMS I    [FFPUT    /SAVE
  2896.     FPPTM2
  2897.     JMS I    FADDM    /Y**2+B3
  2898.     ATANB3
  2899.     JMS I    FDIV1M    /A3/(Y**2+B3)
  2900.     ATANA3
  2901.     JMS I    FADDM    /B2+A3/(Y**2+B3)
  2902.     ATANB2
  2903.     JMS I    FADDM    /Y**2+B2+A3/(Y**2+B3)
  2904.     FPPTM2
  2905.     JMS I    FDIV1M    /A2/(Y**2+B2+A3/(Y**2+B3))
  2906.     ATANA2
  2907.     JMS I    FADDM    /B1+A2/(Y**2+B2+A3/(Y**2+B3))
  2908.     ATANB1
  2909.     JMS I    FADDM    /Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))
  2910.     FPPTM2
  2911.     JMS I    FDIV1M    /A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
  2912.     ATANA1
  2913.     JMS I    FADDM    /B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
  2914.     ATANB0
  2915.     JMS I    FMPYM    /ATAN(Y)=X*(B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))))
  2916.     FPPTM1
  2917.     TAD    GT1FLG    /WAS X>1?
  2918.     SNA CLA
  2919.     JMP    NGT    /NO-TEST IF X<0?
  2920.     JMS I    FSUB1M    /ATAN(X)=PI/2-ATAN(1/X)
  2921.     PIOV2
  2922. NGT,    JMS I    NCHKL    /IF NFLAG SET,NEGATE FAC
  2923.     JMP I    ATAN    /FAC=ATAN(X)
  2924. NHNDLL,    NHNDLE
  2925. NCHKL,    NCHK
  2926. /******NAPERIAN LOGARITHM******
  2927.  
  2928.     GTFLG=ATAN
  2929.  
  2930. LOG,    0
  2931.     TAD    ACH
  2932.     SPA SNA        /X<0 OR X=0?
  2933.     JMP I    ARTRAP    /YES-TAKE ILLEGAL ARGUMENT TRAP
  2934.     CLL RTL
  2935.     SNA        /NO-HORD=2000?
  2936.     TAD    ACX    /YES-EXP=1?
  2937.     CMA IAC
  2938.     IAC
  2939.     SNA
  2940.     TAD    ACL    /YES-LORD=0?
  2941.     SZA CLA
  2942.     JMP    POLYNL    /NO-ARG IS LEGAL AND NOT 1
  2943.     DCA    ACX
  2944.     DCA    ACL
  2945. LTRPRT,    DCA    ACH
  2946.     JMP I    LOG    /YES-LOG(1)=0
  2947. POLYNL,    TAD    ACX
  2948.     DCA    GTFLG    /SAVE EXPONENT FOR LATER
  2949.     DCA    ACX    /ISOLATE MANTISSA IN FAC
  2950.     JMS I    [FFPUT    /SAVE F
  2951.     FPPTM1
  2952.     JMS I    FADDM    /F+SQR(.5)
  2953.     SQRP5
  2954.     JMS I    [FFPUT    /SAVE
  2955.     FPPTM2
  2956.     JMS I    [FFGET
  2957.     FPPTM1
  2958.     JMS I    FSUBM    /F-SQR(.5)
  2959.     SQRP5
  2960.     JMS I    FDIVM    /Z=F+SQR(.5)/F-SQR(.5)
  2961.     FPPTM2
  2962.     JMS I    [FFPUT
  2963.     FPPTM1
  2964.     JMS I    FSQRM    /Z**2
  2965.     JMS I    [FFPUT
  2966.     FPPTM2
  2967.     JMS I    FMPYM    /C5(Z**2)
  2968.     LOGC5
  2969.     JMS I    FADDM    /C3+C5(Z**2)
  2970.     LOGC3
  2971.     JMS I    FMPYM    /C3(Z**2)+C5(Z**4)
  2972.     FPPTM2
  2973.     JMS I    FADDM    /C1+C3(Z**2)+C5(Z**4)
  2974.     LOGC1
  2975.     JMS I    FMPYM    /C1(Z)+C3(Z**3)+C5(Z**5)
  2976.     FPPTM1
  2977.     JMS I    FSUBM    /C1(Z)+C3(Z**3)+C5(Z**5)-1/2=LOG2(F)
  2978.     ONEHAF
  2979.     JMS I    [FFPUT    /SAVE LOG2(F)
  2980.     FPPTM2
  2981.     TAD    GTFLG    /I
  2982.     DCA    ACX    /SET UP FLOAT
  2983.     JMS I    [FFLOAT
  2984.     JMS I    FADDM    /I+LOG2(F)
  2985.     FPPTM2
  2986.     JMS I    FMPYM    /[I+LOG2(F)]*LOGE(2)=LOGE(X)
  2987.     LN2
  2988.     JMP I    LOG    /FAC=LN(X)
  2989.  
  2990.     GT1FLG=LOG
  2991. FMPYM,    FFMPY
  2992. FADDM,    FFADD
  2993. FDIVM,    FFDIV
  2994. FDIV1M,    FFDIV1
  2995. FSUBM,    FFSUB
  2996. FSUB1M,    FFSUB1
  2997. FSQRM,    FFSQ
  2998. ARTRAP,    LM
  2999. /CONSTANTS USED BY VARIOUS FUNCTIONS
  3000.  
  3001. SINA1,    1        /1.5707949
  3002.     3110
  3003.     3747
  3004. SINA3,    0        /-.64592098
  3005.     5325
  3006.     1167
  3007. SINA5,    7775        /.07948766
  3008.     2426
  3009.     2466
  3010. SINA7,    7771        /-.004362476
  3011.     5610
  3012.     3164
  3013. PIOV2,    1        /1.5707963
  3014.     3110
  3015.     3756
  3016. LOG2E,    1        /1.442695
  3017.     2705
  3018.     2434
  3019. LN2OV2,    7777        /.34657359
  3020.     2613
  3021.     4415
  3022. EXPB1,    6        /60.090191
  3023.     3602
  3024.     7054
  3025. EXPA1,    12        /-601.80427
  3026.     5514
  3027.     3104
  3028. EXPA0,    4        /12.015017
  3029.     3001
  3030.     7301
  3031. ATANB0,    7776        /.17465544
  3032.     2626
  3033.     6157
  3034. ATANA1,    2        /3.7092563
  3035.     3553
  3036.     1071
  3037. ATANB1,    3        /6.762139
  3038.     3303
  3039.     670
  3040. ATANA2,    3        /-7.10676
  3041.     4344
  3042.     5267
  3043. ATANB2,    2        /3.3163354
  3044.     3241
  3045.     7554
  3046. ATANA3,    7777        /-.26476862
  3047.     5703
  3048.     4040
  3049. ATANB3,    1        /1.44863154
  3050.     2713
  3051.     3140
  3052. SQRP5,    0        /.7071068
  3053.     2650
  3054.     1170
  3055. LOGC1,    2        /2.8853913
  3056.     2705
  3057.     2440
  3058. LOGC3,    0        /.9614706
  3059.     3661
  3060.     566
  3061. LOGC5,    0        /.59897865
  3062.     2312
  3063.     5525
  3064. ONEHAF,    0        /.5
  3065.     2000
  3066.     0
  3067. LN2,    0        /.6931472
  3068.     2613
  3069.     4415
  3070.  
  3071.     /******FIX******
  3072. /ROUTINE TO FIX ANY FLOATING NUMBER IN FAC BETWEEN -2047 AND +2047 TO
  3073. /A TWELVE BIT INTEGER AND LEAVE RESULT IN EXP (LOC 44)
  3074.  
  3075. FFIX,    0
  3076.     CLA
  3077.     TAD    ACX    /FETCH EXPONENT
  3078.     SZA SMA        /IS NUMBER <1?
  3079.     JMP    .+3    /NO-CONTINUE ON
  3080. FTRPRT,    CLA
  3081.     JMP    FIXDNE+1 /YES-FIX IT TO ZERO
  3082.     TAD    (-13    /SET BINARY POINT AT 11
  3083.     SNA        /PLACES TO RIGHT OF CURRENT POINT?
  3084.     JMP    FIXDNE    /NO-NUMBER IS ALREADY FIXED THEN.
  3085.     SMA        /YES-IS NUMBER TOO LARGE TO FIX?
  3086.     JMP I    (FO    /YES-TAKE OVERFLOW TRAP
  3087.     DCA    ACX    /NO-SET SCALE COUNT
  3088. FIXLP,    CLL        /0 IN LINK
  3089.     TAD    ACH    /GET HIGH MANTISSA
  3090.     SPA        /IS IT <0?
  3091.     CML        /YES-PUT A 1 IN LINK
  3092.     RAR        /SCALE RIGHT
  3093.     DCA    ACH    /SAVE
  3094.     ISZ    ACX    /DONE YET?
  3095.     JMP    FIXLP    /NO
  3096. FIXDNE,    TAD    ACH    /YES-ANSWER IN AC
  3097.     DCA    ACX    /RETURN WITH ANSWER IN 44
  3098.     JMP I    FFIX    /RETURN
  3099.  
  3100. /******FLOAT******
  3101. /ROUTINE TO FLOAT ANY INTEGER IN EXP (LOC 44) INTO FAC
  3102.  
  3103. FFLOAT,    0
  3104.     TAD    ACX
  3105.     DCA    ACH    /PUT NUMBER IN HI MANTISSA
  3106.     DCA    ACL    /CLEAR LOW MANTISSA
  3107.     TAD    (13    /11(10) INTO EXPONENT
  3108.     DCA    ACX
  3109.     JMS I    [FFNOR    /NORMALIZE
  3110.     JMP I    FFLOAT    /RETURN
  3111.  
  3112. /FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF
  3113.  
  3114. FFSQ,    0
  3115.     JMS I    (FFMPY    /CALL MULTIPLY TO MULTIPLY
  3116.     ACX        /FAC BY ITSELF
  3117.     JMP I    FFSQ    /DONE
  3118.  
  3119.     /TAN(X)
  3120.     /COMPUTED AS SIN(X)/COS(X) DUE TO LAZINESS AND LACK OF SPACE
  3121.  
  3122. TAN,    0
  3123.     JMS I    [FFPUT    /SAVE ANGLE
  3124.     FPPTM3        /IN TEMP NOT USED BY SIN(X)
  3125.     JMS I    (COS    /COMPUTE COS(X)
  3126.     JMS I    [FFPUT    /SAVE COS
  3127.     FPPTM4
  3128.     JMS I    [FFGET    /GET ANGLE BACK
  3129.     FPPTM3
  3130.     JMS I    (SIN    /COMPUTE SIN(X)
  3131.     JMS I    (FFDIV    /RETURN TAN(X)=SIN(X)/COS(X)
  3132.     FPPTM4
  3133.     JMP I    TAN    /--RETURN--
  3134.  
  3135.         //ROUTINE TO FIND OUT IF THE TERMINAL IS A VT52 
  3136.         //AND IF SO MODIFY 'CURSOR' TO EXECUTE PROPERLY
  3137. CHK52,    0
  3138.     TAD     V278FG    /GET THE VT278 WORD
  3139.     AND    [200    /KEEP ONLY BIT 3
  3140.     SNA CLA        /IS THIS A VT78 TERMINAL
  3141.     JMP I     CHK52    /NO, GET OUT OF HERE
  3142.     TAD    PVH52    /GET JMS FOR VT52 CURSOR POSITIONING
  3143.     DCA I    [CUR1    /CHANGE THE VT278 JMS TO VT52 JMS
  3144.     TAD    PVH52    /GET JMS FOR VT52 CURSOR POSITIONING
  3145.     DCA I    [CUR2    /CHANGE THE VT278 JMS TO VT52 JMS
  3146.     TAD ("Y
  3147.     DCA I    [CUR3    /CHANGE "[" TO "Y"
  3148.     JMP I    CHK52
  3149.  
  3150.     PAGE
  3151. /
  3152. /INVERSE FLOATING SUBTRACT-USES FLOATING ADD
  3153. /!!FSW1!!-THIS IS OP-FAC
  3154. /
  3155. FFSUB1,    0
  3156.     JMS I    [PATCHF    /WHICH MODE?
  3157.     TAD I    FFSUB1    /CALLED BY USER-GET ADDR. OF OP.
  3158.     JMS I    (ARGET    /GO PICK UP OPERAND
  3159.     CDF
  3160.     JMS I    [FFNEG    /NEGATE FAC
  3161.     TAD    FFSUB1    /AND GO ADD
  3162.     JMP I    (SUB0
  3163. /
  3164. /INVERSE FLOATING DIVIDE
  3165. /FSWITCH=1
  3166. /THIS IS OP/FAC
  3167. /
  3168. FFDIV1,    0
  3169.     JMS I    [PATCHF    /WHICH MODE OF CALL?
  3170.     TAD I    FFDIV1    /CALLED BY USER-GET ADDR.
  3171.     JMS I    (ARGET    /PICK UP OPERAND
  3172.     TAD    ACL    /SWAP THE FAC AND OPERAND
  3173.     DCA    OPL    /THERE IS A POINTER TO OPL
  3174.     TAD I    AC2    /IN AC2 LEFT FROM ARGET SUBR.
  3175.     DCA    ACL
  3176.     TAD    ACX    /MIGHT AS WELL SUBTRACT THE
  3177.     CLL CMA IAC    /EXPONENTS HERE (SAVES A WORD)
  3178.     TAD    OPX    /THEN ZERO OPX SO WILL NOT
  3179.     DCA    ACX    /MESS UP WHEN ITS DONE AGAIN
  3180.     DCA    OPX    /LATER (SEE DIV. ROUTINE)
  3181.     TAD    ACH
  3182.     DCA    AC2    /NOW SWAP HIGH ORDER MANTISSAS
  3183.     TAD    OPH
  3184.     DCA    ACH
  3185.     TAD    AC2
  3186.     DCA    OPH
  3187.     CDF        /DF TO PACKAGE FIELD
  3188.     TAD    FFDIV1    /NOW KLUDGE UP A SUBROUTINE LINKAGE
  3189.     DCA I    (FFDIV
  3190.     TAD    (FFD1
  3191.     DCA I    (MDSET
  3192.     JMP I    (MD1    /GO SET UP AND DIVIDE
  3193. /MDSET-SETS UP SIGNS FOR MULTIPLY AND DIVIDE
  3194. /ALSO SHIFTS OPERAND ONE BIT TO THE LEFT.
  3195. /EXIT WITH EXPONENT OF OPERAND IN AC FOR EXPONENT
  3196. /CALCULATION-CALLED WITH ADDRESS OF OPERAND IN AC AND
  3197. /DATA FIELD SET PROPERLY FOR OPERAND.
  3198. /
  3199. MDSET,    0
  3200.     JMS I    (ARGET    /GET ARGUMENT
  3201. MD1,    CDF        /DF TO PACKAGE FIELD
  3202.     CLA CLL CMA RAL    /SET SIGN CHECK TO -2
  3203.     DCA    TM
  3204.     TAD    OPH    /IS OPERAND NEGATIVE?
  3205.     SMA    CLA
  3206.     JMP    .+3    /NO
  3207.     JMS I    (OPNEG    /YES-NEGATE IT
  3208.     ISZ    TM    /BUMP SIGN CHECK
  3209.     TAD    OPL    /AND SHIFT OPERAND LEFT ONE BIT
  3210.     CLL    RAL
  3211.     DCA    OPL
  3212.     TAD    OPH
  3213.     RAL
  3214.     DCA    OPH
  3215.     DCA    AC1    /CLR. OVERFLOW WORF OF FAC
  3216.     TAD    ACH    /IS FAC NEGATIVE
  3217.     SMA    CLA
  3218.     JMP    LEV    /NO-GO ON
  3219.     JMS I    [FFNEG    /YES-NEGATE IT
  3220.     ISZ    TM    /BUMP SIGN CHECK
  3221.     NOP        /MAY SKIP
  3222. LEV,    TAD    OPX    /EXIT WITH OPERAND EXPONENT IN AC
  3223.     JMP I    MDSET
  3224.  
  3225. /
  3226. /CONTINUATION OF FLOATING DIVIDE ROUTINE
  3227. /
  3228. FD1,    TAD    AC2    /NEGATE HI ORDER PRODUCT
  3229.     CLL CMA IAC
  3230.     TAD    ACH    /COMPARE WITH REMAINDER OF FIRST DIV.
  3231.     SNL        /WELL?
  3232.     JMP I    (DVOPS    /GREATER THAN REM.-ADJUST QUOT OF 1ST DIV.
  3233.     CLL        /OK-DO  (REM-(Q*OPL))/OPH
  3234.     DCA    ACH    /FIRST STORE ADJUSTED PRODUCT
  3235.     JMS I    (DV24    /DIVIDE BY OPH (HI ORDER OPERAND)
  3236. DVL1,    TAD    AC1    /GET QUOT. OF FIRST DIV.
  3237.     SMA        /IF HI ORDER BIT SET-MUST SHIFT 1 RIGHT
  3238.     JMP    FD    /NO-ITS NORMALIZED-DONE
  3239.     CLL
  3240.     ISZ    ACL
  3241.     SKP
  3242.     IAC
  3243.     RAR
  3244.     DCA    ACH    /STORE IN FAC
  3245.     TAD    ACL    /P@ LOW ORDER RIGHT
  3246.     RAR
  3247.     DCA    ACL    /STORE BACK
  3248.     ISZ    ACX    /BUMP EXPONENT
  3249.     NOP
  3250.     TAD    ACH
  3251.     JMP    DVL1+1
  3252. FD,    DCA    ACH    /STORE HIGH ORDER RESULT
  3253.     JMP I    (FDDON    /GO LEAVE DIVIDE
  3254. /
  3255. /CONTINUATION OF ROUTINE TO ADJUST QUOT. OF FIRST DIV.
  3256. /DBAD1 IS ONLY EXECUTED ON DIVIDE OVERFLOW-OTHERWISE THE
  3257. /ROUTINE STARTS AT DVOP2
  3258. /
  3259. DBAD1,    DCA    ACX    /DIVIDE OVERFLO-ZERO ALL
  3260. DVOP2,    SNA        /IS IT ZERO?
  3261.     DCA    ACL    /YES-MAKE WHOLE THING ZERO
  3262.     DCA    ACH
  3263.     JMS I    (DV24    /DIVIDE EXTENDED REM. BY HI DIVISOR
  3264.     TAD    ACL    /NEGATE THE RESULT
  3265.     CLL CMA IAC
  3266.     DCA    ACL
  3267.     SNL        /IF QUOT. IS NON-ZERO, SUBTRACT
  3268.     CMA        /ONE FROM HIGH ORDER QUOT.
  3269.     JMP    DVL1    /GO TO IT
  3270.  
  3271.     /MULTIPLY ACH;ACL;AC1 BY 10.
  3272.  
  3273. MPY10,    0
  3274.     JMS I    (AC2OP    /COPY AC FRACTION TO OP
  3275.     JMS I    (AL1    /*2
  3276.     JMS I    (AL1    /*4
  3277.     JMS I    (OADD    /*5
  3278.     JMS I    (AL1    /*10
  3279.     JMP I    MPY10
  3280.  
  3281. /
  3282. /ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
  3283. /
  3284. PATCHF,    0
  3285.     SZA        /IS AC EMPTY
  3286.     JMP    RTN2    /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
  3287.     TAD    FF    /YES-GET SPECIAL MODE FLIP-FLOP
  3288.     SZA CLA        /IF ON,THE ZERO AC MEANS ADDRESS OF 0
  3289. RTN2,    ISZ    PATCHF    /USE AC AS ADDRESS OF OPERAND
  3290.     JMP I    PATCHF    /RETURN
  3291.  
  3292.     PAGE
  3293.     /FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES
  3294.  
  3295. FFMPY,    0
  3296.     JMS I    [PATCHF    /WHICH MODE OF CALL?
  3297.     TAD I    FFMPY    /CALLED BY USER-GET OPERAND ADDR.
  3298.     JMS I    (MDSET    /SET UP FOR MPY-OPX IN AC ON RETN.
  3299.     TAD    ACX    /DO EXPONENT ADDITION
  3300.     DCA    ACX    /STORE FINAL EXPONENT
  3301.     DCA    DV24    /ZERO TEM STORAGE FOR MPY ROUTINE
  3302.     DCA    AC2
  3303.     TAD    ACH    /IS FAC=0?
  3304.     SNA    CLA
  3305.     DCA    ACX    /YES-ZERO EXPONENT
  3306.     JMS    MP24    /NO-MULTIPLY FAC BY LOW ORDER OPR.
  3307.     TAD    OPH    /NOW MULTIPLY FAC BY HI ORDER MULTIPLIER
  3308.     DCA    OPL
  3309.     JMS    MP24
  3310.     TAD    AC2    /STORE RESULT BACK IN FAC
  3311. RTZRO,    DCA    ACL    /LOW ORDER
  3312.     TAD    DV24    /HIGH ORDER
  3313.     DCA    ACH
  3314.     TAD    ACH    /DO WE NEED TO NORMALIZE?
  3315.     RAL
  3316.     SMA    CLA
  3317.     JMP    SHLFT    /YES-DO IT FAST
  3318. MDONE,    DCA    AC1    /NO-ZERO OVERFLOW WD(DO I NEED THIS???)
  3319.     ISZ    FFMPY    /BUMP RETURN POINTER
  3320.     ISZ    TM    /SHOULD RESULT BE NEGATIVE?
  3321.     JMP I    FFMPY    /NOPE-RETN.
  3322.     JMS I    [FFNEG    /YES-NEGATE IT
  3323.     JMP I    FFMPY    /RETURN
  3324. SHLFT,    CMA        /SUBTRACT 1 FROM EXP.
  3325.     TAD    ACX
  3326.     DCA    ACX
  3327.     JMS I    (AL1    /SHIFT FAC LEFT 1 BIT
  3328.     JMP    MDONE+1    /DONE.
  3329. /
  3330. /24 BIT BY 12 BIT MULTIPLY.  MULTIPLIER IS IN OPL
  3331. /MULTIPLICAND IS IN ACH AND ACL
  3332. /RESULT LEFT IN DV24,AC2, AND AC1
  3333. MP24,    0
  3334.     TAD    (-14    /SET UP 12 BIT COUNTER
  3335.     DCA    OPX
  3336.     TAD    OPL    /IS MULTIPLIER=0?
  3337.     SZA
  3338.     JMP    MPLP1    /NO-GO ON
  3339.     DCA    AC1    /YES-INSURE RESULT=0
  3340.     JMP I    MP24    /RETURN
  3341. MPLP,    TAD    OPL    /SHIFT A BIT OUT OF LOW ORDER
  3342. MPLP1,    RAR        /OF MULTIPLIER AND INTO LINK
  3343.     DCA    OPL
  3344.     SNL        /WAS IT A 1?
  3345.     JMP    MPLP2    /NO-0-JUST SHIFT PARTIAL PRODUCT
  3346.     CLL        /YES-ADD MULTIPLICAND TO PARTIAL PRODUCT
  3347.     TAD    AC2
  3348.     TAD    ACL    /LOW ORDER
  3349.     DCA    AC2
  3350.     RAL        /PROPAGATE CARRY
  3351.     TAD    ACH    /HI ORDER
  3352. MPLP2,    TAD    DV24
  3353.     RAR        /NOW SHIFT PARTIAL PROD. RIGHT 1 BIT
  3354.     DCA    DV24
  3355.     TAD    AC2
  3356.     RAR
  3357.     DCA    AC2
  3358.     RAR        /1 BIT OF OVERFLOW TO AC1
  3359.     DCA    AC1
  3360.     ISZ    OPX    /DONE ALL 12 MULTIPLIER BITS?
  3361.     JMP    MPLP    /NO-GO ON
  3362.     JMP I    MP24    /YES-RETURN
  3363. /
  3364. /PART OF DIVIDE ROUTINE-FFDIV MUST BE AT LOC. 6722
  3365. MP12L,    DCA    OPL    /STORE BACK MULTIPLIET
  3366.     TAD    AC2    /GET PRODUCT SO FAR
  3367.     SNL        /WAS MULTIPLIER BIT A 1?
  3368.     JMP    .+3    /NO-JUST SHIFT THE PARTIAL PRODUCT
  3369.     CLL        /YES-CLEAR LINK AND ADD MULTIPLICAND
  3370.     TAD    ACL    /TO PARTIAL PRODUCT
  3371.     RAR        /SHIFT PARTIAL PRODUCT-THIS IS HI ORDER
  3372.     DCA    AC2    /RESULT-STORE BACK
  3373. DVLP1,    TAD    OPL    /SHIFT A BIT OUT OF MULTIPLIER
  3374.     RAR        /AND A BIT OR RESLT. INTO IT (LO ORD. PROD.)
  3375.     ISZ    FFMPY    /DONE ALL BITS?
  3376.     JMP    MP12L    /NO-LOOP BACK
  3377.     CLL CMA IAC    /YES-LOW ORDER PROD. OF QUOT. X OPL IN AC
  3378.     DCA    ACL    /NEGATE AND STORE
  3379.     CML    RAL    /PROPAGATE CARRY
  3380.     JMP I    (FD1    /GO ON
  3381. /
  3382. /FLOATING DIVIDE ROUTINE
  3383. /USES THE METHOD OF TRIAL DIVISION BY HI ORDER
  3384. FFDIV,    0        /(USED AS A TEM. BY I/O ROUTINES)
  3385.     JMS I    [PATCHF    /WHICH MODE OF CALL?
  3386.     TAD I    FFDIV    /CALLED BY USER-GET ARG. ADDR.
  3387.     JMS I    (MDSET    /GO SET UP FOR DIVIDE-OPX IN AC ON RETN.
  3388. FFD1,    CMA    IAC    /NEGATE EXP. OF OPERAND
  3389.     TAD    ACX    /ADD EXP OF FAC
  3390.     DCA    ACX    /STORE AS FINAL EXPONENT
  3391.     TAD    OPH    /NEGATE HI ORDER OP. FOR USE
  3392.     CLL CMA IAC    /AS DIVISOR
  3393.     DCA    OPH
  3394.     JMS    DV24    /CALL DIV.--(ACH+ACL)/OPH
  3395.     TAD    ACL    /SAVE QUOT. FOR LATER
  3396.     DCA    AC1
  3397.     TAD    (-15    /SET COUNTER FOR 12 BIT MULTIPLY
  3398.     DCA    FFMPY    /TO MULTIPLY QUOT. OF DIV. BY 
  3399.     JMP    DVLP1    /LOW ORDER OF OPERAND (OPL)
  3400. /
  3401. /END OF FLOATING DIVIDE-FUDGE SOME
  3402. /STUFF THEN JUMP INTO MULTIPLY
  3403. /
  3404. FDDON,    TAD    FFDIV    /STORE RETN. ADDR. IN MULT ROUTINE
  3405.     DCA    FFMPY
  3406.     JMP    MDONE    /GO CLEAN UP
  3407. /
  3408. /DIVIDE ROUTINE--24 BITS IN ACH,ACL ARE DIVIDED BY 12 BITS
  3409. /IN OPH.  OPH IS ASSUMED NEGATIVE AND .GT. ACH IN ABSOLUTE VALUE
  3410. /ELSE-DIVIDE OVERFLOW--WE RETURN NORMALLY WITH QUOTIENT
  3411. /IN ACL AND REM. IN ACH.  (AC2=0 ON RETN.)
  3412. /
  3413. DV24,    0
  3414.     TAD    ACH    /CHECK THAT DIVISOR IS .GT. DIVIDEND
  3415.     TAD    OPH    /DIVISOR IN OPH (NEGATIVE)
  3416.     SZL    CLA    /IS IT?
  3417.     JMP I    (DV    /NO-DIVIDE OVERFLOW
  3418.     TAD    (-15    /YES-SET UP 12 BIT LOOP
  3419.     DCA    AC2
  3420.     JMP    DV1    /GO BEGIN DIVIDE
  3421. DV2,    TAD    ACH    /CONTINUE SHIFT OF FAC LEFT
  3422.     RAL
  3423.     DCA    ACH    /RESTORE HI ORDER
  3424.     TAD    ACH    /NOW SUBTRACT DIVISOR FROM HI ORDER
  3425.     TAD    OPH    /DIVIDEND
  3426.     SZL        /GOOD SUBTRACT?
  3427.     DCA    ACH    /YES-RESTORE HI DIVIDEND
  3428.     CLA        /NO-DON'T RESTORE--OPH.GT.ACH
  3429. DV1,    TAD    ACL    /SHIFT FAC LEFT 1 BIT-ALSO SHIFT
  3430.     RAL        /1 BIT OF QUOT. INTO LOW ORD OF ACL
  3431.     DCA    ACL
  3432.     ISZ    AC2    /DONE 12 BITS OF QUOT?
  3433.     JMP    DV2    /NO-GO ON
  3434.     JMP I    DV24    /YES-RETN W/AC2=0
  3435.  
  3436.     PAGE
  3437. /
  3438. /FLOATING ADD
  3439. /
  3440. FFADD,    0
  3441.     JMS I    [PATCHF    /WHICH MODE FO CALL?
  3442.     TAD I    FFADD    /CALLED BY USER-GET ADDR. OF OPR.
  3443.     JMS I    (ARGET    /PICK UP OPERAND
  3444. FAD1,    CDF        /DF TO PACKAGE FIELD
  3445.     TAD    OPH    /IS OPERAND = 0
  3446.     SNA    CLA
  3447.     JMP    DONA    /YES-DONE
  3448.     TAD    ACH    /NO-IS FAC=0?
  3449.     SNA    CLA
  3450.     JMP    DOADD    /YES-DO ADD
  3451.     AC4000
  3452.     AND    ACX    /NO, DO EXPONENT CALCULATION
  3453.     TAD    OPX
  3454.     RAL        /DO 13 BIT SUBTRACT
  3455.     CLA
  3456.     TAD    ACX
  3457.     CML CIA
  3458.     TAD    OPX
  3459.     SNL SZA        /SKP IF OPX .LE. ACX
  3460.     JMP    FACR    /JMP IF OPX .GT. ACX
  3461.     CIA
  3462.     JMS    OPSR
  3463.     JMS    ACSR    /SHIFT FAC ONE PLACE RIGHT
  3464. DOADD,    TAD    OPX    /SET EXPONENT OF RESULT
  3465.     DCA    ACX
  3466.     JMS    OADD    /DO THE ADDITION
  3467.     JMS I    [FFNOR    /NORMALIZE RESULT
  3468. DONA,    ISZ    FFADD    /BUMP RETURN
  3469.     JMP I    FFADD    /RETURN
  3470. FACR,    JMS    ACSR    /SHIFT FAC = DIFF.+1
  3471.     JMS    OPSR    /SHIFT OPR. 1 PLACE
  3472.     JMP    DOADD    /DO ADDITION
  3473. /
  3474. /OPERAND SHIFT RIGHT-ENTER WITH POSITIVE COUNT-1
  3475. /IN AC
  3476. OPSR,    0
  3477.     CMA        /- (COUNT+1) TO SHIFT COUNTER
  3478.     DCA    AC0
  3479. LOP2,    TAD    OPH    /GET SIGN BIT
  3480.     RAL        /TO LINK
  3481.     CLA
  3482.     TAD    OPH    /GET HI MANTISSA
  3483.     RAR        /SHIFT IT RIGHT, PROPAGATING SIGN
  3484.     DCA    OPH    /STORE BACK
  3485.     TAD    OPL
  3486.     RAR
  3487.     DCA    OPL    /STORE LO ORDER BACK
  3488.     RAR        /SAVE 1 BIT OF OVERFLOW
  3489.     DCA    AC2    /IN AC2
  3490.     ISZ    OPX    /INCREMENT EXPONENT
  3491. NOP2,    NOP    
  3492.     ISZ    AC0    /DONE ALL SHIFTS?
  3493.     JMP    LOP2    /NO-LOOP
  3494.     JMP I    OPSR    /YES-RETN.
  3495. /
  3496. /SHIFT FAC LEFT 1 BIT
  3497. /
  3498. AL1,    0
  3499.     TAD    AC1    /GET OVERFLOW BIT
  3500.     CLL    RAL    /SHIFT LEFT
  3501.     DCA    AC1    /STORE BACK
  3502.     TAD    ACL    /GET LOW ORDER MANTISSA
  3503.     RAL        /SHIFT LEFT
  3504.     DCA    ACL    /STORE BACK
  3505.     TAD    ACH    /GET HI ORDER
  3506.     RAL
  3507.     DCA    ACH    /STORE BACK
  3508.     JMP I    AL1    /RETN.
  3509. /
  3510. /SHIFT FAC RIGHT-ENTER WITH COUNT-1 IN AC (POSITIVE)
  3511. /
  3512. ACSR,    0
  3513.     CMA    /AC CONTAINS COUNT-1
  3514.     DCA    AC0    /STORE COUNT
  3515. LOP1,    TAD    ACH    /GET SIGN BIT OF MANTISSA
  3516.     RAL        /SET UP SIGN PROPAGATION
  3517.     CLA
  3518.     TAD    ACH    /GET HIGH ORDER MANTISSA
  3519.     RAR        /SHIFT RIGHT`1, PROPAGATING SIGN
  3520.     DCA    ACH    /STORE BACK
  3521.     TAD    ACL    /GET LOW ORDER
  3522.     RAR        /SHIFT IT
  3523.     DCA    ACL    /STORE BACK
  3524.     RAR
  3525.     DCA    AC1    /SAVE 1 BIT OF OVERFLOW
  3526.     ISZ    ACX    /INCREMENT EXPONENT
  3527. NOP1,    NOP
  3528.     ISZ    AC0    /DONE?
  3529.     JMP    LOP1    /NO-LOOP
  3530.     JMP I    ACSR    /YES-RETN-AC=L=0
  3531. /
  3532. /DIVIDE OVERFLOW-ZERO ACX,ACH,ACL
  3533. /
  3534. DBAD,    CLA    CLL    /NECESSARY SO WE DON'T GET OVRFLO AGAIN
  3535.     JMP I    (DBAD1    /GO ZERO ALL
  3536. /
  3537. /FLOATING SUBTRACT
  3538. /
  3539. FFSUB,    0
  3540.     JMS I    [PATCHF    /WHICH MODE OF CALL?
  3541.     TAD I    FFSUB    /CALLED BY USER-GET ADDR. OF OP
  3542.     JMS I    (ARGET    /PICK UO THE OP.
  3543.     JMS    OPNEG    /NEGATE OPERAND
  3544.     TAD    FFSUB    /JMP INTO FLTG. ADD
  3545. SUB0,    DCA    FFADD    /AFTER SETTING UP RETURN
  3546.     JMP    FAD1
  3547. /
  3548. /FLOATING NEGATE
  3549. /
  3550. FFNEG,    0        /(USED AS A TEM. BY OUTPUT ROUTINE)
  3551.     TAD    ACL    /GET LOW ORDER FAC
  3552.     CLL CMA IAC    /NEGATE IT
  3553.     DCA    ACL    /STORE BACK
  3554.     CML    RAL    /ADJUST OVERFLOW BIT AND
  3555.     TAD    ACH    /PROPAGATE CARRY-GET HI ORD
  3556.     CLL CMA IAC    /NEGATE IT
  3557.     DCA    ACH    /STORE BACK
  3558.     JMP I    FFNEG
  3559. /
  3560. /NEGATE OPERAND
  3561. /
  3562. OPNEG,    0
  3563.     TAD    OPL    /GET LOW ORDER
  3564.     CLL CMA IAC    /NEGATE AND STORE BACK
  3565.     DCA    OPL
  3566.     CML    RAL    /PROPAGATE CARRY
  3567.     TAD    OPH    /GET HI ORDER
  3568.     CLL CMA IAC    /NEGATE AND STORE BACK
  3569.     DCA    OPH
  3570.     JMP I    OPNEG
  3571. /
  3572. /ADD OPERAND TO FAC
  3573. /
  3574. OADD,    0
  3575.     CLL
  3576.     TAD    AC2    /ADD OVERFLOW WORDS
  3577.     TAD    AC1
  3578.     DCA    AC1
  3579.     RAL        /ROTATE CARRY
  3580.     TAD    OPL    /ADD LOW ORDER MANTISSAS
  3581.     TAD    ACL
  3582.     DCA    ACL
  3583.     RAL
  3584.     TAD    OPH    /ADD HI ORDER MANTISSAS
  3585.     TAD    ACH
  3586.     DCA    ACH
  3587.     JMP I    OADD    /RETN.
  3588.     PAGE
  3589. /ARGUMENT PICK UP ROUTINE-ENTER WITH DATA FIELD SET TO EITHER
  3590. /FLTG. DATA FIELD OR FLTG. INSTR. FIELD.
  3591. /ADDRESS OF OPERAND IS IN THE AC ON ENTRY.
  3592. /ON RETURN, THE`AC IS CLEAR
  3593.  
  3594. ARGET,    0
  3595.     DCA    AC2    /STORE ADDRESS OF OPERAND
  3596.     TAD I    AC2    /PICK UP EXPONENT
  3597.     DCA    OPX
  3598.     JMS    ISZAC2    /MOVE POINTER TO HORD,WATCH FOR FIELD OVERLAP
  3599.     TAD I    AC2    /PICK IT UP
  3600.     DCA    OPH    /STORE
  3601.     JMS    ISZAC2    /MOVE POINTER TO LORD,WATCHING FOR OVERLAP
  3602.     TAD I    AC2    /PICK IT UP
  3603.     DCA    OPL    /STORE IT
  3604.     JMP I    ARGET    /RETURN
  3605. /
  3606. /ROUTINE TO NORMALIZE THE FAC
  3607. /
  3608. FFNOR,    0
  3609.     TAD    ACH    /GET THE HI ORDER MANTISSA
  3610.     SNA        /ZERO?
  3611.     TAD    ACL    /YES-HOW ABOUT LOW?
  3612.     SNA
  3613.     TAD    AC1    /LOW=0, IS OVRFLO BIT ON?
  3614.     SNA CLA
  3615.     JMP    ZEXP    /#=0-ZERO EXPONENT
  3616. NORMLP,    AC2000        /NOT 0-MAKE A 2000 IN AC
  3617.     TAD    ACH    /ADD HI ORDER MANTISSA
  3618.     SZA        /HI ORDER = 6000
  3619.     JMP    .+3    /NO-CHECK LEFT MOST DIGIT
  3620.     TAD    ACL    /YES-6000 OK IF LOW=0
  3621.     SZA CLA    
  3622.     SPA CLA        /2,3,4,5,ARE LEGAL LEFT MOST DIGS.
  3623.     JMP    FFNORR    /FOR NORMALIZED #-(+2000=4,5,6,7)
  3624.     JMP    FNLP    /JUMP SO FFGET AND PUT ARE ORGED RIGHT
  3625.  
  3626. FFNORR,    DCA    AC1    /DONE W/NORMALIZE-CLEAR AC1
  3627.     JMP I    FFNOR    /RETURN
  3628. AL1P,    AL1
  3629.     /FLOATING GET
  3630.  
  3631. FFGET,    0
  3632.     JMS I    [PATCHF    /WHICH MODE OF CALL
  3633.     TAD I    FFGET    /CALLED BY USER-GET ADDR. OF OP
  3634.     JMS    ARGET    /PICK UP OPERAND
  3635.     TAD    OPX
  3636.     DCA    ACX    /LOAD THE OPERAND INTO FAC
  3637.     TAD    OPL
  3638.     DCA    ACL
  3639.     TAD    OPH
  3640.     DCA    ACH
  3641.     ISZ    FFGET
  3642.     CDF
  3643.     JMP I    FFGET    /RETN. TO CALL +2
  3644. /
  3645. /FLOATING PUT
  3646. /
  3647. FFPUT,    0
  3648.     JMS I    [PATCHF    /WHICH MODE OF CALL?
  3649.     TAD I    FFPUT    /CALLED BY USER-GET OPR. ADDR
  3650.     DCA    FFGET    /STORE IN A TEMP
  3651.     TAD    ACX    /GET FAC AND STORE IT
  3652.     DCA I    FFGET    /AT SPECIFIED ADDRESS
  3653.     JMS    ISZFGT    /BUMP POINTER,WATCHING FOR FIELD OVERLAP
  3654.     TAD    ACH
  3655.     DCA I    FFGET
  3656.     JMS    ISZFGT
  3657.     TAD    ACL
  3658.     DCA I    FFGET
  3659.     ISZ    FFPUT    /BUMP RETN.
  3660.     CDF
  3661.     JMP I    FFPUT    /RETN. TO CALL+2
  3662.  
  3663. /ROUTINES TO BUMP ARGET AND FPUT POINTERS AND INCREMENT THE
  3664. /DATA FIELD IF THE POINTER CROSSES A FIELD BOUNDARY
  3665.  
  3666. ISZFGT,    0
  3667.     ISZ    FFGET    /BUMP POINTER
  3668.     JMP I    ISZFGT    /NO SKIP MEANS JUST RETURN
  3669.     SKP        /SKIP MEANS WE HAVE TO INCREMENT DATA FIELD
  3670. NEWCDF,    DCA    ISZFGT    /THIS INST EXECUTED ONLY BY ISZAC2
  3671.     RDF        /GET THE DATA FIELD
  3672.     TAD    CDF10    /BUMP BY 1 AND MAKE A CDF
  3673.     DCA    .+1        /PUT IN LINE
  3674.     .
  3675.     JMP I    ISZFGT    /RETURN
  3676.  
  3677. CDF10,    CDF 10
  3678.  
  3679. ISZAC2,    0
  3680.     ISZ    AC2        /BUMP POINTER
  3681.     JMP I    ISZAC2    /NOTHING HAPPENED
  3682.     TAD    ISZAC2    /NEED NEW DF. GET RETURN ADDR
  3683.     JMP    NEWCDF    /AND BUMP DF
  3684. /
  3685. /ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE
  3686. /REMAINDER OF THE FIRST`DIVIDE IS LESS THAN QUOT*OPL
  3687. /USED BY FLTG. DIVIDE ROUTINE
  3688. /
  3689. DVOPS,    CMA    IAC    /NEGATE AND STORE REVISED REMAINDER
  3690.     DCA    ACH    
  3691.     CLL
  3692.     TAD    OPH
  3693.     TAD    ACH    /WATCH FOR OVERFLOW
  3694.     SNL
  3695.     JMP    DVOP1    /OVERFLOW-DON'T ADJUST QUOT. OF 1ST DIV.
  3696.     DCA    ACH    /NO OVERFLOW-STORE NEW REM.
  3697.     CMA        /SUBTRACT 1 FROM QUOT OF
  3698.     TAD    AC1    /FIRST DIVIDE
  3699.     DCA    AC1
  3700. DVOP1,    CLA     CLL
  3701.     TAD    ACH    /GET HI ORD OF REMAINDER
  3702.     JMP I    DVOP2P    /GO ON
  3703. DVOP2P,    DVOP2
  3704.  
  3705. FNLP,    CLL CML CMA    /-1
  3706.     TAD    ACX    /SUBTR. 1 FROM EXPONENT
  3707.     DCA    ACX
  3708.     JMS I    AL1P    /SHIFT FAC LEFT 1
  3709.     JMP    NORMLP    /GO BACK AND SEE IF NORMALIZED
  3710. ZEXP,    DCA    ACX
  3711.     JMP    FFNORR
  3712.     /EDITOR READ ROUTINE SITS HERE ABOVE EDITOR LOAD AREA
  3713.  
  3714. EDREAD,    DCA    EBLK    /ENTER WITH AC = BLOCK
  3715.     JMS I    E7607    /READ EDITOR OFF SYS:
  3716.     EDTSIZ        /THIS MUCH TO FIELD 0
  3717.     0000        /STARTING HERE
  3718. EBLK,    0000        /FROM HERE
  3719.     HLT        /CRASH SYS ON ERROR HERE
  3720.     JMP I    .+1    /JMP INTO EDITOR CHAIN ENTRY NOW
  3721.     EDTBGN
  3722. E7607,    7607
  3723.  
  3724.     /I/O TABLE FOLLOWS AND CROSSES PAGE BOUNDRY
  3725.  
  3726.     /I/O TABLE ENTRIES
  3727.  
  3728. TTYF,    1            /ASCII
  3729.     ZBLOCK    IOTSIZ-1    /FILE #0 (CONSOLE)
  3730.     ZBLOCK    IOTSIZ^MAXFIL    /FILES #1 THROUGH #5
  3731.  
  3732.     PAGE
  3733.     /CROSS FIELD LITERAL EQUATES
  3734.  
  3735.     PILOOP=    [ILOOP
  3736.     PPUTCH=    [PUTCH
  3737.     PPCH=    [PCH
  3738.     PSACM1=    [SAC-1
  3739.     PFFNOR=    [FFNOR
  3740.     PFFGET=    [FFGET
  3741.     PFFPUT=    [FFPUT
  3742.     PUNSFIX= [UNSFIX
  3743.     PERROR= [ERROR
  3744.     PFACCLR= [FACCLR
  3745.     PIDLE=    [IDLE
  3746.     PPSWAP=    [PSWAP
  3747.     PFTYPE=    [FTYPE
  3748.     O377=    [377
  3749.     O200=    [200
  3750.     O10=    [10
  3751.     O17=    [17
  3752.     O7400=    [7400
  3753.     O77=    [77
  3754.     O40=    [40
  3755.     O15=    [15
  3756.     O7700=    [7700
  3757.     /PAGE ZERO LITERAL POOL
  3758.  
  3759.     FIELD    1
  3760.     /FIELD 1 PAGE ZERO TEMPORARIES (VOLATILE)
  3761.  
  3762.     *10
  3763. SXR,    0
  3764. TXR,    0
  3765.  
  3766.     /RECORD I/O PARAMETERS, MUST REMAIN VALID FOR LIFE OF I/O STATEMENT
  3767.  
  3768.     *20
  3769. EOLPTR,    0        /ONCE ONLY FLAG/PTR ZEROED ON IOTABLE INITIALIZATION
  3770. REMSIZ,    0        /INITIALIZED TO REMAINING SIZE OF CURRENT RECORD
  3771. NXTFLD,    0        /INITIALIZED TO HEAD OF RECORD FIELD DEFINITIONS
  3772. EXPNDF,    0        /NEGATIVE IF CURRENT RECORD CAUSED FILE TO EXPAND
  3773.  
  3774.     /VOLATILE TEMPORARIES
  3775.  
  3776. PRODL,    0
  3777. PRODH,    0
  3778. STPCNT,    0
  3779. SUBFPT,    0
  3780. SACPT,    0
  3781.  
  3782.     /IOTABLE POINTER IMAGE FOR FIELD 1
  3783.  
  3784. IOHDR1,    0
  3785. IOBUF1,    0
  3786. IOBLK1,    0
  3787. IOPTR1,    0
  3788. IOHND1,    0
  3789. IOLOC1,    0
  3790. IOLEN1,    0
  3791. IORSZ1,    0
  3792. IOSUB1,    0
  3793. IONRH1,    0
  3794. IONRL1,    0
  3795. IOMAX1,    0
  3796. IOPOS1,    0
  3797. IOFIL1,    0
  3798.             /FIELD 0, PAGE 0 LINKS FOR FFOUT1, AND FFIN1
  3799.  
  3800. FF1,FF
  3801. AC01,AC0
  3802. AC11,AC1
  3803. AC21,AC2
  3804. DECEX1,DECEXP
  3805. ACX1,ACX
  3806. ACH1,ACH
  3807. ACL1,ACL
  3808. APX1,OPX
  3809. OPL1,OPL
  3810. OPH1,OPH
  3811. OPX1,OPX
  3812. CHAR1,CHAR
  3813.             /SEE PAGE ZREO FIELD ZERO FOR VARIABLE DEFINITION
  3814.  
  3815.     PAGE
  3816.     /STRING ACCUMULATOR, ONE 7 OR 8 BIT CHAR PER WORD
  3817.  
  3818. SAC,
  3819. START,    0        /ONCE ONLY STARTUP CODE
  3820.     TLS        /SET TTY FLAG
  3821.     CDF
  3822.     TAD I    (CDFIO    /SET CDF'S IN PSWAP
  3823.     DCA I    (P1CDF
  3824.     TAD I    (CDFIO
  3825.     DCA I    (P1CDF1
  3826.     TAD I    (PSFLAG    /SET SWAP PAGE
  3827.     SMA CLA        /SKP IF 2 PAGE SYSTEM HANDLER
  3828.     TAD    (200    /ELSE USE 7600 AS SWAP AREA
  3829.     TAD    (7400
  3830.     DCA I    (HICORE
  3831.     CLA IAC        /BE SURE OS/8 SWAPPED IN
  3832.     AND I    (PSFLAG
  3833.     SZA CLA
  3834.     JMP    .+4
  3835.     CIF
  3836.     JMS I    (CALLF0    /SWAP IN IF NOT ALREADY IN
  3837.     PSWAP
  3838.     CDF    10
  3839.     TAD I    (SCOPWD    /SAVE SCOPE FLAG
  3840.     DCA I    (SCOPFG    /SAVE IT FOR LATER
  3841.     CDF
  3842.     TAD I    (V278WD    /GET THE VT278 WORD
  3843.     DCA I    (V278FG    /SAVE IT FOR LATER
  3844.     TAD I    (HEIGHT
  3845.     DCA I    (HCTR    /INITIALIZE SCREEN HEIGHT KLUDGE (OS78)
  3846.     TAD    (OVDESC-1 /SETUP OVERLAY BLOCK TABLE
  3847.     DCA    SXR
  3848.     TAD    (ARITHA-1
  3849.     DCA    TXR
  3850. OVSET,    CDF    10
  3851.     TAD I    SXR    /GET BLOCK LOCATION PTR
  3852.     SNA        /SKP IF NOT EOL
  3853.     JMP    SETEM    /GO SET ERROR MESSAGE OVERLAY IF DONE
  3854.     DCA    SACPT    /STORE
  3855.     TAD I    SACPT    /PICK IT UP
  3856.     TAD I    SXR    /ADD OFFSET TO THIS OVERLAY
  3857.     CDF
  3858.     SNA        /SKP IF HAVE OVERLAY
  3859.     JMP    NOOVLY    /ELSE DON'T TRY TO READ IT
  3860.     DCA    CURBK    /STORE INLINE
  3861.     TAD    CUROV    /SEE IF IT WILL FIT IN FIELD 2
  3862.     TAD    (1400
  3863.     CLL CIA
  3864.     TAD I    (PSSTRT    /COMPARE TO START OF PSEUDO CODE
  3865.     CLA CML RAL
  3866.     TAD    (CDF 20
  3867.     CIA
  3868.     TAD I    (CDFPS
  3869.     SPA CLA        /SKP IF THERE IS ROOM
  3870.     JMP    NOFIT    /ELSE DON'T LOAD IT
  3871.     CDF    10
  3872.     CIF        /CALL SYS: TO READ IT IN
  3873.     JMS I    (7607
  3874.     0620        /6 PAGES TO FIELD 2
  3875. CUROV,    0000        /STARTING HERE
  3876. CURBK,    0000        /FROM HERE
  3877.     HLT        /CRASH SYS ON THIS UNLIKELY ERROR
  3878.     CDF        /RESET DF
  3879.     SKP
  3880. NOFIT,    TAD    CURBK    /STORE BLOCK IN OVERLAY TABLE IF COULDN'T LOAD IT
  3881. NOOVLY,    DCA I    TXR    /ELSE CLEAR THE ENTRY
  3882.     TAD    CUROV    /BUMP TO NEXT OVERLAY SLOT
  3883.     TAD    (1400
  3884.     DCA    CUROV
  3885.     JMP    OVSET
  3886. SETEM,    CDF    10    /NOW SET ERROR OVERLAY ADDR
  3887.     TAD I    (CDOPT4    /SAVE CD SWITCHES M-X FOR VERSION AND FREE SPACE MSGS
  3888.     DCA    PRODL    /IN A RANDOM TEMPORARY
  3889.     TAD I    (INFO+4    /SITS AT END OF STRING FUNCTIONS IMAGE
  3890.     CDF
  3891.     TAD    (14
  3892.     DCA I    (ERRA
  3893.     CIF
  3894.     JMS I    (CALLF0    /OUT WITH OS/8 NOW
  3895.     PSWAP
  3896.     CDF        /NOW SET VARIOUS CDF'S AND ADDRESSES
  3897.     TAD I    (CDFPS    /INTERPRETIVE CODE DF AND ADDR
  3898.     DCA I    (CDFPSU
  3899.     TAD I    (PSSTRT
  3900.     DCA I    (INTPC
  3901.     TAD I    (CDFIO    /STRING STOREAGE CDF
  3902.     DCA I    (STDF
  3903.     TAD I    (CDFIO    /ARRAYS
  3904.     DCA I    (ATABDF
  3905.     TAD I    (CDFIO    /SCALAR NUMERICS
  3906.     DCA I    (SCALDF
  3907.     TAD I    (CDFIO    /INCORE DATA LIST
  3908.     DCA I    (DLCDF
  3909.     TAD I    (DLSTRT
  3910.     DCA I    (DATAXR
  3911.     JMP I    START    /OK, NOW GO DO SOME INTERPRETING!
  3912.  
  3913.     PAGE
  3914.     *RECPAK
  3915.  
  3916.     /BRTS FIELD 1 STARTUP CODE (RESIDES IN INPUT BUFFER)
  3917.     /ENTER WITH AC = STARTING BLOCK OF BRTS ON SYS:
  3918.     /CALL+1 = ADDR OF BRTS PARAMETER BLOCK
  3919.  
  3920. INBUF=    SAC+SACLIM+1    /START INPUT BUFFER PAST SAC
  3921.  
  3922. BRTBG1,    0
  3923.     TAD    F0BLK    /ADD FIELD 0 OFFSET TO ADDR OF BRTS PASSED IN AC
  3924.     DCA    F0BLK    /STORE INLINE
  3925.     CDF
  3926.     TAD I    BRTBG1    /NOW GET ADDR OF PARAMETER BLOCK FROM CALL+1
  3927.     DCA    PARM1    /POINT AT IT
  3928. SAVPRM,    CDF
  3929.     TAD I    PARM1    /SAVE BRTS PARAMETERS
  3930.     CDF    10
  3931.     DCA I    SAV1
  3932.     ISZ    PARM1
  3933.     ISZ    SAV1
  3934.     ISZ    CNT1
  3935.     JMP    SAVPRM
  3936.     CIF        /NOW READ IN FIELD 0 OF BRTS
  3937.     JMS I    (7607
  3938.     BRTSZ0        /SIZE CONTROL WORD
  3939.     0000        /ADDR TO LOAD
  3940. F0BLK,    13        /FROM HERE (INITIALLY CONTAINS BLOCK OFFSET TO FIELD 0)
  3941.     HLT        /CRASH SYSTEM IF ERROR HERE
  3942. RSTPRM,    TAD I    SAV2    /NOW RESTORE SYSTEM PARAMETERS
  3943.     CDF
  3944.     DCA I    PARM2
  3945.     CDF    10
  3946.     ISZ    SAV2
  3947.     ISZ    PARM2
  3948.     ISZ    CNT2
  3949.     JMP    RSTPRM
  3950.     CDF        /NOW BUSY OUT ALL BUFFERS OCCUPIED BY CODE
  3951.     TAD I    (CDFPS    /FIRST SEE IF OBJECT CODE RAN INTO BUFFER AREA
  3952.     TAD    (-6211    /IN FIELD 1
  3953. /    SPA
  3954. /    HLT        /UNREACHABLE - LOADER ERROR
  3955.     SZA CLA        /SKP IF HIT FIELD 1
  3956.     JMP    SETHKS    /GO SET ^C HOOKS IF ALL BUFFERS FREE
  3957. KILBUF,    TAD I    (BUFSTK    /SEE IF CODE IN FIELD 1 IS ABOVE END OF THIS BUFFER
  3958.     DCA    SAV1
  3959.     TAD I    SAV1
  3960.     SZA        /SKP IF BUFFER DOES NOT  EXISTS
  3961.     JMP    GOTBUF
  3962.     TAD    (BUFAREA-1
  3963.     CLL CIA
  3964.     TAD I    (PSSTRT
  3965.     SNL CLA
  3966.     HLT        /UNREACHABLE - LOADER ERROR
  3967.     JMP    SETHKS
  3968. GOTBUF,    TAD    (377    /OFFSET TO END OF BUFFER
  3969.     CLL CIA
  3970.     TAD I    (PSSTRT    /ONE LESS THAN FIRST WORD OF CODE
  3971.     SZL CLA        /SKP IF IN THIS BUFFER
  3972.     JMP    SETHKS    /DONE, GO SET ^C HOOKS
  3973.     ISZ I    (BUFSTK    /POP BUFFER FROM FREE STACK
  3974.     JMP    KILBUF    /TRY NEXT ONE
  3975. SETHKS,    TAD    (JMP I    FSTOP1    /NOW SET ^C HOOKS
  3976.     DCA I    (7600
  3977.     TAD    (JMP I    FSTOP1
  3978.     DCA I    (7605
  3979.     TAD I    (BIPCCL    /NOW SEE IF FIELD CONTAINING BATCH IS UNTOUCHED
  3980.     AND    (70    /ISOLATE BATCH FIELD BITS (IF ANY)
  3981.     CIA
  3982.     TAD I    (CDFIO    /SUBTRACT FROM FIELD BITS IN CDF INSTR
  3983.     AND    (100    /AC5 SET IF CDFIO LT SYSTEM SIZE
  3984.     CLL RTL        /IF YES, SET JSW BIT 3
  3985.     TAD    (1000    /ALWAYS SET NON RESTARTABLE BIT
  3986.     DCA I    (JSW    /STORE THE JSW NOW
  3987.     DCA    INBUF    /CLEAR THE TTY INPUT BUFFER NOW
  3988.     JMS I    (START    /GO DO SOME STARTUP CODE
  3989.     TAD    PRODL    /SEE IF /S OR /V SWITCHES PASSED
  3990.     AND    (44
  3991.     SNA CLA        /SKP IF YES
  3992.     JMP I    (ILOOP1    /ELSE START THE INTERPRETER NOW
  3993.     TAD    (5    /LOAD ERROR MESSAGE OVERLAY
  3994.     CIF
  3995.     JMS I    (CALLF0
  3996.     OVLOAD
  3997.     CIF        /NOW CALL THE MESSAGE ROUTINE
  3998.     JMS I    (CALLF0
  3999.     FREESP
  4000.     JMP I    (ILOOP1    /AND START THE INTERPRETER UP
  4001.  
  4002. PARM1,    CDFIO
  4003. SAV1,    SAVBUF
  4004. CNT1,    CDFIO-PSFLAG-1
  4005. PARM2,    CDFIO
  4006. SAV2,    SAVBUF
  4007. CNT2,    CDFIO-PSFLAG-1
  4008. SAVBUF,    ZBLOCK    PSFLAG+1-CDFIO
  4009.  
  4010.     /DESCRIPTION OF OVERLAYS
  4011.     /PTR TO BLOCK NUMBER;OFFSET TO OVERLAY
  4012.  
  4013. OVDESC,    INFO+4;17    /BASIC.AF
  4014.     INFO+4;11    /BASIC.SF
  4015.     INFO+4;6    /BASIC.SR
  4016.     INFO+4;3    /BASIC.FF
  4017.     INFO+4;0    /BASIC.EX
  4018.     0        /TERMINATED BY ZERO WORD
  4019.  
  4020.     PAGE
  4021.  
  4022. INEND=    .-1        /DEFINE LAST LOCATION IN INPUT BUFFER
  4023.     /CONSOLE INPUT ROUTINE
  4024.  
  4025. TTYGCH,    0
  4026. TTYLP,    CDF    10
  4027.     TAD I    INPTR    /SEE IF ANYTHING IN BUFFER
  4028.     ISZ    INPTR
  4029.     SNA
  4030.     JMP    PROMPT    /GET ANOTHER LINE IF NOT
  4031.     CIF CDF
  4032.     JMP I    TTYGCH    /OTHERWISE RETURN
  4033.  
  4034. LFLUSH,    JMS    CRLF1    /RETURN CR
  4035. PROMPT,    TAD    (PMTBUF    /NOW PRINT PROMPT
  4036.     DCA    INPTR
  4037. PRMLP,    TAD I    INPTR    /GET A CHAR
  4038.     SNA
  4039.     JMP    GETLIN    /END OF PROMPT
  4040.     JMS    PCH1    /PRINT IT
  4041.     ISZ    INPTR
  4042.     JMP    PRMLP
  4043. GETLIN,    TAD    (INBUF    /INITIALIZE PTR
  4044. BAKFIN,    DCA    INPTR
  4045. TTYIN,    CIF CDF
  4046.     TAD I    (HEIGHT    /RESET HEIGHT FUDGE
  4047.     DCA I    (HCTR
  4048.     JMS I    (CALLF0    /GET A CHAR
  4049.     GCH
  4050.     DCA I    INPTR    /TENTATIVELY SAVE IN BUFFER
  4051.     TAD I    INPTR
  4052.     SZA        /IGNORE NULLS
  4053.     TAD    (-32
  4054.     SNA
  4055.     JMP    TTYIN    /IGNORE ^Z (CAN'T HAVE END OF FILE ON TTY)
  4056.     TAD    (32-25
  4057.     SNA
  4058.     JMP    LFLUSH    /DELETE LINE IF ^U
  4059.     TAD    (25-177
  4060.     SNA
  4061.     JMP    BACKUP    /RUBOUT CHAR IF RUBOUT
  4062.     TAD    (177-15
  4063.     SNA CLA
  4064.     JMP    GOTCR    /HANDLE END OF LINE IF CR
  4065.     TAD    INPTR    /SEE IF CHAR WILL FIT
  4066.     TAD    (-INEND+2 /(WITH ROOM FOR CR AND NULL DELIMETER)
  4067.     SNA CLA
  4068.     JMP    TTYIN    /IGNORE IT IF NO
  4069.     TAD I    INPTR    /ECHO IT FIRST IF YES
  4070.     JMS    PCH1
  4071.     ISZ    INPTR    /BUMP PTR
  4072.     JMP    TTYIN    /GET ANOTHER CHAR
  4073.  
  4074.     /HANDLE RUBOUTS
  4075.  
  4076. BACKUP,    TAD    INPTR    /SEE IF AT LEFT MARGIN
  4077.     TAD    (-INBUF
  4078.     SNA CLA
  4079.     JMP    TTYIN    /IGNORE RUBOUT IF YES
  4080.     TAD    SCOPFG    /TEST IF SCOPE TERMINAL
  4081.     AND     [200    /KEEP ONLY THE SCOPE BIT
  4082.     SNA CLA
  4083.     JMP    NOSCOP    /JMP OF NOT
  4084.     TAD    (10    /TRANSMIT BS,SP,BS TO ERASE CHAR IF SCOPE
  4085.     JMS    PCH1
  4086.     TAD    (40
  4087.     JMS    PCH1
  4088.     TAD    (10
  4089.     SKP
  4090. NOSCOP,    TAD    (177&"\    /TRANSMIT BACKSLASH FOR OTHER TERMINALS
  4091.     JMS    PCH1
  4092.     STA        /BACK UP PTR
  4093.     TAD    INPTR
  4094.     JMP    BAKFIN
  4095.  
  4096.     /HANDLE CR
  4097.  
  4098. GOTCR,    JMS    CRLF1    /ECHO CR,LF FIRST
  4099.     TAD    (15    /STORE CR IN BUFFER
  4100.     DCA I    INPTR
  4101.     ISZ    INPTR
  4102.     DCA I    INPTR    /MARK END OF BUFFER
  4103.     TAD    (INBUF    /RESET PTR
  4104.     DCA    INPTR
  4105.     JMP    TTYLP    /RETURN FIRST CHAR
  4106.  
  4107. INPTR,    INBUF        /INITIALLY BEGINNING OF INPUT BUFFER
  4108. SCOPFG,    0        /SET NONZERO IF TERMINAL IS SCOPE
  4109.  
  4110. CRLF1,    0
  4111.     CDF        /FIRST ZERO THE CONSOLE PRINT POSITION
  4112.     DCA I    (TTYF+IOTPOS-IOTHDR
  4113.     TAD    (15    /PRINT CR,LF
  4114.     JMS    PCH1
  4115.     TAD    (12
  4116.     JMS    PCH1
  4117.     JMP I    CRLF1
  4118.  
  4119. PCH1,    0
  4120.     CIF        /PRINT CHAR
  4121.     JMS I    (CALLF0
  4122.     PCH
  4123.     JMP I    PCH1
  4124.  
  4125. FREE2,    .+2;0        /CONTINUATION OF DEFINE FREELIST
  4126.     .+2;0
  4127.     .+2;0
  4128.     .+2;0
  4129.     .+2;0
  4130.     .+2;0
  4131.     .+2;0
  4132.     .+2;0
  4133.     .+2;0
  4134.     .+2;0
  4135.     0;0        /LAST ENTRY HAS ZERO LINK
  4136.  
  4137.     PAGE
  4138.     /DISPATCH FOR FIELD 1 FUNCTIONS
  4139.     /ENTRY WITH AC = FUNCTION CODE
  4140.  
  4141. F1DISP,    TAD    JMPF1
  4142.     DCA    .+1
  4143.     HLT
  4144.  
  4145. JMPF1,    JMP I    .+1
  4146.  
  4147.     /DISPATCH TABLE FOR FIELD 1 FUNCTIONS
  4148.  
  4149.     READSF        /0 READ RECORD FIELD TO SAC
  4150.     WRITSB        /1 WRITE SAC TO RECORED FIELD
  4151.     LOCATE        /2 LOCATE RECORD IN RANDOM ACCESS FILE
  4152.     WRTEOR        /3 WRITE END OF RECORD IN FILE
  4153.     DEFSUB        /4 DEFINE FIELDS IN RECORD
  4154.     DFSIZE        /5 DEFINE TOTAL RECORD SIZE
  4155.     DEFPMT        /6 DEFINE INPUT STATEMENT PROMPT STRING
  4156.  
  4157.     /DEFINE INPUT STATEMENT PROMPT
  4158.  
  4159. DEFPMT,    TAD    (PMTBUF-1 /SET THE POINTERS
  4160.     DCA    TXR
  4161.     TAD    (SAC-1
  4162.     DCA    SXR
  4163.     STA
  4164.     CDF
  4165.     TAD I    (SACLEN
  4166.     CDF    10
  4167.     DCA    STPCNT
  4168.     JMP    DEFPGO    /GO SET THE PROMPT STRING NOW
  4169. DEFPLP,    TAD    TXR    /SEE IF IT WILL FIT
  4170.     TAD    (-PMTEND+1
  4171.     SNA CLA
  4172.     JMP    EOPDEF
  4173.     TAD I    SXR    /GET A CHAR
  4174.     DCA I    TXR    /STORE IN BUFFER
  4175. DEFPGO,    ISZ    STPCNT
  4176.     JMP    DEFPLP
  4177. EOPDEF,    DCA I    TXR    /MARK END OF STRING
  4178.     CIF CDF
  4179.     JMP I    (SSMODE    /RETURN IN SMODE
  4180.  
  4181. PMTBUF,    77        /INITIALLY ?
  4182.     ZBLOCK    7
  4183. PMTEND,    0
  4184.  
  4185.     /SETUP FILE TABLE POINTERS IN FIELD 1
  4186.  
  4187. SFN1,    0
  4188.     CDF
  4189.     TAD I    (IOTHDR    /GET ADDR OF CURRENT FILE BLOCK
  4190.     CDF    10
  4191.     DCA    PRODL    /SAVE IN TEMP
  4192.     TAD    (IOHDR1    /SET POINTER TO FIELD 1 TABLE
  4193.     DCA    PRODH
  4194.     TAD    (IOTHDR-IOTFIL-1 /SET COUNT
  4195.     DCA    STPCNT
  4196.     TAD    PRODL    /SETUP POINTERS NOW
  4197.     DCA I    PRODH
  4198.     ISZ    PRODL
  4199.     ISZ    PRODH
  4200.     ISZ    STPCNT
  4201.     JMP    .-5
  4202.     JMP I    SFN1    /RETURN
  4203.  
  4204. FREELS,    .+2;0        /FREE LIST OF RECORD FIELD DESCRIPTORS
  4205.     .+2;0        /THREAD WORD;POSITIVE FIELD SIZE
  4206.     .+2;0
  4207.     .+2;0
  4208.     .+2;0
  4209.     .+2;0
  4210.     .+2;0
  4211.     .+2;0
  4212.     .+2;0
  4213.     .+2;0
  4214.     .+2;0
  4215.     .+2;0
  4216.     .+2;0
  4217.     .+2;0
  4218.     .+2;0
  4219.     .+2;0
  4220.     .+2;0
  4221.     .+2;0
  4222.     .+2;0
  4223.     .+2;0
  4224.     .+2;0
  4225.     .+2;0
  4226.     .+2;0
  4227.     .+2;0
  4228.     .+2;0
  4229.     .+2;0
  4230.     .+2;0
  4231.     .+2;0
  4232.     .+2;0
  4233.     FREE2;0        /LINK TO PART 2 OF LIST
  4234.  
  4235.     PAGE
  4236.     /OPCODE TO LOCATE A RECORD IN RANDOM ACCESS FILE
  4237.  
  4238. LOCATE,    JMS I    (SFN1    /SETUP FILE POINTERS FOR FIELD 1
  4239.     CIF        /FIRST TEST IF FILE IS OPEN
  4240.     JMS I    (CALLF0
  4241.     IDLE        /TAKE ERROR EXIT IF NOT
  4242.     CIF        /NOW FIX FAC TO GET RECORD NUMBER
  4243.     JMS I    (CALLF0
  4244.     FIX23
  4245.     CDF        /TEST IF RECORD LT NUMBER OF RECORDS IN FILE
  4246.     TAD I    IONRL1    /DO DOUBLE PRECISION SUBTRACT
  4247.     CLL CIA
  4248.     TAD I    (ACL
  4249.     CLA CML RAL    /GET BORROW
  4250.     TAD I    IONRH1
  4251.     CIA
  4252.     TAD I    (ACH
  4253.     DCA    EXPNDF    /SAVE TO FLAG FILE EXPANSION IF VARIABLE FILE
  4254.     SNL        /SKP IF FILE EXPANDED
  4255.     JMP    NOXPND    /ELSE DON'T UPDATE HIGHEST REC NO
  4256.     TAD I    (ACL
  4257.     DCA I    IONRL1
  4258.     TAD I    (ACH
  4259.     DCA I    IONRH1    /UPDATE LAST RECORD NUMBER
  4260. NOXPND,    TAD I    IORSZ1    /MULTIPLY RECORD NUMBER BY PHYSICAL REC SIZE
  4261.     SZA        /ERROR IF NOT DIRECT ACCESS FILE
  4262.     JMS I    (MULT23    /RESULT CHAR POSITION IN FILE IN PRODH;PRODL
  4263.     JMP    BR-2    /JMP IF MULTIPLY OVERFLOWED (WAY TOO BIG)
  4264.     TAD    (600
  4265.     CLL CIA
  4266.     TAD    PRODH    /TEST IF CHAR POS GE 384*2**12
  4267.     SZL CLA        /SKP IF NO
  4268.     JMP    BR-2    /ELSE BAD RECORD NUMBER
  4269.     TAD    (600    /DIVIDE BY 384 (600 OCTAL) FOR BLOCK AND CHAR IN BLOCK
  4270.     JMS I    (DIV23    /PRODH=REMAINDER, PRODL=QUOTIENT
  4271.     TAD    PRODL    /SEE IF PAST END OF FILE
  4272.     CLL CMA
  4273.     TAD I    IOMAX1
  4274.     SNL CLA
  4275.     JMP    BR-2    /BAD RECORD NUMBER
  4276.     TAD    PRODL    /SEE IF FILE GROWTH
  4277.     CLL CMA
  4278.     TAD I    IOLEN1    /COMPARE TO CURRENT NUMBER OF BLOCKS IN FILE
  4279.     SZL CLA        /SKP IF IOTLEN LT NEW SIZE INCLUDING NEW BLOCK
  4280.     JMP    NOGRTH    /JMP IF NO (ALWAYS JMPS FOR FIXED SIZE FILES)
  4281.     TAD    PRODL    /UPDATE IOTLEN
  4282.     IAC
  4283.     DCA I    IOLEN1
  4284. NOGRTH,    TAD    PRODL    /GET BLOCK OFFSET
  4285.     TAD I    IOLOC1    /COMPARE TO CURRENT BLOCK IN BUFFER
  4286.     CIA
  4287.     TAD I    IOBLK1
  4288.     SNA CLA        /SKP IF NOT THERE
  4289.     JMP    GOTBLK    /OTHERWISE WE HAVE IT NOW
  4290.     CIF
  4291.     JMS I    (CALLF0    /WRITE CURRENT BLOCK IF DIRTY
  4292.     WRBLK
  4293.     CIF
  4294.     JMS I    (CALLF0    /NOW INIT BLOCK (TO RESET DIRTY BIT)
  4295.     BLINIT
  4296.     CDF
  4297.     TAD    PRODL    /POINT AT THE BLOCK NOW
  4298.     TAD I    IOLOC1    /ADD TO BASE
  4299.     DCA I    IOBLK1
  4300.     TAD    (210    /NOW CALL THE DRIVER TO READ THE BLOCK
  4301.     CIF
  4302.     JMS I    (CALLF0
  4303.     DRCALL
  4304.     CDF
  4305. GOTBLK,    TAD    PRODH    /GET READY TO CALCULATE BYTE POINTERS
  4306.     DCA    PRODL    /SET PRODH;PRODL TO CHAR IN BLOCK
  4307.     DCA    PRODH
  4308.     TAD    (3    /DIVIDE BY 3 FOR BYTE POINTER
  4309.     JMS I    (DIV23
  4310.     TAD    PRODH    /REMAINDER = 3/2 STATE
  4311.     RTR
  4312.     CLA        /GET 2 BIT, INDICATING 3RD CHAR IN GRP
  4313.     TAD I    IOHDR1    /SET THE ODD BIT IF NECESSARY
  4314.     AND    (7777-200
  4315.     SZL
  4316.     TAD    (200
  4317.     DCA I    IOHDR1    /STORE HEADER BITS BACK
  4318.     TAD    PRODL    /NOW GET DOUBLE WORD POINTER
  4319.     CLL RAL        /*2
  4320.     TAD    PRODH    /ADD CHAR OFFSET
  4321.     TAD I    IOBUF1    /ADD TO BASE OF BUFFER
  4322.     DCA I    IOPTR1    /TO SET THE POINTER
  4323. ILOOP1,    CIF CDF        /DONE, RETURN TO ILOOP
  4324.     JMP I    (ILOOP
  4325.     CDF    10
  4326.     CIF        /TAKE ERROR EXIT IF OUT OF RANGE RECORD REQUESTED
  4327. BR,    JMS I    (ERROR
  4328.     CIF CDF
  4329.     JMP I    (EOFSET    /SET END OF FILE NOW
  4330.  
  4331.     /DEFINE RECORD LENGTH (PART OF OPEN PROCESSING)
  4332.  
  4333. DFSIZE,    JMS I    (SFN1    /SET ALL THE POINTERS
  4334.     CIF
  4335.     JMS I    (CALLF0    /GET 12 BIT RECORD SIZE
  4336.     UNSFIX
  4337.     CLL        /RANGE CHECK RECORD NUMBER
  4338.     SZA
  4339.     TAD    (2
  4340.     SNA SZL        /SKP IF RECORD LEGAL
  4341.     JMP    SZ-2    /ERROR IF GT 4095
  4342.     CDF
  4343.     DCA I    IORSZ1    /ALL SET, STORE SIZE IN IOTABLE
  4344.     DCA I    IONRL1
  4345.     DCA I    IONRH1    /CLEAR LAST RECORD SEEN (FOR ^Z DURING FILE CREATION)
  4346.     JMP I    (ILOOP1    /OK, RETURN
  4347.  
  4348.     CDF    10
  4349.     CIF
  4350. SZ,    JMS I    (ERROR    /TAKE ERROR IF RECORD NOT GE 1 AND LE 4093
  4351.  
  4352.     PAGE
  4353.     /READ A RECORD SUBFIELD TO SAC
  4354.  
  4355. READSF,    JMS    SETUP    /DO COMMON SETUP OPERATION
  4356.     DCA I    (SACLEN    /INITIALIZE TO NULL STRING
  4357.     JMP    SUBGO    /JMP TO TOP TEST THE LOOP COUNTER
  4358. SUBRDL,    CDF        /Patch GETCH to pass nulls
  4359.     TAD    (SKP
  4360.     DCA I    (GETCH2
  4361.     CDF 10
  4362.     CIF
  4363.     JMS I    (CALLF0    /GET THE NEXT CHAR
  4364.     GETCH
  4365.     CDF
  4366.     TAD    (SNA    /Reset GETCH routine
  4367.     DCA I    (GETCH2
  4368.     TAD I    (CHAR    /GET CHAR FROM BRTS
  4369.     SNA CLA        /Don't pass nulls
  4370.     JMP    SUBGO
  4371.     TAD I    (SACLEN    /SEE IF CHAR WE GOT WILL FIT
  4372.     TAD    (SACLIM
  4373.     SPA SNA CLA    /SKP IF ROOM
  4374.     JMP    ST1-2    /TAKE ERROR RETURN IF NOT
  4375.     TAD I    (CHAR    /GET CHAR FROM BRTS
  4376.     CDF    10
  4377.     DCA I    SACPT    /STORE IN SAC
  4378.     CDF
  4379.     ISZ    SACPT    /BUMP SAC POINTER
  4380.     STA        /INCR NEGATIVE SAC CHAR COUNT
  4381.     TAD I    (SACLEN
  4382.     DCA I    (SACLEN
  4383. SUBGO,    ISZ    STPCNT    /TEST RECORD FIELD COUNTER
  4384.     JMP    SUBRDL    /ITERATE
  4385.     JMP I    (ILOOP1    /DONE, RETURN
  4386.  
  4387.     CDF    10
  4388.     CIF        /PRINT WARNING IF STRING TRUNCATED
  4389. ST1,    JMS I    (ERROR
  4390.     JMP    .+4
  4391. SBFLSH,    CIF
  4392.     JMS I    (CALLF0    /FLUSH REST IF FIELD
  4393.     GETCH
  4394.     ISZ    STPCNT
  4395.     JMP    SBFLSH
  4396.     JMP I    (ILOOP1    /RETURN TO ILOOP
  4397.     /WRITE A RECORD SUBFIELD FROM SAC
  4398.  
  4399. WRITSB,    JMS    SETUP    /DO COMMON SETUP
  4400.     JMP    WRITGO    /JMP INTO LOOP
  4401. WRITSA,    CDF    10
  4402.     TAD I    SACPT    /GET CHAR FROM SAC
  4403.     CDF
  4404.     ISZ    SACPT
  4405.     SKP        /SKP IN AND SEND IT
  4406. WRITPD,    CLL CLA        /PUT 000 (NULL) CODE AS FILLER CHARACTER
  4407.     CIF
  4408.     JMS I    (CALLF0
  4409.     PUTCH        /PUT CHAR OUT
  4410.     CDF
  4411.     STA        /DECREMENT REMAINING RECORD SIZE
  4412.     TAD    REMSIZ
  4413.     DCA    REMSIZ
  4414. WRITGO,    TAD I    (SACLEN    /SEE IF ANY CHARS LEFT
  4415.     SNA CLA
  4416.     JMP    NULSAC    /NULL SAC, SEE IF FIELD ENDED
  4417.     ISZ I    (SACLEN    /BUMP COUNT
  4418.     NOP
  4419.     ISZ    STPCNT    /TEST FIELD COUNT
  4420.     JMP    WRITSA    /WRITE SAC IF MORE ROOM
  4421.     CDF    10    /ERROR IF FIELD TOO SHORT
  4422.     CIF
  4423. SH,    JMS I    (ERROR    /PRINT WARNING
  4424.     JMP I    (ILOOP1    /--RETURN--
  4425. NULSAC,    ISZ    STPCNT    /SEE IF MORE IN FIELD
  4426.     JMP    WRITPD    /PAD FIELD IF YES
  4427.     JMP I    (ILOOP1    /--RETURN--
  4428.  
  4429.     /WRITE END OF RECORD
  4430.  
  4431. WRTEOR,    JMS    SETUP
  4432.     TAD    REMSIZ    /SET COUNT TO REMAINING RECORD SIZE
  4433.     CMA
  4434.     DCA    STPCNT    /SET COUNTER
  4435.     JMP    EORGO    /GO PAD THE REMAINDER OF RECORD
  4436. EORPAD,    CLL CLA        /PAD RECORD WITH NULLS
  4437.     CIF
  4438.     JMS I    (CALLF0    /SEND OUT A BLANK
  4439.     PUTCH
  4440. EORGO,    ISZ    STPCNT
  4441.     JMP    EORPAD
  4442. EORFIN,    CIF
  4443.     JMS I    (CALLF0    /NOW SEND THE CR/LF
  4444.     CRLFR
  4445.     CDF
  4446.     TAD I    IOHDR1    /SEE IF VARIABLE LENGTH FILE
  4447.     AND    (4
  4448.     SNA CLA
  4449.     JMP I    (ILOOP1    /JMP OUT IF NO
  4450.     TAD    EXPNDF    /SEE IF FILE EXPANDED WITH THIS RECORD
  4451.     SPA CLA        /SKP IF THIS RECORD WAS GE HIGHEST SO FAR
  4452.     JMP I    (ILOOP1    /NO, RETURN
  4453.     TAD    (32    /YES, SEND OUT ^Z
  4454.     CIF
  4455.     JMS I    (CALLF0
  4456.     PUTCH
  4457.     JMP I    (ILOOP1    /--RETURN--
  4458.  
  4459.     /COMMON SETUP CODE FOR READ/WRITE TO RECORD
  4460.  
  4461. SETUP,    0
  4462.     CDF    10
  4463.     TAD    NXTFLD    /SEE IF ANOTHER FIELD LEFT
  4464.     SNA
  4465.     JMP    EOFLD    /JMP IF NO
  4466.     DCA    SXR    /POINT AT ITS DESCRIPTOR
  4467.     TAD I    NXTFLD    /LINK TO NEXT ONE
  4468.     DCA    NXTFLD
  4469.     TAD I    SXR    /GET SIZE IF THIS ONE
  4470. EOFLD,    CMA        /SET STEP COUNTER TO -SIZE-1
  4471.     DCA    STPCNT
  4472.     CDF
  4473.     TAD I    (IOTHDR    /SET PTR TO HEADER WORD
  4474.     DCA    IOHDR1
  4475.     TAD    (SAC    /SET PTR TO SAC
  4476.     DCA    SACPT
  4477.     JMP I    SETUP    /DONE
  4478.  
  4479.     PAGE
  4480.     /DEFINE SUBFIELD OPERATOR
  4481.  
  4482. DEFSUB,    TAD    EOLPTR    /SEE IF FIRST TIME THROUGH
  4483.     SZA CLA        /SKP IF YES, DO INITIALIZATION
  4484.     JMP    DEFGO    /ELSE JUST DEFINE NEXT FIELD
  4485.     CIF
  4486.     JMS I    (CALLF0    /BE SURE FILE OPENED
  4487.     IDLE
  4488.     TAD    REMSIZ    /BE SURE THIS IS DIRECT ACCESS FILE
  4489.     SNA CLA
  4490.     JMP    BF-2    /JMP OUT IF NO, GIVE ERROR
  4491.     CIF
  4492.     JMS I    (CALLF0    /NOW CLEAR ANY CURRENT DEFINES
  4493.     RTNDEF
  4494. DEFGO,    TAD    FREHD    /SEE IF ANY DESCRIPTOR ELEMENTS LEFT
  4495.     SNA
  4496.     JMP    DF-2    /JMP OUT IF NO
  4497.     DCA    SUBFPT    /IF YES, SAVE PTR TO NEXT ONE
  4498.     TAD I    SUBFPT    /REMOVE FROM LIST
  4499.     DCA    FREHD
  4500.     CIF        /NOW GET SIZE OF THIS FIELD
  4501.     JMS I    (CALLF0
  4502.     UNSFIX
  4503.     DCA    SXR    /SAVE IT
  4504.     TAD    SXR    /TEST IF FITS IN CURRENT RECORD
  4505.     CLL CIA
  4506.     TAD    REMSIZ
  4507.     SNL CLA        /SKP IF YES
  4508.     JMP    BF-2    /ELSE TAKE ERROR EXIT
  4509.     TAD    SXR    /REDUCE REMAINING LENGTH OF RECORD
  4510.     CIA
  4511.     TAD    REMSIZ
  4512.     DCA    REMSIZ
  4513.     TAD    EOLPTR    /SEE IF FIRST FIELD
  4514.     SZA CLA        /SKP IF YES
  4515.     JMP    NOTFST    /ELSE SKIP INITIALIZATION
  4516.     CDF
  4517.     TAD I    (IOTSUB
  4518.     DCA    IOSUB1
  4519.     TAD    SUBFPT    /INIT PTR TO FIELDS IN IOTABLE
  4520.     DCA I    IOSUB1
  4521.     CDF    10
  4522.     JMP    .+3
  4523. NOTFST,    TAD    SUBFPT    /STORE LINK TO THIS DESCRIPTOR IN PREV ONE
  4524.     DCA I    EOLPTR
  4525.     TAD    SUBFPT    /MAKE THIS ONE CURRENT
  4526.     DCA    EOLPTR    /AND NEGATE ONCE ONLY STATUS
  4527.     DCA I    EOLPTR    /MARK END OF LIST
  4528.     TAD    SXR    /STORE SIZE
  4529.     ISZ    SUBFPT
  4530.     DCA I    SUBFPT    /IN THE DESCRIPTOR
  4531.     JMP I    (ILOOP1    /--RETURN--
  4532.  
  4533.     CDF    10
  4534.     CIF
  4535. BF,    JMS I    (ERROR    /TAKE ERROR ABORT
  4536.  
  4537.     CDF    10
  4538.     CIF
  4539. DF,    JMS I    (ERROR    /NO MORE ROOM FOR RECORD FIELD DEFINITIONS
  4540.  
  4541. FREHD,    FREELS        /POINTER TO LIST OF AVALIABLE RECORD FIELD DESCRIPTORS
  4542.     /UTILITY ROUTINE TO MULTIPLY ACH;ACL BY AC
  4543.     /PRODUCT RETURNED IN PRODH;PRODL
  4544.     /SKIP RETURN IF RESULT LT 2**23
  4545.     /ERROR RETURN OTHERWISE
  4546.     /(THIS ROUTINE SHOULD REALLY BE PART OF ARRAY SUBSCRIPT CALCULATION)
  4547.  
  4548. MULT23,    0
  4549.     DCA    MULARG    /SAVE MULTIPLIER
  4550.     DCA    PRODH    /CLEAR RESULT REGISTER
  4551.     DCA    PRODL
  4552. MULTLP,    TAD    MULARG    /SEE IF ANYMORE TO MULTIPLY
  4553.     SNA
  4554.     JMP    MOUT    /RETURN IF NOT
  4555.     CLL RAR
  4556.     DCA    MULARG    /SHIFT AND STORE
  4557.     SNL        /SKP IF SHOULD ADD THIS TIME
  4558.     JMP    NOADD
  4559.     TAD I    (ACL
  4560.     TAD    PRODL
  4561.     DCA    PRODL
  4562.     CML RAL
  4563.     TAD I    (ACH
  4564.     TAD    PRODH
  4565.     SPA SZL
  4566.     JMP    MERR    /TAKE ERROR RETURN IF OVERFLOW
  4567.     DCA    PRODH
  4568. NOADD,    TAD I    (ACL    /SHIFT AC LEFT 1
  4569.     CLL RAL
  4570.     DCA I    (ACL
  4571.     TAD I    (ACH
  4572.     RAL
  4573.     SPA SZL
  4574.     JMP    MERR
  4575.     DCA I    (ACH
  4576.     JMP    MULTLP    /DO NEXT BIT
  4577. MOUT,    ISZ    MULT23    /SKIP RETURN IF NO OVERFLOW
  4578. MERR,    CLA CLL
  4579.     JMP I    MULT23    /--RETURN--
  4580. MULARG,    0
  4581.  
  4582.     /ROUTINE TO DIVIDE 23 BIT PRODUCT BY AC
  4583.     /12 BIT QUOTIENT TO PRODL, REMAINDER TO PRODH
  4584.  
  4585. DIV23,    0
  4586.     CLL CIA        /NEGATE DIVISOR
  4587.     DCA    DIVISR
  4588.     TAD    (-15    /DO 13. STEP RESTORING DIVIDE
  4589.     DCA    STPCNT
  4590.     JMP    DIVIT    /JMP INTO LOOP
  4591. DIVLUP,    TAD    PRODH    /SHIFT REMAINDER UP
  4592.     RAL
  4593.     DCA    PRODH
  4594. DIVIT,    TAD    PRODH    /SEE IF GOES IN
  4595.     TAD    DIVISR
  4596.     SMA        /SKP IF NO
  4597.     DCA    PRODH    /UPDATE IF YES
  4598.     CLA
  4599.     TAD    PRODL    /SHIFT QUOT BIT IN
  4600.     RAL
  4601.     DCA    PRODL
  4602.     ISZ    STPCNT
  4603.     JMP    DIVLUP    /ITERATE
  4604.     JMP I    DIV23    /--RETURN--
  4605. DIVISR,    0
  4606.  
  4607.     PAGE
  4608.     /FLOATING POINT OUTPUT ROUTINE
  4609.     /CONVERT INTERNAL NUMBER TO ASCII
  4610.     /EXIT WITH CHAR STRING IN 'INTERB'
  4611.     /XR1 = POINTER TO LAST CHAR STORED
  4612.  
  4613.     *4400
  4614.     XR11=11
  4615.     XR21=12
  4616.     XR31=13
  4617.     XR41=14
  4618.     XR51=15
  4619. FFOUT1,    0
  4620.     CDF    0
  4621.             /ALL OF PAGE REFERENCES TO FIELD ZERO
  4622.     JMS I    [STORE    /GO TO INITIALIZING ROUTINE TO SETUP FOR FIELD ONE
  4623.     TAD    (INTERB-1
  4624.     DCA    XR11    /SET POINTER TO ASCII BUFFER
  4625.     TAD I    ACH1    /SEE IF FAC NEGATIVE
  4626.     SMA CLA
  4627.     JMP    OKPOS    /JMP IF POSITIVE
  4628.     JMS I    [FFNEG1    /TAKE ABS VALUE IF NEGATIVE
  4629.     TAD    (177&"-    /PRINT MINUS SIGN
  4630.     SKP
  4631. OKPOS,    TAD    [40    /PRINT SPACE IF POSITIVE
  4632.     DCA I    XR11
  4633.     TAD I    ACH1    /SEE IF NUMBER IS ZERO
  4634.     SNA CLA
  4635.     JMP    ZERXIT    /SPECIAL CASE IF SO
  4636.     JMS I    (CVTNUM    /CALL ROUTINE TO UNPACK TO BASE 10
  4637.     TAD    (NUMBUF-1
  4638.     DCA    XR21    /POINT XR21 AT DIGIT BUFFER
  4639.     TAD    (5    /TEST FORMAT TO USE
  4640.     TAD I    DECEX1
  4641.     CLL
  4642.     TAD    (-4
  4643.     SNL
  4644.     JMP    SMLFMT    /JMP IF .0NNNNNN TO .0000NNNNNN
  4645.     TAD    (-7
  4646.     SZL CLA
  4647.     JMP    REGFMT    /JMP IF .NNNNNN TO NNNNNN
  4648.             /OTHERWISE USE E FORMAT N.NNNNNE+NNN OR N.NNNNNE-NNN
  4649.     TAD I    XR21    /GET DIGIT TO LEFT OF POINT
  4650.     JMS I    [PUTD    /PUT IT OUT
  4651.     TAD    (177&".
  4652.     DCA I    XR11    /NOW SEND OUT DECIMAL POINT
  4653.     TAD    (-5
  4654.     DCA I    AC21    /DO 5 MORE DIGITS
  4655.     TAD I    XR21    /PICK UP DIGIT
  4656.     JMS I    [PUTD    /CONVERT TO ASCII AND STORE
  4657.     ISZ I    AC21
  4658.     JMP    .-3    /LOOP FOR MORE
  4659.     TAD    (177&"E    /PRINT E
  4660.     DCA I    XR11
  4661. /    CLL
  4662.     TAD I    DECEX1    /TAKE ABS(DECEXP)
  4663.     SPA
  4664.     CML CIA
  4665.     DCA I    DECEX1
  4666.     RTL        /CONVERT "+" TO "-" IF NEGATIVE
  4667.     TAD    (177&"+
  4668.     DCA I    XR11
  4669.     JMS    IDIV    /PRINT 3 DIGITS OF EXPONENT NOW
  4670.     -144
  4671.     JMS    IDIV
  4672.     -12
  4673.     TAD I    DECEX1
  4674.     JMS I    [PUTD
  4675. RET,    JMS I    [RESTRE    /REPLACE XR1 AND LIKE THAT
  4676.     CIF CDF    0
  4677.     JMP I    FFOUT1    /ALL DONE --RETURN--
  4678.  
  4679.     /HANDLE .0NNNNNN TO .0000NNNNNN
  4680.  
  4681. SMLFMT,    DCA I    AC01    /STORE NUMBER OF LEADING ZEROES
  4682.     TAD    (177&".    /PUT OUT DECIMAL POINT
  4683.     DCA I    XR11
  4684.     JMS I    [PUTD    /SEND A 0
  4685.     ISZ I    AC01
  4686.     JMP    .-2    /LOOP FOR LEADING 0'S
  4687.  
  4688.     /GENERAL NON E FORMAT .NNNNNN TO NNNNNN
  4689.  
  4690. REGFMT,    TAD    (-7
  4691.     DCA I    AC11    /INIT COUNT OF NONZERO DIGITS
  4692.     TAD    (NUMBUF+6
  4693.     DCA I    AC21    /POINT AT END OF DIGIT BUFFER
  4694. SHRINK,    STA        /DECREMENT DIGIT POINTER
  4695.     TAD I    AC21
  4696.     DCA I    AC21
  4697.     ISZ I    AC11    /REDUCE SIGNIFICANT DIGIT COUNT
  4698.     TAD I    DECEX1
  4699.     IAC
  4700.     TAD I    AC11
  4701.     SMA CLA
  4702.     JMP    PRTLP    /JMP OUT IF NOT TO RIGHT OF DECIMAL POINT
  4703.     STA
  4704.     TAD I    AC21    /ELSE LOOK AT DIGIT
  4705.     DCA    17
  4706.     TAD I    17
  4707.     SNA CLA
  4708.     JMP    SHRINK    /DISCARD IT IF ZERO
  4709. PRTLP,    STA
  4710.     TAD I    DECEX1
  4711.     DCA I    DECEX1    /SEE IF DIGIT TO BE PRINTED FOLLOWS DP
  4712.     AC0002
  4713.     TAD I    DECEX1
  4714.     SZA CLA
  4715.     JMP    NODP    /NO
  4716.     TAD    (177&".    /YES, PRINT DP
  4717.     DCA I    XR11
  4718. NODP,    TAD I    XR21    /PICK UP DECIMAL DIGIT
  4719.     JMS I    [PUTD    /PUT OUT
  4720.     ISZ I    AC11
  4721.     JMP    PRTLP    /JMP IF MORE DIGITS TO PRINT
  4722.     JMP    RET    /--RETURN--
  4723.  
  4724. ZERXIT,    JMS I    [PUTD
  4725.     JMP    RET    /--RETURN--
  4726.  
  4727.     /DIVIDE I DECEX1 BY -DIVISOR IN CALL+1
  4728.  
  4729. IDIV,    0
  4730.     DCA I    AC11    /CLEAR QUOTIENT
  4731. IDIVLP,    TAD I    DECEX1
  4732.     CDF    10
  4733.     TAD I    IDIV
  4734.     CDF    0
  4735.     SPA
  4736.     JMP    IDVOUT    /JMP OUT IF LESS THAN DIVISOR
  4737.     DCA I    DECEX1    /ELSE UPDATE IT
  4738.     ISZ I    AC11    /TALLY QUOTIENT
  4739.     JMP    IDIVLP    /ITERATE
  4740. IDVOUT,    CLA
  4741.     TAD I    AC11    /GET QUOT AS NEXT DIGIT
  4742.     JMS I    [PUTD    /PUT OUT
  4743.     ISZ    IDIV
  4744.     JMP I    IDIV
  4745.  
  4746.     PAGE
  4747.     /CONVERT NUMBER IN FAC TO FORMAT N.NNNNNE NNN
  4748.     /DECIMAL EXPONENT RETURNED AS SIGNED NUMBER IN I DECEX1
  4749.     /6 DIGITS STORED IN NUMBUF AS BINARY 0-9
  4750.     /FIRST REDUCES MANTISSA TO FORM 0DD DDF FFF FFF...
  4751.     /BY SUCCESSIVE MULTIPLIES OR DIVIDES BY 10. FOLLOWED BY
  4752.     /RENORMALIZATIONS UNTIL INTEGER BITS
  4753.     /DDDD ARE LT 10.
  4754.     /DECIMAL DIGITS ARE ISOLATED BY REPEATED MULTIPLICATION BY 10.
  4755.  
  4756. CVTNUM,    0
  4757.     DCA I    AC11    /CLEAR OVERFLOW WORD
  4758.     JMS    ADJDEC    /NORMALIZE NUMBER AND SET RETURN ADDR
  4759.     TAD I    ACX1    /RANGE CHECK BINARY EXPONENT NOW
  4760.     SPA SNA
  4761.     JMP    MULGO2    /JMP IF NUMBER LT 1
  4762.     TAD    (-5    /SEE IF EXP GT 4
  4763.     SMA
  4764.     JMP    DIVGO    /JMP IF YES, REDUCE TOWARDS ZERO
  4765. INRANG,    DCA I    AC21    /SET SHIFT COUNTER
  4766.     SKP
  4767.     JMS    AR1    /SHIFT FAC RIGHT
  4768.     ISZ I    AC21
  4769.     JMP    .-2    /LEAVE EFFECTIVE BINARY POINT RIGHT OF I ACH1 BIT 4
  4770.     TAD I    ACH1    /ACH = 0DD DDF FFF FFF (D=DECIMAL DIGIT BITS)
  4771.     TAD    (5400    /SEE IF DDDD GE 10
  4772.     SMA CLA
  4773.     JMP    DIVGO    /DIVIDE AGAIN (NORMALIZATION WILL WORK)
  4774.     CLL
  4775.     TAD I    AC11    /NOW ROUND BY ADDING 0.000005
  4776.     TAD    (4761
  4777.     DCA I    AC11
  4778.     IAC        /ADD 24761 TO LOW BITS
  4779.     RAL
  4780.     TAD I    ACL1
  4781.     DCA I    ACL1
  4782.     SZL
  4783.     ISZ I    ACH1
  4784.     TAD I    ACH1
  4785.     TAD    (5400    /SEE IF CARRY INTO 9.XXX...
  4786.     SZA CLA
  4787.     JMP    CVT10    /JMP IF NO
  4788.     TAD    [200    /ELSE SET TO 1.00000
  4789.     DCA I    ACH1
  4790.     DCA I    ACL1
  4791.     DCA I    AC11
  4792.     ISZ I    DECEX1    /AND BUMP DECIMAL EXPONENT
  4793. O4,    4        /EFFECTIVE NOP
  4794.  
  4795.     /NOW CONVERT TO DECIMAL DIGITS
  4796.  
  4797. CVT10,    TAD    (-6    /DO 6 DIGITS
  4798.     DCA I    AC01
  4799.     TAD    (NUMBUF-1
  4800.     DCA    XR31
  4801.     JMP    CVTGO    /FIRST DIGIT IS ALREADY IN
  4802. CVTLP,    TAD I    ACH1    /ZERO OUT PREV DIGIT
  4803.     AND    [177
  4804.     DCA I    ACH1
  4805.     JMS I    (MPY101    /NOW MULTIPLY BY 10.
  4806. CVTGO,    TAD I    ACH1    /GET DIGIT FROM 0DD DDF FFF FFF
  4807.     RTL
  4808.     RTL
  4809.     RTL
  4810.     AND    [17
  4811.     DCA I    XR31    /STORE IT
  4812.     ISZ I    AC01
  4813.     JMP    CVTLP    /LOOP IF MORE
  4814.     JMP I    CVTNUM    /--RETURN--
  4815.  
  4816.     /ROUTINE TO TRADE BINARY FOR DECIMAL EXPONENTS
  4817.     /ENTER TO NORMALIZE 36 BIT NUMBER AND SET RETURN ADDR
  4818.     /RE ENTER TO MULTIPLY OR DIVIDE BY 10. AND RENORMALIZE
  4819.  
  4820. ADJDEC,    0
  4821.     DCA I    DECEX1    /STORE UPDATED DECIMAL EXPONENT
  4822. NORML,    TAD I    ACH1    /SEE IF FRACTION IS NORMALIZED
  4823.     RAL
  4824.     SPA SZL CLA
  4825.     JMP I    ADJDEC    /RETURN IF YES
  4826.     JMS I    (AL11    /SHIFT AC LEFT 1 BIT
  4827.     STA
  4828.     TAD I    ACX1    /COMPENSATE BINARY EXPONENT
  4829.     DCA I    ACX1
  4830.     JMP    NORML    /TRY AGAIN
  4831.  
  4832. MULGO,    TAD I    ACX1    /INCREASE BINARY EXP TOWARDS ZERO
  4833. MULGO2,    TAD    O4
  4834.     DCA I    ACX1
  4835.     JMS I    (AC2OP    /COPY AC TO OP
  4836.     JMS    AR1    /SHIFT RIGHT 4 BITS AND MULTIPLY BY 10.
  4837.     JMS    AR1    /MAX RELATIVE ERROR LT (7*2^-34)/5 PER MULTIPLY
  4838.     JMS I    (OADD1
  4839.     JMS    AR1
  4840.     AC7776        /DECREASE DECIMAL EXPONENT
  4841.     JMP    DECRXP    /RENORMALIZE AND TRY AGAIN
  4842. DIVGO,
  4843.     CLA CLL
  4844.     TAD    [-40    /SET 32. STAGE SUBTRACT-SHIFT DIVIDE (SLOW BUT ACCURATE)
  4845.     DCA I    AC21    /MAX RELATIVE ERROR WILL BE LT 9*2^-34. PER DIVIDE
  4846. DVLOOP,    TAD I    ACH1    /SEE IF GE 10.
  4847.     TAD    (5400
  4848.     SMA
  4849.     DCA I    ACH1    /UPDATE IF YES
  4850.     CML STA RAL
  4851.     DCA I    AC01    /SAVE LOW ORDER BIT
  4852.     JMS I    (AL11    /SHIFT MANTISSA NOW
  4853.     ISZ I    AC01    /STORE BIT NOW
  4854.     ISZ I    AC11
  4855.     ISZ I    AC21    /BUMP COUNT
  4856.     JMP    DVLOOP    /ITERATE
  4857.     TAD I    ACH1    /NOW ZERO OUT REMAINDER
  4858.     AND    [377
  4859.     DCA I    ACH1
  4860. DECRXP,    IAC        /NOW INCREASE DECIMAL EXPONENT
  4861.     TAD I    DECEX1
  4862.     JMP    ADJDEC+1
  4863.  
  4864.  
  4865.     /SHIFT FAC RIGHT 1 BIT
  4866.  
  4867. AR1,    0
  4868.     TAD I    ACH1
  4869.     CLL RAR
  4870.     DCA I    ACH1
  4871.     TAD I    ACL1
  4872.     RAR
  4873.     DCA I    ACL1
  4874.     TAD I    AC11
  4875.     RAR
  4876.     DCA I    AC11
  4877.     JMP I    AR1    /DONE
  4878.  
  4879.     PAGE
  4880.  
  4881.     /FLOATING POINT INPUT ROUTINE
  4882.     /IGNORES LEADING SPACES, TABS, CARRAIGE CONTROL CHARS
  4883.     /PRODUCES ROUNDED RESULT GOOD TO 23 BITS USING 35 BIT ARITHMETIC
  4884.  
  4885.     XR11=11
  4886.     XR21=12
  4887.     XR31=13
  4888.     XR41=14
  4889.     XR51=15
  4890. FFIN1,    0
  4891.     CDF    0
  4892.     STA
  4893.     DCA    DPFLAG    /SET A DECIMAL POINT FLAG
  4894.     STA
  4895.     DCA    SIGN    /INITIALIZE MINUS SIGN FLAG
  4896.     CDF    10
  4897.     DCA I    (MPY101    /USE ROUTINE ENTRY AS A FLAG
  4898.     CDF    0
  4899.     DCA    OVFCNT    /ZERO OVERFLOW DIGIT COUNT
  4900.     DCA I    ACH1    /CLEAR OUT THE FAC NOW
  4901.     DCA I    ACL1
  4902.     DCA I    ACX1
  4903.     DCA I    AC11    /CLEAR OVERFLOW WORD TOO
  4904. FRACLP,    DCA    DIGCNT    /CLEAR DIGIT COUNTER
  4905. DIGLUP,    JMS    GCHR    /GET A CHAR
  4906.     JMP    NOTDIG    /JMP IF NOT A DIGIT
  4907.     TAD I    ACH1    /SEE IF ROOM IN REGISTER
  4908.     TAD    (-314    /OK IF HIGH WORD LT 2048/10 = 204
  4909.     SPA CLA        /SKP IF NO
  4910.     JMP    DGFITS    /ELSE HANDLE IT NORMALLY
  4911.     TAD    DPFLAG    /SEE IF DIGIT IS AFTER DP
  4912.     SPA CLA        /SKP IF YES
  4913.     ISZ    OVFCNT    /ELSE BUMP IGNORED SIGNIFICANT DIGIT COUNT
  4914.     JMP    DIGLUP    /TRY NEXT CHAR
  4915. DGFITS,    JMS I    (MPY101    /MULTIPLY BY 10 (INDICATES A DIGIT GOTTEN)
  4916.     TAD    DIGIT    /NOW ADD IN THE NEW DIGIT
  4917.     DCA I    AC21    /PUT IN OP LOW WORD
  4918.     DCA I    OPL1
  4919.     DCA I    OPH1    /ZERO HIGH OP
  4920.     JMS I    (OADD1    /ADD IT IN
  4921.     STA        /NOW BUMP DIGIT COUNTER
  4922.     TAD    DIGCNT
  4923.     JMP    FRACLP    /GET ANOTHER CHAR
  4924.  
  4925. NOTDIG,    ISZ    DPFLAG    /TEST THE DP FLAG
  4926.     JMP    NOTPD    /JMP IF DP SEEN ALREADY
  4927.     AC0002        /ELSE SEE IF THIS IS DP
  4928.     TAD    DIGIT
  4929.     SNA CLA        /SKP IF NO
  4930.     JMP    FRACLP    /GET FRACTION DIGITS IF YES
  4931.     DCA    DIGCNT    /ZERO FRACTION DIGIT COUNT IF NO DP SEEN
  4932. NOTPD,    TAD    SIGN    /SAVE SIGN OF FRACTION
  4933.     CDF    10
  4934.     DCA    FSIGN    /IN A TRULY RANDOM PLACE
  4935.     STA        /NOW RESET MINUS SIGN FLAG
  4936.     DCA    SIGN
  4937.     ISZ I    (MPY101    /DISABLE LEADING SPACE SUPRESSION NOW
  4938.     CDF    0
  4939.     TAD I    CHAR1    /SEE IF E FORMAT
  4940.     TAD    (-105
  4941.     SNA CLA        /SKP IF NO
  4942. GETEXP,    JMS    GCHR    /ELSE GET A DECIMAL EXPONENT CHAR
  4943.     JMP    EDONE    /JMP IF AT DELIMITER
  4944.     TAD I    DECEX1    /MULTIPLY CURRENT EXP BY 10
  4945.     CLL RTL        /*4
  4946.     TAD I    DECEX1    /*5
  4947.     CLL RAL        /*10
  4948.     TAD    DIGIT    /ADD IN NEW DIGIT
  4949.     JMP    GETEXP    /UPDATE I DECEX1 AND GET NEXT DIGIT
  4950. EDONE,    JMS I    (SNFAC    /SPECIAL CASE TEST FOR ZERO FRACTION
  4951.     JMP    RET1    /RETURN IF YES, (SIMPLIFIES ADJDEC ROUTINE)
  4952.     TAD    O43    /OK, SET INITIAL EXPONENT
  4953.     DCA I    ACX1
  4954.     TAD I    DECEX1    /GET EXPONENT
  4955.     ISZ    SIGN
  4956.     CIA        /IN TWOS COMPLEMENT
  4957.     TAD    DIGCNT    /ADD COMPENSATION FOR DIGITS AFTER DP
  4958.     TAD    OVFCNT    /ADD EXCESS DIGITS IGNORED BEFORE DP
  4959.     JMS I    (ADJDEC    /SET IT AND NORMALIZE
  4960.     TAD I    DECEX1    /TEST THE REMAINING DECIMAL EXP
  4961.     SPA
  4962.     JMP I    (DIVGO    /DIVIDE FRACTION BY 10 IF MINUS
  4963.     SZA CLA
  4964.     JMP I    (MULGO    /MULTIPLY FRACTION BY 10 IF POSITIVE
  4965.     TAD I    AC11    /ROUND TO 23 BITS IF REDUCED TO ZERO
  4966.     SPA CLA        /SKP IF NO ROUND
  4967.     ISZ I    ACL1
  4968.     JMP    NOBUMP    /NO CARRY
  4969.     ISZ I    ACH1
  4970.     TAD I    ACH1    /TEST IF OVERROUND
  4971.     SMA CLA        /SKP IF YES
  4972.     JMP    NOBUMP
  4973.  
  4974.     JMS I    (AR1    /CORRECT IT
  4975.     ISZ I    ACX1    /COMPENSATE BINARY EXPONENT
  4976. O43,    43        /EFFECTIVE NOP
  4977. NOBUMP,    ISZ    FSIGN    /TEST SIGN OF RESULT
  4978.     JMS I    [FFNEG1    /COMPLEMENT IF NEGATIVE
  4979. RET1,    CIF CDF    0
  4980.     JMP I    FFIN1    /--RETURN--
  4981.  
  4982. OVFCNT,    0        /OVERFLOW DIGIT COUNT
  4983. DPFLAG,    0        /DECIMAL POINT SEEN FLAG
  4984. FSIGN,    0        /TEMPORARY SIGN OF FRACTION
  4985.  
  4986. DIGCNT=    XR31
  4987. SIGN=    XR41
  4988. DIGIT=    XR51
  4989.     /ROUTINE TO GET NEXT DIGIT
  4990.     /RETURN TO CALL+1 IF DON'T HAVE DIGIT
  4991.     /RETURN TO CALL+2 IF HAVE DIGIT
  4992.  
  4993. GCHR,    0
  4994.     DCA I    DECEX1    /STORE ACCUMULATED EXPONENT (MAYBE)
  4995.     JMS I    (INPUT    /GET A CHAR FROM TTY.
  4996.     TAD I    CHAR1    /PICK IT UP
  4997.     TAD    (-53    /TEST IF + OR -
  4998.     CLL RTR        /LINK ON IF MINUS
  4999.     SZA CLA        /SKP IF + OR -
  5000.     JMP    NOTSGN    /ELSE SKIP THIS
  5001.     SZL        /SKP IF +
  5002.     DCA    SIGN    /FLIP SWITCH IF -
  5003.     JMS I    (INPUT    /GET A CHAR.
  5004. NOTSGN,    TAD I    CHAR1
  5005.     TAD    (-72    /SEE IF ITS A DIGIT
  5006.     CLL
  5007.     TAD    (12
  5008.     DCA    DIGIT    /STORE FOR LATER
  5009.     SZL        /DIGIT?
  5010.     ISZ    GCHR    /YES-RETN. TO CALL+2
  5011.     JMP I    GCHR    /NO-RETN. TO CALL+1
  5012.  
  5013.     PAGE
  5014.  
  5015. SNFAC,    0
  5016.     TAD I    ACH1    /TEST ALL 36 BITS FOR ZERO
  5017.     SNA
  5018.     TAD I    ACL1
  5019.     SNA
  5020.     TAD I    AC11
  5021.     SZA CLA        /SKP RETURN BUMP IF ALL ZERO
  5022.     ISZ    SNFAC
  5023.     JMP I    SNFAC    /--RETURN--
  5024.  
  5025.  
  5026.     /MULTIPLY I ACH1 I;ACL1 I;AC11 BY 10.
  5027.  
  5028. MPY101,    0
  5029.     JMS I    (AC2OP    /COPY AC FRACTION TO OP
  5030.     JMS I    (AL11    /*2
  5031.     JMS I    (AL11    /*4
  5032.     JMS I    (OADD1    /*5
  5033.     JMS I    (AL11    /*10
  5034.     JMP I    MPY101
  5035.  
  5036. /
  5037. /FLOATING NEGATE
  5038. /
  5039. FFNEG1,    0        /(USED AS A TEM. BY OUTPUT ROUTINE)
  5040.     TAD I    ACL1    /GET LOW ORDER FAC
  5041.     CLL CMA IAC    /NEGATE IT
  5042.     DCA I    ACL1    /STORE BACK
  5043.     CML    RAL    /ADJUST OVERFLOW BIT AND
  5044.     TAD I    ACH1    /PROPAGATE CARRY-GET HI ORD
  5045.     CLL CMA IAC    /NEGATE IT
  5046.     DCA I    ACH1    /STORE BACK
  5047.     JMP I    FFNEG1
  5048. AL11,    0
  5049.     TAD I    AC11    /GET OVERFLOW BIT
  5050.     CLL    RAL    /SHIFT LEFT
  5051.     DCA I    AC11    /STORE BACK
  5052.     TAD I    ACL1    /GET LOW ORDER MANTISSA
  5053.     RAL        /SHIFT LEFT
  5054.     DCA I    ACL1    /STORE BACK
  5055.     TAD I    ACH1    /GET HI ORDER
  5056.     RAL
  5057.     DCA I    ACH1    /STORE BACK
  5058.     JMP I    AL11    /RETN.
  5059.  
  5060.  
  5061. OADD1,    0
  5062.     CLL
  5063.     TAD I    AC21    /ADD OVERFLOW WORDS
  5064.     TAD I    AC11
  5065.     DCA I    AC11
  5066.     RAL        /ROTATE CARRY
  5067.     TAD I    OPL1    /ADD LOW ORDER MANTISSAS
  5068.     TAD I    ACL1
  5069.     DCA I    ACL1
  5070.     RAL
  5071.     TAD I    OPH1    /ADD HI ORDER MANTISSAS
  5072.     TAD I    ACH1
  5073.     DCA I    ACH1
  5074.     JMP I    OADD1    /RETN.
  5075.  
  5076.     /CONVERT NUMBER IN AC TO ASCII DIGIT
  5077.     /MUST NOT TOUCH THE LINK
  5078.  
  5079. PUTD,    0
  5080.     TAD    (177&"0    /ADD IN 0
  5081.     DCA I    XR11    /STORE IN BUFFER
  5082.     JMP I    PUTD
  5083.  
  5084.     /INPUT ROUTINE, IGNORES LEADING SP, HT, LF, VT, FF, AND CR CHARS
  5085.  
  5086. INPUT,    0
  5087.     CIF CDF
  5088.     JMS I    (GETCH1    /LINK TO FIELD 0 ROUTINE
  5089.     CDF
  5090.     TAD    MPY101    /TEST IF ANY INPUT YET
  5091.     SNA CLA        /BYPASS LEADING CHAR IGNORES IF YES
  5092.     TAD I    CHAR1    /NO-GET CHAR1
  5093.     TAD    [-40    /COMPARE AGAINST SPACE
  5094.     SZA        /SKP IF SPACE
  5095.     TAD    (40-11    /CHECK IF HT, LF, VT OR FF
  5096.     CLL
  5097.     TAD    (-5
  5098.     SNL CLA        /SKP IF NONE OF ABOVE
  5099.     JMP    INPUT+1    /YES-IGNORE IT
  5100.     JMP I    INPUT    /RETURN
  5101.  
  5102.  
  5103. /THIS ROUTINE MOVES THE FIELD ZERO AI REGISTERS 
  5104. /TO THEIR FIELD 1 COUNTERPARTS
  5105.  
  5106. STORE,    0
  5107.     TAD    INC4    /USE AI 17
  5108.     DCA    MOV1    /AS THE POINTER TO FIELD 0 REGISTERS
  5109.     TAD    INC1
  5110.     DCA    MOV2    /TO POINT TO FIELD ONE AI REGISTERS
  5111.     TAD    MOV31
  5112.     DCA    MOV3    /INCREMENT MOV2 THIS LOOP
  5113.     TAD    (10
  5114.     JMS    MOVER    /GO MOVE REGISTERS
  5115.     JMP I    STORE
  5116.  
  5117.  
  5118.  
  5119. /THIS ROUTINE IS USED BOTH BY STORE AND RESTRE
  5120. /TO MOVE FIELD 0 REG TO FIELD ONE, AND REVERSE
  5121.  
  5122. MOVER,    0
  5123.     DCA    17
  5124.     TAD    (-5
  5125.     DCA    AICNT    /DO 5 REGISTERS
  5126. MOV1,    0
  5127. MOV2,    0
  5128. MOV3,    0
  5129.     ISZ    AICNT
  5130.     JMP    MOV1
  5131.     JMP I    MOVER
  5132.  
  5133.  
  5134. AICNT,0            /COUNTDOWN VARIABLE
  5135. INC1,    DCA    11    /CALCULATED DCA
  5136. INC4,    TAD I    17    /CALCULATED TAD
  5137. INC5,    DCA I    17    /CALCULATED DCA
  5138. INC7,    TAD    11    /CALCULATED TAD
  5139. MOV31,    ISZ    MOV2    /INCREMENT THE SECOND VARIABLE
  5140. MOV30,    ISZ    MOV1    /INCREMENT THE FIRST CALCULATED VARIABLE
  5141.  
  5142.  
  5143. RESTRE,    0
  5144.     TAD    INC7    /MOVE FROM AI 11, FIELD 1
  5145.     DCA    MOV1
  5146.     TAD    INC5    /TO AI 11, FIELD 0
  5147.     DCA    MOV2
  5148.     TAD    MOV30    /INCREMENT INC7 THIS TIME
  5149.     DCA    MOV3
  5150.     TAD    (10
  5151.     JMS    MOVER
  5152.     JMP I    RESTRE
  5153.  
  5154.  
  5155.     /COPY AC FRACTION TO OP FRACTION
  5156. AC2OP,    0
  5157.     TAD I    ACH1
  5158.     DCA I    OPH1
  5159.     TAD I    ACL1
  5160.     DCA I    OPL1
  5161.     TAD I    AC11
  5162.     DCA I    AC21
  5163.     JMP I    AC2OP
  5164.  
  5165.  
  5166. /////////////////////////////////////////////////////////////
  5167. /////////////////////////////////////////////////////////////
  5168. ////////////// OVERLAY 2- STRING FUNCTIONS  /////////////////
  5169. /////////////////////////////////////////////////////////////
  5170. /////////////////////////////////////////////////////////////
  5171.  
  5172.     FIELD 2
  5173.     *2000
  5174.     RELOC    OVERLAY
  5175.  
  5176.     /VERSION NUMBER WORD FOR STRING OVERLAY
  5177.  
  5178.     VERSON&77^100+SUBVSF+60
  5179.  
  5180. OVDISP,    TAD    PSACM1
  5181.     DCA    SACXR    /ALWAYS SET SACXR UP FOR STRING FUNCTIONS
  5182.     JMS I    (FBITGT    /GET FUNCTION TYPE
  5183.     TAD    JMPSF    /BUILD JMP DISPATCH INLINE
  5184.     DCA    .+1
  5185.     HLT
  5186.  
  5187. JMPSF,    JMP I    .+1    /JMP OFF THE SET 2 TABLE
  5188.  
  5189.     /JUMP TABLE FOR FUNCTION SET 2
  5190.  
  5191.     ASC        /FUNCTION BITS=    000
  5192.     CHR        /        020
  5193.     DATE        /        040
  5194.     LEN        /        060
  5195.     POS        /        100
  5196.     SEG        /        120
  5197.     STR        /        140
  5198.     VAL        /        160
  5199.     FIXPT        /        200
  5200.     TRACE        /        220
  5201.     STRNEG        /        240
  5202.     CAPS        /        260
  5203.     OCT        /        300
  5204.     BIN        /        320
  5205.     OCS        /        340
  5206.  
  5207.     /OCS$(O) RETURN OCTAL REPRESENTATION OF POSITIVE NUMBER LT 2^23
  5208.  
  5209. OCS,    JMS I    FIX23I    /FIX THE NUMBER
  5210.     TAD    (-10    /RETURN 8. DIGITS
  5211.     DCA    TEMP2
  5212. OCSLUP,    TAD    ACH    /ISOLATE NEXT DIGIT
  5213.     RTL
  5214.     RTL
  5215.     AND    (7
  5216.     TAD    (60    /MAKE ASCII
  5217.     JMS I    (SACPUT    /PUT IN SAC
  5218.     JMS I    (AL1    /SHIFT LEFT
  5219.     JMS I    (AL1
  5220.     JMS I    (AL1
  5221.     ISZ    TEMP2
  5222.     JMP    OCSLUP    /DO NEXT DIGIT
  5223.     JMP I    (SETLEN    /SET LENGTH AND RETURN IN SMODE
  5224.     /OCT AND BIN FUNCTIONS
  5225.  
  5226. OCT,    TAD    (6    /SET MASK TO 7 IF OCT(O$)
  5227. BIN,    IAC        /SET MASK TO 1 IF BIN(B$)
  5228.     DCA    AC0
  5229.     JMS I    PFACCLR    /ZERO THE FAC
  5230.     TAD    SACLEN    /SEE IF NULL STRING
  5231.     SNA CLA
  5232.     JMP    OBXIT    /QUICK EXIT IF YES
  5233. OBLUP,    CDF    10
  5234.     TAD I    SACXR    /GET A CHAR
  5235.     CDF
  5236.     DCA    TEMP2    /SAVE IT
  5237.     TAD    AC0    /MASK THE HIGH ORDER BITS
  5238.     CMA
  5239.     AND    TEMP2
  5240.     TAD    (-60    /SEE IF LEGAL DIGIT
  5241.     SZA CLA
  5242.     JMP    OBERR    /RETURN AT ONCE IF NO
  5243.     TAD    AC0    /NOW SETUP FOR SHIFT
  5244. OBSHFT,    DCA    AC2
  5245.     JMS I    (AL1    /SHIFT FAC LEFT
  5246.     TAD    AC2    /SHIFT MASK RIGHT
  5247.     CLL RAR
  5248.     SZA        /SKP IF DONE
  5249.     JMP    OBSHFT    /ELSE DO ANOTHER
  5250.     TAD    AC0    /NOW ISOLATE NEW BITS
  5251.     AND    TEMP2
  5252.     TAD    ACL
  5253.     DCA    ACL
  5254.     ISZ    SACLEN    /DECR COUNT
  5255.     JMP    OBLUP    /LOOP
  5256. OBXIT,    TAD    (27    /NOW SET EXPONENT OF RESULT
  5257.     DCA    ACX
  5258.     JMS I    PFFNOR    /FLOAT NUMBER
  5259.     JMP I    PILOOP    /EXIT
  5260. OBERR,    TAD    SACXR    /IF BAD CHAR, RETURN -(ITS INDEX IN STRING)
  5261.     CIA
  5262.     TAD    PSACM1
  5263.     JMP I    (FLOATS    /FLOAT IT AND RETURN
  5264.  
  5265.     PAGE
  5266.     /CHR$ FUNCTION
  5267.     /RETURNS 1 7 BIT CHAR FOR VALUE OF X
  5268.  
  5269. CHR,    JMS I    PUNSFIX    /FIX X TO 12 BIT INTEGER
  5270.     AND    IOMASK    /MASK TO 7 OR 8 BITS
  5271.     JMS I    (SACPUT    /PUT STRING IN SAC
  5272. SETLEN,    TAD    SACXR    /NOW COMPUTE -SAC LENGTH
  5273.     CIA
  5274.     TAD    PSACM1
  5275.     DCA    SACLEN    /SET IT
  5276.     JMP I    (SSMODE    /SET TO SMODE AND RETURN
  5277.  
  5278.     /ASC FUNCTION
  5279.     /RETURNS DECIMAL ASCII FOR 1 CHAR STRING IN FAC
  5280.  
  5281. ASC,    CDF    10
  5282.     TAD I    SACXR    /GET FIRST CHAR OF STRING
  5283.     CDF
  5284.     JMP    FLOATS    /FLOAT RESULT INTO FAC AND RETURN
  5285.  
  5286.     /LEN FUNCTION
  5287.     /RETURNS LENGTH OF SAC IN FAC
  5288.  
  5289. LEN,    TAD    SACLEN    /LENGTH OF STRING IN SAC
  5290.     CIA        /MAKE POSITIVE
  5291.  
  5292.     /ROUTINE TO FLOAT FAC AND RETURN
  5293.  
  5294. FLOATS,    DCA    ACH    /NUMBER TO BE FLOATED IN HORD
  5295.     DCA    ACL    /CLEAR LORD
  5296.     DCA    AC1    /CLEAR FPP OVERFLOW
  5297.     TAD    (13    /SET EXP TO 11
  5298.     DCA    ACX
  5299.     JMS I    PFFNOR    /NORMALIZE
  5300.     JMP I    PILOOP    /RETURN
  5301.  
  5302.     /STR$ FUNCTION
  5303.     /RETURNS ASCII STRING FOR NUMBER IN FAC
  5304.  
  5305. STR,    JMS I    (FFOUT    /GET NUMBER INTO INTERMEDIATE BUFFER FIRST
  5306.     TAD    XR1
  5307.     CIA
  5308.     TAD    (INTERB-1
  5309.     DCA    TEMP2    /SAVE COUNTER
  5310.     TAD    (INTERB-1
  5311.     DCA    XR1    /POINT AT BUFFER
  5312. STRLUP,    TAD I    XR1    /GET A CHAR
  5313.     TAD    (-40    /CROCK TO DELETE BLANKS
  5314.     SNA        /SKP IF NOT BLANK
  5315.     JMP    .+3    /ELSE IGNORE CHAR
  5316.     TAD    O40    /FIX CHAR
  5317.     JMS I    (SACPUT
  5318.     ISZ    TEMP2
  5319.     JMP    STRLUP    /LOOP FOR MORE
  5320.     JMP    SETLEN    /DONE-SET LENGTH OF SAC AND RETURN
  5321.     /CAP$ FUNCTION
  5322.     /CONVERT SAC TO UPPER CASE
  5323.  
  5324. CAPS,    TAD    SACLEN    /SEE IF NULL STRING
  5325.     SNA
  5326.     JMP I    (SSMODE    /NOTHING TO DO
  5327.     DCA    VALCNT    /SET COUNT
  5328.     TAD    PSACM1    /SETUP PTR
  5329.     DCA    XR1
  5330.     CDF    10
  5331. CAPSLP,    TAD I    SACXR    /RANGE CHECK CHAR FOR LOWER CASE ALPHA
  5332.     TAD    (-173
  5333.     CLL
  5334.     TAD    (173-141
  5335.     SZL        /SKP IF NOT LOWER CASE
  5336.     TAD    (-40    /ELSE CONVERT TO UPPER CASE
  5337.     TAD    (141    /RESTORE CHAR
  5338.     DCA I    XR1    /PUT BACK IN SAC
  5339.     ISZ    VALCNT
  5340.     JMP    CAPSLP
  5341. /    CDF
  5342.     JMP I    (SSMODE    /--RETURN--
  5343.  
  5344.     /VAL FUNCTION
  5345.     /RETURNS NUMBER IN FAC FOR STRING IN SAC
  5346.  
  5347. VAL,    STA
  5348.     TAD    SACLEN
  5349.     DCA    VALCNT    /COUNT OF CHARS TO INPUT
  5350.     TAD    (VALGET    /ADDR OF PHONY INPUT ROUTINE
  5351.     DCA I    (IGETCH    /PUT IN INPUT ROUTINE IN PLACE OF KRB
  5352.     JMS I    (FFIN    /CALL FPP INPUT ROUTINE
  5353.     TAD    (GETCH    /NOW RESTORE REAL INPUT ADDR
  5354.     DCA I    (IGETCH    /RESTORE IN INPUT ROUTINE
  5355.     JMP I    PILOOP    /DONE
  5356.  
  5357. VALGET,    0
  5358.     ISZ    VALCNT    /TEST COUNT
  5359.     JMP    .+3    /JMP IF NOT END OF SAC
  5360.     TAD    O77    /ELSE RETURN AN EFFECTIVE DELIMITER TO FFIN
  5361.     JMP    RTNCR
  5362.     CDF    10
  5363.     TAD I    SACXR    /GET THE CHAR FROM SAC
  5364.     CDF
  5365. RTNCR,    DCA    CHAR
  5366.     JMP I    VALGET    /RETURN WITH CHAR IN 'CHAR'
  5367.  
  5368. VALCNT,    0
  5369.  
  5370.     PAGE
  5371.     /DATE FUNCTION
  5372.     /RETURNS STRING OF THE FORM "DD-MMM-YY" IN SAC IF DATE IS PRESENT
  5373.     /RETURNS NULL STRING OTHERWISE
  5374.  
  5375.  
  5376. DATE,    TAD    CDFIO    /COPY CDF TO FIELD 17600 IN LINE
  5377.     DCA    .+1
  5378. YEAREX,    0
  5379.     TAD    PSFLAG    /GET TD8E BIT TO LINK
  5380.     CLL RAL
  5381.     SNL CLA
  5382.     TAD I    (MDATE    /IF ZERO LOOK AT MDATE IN N7600
  5383.     SZL
  5384.     TAD I    (MDATE-200 /ELSE LOOK AT N7400
  5385.     CDF        /DATE IS IN THE FORM MMM MDD DDD YYY
  5386.     SNA        /SKP IF HAVE SYSTEM DATE
  5387.     JMP I    (SETLEN    /ELSE RETURN NULL STRING
  5388.     DCA    DATEWD
  5389.     TAD I    (BIPCCL    /NOW GET YEAR EXTENSION
  5390.     AND    (600    /IT'S IN THE 600 BITS
  5391.     CLL RTR
  5392.     RTR        /SHIFT INTO PLACE
  5393.     DCA    YEAREX    /HOLD YEAR EXTENSION
  5394.     TAD    DATEWD    /NOW GET DAY OF MONTH
  5395.     AND    (370
  5396.     CLL RTR
  5397.     RAR
  5398.     JMS    PUTN    /PUT "DD-" IN SAC
  5399.     TAD    (55
  5400.     JMS    SACPUT
  5401.     TAD    DATEWD    /ISOLATE MONTH
  5402.     AND    O7400
  5403.     CLL RTL
  5404.     RTL
  5405.     RTL
  5406.     TAD    (MONTHS-2
  5407.     DCA    TEMP2    /POINT AT ASCII FOR THIS MONTH
  5408.     TAD I    TEMP2    /GET THE FIRST CHAR
  5409.     JMS    SACPUT    /PUT IN SAC
  5410.     ISZ    TEMP2
  5411.     TAD I    TEMP2    /GET THE NEXT CHAR
  5412.     BSW
  5413.     AND    O77    /MASK TO 6BIT
  5414.     TAD    (140    /CONVERT TO LOWER CASE
  5415.     JMS    SACPUT
  5416.     TAD I    TEMP2    /GET THE LAST CHAR
  5417.     AND    O77
  5418.     TAD    (140
  5419.     JMS    SACPUT    /STORE IT
  5420.     TAD    (55    /SEND OUT "-"
  5421.     JMS    SACPUT
  5422.     TAD    DATEWD    /FINALLY GET YEAR
  5423.     AND    (7
  5424.     TAD    YEAREX    /ADD TO EXTENSION BITS
  5425.     TAD    O106    /ADD 70. FOR BASE YEAR
  5426.     JMS    PUTN    /PUT OUT "YY"
  5427.     JMP I    (SETLEN    /SET LENGTH AND RETURN IN SMODE
  5428.  
  5429. PUTN,    0
  5430.     ISZ    NHIGH    /BUMP HIGH ORDER DIGIT
  5431.     TAD    (-12    /-10.
  5432.     SMA
  5433.     JMP    .-3    /LOOP IF NOT REDUCED YET
  5434.     TAD    (12+60    /CONVERT TO DECIMAL DIGIT
  5435.     DCA    NLOW    /HOLD MOMENTARILY
  5436.     TAD    NHIGH    /NOW GET HI ORDER DIGIT
  5437.     TAD    (57    /MAKE 6BIT
  5438.     JMS    SACPUT
  5439.     TAD    NLOW    /SEND OUT LOW DIGIT
  5440.     JMS    SACPUT
  5441.     DCA    NHIGH    /CLEAR NHIGH FOR NEXT TIME (BE CAREFULL!!)
  5442.     JMP I    PUTN
  5443.  
  5444. SACPUT,    0
  5445.     CDF    10
  5446.     DCA I    SACXR    /STORE THE CHAR
  5447.     CDF
  5448.     JMP I    SACPUT
  5449.  
  5450. NHIGH,    0
  5451. NLOW,    0
  5452.  
  5453. MONTHS,    TEXT    /AJANAFEBAMARAAPRAMAYAJUNAJULAAUGASEPAOCTANOVADEC/
  5454. DATEWD=    .-1
  5455. O106=    MONTHS+2
  5456.     /TRACE FUNCTION-ROUTINE TO TURN TRACE ON AND OFF
  5457.  
  5458. TRACE,    TAD    ACH    /GET HI MANTISSA OF ARG
  5459.     SNA CLA        /SKP TO TURN TRACE ON
  5460.     TAD    TRREST    /ELSE RESTORE TRACE BYPASS INSTR IN LINE NUMBER ROUTINE
  5461.     DCA I    (TRHOOK    /BY NOP ING INSTRUCTION AT TRHOOK
  5462. TRREST,    JMP I    PILOOP
  5463.  
  5464.     PAGE
  5465.     /SEG$ FUNCTION
  5466.     /RETURNS SEGMENT OF X$ BETWEEN Y AND Z
  5467.     /IF Y<=0,THEN Y TAKEN AS 1
  5468.     /IF Y>LEN(X$),NULL STRING RETURNED
  5469.     /IF Z<=0,NULL STRING RETURNED
  5470.     /IF Z>LEN(X$),Z IS SET=LEN(X$)
  5471.     /IF Z<Y,NULL STRING IS RETURNED
  5472.  
  5473. SEG,    TAD    ACH    /IS Y>0?
  5474.     SMA SZA CLA
  5475.     JMS I    PUNSFIX    /FIX IF POSITIVE
  5476.     SNA
  5477.     IAC        /SET Y TO 1 IF Y.LE.0
  5478.     DCA    YARG
  5479.     TAD    SACLEN    /COMPARE YARG TO SACLEN
  5480.     CIA
  5481.     STL CIA
  5482.     TAD    YARG
  5483.     SNL SZA CLA    /SKP IF YARG.LOS.LEN(X$)
  5484.     JMP    NULLST    /NO-RETURN THE NULL STRING
  5485.     DCA    INSAV    /FAKE POINTER TO SCALAR #0
  5486.     JMS I    ARGPLK    /GET ADDR OF Z
  5487.     JMS I    PFFGET    /LOAD Z INTO FAC
  5488. ARGPLK,    ARGPRE        /LOC SKIPPED BY FPP SO WE PUT CONST HERE
  5489.     TAD    ACH    /HI MANTISSA OF Z
  5490.     SPA SNA CLA    /IS Z<0?
  5491.     JMP    NULLST    /YES-RETURN THE NULL STRING
  5492.     JMS I    PUNSFIX    /NO-FIX Z
  5493.     STL
  5494.     TAD    SACLEN    /CALC Z-LEN(SAC)
  5495.     SNL        /SKP IF Z.LO.LEN(SAC)
  5496.     CLA        /ELSE TAKE LEN(SAC)
  5497.     CMA
  5498.     TAD    SACLEN
  5499.     TAD    YARG    /NUMBER OF BYTES TO USE
  5500.     SMA
  5501.     JMP    NULLST    /NONE, RETURN NULL STRING
  5502.     DCA    STRCNT
  5503.     TAD    YARG    /INDEX INTO STRING FOR SOURCE BYTES
  5504.     TAD    (SAC-2
  5505.     DCA    XR2    /SET SOURCE XR
  5506.     TAD    STRCNT
  5507.     DCA    SACLEN    /SET NEW LENGTH OF SAC NOW
  5508.     CDF    10
  5509.     TAD I    XR2    /NOW MOVE THE BYTES
  5510.     DCA I    SACXR
  5511.     ISZ    STRCNT
  5512.     JMP    .-3
  5513. /    CDF
  5514.     JMP I    (SSMODE    /--RETURN--
  5515. NULLST,    CLA CLL
  5516.     DCA    SACLEN    /ZERO SAC
  5517.     JMP I    (SSMODE    /--RETURN--
  5518. YARG,    0
  5519.     /POS FUNCTION
  5520.     /RETURNS THE POSITION IN X$ OF Y$ STARTING AFTER Z
  5521.  
  5522. POS,    CLA CLL
  5523.     DCA    INSAV    /FAKE AS STRING CALL TO STRING 0
  5524.     JMS I    (STFIND    /FIND Y$
  5525.     TAD    STRCNT    /# OF CHARS IN Y$
  5526.     SNA CLA        /IS Y$ THE NULL STRING?
  5527.     JMP    ONERET    /YES-RETURN 1 AS POSITION
  5528.     TAD    SACLEN    /NO-# OF CHARS IN X$
  5529.     SNA CLA        /IS X$ THE NULL STRING?
  5530.     JMP    ZRORET    /YES-RETURN 0
  5531.     TAD    ACH    /NO-GET HORD OF Z
  5532.     SPA SNA CLA    /IS Z GT 0?
  5533. PA,    JMS I    PERROR    /NO-ILLEGAL ARGUMENT
  5534.     JMS I    PUNSFIX    /FIX Z
  5535.     DCA    POSITN    /USE IT AS POSITION TO START SEARCH
  5536.     TAD    POSITN
  5537.     STL
  5538.     TAD    SACLEN    /COMPARE POSITION TO MAXIMUM LENGTH OF STRING
  5539.     SNL SZA CLA
  5540.     JMP    PA    /Z IS PAST END OF STRING-ERROR
  5541. POSSET,    TAD    STRCNT
  5542.     CMA
  5543.     TAD    POSITN    /GET POSITION NOW CHECKING+SIZE IF Y$
  5544.     TAD    SACLEN    /COMPARE AGAINST LENGTH OF STRING
  5545.     SMA SZA CLA    /ANY MORE TO COME?
  5546.     JMP    ZRORET    /NO-SEARCH FAILS
  5547.     JMS I    (BYTSET    /SETUP BYTE LOAD ROUTINE
  5548.     TAD    POSITN    /SEARCH START POSITION IN X$
  5549.     TAD    (SAC-2    /ADD TO BASE OF SAC
  5550.     DCA    SACXR
  5551.     TAD    STRCNT    /# OF CHARS IN Y$
  5552.     DCA    AC2    /COUNTER
  5553. SRCLP,    JMS I    (LDB
  5554.     CIA
  5555.     CDF    10
  5556.     TAD I    SACXR    /COMPARE CHARS
  5557.     CDF
  5558.     SNA CLA        /DO THEY MATCH?
  5559.     JMP    SCONTU    /YES-CONTINUE MATCH TO NEXT CHAR IN X$ AND Y$
  5560.     ISZ    POSITN    /BUMP POSITION TO BE CHECKED
  5561.     JMP    POSSET    /ITERATE
  5562.  
  5563. SCONTU,    ISZ    AC2    /MORE CHARS IN Y$?
  5564.     JMP    SRCLP    /YES, ITERATE
  5565.     TAD    POSITN    /NO FOUND A MATCH
  5566.     JMP I    (FLOATS
  5567. ZRORET,    JMS I    PFACCLR    /SEARCH FAILS-RETURN 0
  5568.     JMP I    PILOOP
  5569.  
  5570. ONERET,    CLA IAC
  5571.     JMP I    (FLOATS    /RETURN 1
  5572. POSITN,    0
  5573.  
  5574.     PAGE
  5575.     /STRING ARITHMETIC INTERFACE
  5576.     /SETS UP BUFFERS AND CALLS STRING PACKAGE LOCATED IN FIELD 1
  5577.  
  5578.     /STRING ARITH EXIT ROUTINE
  5579.  
  5580.  
  5581. SEXIT,    DCA    SACLEN    /STORE SAC LENGTH PASSED IN AC
  5582.     JMP    SRETN    /JMP TO FINISH OFF
  5583.  
  5584. XSARITH,JMS    SACTOA    /MOVE SAC TO ABUF FIRST, TERMINATED BY A NULL
  5585.     TAD    (BBUF-1    /MOVE ARG TO B BUFFER
  5586.     DCA    XR1
  5587.     TAD    STRCNT
  5588.     SNA CLA
  5589.     JMP    SGO
  5590. SARMOV,    JMS I    (LDB
  5591.     CDF    10
  5592.     DCA I    XR1
  5593.     CDF
  5594.     ISZ    STRCNT
  5595.     JMP    SARMOV
  5596. SGO,    CDF    10
  5597.     DCA I    XR1
  5598. /    CDF
  5599.     JMS I    (PWFECH    /GET SUB-OPCODE
  5600.     TAD    (JMP I SARVEC /CREATE JMP INLINE
  5601.     DCA    .+2
  5602.     CIF CDF    10    /LINKAGE TO FIELD 1
  5603.     HLT        /GETS DISPATCH TO ROUTINE
  5604.  
  5605.     /VECTOR OF STRING ARITH ENTRY POINTS
  5606.  
  5607. SARVEC,    SADD
  5608.     SSUB
  5609. PSISUB,    SISUB
  5610.     SMUL
  5611.     SDIV
  5612.     SIDIV
  5613.  
  5614.     /INT$(A$) FUNCTION
  5615.  
  5616. FIXPT,    JMS    SACTOA    /COPY ARG TO A BUFFER
  5617.     CIF CDF    10
  5618.     JMP I    (SINTEGR /JMP TO INT FUNCTION
  5619.  
  5620.     /STRING UNARY MINUS
  5621.  
  5622. STRNEG,    JMS    SACTOA    /COPY ARG TO THE A BUFFER
  5623.     CIF CDF    10
  5624.     DCA I    (BBUF    /PASS NULL STRING IN B BUFFER
  5625.     JMP I    PSISUB    /JMP TO SUBTRACT ROUTINE
  5626.  
  5627.     /PRINT USING INIT AND OUTPUT
  5628.  
  5629. XPUINI,    TAD    (FMTBUF-ABUF
  5630.     JMS    SACTOA    /MOVE SAC TO PATTERN REGISTER
  5631.     CDF    10    /NOW SET THE INIT FLAG
  5632.     STL RTL
  5633.     DCA I    (UINIT
  5634.     JMP I    PILOOP    /RETURN TO ILOOP (RESETS DF)
  5635.  
  5636. XPUEXE,    TAD    (BBUF-ABUF /LOAD B BUFFER WITH OUTPUT NUMBER STRING
  5637.     JMS    SACTOA
  5638.     CIF CDF    10
  5639.     TAD I    (UINIT    /ADVANCE STATE OF INIT FLAG
  5640.     CLL RAR
  5641.     DCA I    (UINIT    /THIS CLEARS INIT STATE ON SECOND OUTPUT
  5642.     JMP I    (USING    /JMP TO PRINT USING CODE NOW
  5643.  
  5644. SRETN,    TAD    PSACM1    /RETURN HERE FOR FINAL STRING PROCESSING
  5645.     DCA    SACXR    /SETUP TO COPY RESULT INTO SAC
  5646.     TAD    (SBUF-1
  5647.     DCA    XR1
  5648.     TAD    SACLEN
  5649.     SNA
  5650.     JMP I    (SSMODE    /DONE IF NULL STRING
  5651.             /SET INTERPRETER TO STRING MODE (IN CASE OF FUNCTION CALL)
  5652.     DCA    STRCNT
  5653.     CDF    10
  5654. STRLP,    TAD I    XR1
  5655.     DCA I    SACXR
  5656.     ISZ    STRCNT
  5657.     JMP    STRLP
  5658. /    CDF
  5659.     JMP I    (SSMODE    /DONE, SET TO SMODE
  5660.  
  5661. SACTOA,    0
  5662.     TAD    (ABUF-1    /SET POINTER TO STRING BUFFER IN FIELD 1
  5663.     DCA    XR1    /AC CONTAINS OFFSET IF CALL TO STORE IN B BUFFER
  5664.     TAD    PSACM1    /INIT SACXR INCASE IF PRINT USING CALL
  5665.     DCA    SACXR    /(NORMAL STRING CALLS INIT IT FOR US)
  5666.     CDF    10
  5667.     TAD    SACLEN
  5668.     SNA CLA
  5669.     JMP    SACNUL    /JUST OUTPUT ZERO IF NULL STRING
  5670.     TAD I    SACXR    /GET A BYTE
  5671.     DCA I    XR1    /MOVE CHAR TO BUFFER
  5672.     ISZ    SACLEN
  5673.     JMP    .-3    /ITERATE
  5674. SACNUL,    DCA I    XR1    /STORE THE TERMINATING NULL
  5675.     CDF
  5676.     JMP I    SACTOA    /DONE
  5677.  
  5678.     PAGE
  5679.     RELOC
  5680.     *OVERLAY
  5681.  
  5682.     VERSON&77^100+SUBVEF+60
  5683.  
  5684.     /LINE NUMBER TRACE FEATURE
  5685.     /PRINT MESSAGE OF FORM %NNNNN% ON CONSOLE WHEN
  5686.     /NEW LINE ENCOUNTERED
  5687.  
  5688. TPRINT,    TAD    (45    /PRINT LEADING %
  5689.     JMS I    PPCH
  5690.     JMS    PRTLNO    /NOW PRINT BCD LINE NUMBER
  5691.     TAD    O40
  5692.     JMS I    PPCH    /PRINT A TRAILING SPACE
  5693.     TAD    (45    /PRINT A TRAILING %
  5694.     JMS I    PPCH
  5695.     JMS I    (PCRLF    /NOW A CR,LF
  5696.     JMP I    PILOOP    /--RETURN--
  5697.  
  5698.     /PRINT 5 DIGIT BCD LINE NUMBER, SUPPRESSING LEADING ZEROES
  5699.  
  5700. PRTLNO,    0
  5701.     TAD    O40    /FIRST PRINT LEADING SPACE
  5702.     JMS I    PPCH
  5703.     TAD    (SNA    /INIT LZ SWITCH
  5704.     DCA    MAKSWT
  5705.     TAD    LINEHI    /HANDLE DIGIT 1
  5706.     RTR
  5707.     RTR
  5708.     JMS    MAKED
  5709.     TAD    LINEHI    /DIGIT 2
  5710.     JMS    MAKED
  5711.     TAD    LINELO    /DIGIT 3
  5712.     RTL
  5713.     RTL
  5714.     RAL
  5715.     JMS    MAKED
  5716.     TAD    LINELO    /DIGIT 4
  5717.     RTR
  5718.     RTR
  5719.     JMS    MAKED
  5720.     TAD    LINELO    /ALWAYS PRINT LAST DIGIT
  5721.     AND    O17
  5722.     TAD    (60
  5723.     JMS I    PPCH
  5724.     JMP I    PRTLNO    /DONE
  5725.  
  5726.     /ROUTINE TO UNPACK BCD DIGITS
  5727.  
  5728. MAKED,    0
  5729.     AND    O17    /ISOLATE DIGIT
  5730. MAKSWT,    HLT        /SKP/SNA SWITCH
  5731.     JMP I    MAKED    /RETURN IF SUPPRESSED
  5732.     TAD    (60    /MAKE 7BIT
  5733.     JMS I    PPCH    /PRINT IT
  5734.     TAD    (SKP    /NOW RESET SWITCH
  5735.     DCA    MAKSWT
  5736.     JMP I    MAKED    /DONE
  5737.     /ERROR MESSAGE PRINTER
  5738.  
  5739. ERRORR,    0
  5740.     CLL CLA
  5741.     TAD    (INBUF        /PURGE ANY CHARACTERS IN INPUT BUFFER
  5742.     CDF 10
  5743.     DCA I    PINPTR
  5744.     DCA I    (INBUF
  5745.     CDF 0
  5746.     TAD    (ETAB-1        /GET BEGINNING OF ERROR TABLE
  5747.     DCA    EPTR
  5748.     DCA    ERRNUM        /ERROR # COUNTER
  5749. ESRCH,    ISZ    ERRNUM        /UPDATE ERR NUMBER
  5750.     ISZ    EPTR        /POINTER TO NEXT ERROR ADDRESS
  5751.     TAD I    EPTR        /GET -ERROR ADDR FROM TABLE
  5752.     SNA            /IF 0 WE GOT A PROBLEM IT IS THE END
  5753.     JMP    FSTOPN        /EXIT BRTS
  5754.     TAD I    PERROR        /GET ERROR ADDRESS
  5755.     SZA CLA            /SKIP ON A MATCH
  5756.     JMP    ESRCH        /NO MATCH TRY AGAIN
  5757.     TAD    LINELO
  5758.     DCA    ERLINL
  5759.     TAD    LINEHI
  5760.     DCA    ERLINH
  5761.     TAD    (ECRASH-ETAB    /IS ERROR FATAL
  5762.     CIA
  5763.     TAD    ERRNUM        /GET ERROR NUMBER
  5764.     SMA SZA CLA
  5765.     JMP    NOTNOR        /YES, GOTO ERNORM TO PRINT ERR #
  5766.     AC4000            / Is on error active
  5767.     AND    ERRFLG
  5768.     SNA CLA
  5769.     JMP    ERNORM        /NO, GOTO TO NORMAL ERROR ROUTINE
  5770.     CLL CLA IAC
  5771.     AND    ERRFLG        /YES, BUT IS THIS A SECOND ERROR
  5772.     SZA CLA
  5773.     JMP    NOTNOR        /YES
  5774.     TAD    ERRCOD        /NO, SET UP GOTO ADDRESS
  5775.     DCA I    (NEWPC        /FOR ON ERROR GOTO
  5776.     TAD    ERRFLD
  5777.     DCA    INSAV
  5778.     ISZ    ERRFLG
  5779.     JMP I    (SUCJMP        /AND GO TO IT
  5780.  
  5781. NOTNOR,    CLL CLA CMA
  5782.     SKP
  5783. ERNORM,    CLL CLA
  5784.     DCA    ERNTST
  5785.     JMS I    (PCRLF
  5786.     JMS I    (SCRIBE
  5787.     MSGERR            /PRINT "ERROR "
  5788.     JMS I    (ERNMBR        /PRINT ERR #
  5789.     JMS I    (SCRIBE
  5790.     ATLINE            /PRINT " AT LINE "
  5791.     JMS    PRTLNO        /PRINT LINE #
  5792.     JMS I    (PCRLF
  5793.     ISZ    ERNTST
  5794.     SKP
  5795.     JMP    FSTOPN
  5796.     TAD    (EFATAL-ETAB
  5797.     CIA
  5798.     TAD    ERRNUM        /WAS IT FATAL
  5799.     SMA SZA CLA
  5800.     JMP    FSTOPN
  5801.     JMP I    ERRORR
  5802.  
  5803. FSTOPN,    CLL CLA
  5804.     TAD    (140    /FAKE A CALL TO INTERPRETER EXIT FUNCTION
  5805.     DCA    INSAV
  5806.     JMP I    (FUNC5I
  5807. EPTR,    0
  5808. PINPTR,    INPTR
  5809. ERNTST,    0
  5810.  
  5811.     PAGE
  5812.  
  5813.     /ERROR MESSAGE MAPPING TABLE
  5814.     /CONTAINS RELATIVE CORE ADDR OF TEXT, FOLLOWED BY -CALLING ADDR
  5815.     /TERMINATED BY ZERO TO FORCE UNKNOWN ERROR MESSAGE IF NO MATCH
  5816.     /ERRORS PRECEEDING TAG "EFATAL" ARE WARNINGS ONLY
  5817.  
  5818.  
  5819. ETAB,    -BR-1        /Bad record number in random access file
  5820.     -DI-1        /Illegal character in numeric string
  5821.     -DM-1        /Illegal minus sign
  5822.     -DP-1        /More than one decimal point encountered
  5823.     -DV-1        /Division by zero
  5824.     -DVS-1        /Divide by zero in string arithmetic
  5825.     -EN-1        /Lookup or enter error in OPEN, STORE, OR RECALL
  5826.     -IF-1        /Illegal DEV:FILENAME specification in FILE command
  5827.     -IN-1        /Inquire failure in FILE command
  5828.     -IS-1        /Imaginary square root
  5829.     -O0-1        /Numeric or input overflow
  5830.     -ON-1        /ON statement out of range
  5831.     -OVS-1        /String arithmetic overflow error
  5832.     -RE-1        /Attempt to read past EOF
  5833.     -SH-1        /String truncated during record write
  5834.     -ST-1        /String truncated on input
  5835.     -ST1-1        /String truncated during record read
  5836.     -TR-1        /Trap character found
  5837.     -WE-1        /Attempt to write past EOF
  5838.     -1        /EFFECTIVE NOP FOR EXPANSION
  5839.     -1        /EFFECTIVE NOP FOR EXPANSION
  5840.     -1        /EFFECTIVE NOP FOR EXPANSION
  5841.     -1        /EFFECTIVE NOP FOR EXPANSION
  5842.     -1        /EFFECTIVE NOP FOR EXPANSION
  5843. EFATAL,    -BC-1        /CHAIN attempted with BCOMP.SV or BLOAD.SV missing
  5844.     -BF-1        /Error in DEFINE statement
  5845.     -BO-1        /No more file buffers available
  5846.     -CF-1        /Bad DEV:FILE.EX format in CHAIN statement
  5847.     -CI-1        /Inquire failure in CHAIN
  5848.     -CL-1        /Lookup failure in CHAIN
  5849.     -CN-1        /Attempt to CHAIN to a .SV file not on SYS:
  5850.     -DA-1        /Attempt to READ past end of DATA list
  5851.     -DE-1        /Device driver error
  5852.     -DF-1        /No more room for record defines
  5853.     -DO-1        /No more room for drivers
  5854.     -EM-1        /Attempt to raise negative number to a real power
  5855.     -FB-1        /Attempt to create a second file
  5856.     -FC-1        /Loosing tentative file
  5857.     -FE-1        /Fetch error in open
  5858.     -FI-1        /Attempt to use unopened file
  5859.     -FM-1        /Attempt to FIX a negative number
  5860.     -FN-1        /Illegal file number
  5861.     -FO-1        /Attempt to fix a number > 4095
  5862.     -FO2-1        /Attempt to FIX a number > 2**23-1
  5863.     -GR-1        /EXIT or RETURN executed with out GOSUB
  5864.     -GS-1        /GOSUB stack overflow
  5865.     -H1-1        /Failure in USR call in STORE, RECALL, CALL
  5866.     -H2-1        /Error in STORE while creating tempory file
  5867.     -H3-1        /Lookup error in RECALL or CALL
  5868.     -H5-1        /Can't STORE tempory file error in close
  5869.     -H6-1        /Bad DEV:FILE.EX format in STORE, RECALL, or CALL
  5870.     -H7-1        /Attempt to create a second tentative file in STORE
  5871.     -H8-1        /File overflow in STORE exceeded free space
  5872.     -HN-1        /Input error in disk read on RECALL
  5873.     -IA-1        /Illegal argument in user function
  5874.     -LM-1        /Illegal argument in LOG function
  5875.     -NC-1        /Bad command length or CCL.SV missing
  5876.     -OE-1        /Device driver error while overlaying
  5877.     -PA-1        /Illegal arg in POS
  5878.     -SC-1        /SAC overflow on concatenate
  5879.     -SL-1        /String to long or undefined
  5880.     -SR-1        /Attempt to read string from numeric file
  5881.     -SU-1        /Subscript error
  5882.     -SW-1        /Attempt to write string into numeric file
  5883.     -SZ-1        /Illegal record size
  5884.     -VR-1        /Attempt to read variable length file
  5885.     -1        /EFFECTIVE NOP FOR EXPANSION
  5886.     -1        /EFFECTIVE NOP FOR EXPANSION
  5887.     -1        /EFFECTIVE NOP FOR EXPANSION
  5888.     -1        /EFFECTIVE NOP FOR EXPANSION
  5889.     -1        /EFFECTIVE NOP FOR EXPANSION
  5890.     -1        /EFFECTIVE NOP FOR EXPANSION
  5891.     -CALL4-1    /Error loading user overlay
  5892.     -3401-1        /Error in user overlay
  5893. ECRASH,    -CC-1        /Execution aborted a CTRL C found
  5894.     -RS-1        /RESUME executed without error condition
  5895.     0
  5896.  
  5897.     PAGE
  5898.  
  5899. SCRIBE,    0
  5900.     TAD I    SCRIBE
  5901.     DCA    MSGPTR
  5902.     ISZ    SCRIBE
  5903. SNXTCH,    TAD I    MSGPTR
  5904.     SNA
  5905.     JMP I    SCRIBE
  5906.     JMS I    PPCH
  5907.     ISZ    MSGPTR
  5908.     JMP    SNXTCH
  5909.  
  5910. MSGPTR,    0
  5911.  
  5912. ERNMBR,    0        /2 DIGIT DECIMAL PRINT
  5913.     TAD    ERRNUM
  5914.     JMS    ERRDEC
  5915.     JMP I    ERNMBR
  5916.  
  5917.     DECIMAL
  5918.  
  5919. ERRDEC,    0
  5920.     JMS    ERROUT
  5921.     -1000
  5922.     -100
  5923.     -10
  5924.     0
  5925.     JMP I    ERRDEC
  5926.  
  5927.     OCTAL
  5928.  
  5929. ERROUT,    0
  5930.     DCA    ERNUMB    /SAVE IT
  5931. EROUT1,    DCA    ERDGT    /CLEAR DIGIT COUNTER
  5932.     CLL CLA
  5933.     TAD    ERNUMB    /GET CURRENT VALUE
  5934.     TAD I    ERROUT    /MINUS DIGIT BEING PRINTED
  5935.     SNL        /DID IT OVERFLOW
  5936.     JMP    EROUT2    /NO, TO FAR
  5937.     ISZ    ERDGT    /YES BUMP DIGIT
  5938.     DCA    ERNUMB    /AND UPDATE VALUE
  5939.     JMP    EROUT1+1
  5940. EROUT2,    CLL CLA
  5941.     TAD    ERDGT    /OUTPUT THE DIGIT
  5942.     TAD    K60
  5943.     JMS I    PPCH
  5944.     ISZ    ERROUT    /GET NEXT ARGUMENT
  5945.     TAD I    ERROUT    /DONE ENOUGH
  5946.     SZA CLA
  5947.     JMP    EROUT1    /NOPE MORE TO DO
  5948.     TAD    ERNUMB    /ALL DONE OUTPUT LAST DIGIT
  5949.     TAD    K60
  5950.     JMS I    PPCH
  5951.     JMP I    ERROUT
  5952.  
  5953. ERNUMB,    0
  5954. ERDGT,    0
  5955.  
  5956.     /PRINT CR,LF
  5957.  
  5958. PCRLF,    0
  5959.     TAD    O15    /CR
  5960.     JMS I    PPCH
  5961.     TAD    (12    /LF
  5962.     JMS I    PPCH
  5963.     DCA I    (TTYF+IOTPOS-IOTHDR /ZERO THE CONSOLE COLUMN COUNT NOW
  5964.     JMP I    PCRLF    /RETURN
  5965.  
  5966. MSGERR,    "E;"R;"R;"O;"R;" ;0
  5967. ATLINE,    " ;"A;"T;" ;"L;"I;"N;"E;0
  5968.  
  5969.     PAGE
  5970.     /ROUTINE TO PRINT VERSION AND FREE SPACE MESSAGES
  5971.  
  5972. FREESP,    0
  5973.     JMS I    PPSWAP    /SWAP OUT OS/8
  5974.     CDF    10    /PICK UP CD SWITCHES
  5975.     TAD I    (CDOPT4    /GET CD OPTION BITS [MNO PQR STU VWX]
  5976.     CDF
  5977.     DCA    ACH    /SAVE THEM
  5978.     JMS I    PPSWAP    /KICK OUT OS/8
  5979.     TAD    ACH    /SEE IF /V SET
  5980.     AND    (4
  5981.     SNA CLA        /SKP IF YES
  5982.     JMP    NOVER
  5983.     JMS I    (SCRIBE    /PRINT IT
  5984.     VERMSG
  5985.     JMS I    (PCRLF    /FOLLOWED BY CRLF
  5986. NOVER,    TAD    ACH    /SEE IF /S SET
  5987.     AND    (40
  5988.     SNA CLA        /SKP IF YES
  5989.     JMP I    PILOOP    /RETURN TO INTERPRETER IF NO
  5990.     TAD    CDFPS    /GET FIELD BITS OF CODE
  5991.     CLL RTR
  5992.     RTR
  5993.     AND    (3
  5994.     DCA    AC0
  5995.     TAD    PSSTRT    /COMBINE WITH ADDR
  5996.     AND    (7774
  5997.     TAD    AC0
  5998.     RTR
  5999.     RAR        /SHIFT FIELD BITS TO AC0-2
  6000.     XX=    BUFAREA%10
  6001.     TAD    (-XX-1000 /SUBTRACT SPACE TAKEN BY BRTS THRU FIELD 1
  6002.     DCA    AC0    /SAVE IT
  6003.     TAD    AC0
  6004.     CLL RTL        /GET INTEGER BITS FOR HOW MANY K
  6005.     RTL
  6006.     RTL
  6007.     AND    (37    /MASK THEM
  6008.     DCA    AC1    /SAVE THEM
  6009.     DCA    AC2
  6010. DLP1,    TAD    AC1    /CONVERT TO DECIMAL
  6011.     TAD    (-12
  6012.     SPA
  6013.     JMP    GOTQUO
  6014.     DCA    AC1
  6015.     ISZ    AC2
  6016.     JMP    DLP1
  6017. GOTQUO,    CLA
  6018.     TAD    AC2    /GET TENS DIGIT
  6019.     SZA        /SKP IF ZERO
  6020.     JMS    PUTDG    /OR PUT IT OUT
  6021.     TAD    AC1    /DO UNITS
  6022.     JMS    PUTDG
  6023.     TAD    AC0    /GET FIRST FRACTION DIGIT
  6024.     AND    (177
  6025.     DCA    AC0
  6026.     TAD    AC0
  6027.     CLL RTR
  6028.     TAD    AC0
  6029.     CLL RTR
  6030.     CLL RTR
  6031.     AND    O17
  6032.     SNA        /SKP IF NONZERO FRACTION
  6033.     JMP    NOFRAC
  6034.     DCA    AC0
  6035.     TAD    (56    /PRINT .
  6036.     JMS I    (PCH
  6037.     TAD    AC0
  6038.     JMS    PUTDG
  6039. NOFRAC,    JMS I    (SCRIBE    /PRINT "K FREE SPACE"
  6040.     SPCLFT
  6041.     JMS I    (PCRLF
  6042.     JMP I    PILOOP    /RETURN TO INTERPRETER
  6043.  
  6044. PUTDG,    0
  6045.     TAD    (60
  6046.     JMS I    (PCH
  6047.     JMP I    PUTDG
  6048.  
  6049. VERMSG,    "B;"R;"T;"S;" ;"V;"e;"r;"s;"i;"o;"n;" ;VERSON;SUBVER+60;0
  6050. SPCLFT,    "K;" ;"F;"r;"e;"e;" ;"S;"p;"a;"c;"e;0
  6051.  
  6052.     PAGE
  6053.     RELOC
  6054.     FIELD    3    /LOAD FILES HERE
  6055.  
  6056. //////////////////////////////////////////////////
  6057. //////////////////////////////////////////////////
  6058. ///////// OVERLAY 3-FILE MANIPULATING ////////////
  6059. /////////    FUNCTIONS          ////////////
  6060. //////////////////////////////////////////////////
  6061. //////////////////////////////////////////////////
  6062.  
  6063.     *OVERLAY
  6064.  
  6065.     VERSON&77^100+SUBVFF+60    /VERSION WORD FOR FILES OVERLAY
  6066.  
  6067. OVDISP,    JMS I    (FBITGT    /GET FUNCTION TYPE
  6068.     TAD    JMPFF    /BUILD JMP INLINE
  6069.     DCA    .+1
  6070.     HLT
  6071.  
  6072. JMPFF,    JMP I    .+1    /CALL FOR FILE MANIPULATING FUNCTIONS
  6073.  
  6074.     /JUMP TABLE FOR FILE FUNCTIONS
  6075.  
  6076.     CHAIN        /FUNCTION BITS=    000
  6077.     CLOSE        /        020
  6078.     OPENAF        /        040
  6079.     OPENAV        /        060
  6080.     OPENNF        /        100
  6081.     OPENNV        /        120
  6082.     FSTOP        /INT. EXIT    140
  6083.     CCL        /        160
  6084.  
  6085.     /CCL(C$) FUNCTION - PASS COMMAND STRING TO CCL
  6086.  
  6087. CCL,    TAD    SACLEN    /TEST COMMAND STRING LENGTH
  6088.     SZA
  6089.     TAD    (CCLMAX
  6090.     SPA SNA CLA    /SKP IF IN RANGE (ALLOWING TERMINATING NULL)
  6091.     JMP    NC    /ERROR
  6092.     JMS I    PPSWAP    /GET OS/8
  6093.     JMS    MOVCMD    /SHUFFLE COMMAND TO SAFE PLACE IN FIELD 1
  6094.     SAC-1        /FROM SAC
  6095.     BUFAREA-1    /TO BUFFER AREA ABOVE USR
  6096.     CIF    10
  6097.     JMS I    O7700    /LOCK USR IN
  6098.     10
  6099.     CLA IAC        /LOOK UP "SYS:CCL.SV"
  6100.     CIF    10
  6101.     JMS I    O200
  6102.     2        /LOOKUP
  6103. CCLBLK,    CCLNAM
  6104.     0
  6105. NC,    JMS I    PERROR    /FATAL ERROR IF NO FIND
  6106.     JMS I    (PSWAP2    /DO THE ONCE ONLY EXIT CODE NOW
  6107.             /(THE CCL COMMAND WILL WIPE THE SAVED BATCH STATE)
  6108.     TAD I    (JSW    /KEEP ONLY THE BATCH SAVED STATE
  6109.     AND    (400
  6110.     TAD    (2001    /SET JSW FOR USR IN CORE
  6111.     DCA I    (JSW
  6112.     TAD    CCLBLK    /COPY BLOCK NUMBER INLINE
  6113.     DCA    CHNBLK
  6114.     JMS    MOVCMD    /NOW MOVE THE COMMAND TO CD AREA
  6115.     BUFAREA-1    /FROM HERE
  6116.     7577        /TO HERE
  6117.     CIF    10    /DO A RESET TO DELETE ANY TENTATIVE FILES
  6118.     JMS I    O200
  6119.     13        /RESET
  6120.     CIF    10    /NOW DO THE CHAIN
  6121.     JMS I    O200
  6122.     6        /CHAIN
  6123. CHNBLK,    0
  6124.  
  6125. MOVCMD,    0
  6126.     TAD I    MOVCMD    /GET SOURCE PTR
  6127.     ISZ    MOVCMD
  6128.     DCA    SACXR
  6129.     TAD I    MOVCMD    /GET TARGET PTR
  6130.     ISZ    MOVCMD
  6131.     DCA    XR1
  6132.     TAD    SACLEN    /SET COUNTER
  6133.     DCA    AC0
  6134.     CDF    10    /DATA IN FIELD 1
  6135. CCLMOV,    TAD I    SACXR    /GET A BYTE
  6136.     AND    IOMASK    /MASK
  6137.     TAD    O200    /SET PARITY BIT
  6138.     DCA I    XR1    /STORE IT
  6139.     ISZ    AC0
  6140.     JMP    CCLMOV
  6141.     DCA I    XR1    /STORE TERMINATING NULL
  6142.     CDF
  6143.     JMP I    MOVCMD
  6144.  
  6145. CCLNAM,    FILENAME CCL.SV
  6146.  
  6147.     PAGE
  6148.     /FILE CLOSING ROUTINE
  6149.  
  6150. CLOSE,    TAD I    IOTHND    /SEE IF FILE IS IDLE
  6151.     SZA CLA        /SKP IF YES, CLOSE IS A NOP
  6152.     TAD    ENTNO    /GET FILE #
  6153.     SNA CLA        /IS IT TTY?
  6154.     JMP I    PILOOP    /YES-DON'T DO ANYTHING
  6155.     TAD I    IOTRSZ    /NO ^Z IF RANDOM ACCESS FILE (ALREADY HANDLED)
  6156.     SNA CLA
  6157.     JMS I    PFTYPE    /IS FILE NUMERIC?
  6158.     JMP    NOCZ    /YES-DON'T OUTPUT ^Z
  6159.     JMS I    (FOTYPE    /NO-IS FILE VARIABLE LENGTH?
  6160.     JMP    NOCZ    /NO-DON'T OUTPUT ^Z
  6161.     TAD    (32    /YES
  6162.     JMS I    PPUTCH    /WRITE A ^Z IN FILE
  6163. NOCZ,    JMS I    (WRBLK    /WRITE LAST BLOCK IF IT HAS CHANGED
  6164.     JMS I    (RTNDEF    /RETURN ANY CURRENT RECORD DESCRIPTORS TO FREELIST NOW
  6165.     JMS I    PPSWAP    /RESTORE 17600
  6166.     JMS I    (FOTYPE    /IS FILE FIXED LENGTH?
  6167.     JMP    CLOSED    /YES-NO NEED TO CLOSE THE FILE
  6168.  
  6169.     TAD I    IOTLEN    /NO-GET FILE LENGTH
  6170.     DCA    CLENG    /PUT IN CLOSE CALL
  6171.     TAD    IOTFIL
  6172.     DCA    FNAP    /POINTER TO FILE NAME
  6173.     TAD I    IOTHDR
  6174.     CLL RTL
  6175.     RTL
  6176.     RAL        /GET DEVICE NUMBER INTO BITS 8-11
  6177.     AND    O17    /ISOLATE IT
  6178.     CIF 10
  6179.     JMS I    O7700    /CALL USR
  6180.     4        /CLOSE
  6181. FNAP,    0        /POINTER TO FILE NAME
  6182. CLENG,    0
  6183. FC,    JMS I    PERROR    /FILE CLOSING ERROR
  6184.             /FALL INTO BUFFER/HANDLER RELEASE ROUTINE
  6185.  
  6186.  
  6187. CLOSED,    STA        /RETURN THIS BUFFER TO THE POOL
  6188.     TAD    BUFSTK
  6189.     DCA    BUFSTK
  6190.     TAD I    IOTBUF
  6191.     DCA I    BUFSTK
  6192.     /RELEASE HANDLER (MESSY)
  6193.  
  6194.     TAD I    IOTHND    /SEE IF CORESIDENT WITH SYS:
  6195.     TAD    O200
  6196.     SMA CLA
  6197.     JMP    CRETN    /JMP IF YES
  6198.     TAD    (-MAXFIL /SEE IF ANY OTHER FILES USING DEVICE CORESIDENT
  6199.     DCA    AC2    /WITH THIS FILE
  6200.     TAD    (MAXFIL^IOTSIZ+TTYF+IOTHND-IOTHDR
  6201.     DCA    AC0    /POINT AT HANDLER ENTRY FOR LAST FILE
  6202. CHECKL,    TAD    AC2    /-# OF FILE WERE CHECKING
  6203.     TAD    ENTNO    /COMPARE TO CURRENT NUMBER
  6204.     SNA CLA        /IS IT THIS ONE?
  6205.     JMP    PSTCHK    /YES-DON'T CHECK DRIVER
  6206.     TAD I    AC0    /GET HANDLER ENTRY POINT FOR THIS FILE
  6207.     AND    (7600    /ISOLATE PAGE BITS
  6208.     CIA        /NEGATE
  6209.     TAD I    IOTHND    /COMPARE TO PAGE OF CURRENT FILE'S HANDLER
  6210.     AND    (7600
  6211.     SNA CLA        /SAME DEVICE?
  6212.     JMP    CRETN    /YES-LEAVE DRIVER IN CORE
  6213. PSTCHK,    TAD    AC0    /BUMP HANDLER EP PTR BACK
  6214.     TAD    (-IOTSIZ
  6215.     DCA    AC0
  6216.     ISZ    AC2    /ALL 4 CHECKED?
  6217.     JMP    CHECKL    /NO-CHECK THE NEXT 1
  6218.     TAD I    IOTHND    /RETURN THE HANDLER TO THE POOL NOW
  6219.     TAD    (-HAREA    /GET PAGE OFFSET TO AC10,11
  6220.     RTL
  6221.     RTL
  6222.     RTL
  6223.     AND    (7
  6224.     CMA
  6225.     DCA    AC0    /SET SHIFT COUNT
  6226.     TAD I    IOTHDR    /SEE IF 2 PAGES BEING FREED
  6227.     AND    O10
  6228.     SNA CLA        /SKP IF YES
  6229.     TAD    (40    /ELSE JUST DO ONE BIT
  6230.     TAD    (7637
  6231.     STL RAR        /SHIFT MASK DOWN
  6232.     ISZ    AC0
  6233.     JMP    .-2
  6234.     AND    DMAP    /NOW CLEAR THE BIT(S)
  6235.     DCA    DMAP
  6236.     TAD    (RESTBL    /MARK ALL ENTRY POINTS GONZO
  6237.     DCA    AC0
  6238.     TAD I    IOTHND    /SAVE PAGE BITS OF HANDLER
  6239.     AND    (7600
  6240.     DCA    AC2
  6241.     TAD    (-17    /DO 15. ENTRY POINTS
  6242.     DCA    TEMP2
  6243.     CDF    10
  6244. FREHND,    TAD I    AC0    /NOW MARK ENTRIES NONRESIDENT
  6245.     AND    (7600
  6246.     CIA
  6247.     TAD    AC2
  6248.     SNA CLA        /SKP IF NOT CORESIDENT
  6249.     DCA I    AC0    /ELSE CLEAR IT
  6250.     ISZ    AC0
  6251.     ISZ    TEMP2
  6252.     JMP    FREHND
  6253.     CDF
  6254. CRETN,    DCA I    IOTHND    /MAKE THE FILE IDLE NOW
  6255.     DCA I    IOTHDR    /CLEAR DEVICE BITS TOO
  6256.     JMS I    PPSWAP    /REMOVE OS/8
  6257.     JMP I    PILOOP    /RETURN TO ILOOP
  6258.  
  6259.     PAGE
  6260.     /CHAIN FUNCTION
  6261.     /INVOKES USR CHAIN OPERATION IF FILE EXTENSION IS .SV
  6262.     /OTHERWISE SETS UP CD AREA AND CHAINS TO BCOMP
  6263.  
  6264. CHAIN,    JMS I    PPSWAP    /RESTORE PG 17600
  6265.     JMS I    DNA2    /GET FILE NAME IN NAME AREA FROM CURRENT FILE
  6266.     0201        /DEFAULT EXTENSION .BA
  6267. CF,    JMS I    PERROR    /ERROR IF ILLEGAL FILE NAME
  6268.     CIF 10
  6269.     JMS I    O7700    /CALL USR
  6270.     10        /LOCK IN CORE
  6271.     TAD I    IOTDEV
  6272.     DCA    DNA1    /FIRST TWO CHARS OF DEV NAME
  6273.     TAD I    IOTDEV+1 /LAST TWO CHARS
  6274.     DCA    DNA2
  6275.     CIF    10
  6276.     JMS I    O200
  6277.     12        /INQUIRE
  6278. DNA1,    0
  6279. DNA2,    NAMEG
  6280. CDIN,    0
  6281. CI,    JMS I    PERROR    /ERROR
  6282.     TAD    CDIN    /GET ENTRY POINT OF DRIVER FOR CHAIN FILE
  6283.     SZA CLA        /IS IT IN CORE?
  6284.     JMP    DISIN    /YES-NO NEED TO FETCH IT
  6285.     TAD    DNA2    /NO-DEVICE # INTO AC
  6286.     CIF 10
  6287.     JMS I    O200
  6288.     1        /FETCH HANDLER
  6289.     7001        /INTO PAGE 7000
  6290.     JMP    CI    /MAKE IT LOOK LIKE INQUIRE ERROR
  6291. DISIN,    TAD    IOTFIL
  6292.     DCA    STB    /POINTER TO FILE NAME
  6293.     TAD    DNA2    /GET DEVICE #
  6294.     CIF 10
  6295.     JMS I    O200
  6296.     2        /LOOKUP
  6297. STB,    0        /POINTER TO FILE NAME
  6298. FLN,    0
  6299. CL,    JMS I    PERROR    /LOOKUP ERROR
  6300.     TAD    IOTFIL    /POINT AT FILENAME EXTENSION
  6301.     TAD    (3
  6302.     DCA    TEMP2
  6303.     TAD I    TEMP2    /SEE IF .SV EXTENSION
  6304.     TAD    (-2326
  6305.     SNA CLA
  6306.     JMP    CICHAIN    /JMP IF YES, DO USR CHAIN
  6307.     CDF    10    /ELSE TEST IF BCOMP AND BLOAD ARE BOTH ACCOUNTED FOR
  6308.     TAD I    (INFO+2    /LOOK AT BLOAD BLOCK
  6309.     SZA CLA        /FORCE ERROR IF NOT THERE
  6310.     TAD I    (INFO+1    /LOOK AT BCOMP BLOCK
  6311.     SNA
  6312. BC,    JMS I    PERROR    /TAKE ERROR EXIT IF NOT BOTH THERE
  6313.     DCA    CBLK    /ALL SET, STORE BCOMP BLOCK INLINE
  6314.     TAD    STB    /GET STARTING BLOCK
  6315.     DCA I    (INFO+14 /STARTING BLOCK IN CD AREA
  6316.     TAD    FLN    /FILE LENGTH
  6317.     CLL RTL
  6318.     RTL
  6319.     AND    (7760    /PUT IN BITS 0-7
  6320.     TAD    DNA2    /COMBINE WITH DEVICE #
  6321.     DCA I    (INFO+13 /PUT IN CD AREA
  6322.     TAD    (40    /SET /G SWITCH FOR BLOAD TO RUN PROGRAM AFTER COMPILE
  6323.     DCA I    (CDOPT3    /IN CD SWITHCES [ABC DEF GHI JKL]
  6324.     TAD    CDFIO    /PASS SIZE OF SYSTEM THROUGH THE = OPTION TO BCOMP
  6325.     CLL RTR
  6326.     RAR
  6327.     AND    (7
  6328.     DCA I    (CDOPT6    /THIS PRESERVES BATCH IF POSSIBLE
  6329.     CDF
  6330.     JMS I    (PSWAP2    /NOW EXEC DESTRUCTIVE EXIT CODE
  6331.     JMS I    (7607    /READ FROM SYS:
  6332.     BCSIZ1+10    /4 BLOCKS TO FIELD 1
  6333.     BCLOD1        /TO HERE
  6334. CBLK,    0        /FROM HERE
  6335.     HLT        /CRASH SYSTEM IF SYS FAILED
  6336.     CIF CDF    10    /NOW JMP INTO FIELD 1
  6337.     JMP I    (CCHAIN
  6338.  
  6339. CICHAIN,STA        /TEST IF OUR .SV FILE IS ON SYS:
  6340.     TAD    DNA2
  6341.     SZA CLA        /SKP IF OK
  6342. CN,    JMS I    PERROR    /ERROR ABORT: CAN'T CHAIN OUTSIDE SYS:
  6343.     JMS I    (PSWAP2    /NOW EXEC ONCE ONLY CLEAN UP ROUTINE
  6344.     TAD    (MAGIC    /SET MAGIC NUMBER INTO CD = OPTION TO BYPASS
  6345.     CDF    10    /INITIALIZATION LOOKUPS
  6346.     DCA I    (7642    /FOR CHAINS TO PRE COMPILED PROGRAMS
  6347.     CDF
  6348.     TAD    STB    /COPY STARTING BLOCK INLINE
  6349.     DCA    CHNSTB
  6350.     CIF    10    /NOW DO A RESET AND DELETE TENTATIVE FILES
  6351.     JMS I    O200
  6352.     13        /RESET
  6353.     CIF 10        /FLAG TENTATIVE FILE CLEANUP
  6354.     JMS I    O200
  6355.     6        /NOW DO THE CHAIN EXIT
  6356. CHNSTB,    HLT
  6357.     /FINAL ENTER/LOOKUP PROCESSING
  6358.  
  6359. CLEANP,    DCA I    IOTPOS    /ZERO COLUMN POINTER
  6360.     CMA        /-1
  6361.     TAD I    IOTLOC    /STARTING BLOCK-1
  6362.     DCA I    IOTBLK    /CURRENT BLOCK #=STARTING BLOCK-1
  6363.     TAD I    IOTBUF
  6364.     DCA I    IOTPTR    /READ/WRITE POINTER AT BEGINNING OF BUFFER
  6365.     CIF 10
  6366.     JMS I    O200    /CALL TO USR
  6367.     11        /USROUT
  6368.     JMS I    PPSWAP    /GET RID OF 17600
  6369.     JMS I    (BLZERO
  6370.     JMS I    (NEXREC    /DO A NEXREC TO READ IN FIRST FILE BLOCK
  6371.     JMP I    PILOOP    /DONE, LET'S GET THE HELL OUT OF HERE
  6372.  
  6373.     PAGE
  6374.     /FILE OPENING ROUTINE
  6375.  
  6376. OPENAV,    TAD    (4    /ALPHANUMERIC,VARIABLE LENGTH
  6377. OPENAF,    IAC        /ALPHANUMERIC,FIXED LENGTH
  6378.     JMP    OPENNF
  6379. OPENNV,    TAD    (4    /NUMERIC,VARIABLE LENGTH
  6380. OPENNF,    DCA    AC0    /SAVE NEW HEADER WORD
  6381.     TAD    ENTNO    /IS FILE TTY?
  6382.     SNA CLA
  6383.     JMP I    PILOOP    /YES-DON'T DO ANYTHING
  6384.     TAD    AC0    /IF NOT CONSOLE, SET HEADER WORD
  6385.     DCA I    IOTHDR
  6386.     DCA I    IOTRSZ    /ASSUME NON RANDOM ACCESS FILE
  6387.     TAD I    IOTHND    /GET HANDLER ENTRY
  6388.     SZA CLA        /IS FILE IDLE?
  6389. FB,    JMS I    PERROR    /ATTEMPT TO OPEN FILE ALREADY OPEN
  6390.     JMS I    PPSWAP    /RESTORE 17600
  6391.     JMS I    (NAMEG    /GET FILE DEVICE NAME AND FILE NAME INTO WORDS 7-14 FROM SAC
  6392.     0401        /DEFAULT EXTENSION IS .DA
  6393.     JMP    IF    /GIVE ERROR IF BAD FORMAT NAME
  6394.     CIF 10
  6395.     JMS I    O7700    /CALL TO USR
  6396.     10        /LOCK USR IN CORE
  6397.     TAD I    IOTDEV
  6398.     DCA    DEVNA1    /DEVICE NAME INTO INQUIRE CALL
  6399.     TAD I    IOTDEV+1
  6400.     DCA    DEVNA2
  6401.     CIF 10
  6402.     JMS I    O200    /CALL TO USR
  6403.     12        /INQUIRE
  6404. DEVNA1,    0        /DEVICE NAME
  6405. DEVNA2,    0
  6406. ENTRYN,    0        /ENTRY POINT
  6407.     JMP    INERR    /INQUIRE ERROR, GO RECOVER AND WARN USER
  6408.     TAD    DEVNA2    /GET DEVICE #
  6409.     CLL RAR
  6410.     RTR        /PUT INTO BITS 0-3
  6411.     RTR
  6412.     TAD I    IOTHDR
  6413.     DCA I    IOTHDR    /STORE IN HEADER WORD
  6414.     CDF    10    /GET INTO USR FIELD
  6415.     STA
  6416.     TAD    DEVNA2
  6417.     TAD I    (USRDHT    /INDEX INTO USR DEVICE HANDLER TABLE
  6418.     DCA    AC0
  6419.     TAD I    AC0    /LOOK AT OUR DEVICE
  6420.     CDF
  6421.     CLL RAL
  6422.     SZL CLA
  6423.     TAD    (20    /LOOK FOR 2 CONSECUTIVE PAGES IF BIG HANDLER
  6424.     TAD    (40
  6425.     DCA    AC0    /SET INITIAL PAGE MASK IN CASE WE LOOK FOR SPACE
  6426.     SZL        /STORE 2 PAGE BIT IN HEADER FOR SUBSEQUENT
  6427.     TAD    O10    /RELEASE OF HANDLER PAGES
  6428.     TAD I    IOTHDR
  6429.     DCA I    IOTHDR
  6430.     TAD    ENTRYN    /GET DRIVER ADDRESS
  6431.     SZA        /IS IT IN CORE?
  6432.     JMP    DRIVRN    /YES, NO NEED TO FETCH IT
  6433.     RAL        /GET 2 PAGE ALLOWANCE BIT TO AC11
  6434.     TAD    (HAREA    /POINT AT HANDLER AREA
  6435. HSRCH,    DCA    FETPAG    /SEARCH FOR A SLOT
  6436.     TAD    AC0
  6437.     AND    DMAP    /BITS OFF INDICATE AVIALABLE CORE
  6438.     SNA CLA
  6439.     JMP    GOTPAG    /JMP IF GOT IT
  6440.     TAD    AC0    /ELSE MOVE WINDOW UP
  6441.     CLL RAR
  6442.     DCA    AC0
  6443.     SZL        /SKP IF NOT PAST END OF FREE AREA
  6444. DO,    JMS I    PERROR    /ELSE TAKE ERROR EXIT
  6445.     TAD    FETPAG
  6446.     TAD    O200
  6447.     JMP    HSRCH    /TRY AGAIN
  6448.  
  6449. GOTPAG,    TAD    AC0    /BUSY OUT THE PAGES WE'RE USING
  6450.     TAD    DMAP
  6451.     DCA    DMAP
  6452.     TAD    DEVNA2    /FETCH THE HANDLER BY NUMBER
  6453.     CIF 10
  6454.     JMS I    O200    /CALL TO USR
  6455.     1        /FETCH
  6456. FETPAG,    0        /DRIVER ADDRESS
  6457. FE,    JMS I    PERROR    /FETCH ERROR
  6458.     TAD    FETPAG    /NOW STORE THE HANDLER IN IOTABLE
  6459. DRIVRN,    DCA I    IOTHND
  6460.     TAD I    BUFSTK    /SEE IF ANY FREE BUFFERS
  6461.     SNA
  6462. BO,    JMS I    PERROR    /TAKE ERROR EXIT IF NONE
  6463.     DCA I    IOTBUF    /ELSE STORE IT IN IOTAB
  6464.     ISZ    BUFSTK    /BUMP FREELIST PTR UP
  6465.  
  6466.     TAD I    IOTHDR    /GET HEADER WORD
  6467.     AND    (4    /TEST VARIABLE LENGTH BIT
  6468.     SNA CLA        /SKP IF NEW FILE BEING CREATED
  6469.     JMP    FLOOK    /DO A LOOKUP IF FIXED
  6470.     TAD    (3
  6471.     JMS I    (ENTLOK    /ENTER
  6472.     DCA I    IOTMAX    /MAXIMUM LENGTH IN WORD 7
  6473.     DCA I    IOTLEN    /ZERO ACTUAL LENGTH
  6474.     JMP I    (CLEANP    /FINALIZE I/O TABLE ENTRY
  6475. FLOOK,    AC0002
  6476.     JMS I    (ENTLOK    /LOOKUP
  6477.     DCA I    IOTLEN    /ACTUAL LENGTH
  6478.     TAD I    IOTLEN
  6479.     DCA I    IOTMAX    /ALSO EQUALS MAXIMUM LENGTH
  6480.     JMP I    (CLEANP    /FINISH OFF
  6481.  
  6482. INERR,    CIF    10
  6483.     JMS I    O200    /DO A USROUT FIRST
  6484.     11
  6485. IN,    JMS I    PERROR    /GIVE ERROR WARNING
  6486.     SKP        /SKP TO CLEAR THIS CHANNEL AND EXIT
  6487. IF,    JMS I    PERROR    /GIVE ERROR WARNING
  6488.     DCA I    IOTHDR    /CLEAR HEADER
  6489.     DCA I    IOTHND    /CLEAR HANDLER ENTRY
  6490.     JMP I    PILOOP    /EXIT
  6491.  
  6492.     PAGE
  6493.     /ROUTINE TO ENTER OR LOOKUP FILE
  6494.     /ENTRY AC = ENTER OR LOOKUP FUNCTION NUMBER
  6495.     /IF NON FILE STRUCTURED OUTPUT DEVICE, SETS UP FOR BLOCK ZERO
  6496.     /INITIALIZATION ON FIRST OUTPUT CALL
  6497.     /IF NON FILE STRUCTURED INPUT DEVICE, SETS UP FOR BLOCK ZERO
  6498.     /INITIALIZATION DURING FINAL OPEN PROCESSING INSTEAD
  6499.  
  6500. ENTLOK,    0
  6501.     DCA    FNOM    /FUNCTION NUMBER IN PLACE
  6502.     TAD    IOTFIL    /POINTER TO FILE NAME
  6503.     DCA    STARTB    /INTO CALL
  6504.     TAD I    (DEVNA2    /DEVICE NUMBER
  6505.     CIF 10
  6506.     JMS I    O200    /CALL TO USR
  6507. FNOM,    0        /ENTER OR LOOKUP
  6508. STARTB,    0
  6509. FLEN,    0
  6510.     JMP    ENTERR    /ENTER/LOOKUP ERROR, TAKE RECOVERY EXIT
  6511.     TAD    STARTB    /SEE IF EITHER BLOCK OR NEGATIVE LENGTH RETURNED
  6512.     SNA
  6513.     TAD    FLEN    /INDICATING FILE STRUCTURED DEVICE
  6514.     SZA CLA
  6515.     JMP    FILSTU    /JMP IF FILE STRUCTURED DEVICE
  6516.     TAD    (20    /NO-FILE IS READ/WRITE ONLY
  6517.     TAD I    IOTHDR
  6518.     DCA I    IOTHDR    /SET READ/WRITE ONLY BIT
  6519.     AC7776        /TEST IF ENTER OR LOOKUP
  6520.     TAD    FNOM
  6521.     SNA CLA        /SKP IF ENTER AND SET START BLOCK TO ZERO
  6522.     IAC        /ELSE SET TO ONE FOR DEVICE INITIALIZATION FUDGE
  6523. FILSTU,    TAD    STARTB    /GET STARTING BLOCK # OF FILE
  6524.     DCA I    IOTLOC    /PUT IN I/O TABLE
  6525.     TAD    FLEN    /FILE LENGTH
  6526.     CIA        /MAKE FILE LENGTH POSITIVE
  6527.     JMP I    ENTLOK    /RETURN
  6528.  
  6529. ENTERR,    CIF    10    /FIRST KICK OUT USR
  6530.     JMS I    O200
  6531.     11        /USROUT
  6532. EN,    JMS I    PERROR    /GIVE ENTER/LOOKUP ERROR WARNING
  6533.     JMS I    PPSWAP    /BRING OS/8 RESIDENT IN FOR HANDLER RELEASE
  6534.     JMP I    (CLOSED    /GO FINISH OFF
  6535. /SUBROUTINE PSWAP2-RESTORE OS/8 RESIDENT MONITOR PRIOR TO EXIT FROM INTERPRETERTER
  6536. /THIS IS DESTRUCTIVE CODE, AND ONCE THIS ROUTINE HAS BEEN EXECUTED
  6537. /THERE IS NO PLACE TO GO BUT OUT.
  6538. /HAS 3 FUNCTIONS:
  6539. /        1) REMOVES CTRL/C HOOKS FROM SYS DRIVER
  6540. /        2) RESTORES BATCH CONTROL WORDS TO N7774-N7777
  6541. /        3) IF SYS IS 2 PAGE HANDLER, RESTORES PAGE 27600 AND FIXES CDF'S IN 07600
  6542.  
  6543. PSWAP2,    0
  6544.     TAD    (4207
  6545.     DCA I    BOSPT1    /REMOVE CTRL/C HOOKS
  6546.     TAD    (6213
  6547.     DCA I    (7605
  6548.     TAD    BOSPT1
  6549.     DCA I    (HICORE    /FUDGE POINTER IN SWAP ROUTINE
  6550.             /IN CASE OF 2 PAGE SYSTEM HANDLER
  6551.     TAD    PSFLAG    /GET RESIDENT STATUS FLAG
  6552.     SMA CLA        /SKP IF ROOM ALLOCATED FOR 2 PAGE HANDLER
  6553.     JMP    NOT2PG    /JMP IF NO
  6554.     DCA    PSFLAG    /CLEAR RESIDENT STATUS FLAG
  6555.     TAD    (CDF 20
  6556.     DCA I    (P2CDF    /PUT CDF 20 IN SWAP ROUTINE
  6557.     TAD    (CDF 20
  6558.     DCA I    (P2CDF1
  6559.     JMS I    PPSWAP    /MOVE DOWN PAGE 27600
  6560.     AC7775        /TEST MAGIC LOCATION FOR A 3
  6561.     TAD I    (7612
  6562.     SZA CLA
  6563.     JMP    NOT2PG    /DO NOTHING IF NOT 2 PAGE HANDLER
  6564.     TAD    (7635    /ELSE SETUP MAGIC POINTER
  6565.     DCA    AC0
  6566. HNDLP,    TAD I    AC0    /NOW RANGE CHECK CONTENTS OF THIS WORD
  6567.     TAD    (-6300
  6568.     CLL
  6569.     TAD    (70
  6570.     SNL CLA        /SKP IF CIF CDF N0, N.NE.0
  6571.     JMP    NOPAT    /ELSE TRY AGAIN
  6572.     TAD I    AC0    /GET INSTRUCTION BACK
  6573.     AND    (7707
  6574.     TAD    (20    /RESTORE FIELD 2
  6575.     DCA I    AC0    /PUT IT BACK
  6576. NOPAT,    ISZ    AC0    /CONTINUE TO END OF PAGE
  6577.     JMP    HNDLP
  6578. NOT2PG,    TAD I    (JSW    /SEE IF BATCH UNTOUCHED OR NOT
  6579.     AND    (400
  6580.     SNA CLA        /SKP IF YES, NO NEED TO RESTORE PARAMETER WORDS
  6581.     TAD I    (BIPCCL    /SEE IF BATCH RUNNING
  6582.     RAL
  6583.     SMA CLA
  6584.     JMP I    PSWAP2    /RETURN NOW IF NO
  6585.     TAD I    (BIPCCL
  6586.     AND    (70    /ISOLATE FIELD BITS
  6587.     TAD    CDFO
  6588.     DCA    .+3    /CDF TO HI CORE
  6589.     CDF    10
  6590.     TAD I    BOSPT1    /GET BATCH WORD
  6591.     HLT
  6592.     DCA I    BOSPT2    /BACK INTO LOFTY STATE
  6593.     ISZ    BOSPT1
  6594.     ISZ    BOSPT2
  6595.     JMP    .-6
  6596. CDFO,    CDF
  6597.     JMP I    PSWAP2    /WE ARE FINISHED, SO RETURN
  6598.  
  6599. BOSPT1,    7600
  6600. BOSPT2,    7774
  6601.  
  6602.     /ROUTINE FOR INTERPRETER EXIT
  6603.  
  6604. FSTOP,    CLL CLA IAC
  6605.     AND    PSFLAG    / If os8 area is in don't swap it
  6606.     SNA CLA
  6607.     JMS I    PPSWAP
  6608.     JMS    PSWAP2
  6609.     CDF    10
  6610.     TAD I    (EDBLK    /GET BLOCK NUMBER FOR EDITOR
  6611.     CDF
  6612.     SNA        /SKP IF EDITOR WAS RUN
  6613.     JMP I    (7605    /RETURN TO KBM IF NO EDITOR
  6614.     JMP I    (EDREAD    /JMP TO HIGHER CORE TO DO READ (EDITOR OVERLAYS HERE)
  6615.             /PASSING BLOCK IN AC
  6616.     PAGE
  6617.     /ROUTINE TO PARSE A FILE NAME OF THE FORM "DEVN:FILENM.EX"
  6618.     /CALL+1 = DEFAULT EXTENSION, ASSUMES DEFAULT DEVICE DSK:
  6619.     /RETURN TO CALL+2 IF BAD FILE NAME SYNTAX
  6620.     /RETURN TO CALL+3 IF GOT GOOD NAME
  6621.  
  6622. NAMEG,    0
  6623.     TAD I    NAMEG    /GET DEFAULT EXT
  6624.     ISZ    NAMEG
  6625.     DCA    EXT    /SAVE IN BUFFER
  6626.     STA        /SET SOME SWITCHES
  6627.     DCA    COLSWT
  6628.     STA
  6629.     DCA    DOTSWT
  6630.     TAD    PSACM1    /SET POINTER TO SAC NOW
  6631.     DCA    SACXR
  6632.     TAD    (0423    /NOW GET DEFAULT DEVICE - DSK:
  6633.     DCA    DEV
  6634.     TAD    (1300
  6635. GOTDEV,    DCA    DEV+1
  6636. NAMLUP,    TAD    (-4    /SET A WORD COUNT
  6637.     DCA    XR1
  6638.     TAD    (NAME    /POINT AT NAME BUFFER
  6639.     DCA    TEMP2
  6640.     DCA    NAME    /ZERO OUT THE NAME NOW
  6641.     DCA    NAME+1
  6642.     DCA    NAME+2
  6643. GETNAM,    JMS    NGCH    /GET A CHAR
  6644.     ISZ    XR1    /TEST COUNT
  6645.     SKP
  6646.     JMP I    NAMEG    /ERROR RETURN IF PAST FIELD SIZE
  6647.     TAD    AC0    /OK, GET CHAR
  6648.     AND    O77    /6 BITS
  6649.     CLL RTL
  6650.     RTL
  6651.     RTL        /SHIFT LEFT
  6652.     DCA I    TEMP2    /PUT IN BUFFER
  6653.     JMS    NGCH    /GET ANOTHER CHAR
  6654.     TAD    AC0
  6655.     AND    O77    /6 BITS
  6656.     TAD I    TEMP2    /ADD TO PREV ONE
  6657.     DCA I    TEMP2
  6658.     ISZ    TEMP2    /UP TO NEXT WORD
  6659.     JMP    GETNAM    /DO NEXT WORD
  6660. GOTCOL,    ISZ    COLSWT    /SEE IF : SEEN YET
  6661.     JMP I    NAMEG    /YES, A BADDY
  6662.     TAD    NAME+2    /SEE IF DEV GT 4 CHARS
  6663.     SNA CLA
  6664.     TAD    NAME    /ANY DEV THERE
  6665.     SNA
  6666.     JMP I    NAMEG    /NO, NO GOOD
  6667.     DCA    DEV    /OK, STORE IT
  6668.     TAD    NAME+1    /AND THE NEXT WORD TOO
  6669.     JMP    GOTDEV    /GET FILE NOW
  6670. GOTDOT,    ISZ    DOTSWT    /SEE IF . SEEN YET
  6671.     JMP I    NAMEG    /YES, ERROR
  6672.     ISZ    COLSWT    /DISALLOW FURTHER : TOO
  6673.     NOP
  6674.     TAD    (EXT    /POINT AT EXTENSION FIELD NOW
  6675.     DCA    TEMP2
  6676.     DCA    EXT    /ZERO OUT THE DEFAULT EXTENSION
  6677.     AC7776        /ALLOW ONLY ONE WORD
  6678.     DCA    XR1
  6679.     JMP    GETNAM    /GET THE EXTENSION ALREADY
  6680. EONAM,    STA
  6681.     TAD    IOTDEV    /ALL SET, MOVE THE NAME INTO CURRENT IOTABLE
  6682.     DCA    XR1
  6683.     TAD    (DEV-1
  6684.     DCA    XR2
  6685.     TAD    (-6    /6 WORDS
  6686.     DCA    AC0
  6687.     TAD I    XR2    /GET A PAIR OF CHARS
  6688.     DCA I    XR1    /AND STORE THEM
  6689.     ISZ    AC0
  6690.     JMP    .-3
  6691.     ISZ    NAMEG    /TAKE SUCCESSFUL RETURN
  6692.     JMP I    NAMEG
  6693. NGCH,    0
  6694.     TAD    SACLEN    /SEE IF ANYTHING IN SAC
  6695.     SNA CLA
  6696.     JMP    EONAM    /END OF NAME IF NO
  6697.     ISZ    SACLEN
  6698.     NOP
  6699.     CDF    10
  6700.     TAD I    SACXR    /GET A CHAR
  6701.     CDF
  6702.     DCA    AC0    /SAVE IT
  6703.     TAD    AC0
  6704.     TAD    (-56    /CHECK IF .
  6705.     SNA CLA
  6706.     JMP    GOTDOT    /JMP IF YES
  6707.     CLL        /NOW CHECK IF ALPHANUMERIC
  6708.     TAD    AC0
  6709.     TAD    (-60
  6710.     SMA
  6711.     TAD    (60-72
  6712.     SNA
  6713.     JMP    GOTCOL    /JMP IF HAPPENS TO BE :
  6714.     SMA
  6715.     TAD    (72-101
  6716.     SMA
  6717.     TAD    (101-133
  6718.     SNL CLA        /SKP IF A-Z OR 0-9
  6719.     JMP I    NAMEG    /ELSE WORNG CHAR
  6720.     JMP I    NGCH
  6721.  
  6722. COLSWT,    0
  6723. DOTSWT,    0
  6724. DEV,    ZBLOCK    2
  6725. NAME,    ZBLOCK    3
  6726. EXT,    0
  6727.  
  6728.     PAGE
  6729. //////////////////////////////////////////
  6730. //////////////////////////////////////////
  6731. //////////     EXTENDED BASIC     ////////
  6732. //////////        BASIC.EX        ////////
  6733. //////////////////////////////////////////
  6734. //////////////////////////////////////////
  6735.  
  6736.  
  6737. USR=7700
  6738. PR0=6206
  6739. PR1=6216
  6740. PR3=6236
  6741.  
  6742.     RELOC
  6743.     FIELD 3
  6744.     *2000
  6745.     RELOC    OVERLAY
  6746.     VERSON&77^100+SUBVEX+60
  6747. OVDISP,    TAD    PSACM1
  6748.     DCA    SACXR
  6749.     JMS I    (FBITGT        /GET FUNCTION TYPE
  6750.     TAD    JMPEX
  6751.     DCA    .+1
  6752.     HLT
  6753. JMPEX,    JMP I .+1        /CALL FOR GRAPHIC FUNCTION
  6754.  
  6755.     /JUMP TABLE FOR GRAPHICS FUNCTIONS
  6756.  
  6757.     EID    /FUNCTION BITS    = 000
  6758.     LST    /        = 020
  6759.     SCD    /        = 040
  6760.     EIL    /        = 060
  6761.     SGR    /        = 100
  6762.     SFM    /        = 120
  6763.     LCD    /        = 140
  6764.     LGD    /        = 160
  6765.     SLEEP    /        = 200
  6766.     SCS    /        = 220
  6767.     SSI    /        = 240
  6768.     ERR    /        = 260
  6769.     TRAP    /        = 300
  6770.     ERL    /        = 320
  6771.     KSTROK    /        = 340
  6772.  
  6773. TRAP,    CLL CLA
  6774.     JMS I    (FIXRGS
  6775.     TAD    TEMP1
  6776.     CIA
  6777.     DCA    TRPCHR
  6778.     JMP I    PILOOP
  6779.  
  6780. EID,    JMS I    (FIX23
  6781.     JMS I    (ESCBRK        /PRINT AN ESC BRACKET
  6782.     TAD    ACL
  6783.     AND    (3
  6784.     TAD    K60        /TURN IT INTO AN ASCII CHARACTER
  6785.     JMS I    (SACP
  6786.     TAD    (112        /PRINT A J TO FINISH OF COMMAND
  6787.     JMS I    (SACP
  6788. SETL,    TAD    SACXR        /GET NUMBER OF CHARACTERS PRINTED
  6789.     CIA
  6790.     TAD    PSACM1        /GET PRIVIOUS LENGTH
  6791.     DCA    SACLEN        /SAVE TOTAL SUM IN SAC LENGTH
  6792.     JMP I    (SSMODE
  6793.  
  6794.  
  6795. SACP,    0            /STORE DATA IN STRING AC
  6796.     CDF 10
  6797.     DCA I    SACXR
  6798.     CDF
  6799.     JMP I    SACP
  6800.  
  6801. LST,    JMS I    (ESCBRK
  6802.     TAD    (151        /PRINT i FOR PRINT SCREEN
  6803.     JMS I    (SACP
  6804.     JMP I    (SETL
  6805. ESCBRK,    0
  6806.     TAD    KESC        /PRINT AN ESC
  6807.     JMS I    (SACP
  6808.     TAD    KBRACK        /PRINT A BRACKET
  6809.     JMS I    (SACP
  6810.     JMP I    ESCBRK
  6811.  
  6812. EIL,    JMS I    (FIX23        /FIX THE NUMBER PASSED
  6813.     JMS I    (ESCBRK        /PRINT AN ESC [
  6814.     TAD    ACL        /GET THE NUMBER
  6815.     AND    (3        /CANT BE LARGER THAN 3
  6816.     TAD    K60        /TURN IT INTO AN ASCII CHARACTER
  6817.     JMS I    (SACP        /AND PRINT IT
  6818.     TAD    (113        /PRINT A K
  6819.     JMS I    (SACP
  6820.     JMP I    (SETL        /GOTO STANDARD EXIT ROUTINE
  6821.  
  6822. SFM,    JMS I    (FIX23        /FIX THE NUMBER PASSED
  6823.     JMS I    (ESCBRK        /PRINT AND ESC [
  6824.     TAD    O77        /PRINT A ?
  6825.     JMS I    (SACP
  6826.     TAD    (63        /PRINT A 3
  6827.     JMS I    (SACP
  6828.     TAD    ACL        /GET NUMBER SENT
  6829.     RAR            /PUT CHARACTER INTO LINK, CAN ONLY
  6830.     CLA            /BE A 0 OR 1 SO THIS WORKS FINE
  6831.     SNL
  6832.     TAD    K4        /PRINT A SMALL L FOR 80 COL
  6833.     TAD    (150        /PRINT A SMALL H FOR 132 COL
  6834.     JMS I    (SACP        /PUT THE CHARACTER INTO SAC
  6835.     JMP I    (SETL        /AND GOTO STANDARD EXIT ROUTINE
  6836.  
  6837. CONVRT,    0            /CONVERT A STRING TO A NUMBER
  6838.     STA            /VALUE LEFT IN FAC
  6839.     TAD    SACLEN
  6840.     DCA    CON1
  6841.     TAD    (CONVT1
  6842.     DCA I    (IGETCH
  6843.     JMS I    (FFIN
  6844.     TAD    (GETCH
  6845.     DCA I    (IGETCH
  6846.     JMS I    (FIX23
  6847.     JMP I    CONVRT
  6848.  
  6849. CONVT1,    0
  6850.     ISZ    CON1
  6851.     JMP    .+3
  6852.     TAD    O77
  6853.     JMP    CONVT2
  6854.     CDF    10
  6855.     TAD I    SACXR
  6856.     CDF
  6857. CONVT2,    DCA    CHAR
  6858.     JMP I    CONVT1
  6859. CON1,    0
  6860.  
  6861.     PAGE
  6862. VALID,    0            /SETUP AND CHECK ROUTINE FOR SCD, LCD, LGD
  6863.     CLL CLA CMA        /SUBTRACT 1 FROM CURROW TO GET CORRECT
  6864.     TAD    CURROW        /POSITION
  6865.     DCA    ROWTMP
  6866.     CLL CLA CMA
  6867.     TAD    CURCOL        /DO THE SAMETHING HERE
  6868.     DCA    COLTMP
  6869.     TAD    PSACM1        /SAVE SAC COUNTER, CONVRT WILL DESTROY IT
  6870.     DCA    BOXSAC
  6871.     JMS I    (FIXRGS        /FIX THE NUMBERS SO IT CAN BE USED
  6872.     TAD    TEMP1        /IF BOXH = 0 THEN BAIL OUT
  6873.     SNA
  6874.     JMP    BOXLEV
  6875.     CIA
  6876.     DCA    BOXH        /BOXH IS OK SO MAKE IT 2'S COMP AND SAVE IT
  6877.     TAD    ACL        /IF BOXW = 0 THEN BAIL OUT
  6878.     SNA
  6879.     JMP    BOXLEV
  6880.     CIA
  6881.     DCA    BOXW        /BOXW IS OK SO MAKE IT 2'S COMP AND SAVE IT
  6882.     JMS I    (CONVRT        /CONVERT THE STRING INTO A NUMBER
  6883.     TAD    ACL        /GET THE CHARACTER
  6884.     AND    IOMASK        /MASK IT TO 7 BIT
  6885.     TAD    SCSLOC        /ADD BITS FOR CHARACTER SET AND ATTRIBUTES
  6886.     DCA    SAVCHR        /AND SAVE IT FOR LATER
  6887.     TAD    BOXH        /BACK UP COUNTERS
  6888.     DCA    BOXH1
  6889.     TAD    BOXW
  6890.     DCA    BOXW1
  6891.     DCA    XR5        /GIVE SCREEN TIME TO SETTLE
  6892.     ISZ    XR5
  6893.     JMP    .-1
  6894.     ISZ    XR5
  6895.     JMP    .-1
  6896.     JMP I    VALID        /RETURN TO CALLING ROUTINE
  6897.  
  6898. SCD,    JMS    VALID        /SETUP AND CHECK ALL DATA
  6899.     CLL CLA CMA
  6900.     TAD    CURCOL        /SETUP COLTMP FOR PRINT
  6901.     DCA    COLTMP
  6902. SCD1,    JMS    XPRNT        /GO AND PRINT THE CHARACTER
  6903.     ISZ    COLTMP        /UPDATE COL POSITION
  6904.     ISZ    BOXW        /ARE WE DONE WITH THE WIDTH
  6905.     JMP    SCD1        /NO GO AGAIN
  6906.     TAD    BOXW1        /YES, RESET WIDTH COUNTER
  6907.     DCA    BOXW
  6908.     CMA
  6909.     TAD    ROWTMP
  6910.     DCA    ROWTMP
  6911.     ISZ    BOXH        /HAS HEIGHT OF BOX BEEN COMPLETED
  6912.     JMP    SCD+1        /NO, GO AT IT AGAIN
  6913. BOXLEV,    CLL CLA            /STANDARD EXIT FOR SETUP, SCD, LCD, LGD
  6914.     TAD    BOXSAC        /RESET SAC COUNTER GOT DAMMAGED IN VALID
  6915.     DCA    SACXR
  6916.     JMS I    (SACP        /THROW A NULL INTO SAC TO MAKE IT HAPPY
  6917.     JMP I    (SETL        /AND LEAVE
  6918.  
  6919. XPRNT,    0            /PANEL MEMORY PRINT ROUTINE VERY FAST
  6920.     CLL CLA
  6921.     TAD    SAVCHR        /GET THE CHARACTER W/ ATTRIBUTES
  6922.     DCA    COLTMP+1    /AND PUT IT IN SCREEN CALLINT ROUTINE
  6923.     PR1            /CALL PANEL MEMORY
  6924. ROWTMP,    0            /FURTHER EXPLAINATION CAN BE OBTAINED
  6925. COLTMP,    0            /IN THE DECMATE HARDWARE MANUAL
  6926.     0
  6927.     7777            /TERMINATE PANEL MEMORY CALL
  6928.     CLL CLA
  6929.     JMP I    XPRNT
  6930.  
  6931.  
  6932. BOXH,    0
  6933. BOXH1,    0
  6934. BOXW,    0
  6935. BOXW1,    0
  6936. BOXSAC,    0
  6937.  
  6938. KSTROK,    JMS I    (FIXRGS
  6939.     TAD    TEMP1
  6940.     CIA
  6941.     SNA            /IF COUNTER IS SET TO 0 DON'T USE TIMER
  6942.     JMP    KEYGCH
  6943.     DCA    TEMP1        /SAVE COUNTER
  6944.     DCA    XR4
  6945. KEY1,    TAD    (7773
  6946.     DCA    XR5
  6947.     ISZ    XR4        /KILL .0155 SECONDS
  6948.     JMP    .-1
  6949.     ISZ    XR5        / TIMES 10 BASE 8 = ABOUT 1/10TH OF A SECOND
  6950.     JMP    .-3
  6951.     KSF            /IS K.B. FLAG SET
  6952.     JMP    NOKEY        /NO, CHECK WAIT LOOP FOR COUNTER TIME OUT
  6953.     JMS I    (CLOOK        /GET THE CHARACTER
  6954.     JMP    KEYGCH
  6955.  
  6956. NOKEY,    ISZ    TEMP1        /IS OUR COUNTER DONE
  6957.     JMP    KEY1        /NO
  6958.     JMP I    (SETL        /YES, EXIT
  6959.  
  6960. KEYGCH,    SNA            /DO WE HAVE A CHARACTER
  6961.     JMS I    (GCH        /NO SO GET ONE (HARD WAIT FOR FIRTS CHARACTER
  6962.     DCA    TEMP2        /WE GOT A CHARACTER NOW.
  6963.     TAD    TEMP2        /PUT CHARACTER INTO SAC
  6964.     JMS I    (SACP
  6965.     TAD    TEMP2        /NOW CHECK FOR AN ESC CHARACTER
  6966.     TAD    (-33
  6967.     SNA CLA
  6968.     JMP    KEY2        /GOTO ESC ROUTINE (ESC SEQ. NEVER ECHO)
  6969.     TAD    ACL        /DO WE ECHO THE CHARACTER
  6970.     SNA CLA            /0 AC SAY'S DON'T ECHO
  6971.     JMP I    (SETL        /NO ECHO SO LEAVE
  6972.     TAD    TEMP2
  6973.     JMS I    PPCH        /ECHO THE CHARACTER
  6974.     JMP I    (SETL        /LEAVE
  6975.  
  6976. KEY2,    KSF            /SKIP ON K.B. FLAG
  6977.     JMP I    (SETL        /DONE WHEN NOT SET
  6978.     KRB
  6979.     JMS I    (SACP
  6980.     TAD    (-1000        / Time out to give terminal time to
  6981.     DCA    XR4        / Set up next character in escape sequence
  6982.     ISZ    XR4
  6983.     JMP    .-1
  6984.     JMP    KEY2
  6985.  
  6986.     PAGE
  6987.  
  6988.  
  6989. SLEEP,    CLL CLA
  6990.     JMS I    (FIXRGS        /NORMALIZE THE VALUE AND LEAVE IT IN TEMP1
  6991.     TAD    TEMP1        /GET THE VALUE FOR LENGTH OF SLEEP
  6992.     SNA            /IS IT ZERO
  6993.     JMP I    PILOOP        /SURE IS GET OUT
  6994.     CMA            /IT'S OK SET UP COUNTER
  6995.     DCA    TEMP1        /SAVE IT WHERE WE FOUND IT
  6996. SLEEP1,    CLA            /A MUST WHEN WE RETURN AGAIN
  6997.     TAD    COUNT
  6998.     DCA    COUNT2        /SET UP COUNTERS
  6999.     ISZ    COUNT1        /TIMER
  7000.     JMP    .-1        /KILL .0155 SECONDS
  7001.     ISZ    COUNT2        / X 100  BASE 8
  7002.     JMP    .-3        /IS APPROX. 1/10TH SECOND
  7003.     JMS I    (CTCCHK        /LOOK FOR A CTRL C
  7004. SLEEP2,    ISZ    TEMP1        /ARE WE DONE
  7005.     JMP    SLEEP1        /NO DO IT AGAIN
  7006.     JMP I    PILOOP        /ALL DONE TIME TO LEAVE
  7007.  
  7008. COUNT,    7773
  7009. COUNT1,    0
  7010. COUNT2,    0
  7011.  
  7012. ERR,    TAD    ERRNUM        /GET ERROR NUMBER
  7013.     DCA    ACH        /FLOAT NUMBER IN HORD
  7014.     DCA    ACL
  7015.     DCA    AC1
  7016.     TAD    (13
  7017.     DCA    ACX
  7018.     JMS I    PFFNOR
  7019.     JMP I    PILOOP
  7020.  
  7021. ERL,    TAD    ERLINH
  7022.     RTR
  7023.     RTR
  7024.     JMS    ERL1
  7025.     TAD    ERLINH
  7026.     JMS    ERL1
  7027.     TAD    ERLINL
  7028.     RTL
  7029.     RTL
  7030.     RAL
  7031.     JMS    ERL1
  7032.     TAD    ERLINL
  7033.     RTR
  7034.     RTR
  7035.     JMS    ERL1
  7036.     TAD    ERLINL
  7037.     AND    O17
  7038.     TAD    K60
  7039.     JMS I    (SACP
  7040.     TAD    SACXR
  7041.     CIA
  7042.     TAD    PSACM1
  7043.     DCA    SACLEN
  7044.     TAD    (160
  7045.     DCA    INSAV
  7046.     JMP I    (FUNC2I
  7047.  
  7048. ERL1,    0
  7049.     AND    O17
  7050.     TAD    K60
  7051.     JMS I    (SACP
  7052.     JMP I    ERL1
  7053.  
  7054. LCD,    JMS I    (VALID        /SET UP AND CHECK ALL DATA
  7055.     JMS I    (XPRNT        /PRINT BOTTOM LINE OF BOX
  7056.     ISZ I    (COLTMP        /MOVE COL POSITION RIGHT 1
  7057.     ISZ I    (BOXW        /ARE WE DONE
  7058.     JMP    LCD+1        /NO, GO AGAIN
  7059. LCD1,    CLL CLA CMA        /MOVE
  7060.     TAD I    (ROWTMP        /ROW POSITION
  7061.     DCA I    (ROWTMP        /UP ONE
  7062.     ISZ I    (BOXH        /ARE SIDES DONE
  7063.     JMP    .+2        /NO
  7064.     JMP    LCD2        /YES
  7065.     CMA            /CURCOL IS ALWAYS 1 TO BIG SO ADD A -1
  7066.     TAD    CURCOL        /NOW PRINT CHARACTER ON LEFT SIDE
  7067.     DCA I    (COLTMP
  7068.     JMS I    (XPRNT
  7069.     CLL CLA IAC RAL
  7070.     TAD I    (BOXW1
  7071.     CIA
  7072.     TAD    CURCOL
  7073.     DCA I    (COLTMP
  7074.     JMS I    (XPRNT
  7075.     JMP    LCD1
  7076.  
  7077. LCD2,    CLL CLA IAC
  7078.     TAD I    (ROWTMP
  7079.     DCA I    (ROWTMP
  7080.     CLL CLA CMA
  7081.     TAD    CURCOL
  7082.     DCA I    (COLTMP
  7083. LCD3,    JMS I    (XPRNT
  7084.     ISZ I    (COLTMP
  7085.     ISZ I    (BOXW1
  7086.     JMP    LCD3
  7087.     JMP I    (BOXLEV
  7088.  
  7089.     PAGE
  7090.  
  7091. SGR,    JMS I    (FIX23        /FIX THE NUMBER THAT WAS SENT
  7092.     CLL CLA
  7093.     TAD    ACL
  7094.     AND    (17
  7095.     BSW
  7096.     RTL
  7097.     MQL            /PUT AC INTO MQ CLEAR AC
  7098.     TAD    SCSLOC
  7099.     AND    (200
  7100.     MQA            /OR AC AND MQ RESULT IN AC
  7101.     DCA    SCSLOC
  7102.     JMS I    (ESCBRK        /PRINT AN ESC [
  7103.     TAD    K60        /SHUT OFF ALL ATTRIBUTES
  7104.     JMS I    (SACP
  7105.     TAD    ACL
  7106.     AND    (17
  7107.     RAR
  7108.     SZL
  7109.     JMS     SEVEN7
  7110.     RAR
  7111.     SZL
  7112.     JMS    ONE1
  7113.     RAR
  7114.     SZL
  7115.     JMS    FOUR4
  7116.     RAR
  7117.     SZL CLA
  7118.     JMS    FIVE5
  7119.     TAD    (155        /SMALL M
  7120. SGRLEV,    JMS I    (SACP
  7121.     JMP I    (SETL
  7122.  
  7123. SEVEN7,    0
  7124.     DCA    SAVCHR
  7125.     TAD    (67
  7126.     JMS    SEMI
  7127.     TAD    SAVCHR
  7128.     JMP I    SEVEN7
  7129.  
  7130. ONE1,    0
  7131.     DCA    SAVCHR
  7132.     TAD    (61
  7133.     JMS    SEMI
  7134.     TAD    SAVCHR
  7135.     JMP I    ONE1
  7136.  
  7137. FOUR4,    0
  7138.     DCA    SAVCHR
  7139.     TAD    (64
  7140.     JMS    SEMI
  7141.     TAD    SAVCHR
  7142.     JMP I    FOUR4
  7143.  
  7144. FIVE5,    0
  7145.     TAD    (65
  7146.     JMS    SEMI
  7147.     JMP I    FIVE5
  7148.  
  7149. SEMI,    0
  7150.     DCA    XR5
  7151.     TAD    (73        /SEMICOLON
  7152.     JMS I    (SACP
  7153.     TAD    XR5
  7154.     JMS I    (SACP
  7155.     JMP I    SEMI
  7156.  
  7157. SSI,    TAD    V278FG        /GET SYSTEM TYPE
  7158.     AND    K4        /IS IT A VT278
  7159.     SNA CLA
  7160.     JMP    SSILEV        /NO GETOUT
  7161.     JMS I    (FIX23        /YES, OK
  7162.     6130            / clkset
  7163.     6131            / cklskp
  7164.     JMP    SSIDM1
  7165.  
  7166. SSIDM2,    TAD    ACL        / Get value passed
  7167.     SNA CLA
  7168.     CLL CLA IAC
  7169.     PR3
  7170.      0001
  7171.      7777
  7172.     JMP    SSILEV
  7173.  
  7174. SSIDM1,    6136            / Clear DMi clock flag
  7175.     TAD    (-20        /SET AC > -17
  7176.     PR3            /SET SCREEN INTENSITY TO 0
  7177.     5161
  7178.     CLL CLA
  7179.     TAD    ACL        /GET VALUE PASSED
  7180.     AND    (17
  7181.     PR3            /SET NEW SCREEN INTENSITY
  7182.     5161
  7183.  
  7184. SSILEV,    CLL CLA
  7185.     JMS I    (SACP        /THROW NULL INTO SAC
  7186.     JMP I    (SETL
  7187.  
  7188.     PAGE
  7189.  
  7190.  
  7191. LGD,    JMS I    (VALID
  7192.     TAD I    (BOXH
  7193.     IAC            /IS HEIGHT VALUE LESS THAN 2
  7194.     SNA CLA
  7195.     JMP I    (BOXLEV        /YES GET OUT
  7196.     TAD I    (BOXW
  7197.     IAC            /IS WIDTH VALUE LESS THAN 2
  7198.     SNA CLA
  7199.     JMP I    (BOXLEV        /YES GET OUT
  7200.     TAD    ACL        /WHAT TYPE OF BOX 0, 1, 2?
  7201.     AND    (3
  7202.     SNA            /IS IT TYPE 0
  7203.     JMP I    (TYPE0        /YES
  7204.     TAD    (-1        /NO, IS IT TYPE1
  7205.     SNA
  7206.     JMP I    (TYPE1        /YES
  7207.     TAD    (-1        /NO, IS IT TYPE2
  7208.     SNA CLA
  7209.     JMP I    (TYPE2        /YES
  7210.     JMP I    (BOXLEV        /NO CORRECT VALUE WAS SELECTED SO GET OUT
  7211.  
  7212. LGDGO,    TAD    CHRTR1        /PRINT LOWER LEFT CORNER
  7213.     TAD    XR5        /ADD GRAPHIC FEATURES
  7214.     DCA    SAVCHR
  7215.     JMS I    (XPRNT
  7216.     TAD    CHRTR2        /SETUP CHARACTER FOR BOTTOM
  7217.     TAD    XR5
  7218.     DCA    SAVCHR
  7219.     CLL CLA IAC
  7220.     TAD I    (BOXW1
  7221.     DCA I    (BOXW
  7222. LGDGO1,    ISZ I    (BOXW
  7223.     JMP    .+2
  7224.     JMP    LGDGO7
  7225.     ISZ I    (COLTMP        /UPDATE COL POSITION
  7226.     JMS I    (XPRNT
  7227.     JMP    LGDGO1
  7228. LGDGO7,    ISZ I    (COLTMP
  7229.     TAD    CHRTR3        /LOWER RIGHT CORNER
  7230.     TAD    XR5
  7231.     DCA    SAVCHR
  7232.     JMS I    (XPRNT
  7233. LGDGO2,    CLL CLA CMA
  7234.     TAD I    (ROWTMP        /MOVE ROW POSITION UP ONE
  7235.     DCA I    (ROWTMP
  7236.     ISZ I    (BOXH        /ARE SIDES DONE
  7237.     JMP    .+2
  7238.     JMP    LGDGO3
  7239.     TAD    CHRTR8        /PRINT LEFT SIDE
  7240.     TAD    XR5
  7241.     DCA    SAVCHR
  7242.     CMA
  7243.     TAD    CURCOL
  7244.     DCA I    (COLTMP
  7245.     JMS I    (XPRNT
  7246.     TAD    CHRTR4        /PRINT RIGHT SIDE
  7247.     TAD    XR5
  7248.     DCA    SAVCHR
  7249.     CLL CLA IAC RAL
  7250.     TAD I    (BOXW1
  7251.     CIA
  7252.     TAD    CURCOL
  7253.     DCA I    (COLTMP
  7254.     JMS I    (XPRNT
  7255.     JMP    LGDGO2
  7256.  
  7257. LGDGO3,    CLL CLA IAC
  7258.     TAD I    (ROWTMP
  7259.     DCA I    (ROWTMP
  7260.     CMA
  7261.     TAD    CURCOL
  7262.     DCA I    (COLTMP
  7263.     TAD    CHRTR7        /PRINT TOP LEFT CORNER
  7264.     TAD    XR5
  7265.     DCA    SAVCHR
  7266.     JMS I    (XPRNT
  7267.     TAD    CHRTR6        /PRINT TOP
  7268.     TAD    XR5
  7269.     DCA    SAVCHR
  7270.     CLL CLA IAC
  7271.     TAD I    (BOXW1
  7272.     DCA I    (BOXW
  7273. LGDGO4,    ISZ I    (COLTMP
  7274.     ISZ I    (BOXW
  7275.     JMP    .+2
  7276.     JMP    LGDGO5
  7277.     JMS I    (XPRNT
  7278.     JMP    LGDGO4
  7279.  
  7280. LGDGO5,    TAD    CHRTR5        /PRINT TOP RIGHT CORNER
  7281.     TAD    XR5
  7282.     DCA    SAVCHR
  7283.     JMS I    (XPRNT
  7284.     JMP I    (BOXLEV
  7285.  
  7286. CHRTR1,    0            /L.F. CORNER
  7287. CHRTR2,    0            /BOTTOM
  7288. CHRTR3,    0            /B.R. CORNER
  7289. CHRTR4,    0            /R. SIDE
  7290. CHRTR5,    0            /T.R. CORNER
  7291. CHRTR6,    0            /TOP
  7292. CHRTR7,    0            /T.L. CORNER
  7293. CHRTR8,    0            /LEFT SIDE
  7294.  
  7295.     PAGE
  7296. TYPE0,    CLL CLA            /SET UP VALUES FOR THIS TYPE OF BOX
  7297.     TAD    (16
  7298.     DCA I    (CHRTR1
  7299.     TAD    (22
  7300.     DCA I    (CHRTR2
  7301.     TAD    (13
  7302.     DCA I    (CHRTR3
  7303.     TAD    (31
  7304.     DCA I    (CHRTR4
  7305.     TAD    (14
  7306.     DCA I    (CHRTR5
  7307.     TAD    (22
  7308.     DCA I    (CHRTR6
  7309.     TAD    (15
  7310.     DCA I    (CHRTR7
  7311.     TAD    (31
  7312.     DCA I    (CHRTR8
  7313.     TAD    SCSLOC
  7314.     AND    (7577
  7315.     DCA    XR5
  7316.     JMP I    (LGDGO
  7317.  
  7318. TYPE1,    CLL CLA            /SET UP VALUES FOR THIS TYPE OF BOX
  7319.     TAD    (11
  7320.     DCA I    (CHRTR1
  7321.     TAD    (7
  7322.     DCA I    (CHRTR2
  7323.     TAD    (10
  7324.     DCA I    (CHRTR3
  7325.     TAD    (5
  7326.     DCA I    (CHRTR4
  7327.     TAD    (12
  7328.     DCA I    (CHRTR5
  7329.     TAD    (6
  7330.     DCA I    (CHRTR6
  7331.     TAD    (13
  7332.     DCA I    (CHRTR7
  7333.     TAD    (4
  7334.     DCA I    (CHRTR8
  7335.     TAD    SCSLOC
  7336.     AND    (7577
  7337.     TAD    (200
  7338.     DCA    XR5
  7339.     JMP I    (LGDGO
  7340.  
  7341. TYPE2,    CLL CLA            /SET UP VALUES FOR THIS TYPE OF BOX
  7342.     TAD    (6
  7343.     DCA I    (CHRTR1
  7344.     TAD    (6
  7345.     DCA I    (CHRTR2
  7346.     TAD    (6
  7347.     DCA I    (CHRTR3
  7348.     TAD    (36
  7349.     DCA I    (CHRTR4
  7350.     TAD    (34
  7351.     DCA I    (CHRTR5
  7352.     TAD    (34
  7353.     DCA I    (CHRTR6
  7354.     TAD    (34
  7355.     DCA I    (CHRTR7
  7356.     TAD    (36
  7357.     DCA I    (CHRTR8
  7358.     TAD    SCSLOC
  7359.     AND    (7577
  7360.     TAD    (200
  7361.     DCA    XR5
  7362.     JMP I    (LGDGO
  7363.  
  7364.  
  7365. SCS,    JMS I    (FIX23
  7366.     CLL CLA
  7367.     TAD    ACL        /GET THE VALUE SENT
  7368.     AND    (1
  7369.     RAR            /PUT VALUE INTO LINK
  7370.     TAD    SCSLOC        /GET CHARACTER ATTRIBUTES
  7371.     AND    (7400        /SAVE ALL ATTRIBUTES EXCEPT GRAPHICS CHAR.
  7372.     SZL
  7373.     TAD    (200
  7374.     DCA    SCSLOC        /SAVE IT WHERE IT WON'T GET DAMMAGED
  7375.     JMS I    (SACP        /THROW A NULL INTO SAC TO MAKE IT HAPPY
  7376.     JMP I    (SETL        /TIME TO LEAVE
  7377.  
  7378.     PAGE
  7379. ////////////////////////////////////////////
  7380. ////////////////////////////////////////////
  7381. //////////    STORE AND RECALL    //////////
  7382. //////////        BASIC.SR        //////////
  7383. ////////////////////////////////////////////
  7384. ////////////////////////////////////////////
  7385.  
  7386.  
  7387.     RELOC
  7388.     FIELD 3
  7389.     *5000
  7390.     RELOC OVERLAY    
  7391.     VERSON&77^100+SUBVSR+60
  7392. OVDISP,    TAD    V278FG        /GET THE SYSTEM TYPE
  7393.     AND    K4        /MASK OUT THE VT278 BIT
  7394.     SNA CLA            /IS IT A VT278
  7395.     JMP I    PILOOP        /NO GET OUT
  7396.     JMS I    (FBITGT        /YES, OK TO USE STORE AND RECALL
  7397.     TAD    JMPSR
  7398.     DCA    .+1
  7399.     HLT
  7400. JMPSR,    JMP I    .+1
  7401.  
  7402.     /JUMP TABLE
  7403.  
  7404.     XSTORE    /FUNCTION BITS    = 000
  7405.     XRECAL    /        = 020
  7406.     CALL    /        = 040
  7407.  
  7408. XSTORE,    DCA    XR5        /SET UP FOR 40MS DELAY
  7409.     ISZ    XR5
  7410.     JMP    .-1        /KILL .0155 SECONDS TWICE
  7411.     ISZ    XR5        /REQUIRED FOR VT278 TO GIVE TIME
  7412.     JMP    .-1        /FOR THE SCREEN TO SETTLE ON PR CALLS
  7413.     TAD    K4        /IS THERE A FILEV OUT STANDING
  7414.     AND I    IOTHDR
  7415.     SZA CLA            /SKIP IF AC = 0
  7416. H7,    JMS I    PERROR        /A TENTITIVE FILE ALREADY OPEN
  7417.     JMS I    (INQUIR        /LOOK UP DEVICE HANDLER
  7418.     JMS I    (ENTER        /FIND LARGEST FREE SPACE ON DISK
  7419.     CLL CLA CMA
  7420.     TAD    (BUFFER        /GET START OF BUFFER ADDRESS
  7421.     DCA    XR5        /AND SAVE IT
  7422.     DCA    ROW        /SET INITIAL ROW ADDRESS
  7423.     DCA    COLMN        /SET INITIAL COL ADDRESS
  7424.     DCA    BLKCNT        /SET INITIAL BLOCK COUNT
  7425. STOR1,    JMS    GETCHR        /GET A CHARACTER FROM THE SCREEN
  7426.     DCA    SAVCHR
  7427.     TAD    SAVCHR
  7428.     SNA CLA            /IS THE CHARACTER A NULL (000)
  7429.     JMP    UPDATE        /YES, UPDATE COUNTERS AND GET ANOTHER CHAR.
  7430.     TAD    (-40        /IS THE CHARACTER A SPACE
  7431.     SNA CLA
  7432.     JMP    UPDATE        /YES, GO GET ANOTHER CHARACTER
  7433.     TAD    ROW        /IT'S OK OUTPUT ROW, COL, CHAR
  7434.     DCA I    XR5        /INTO BUFFER AREA
  7435.     TAD    COLMN
  7436.     DCA I    XR5
  7437.     TAD    SAVCHR
  7438.     DCA I    XR5
  7439.     TAD    (BUFEND        /GET ENDING ADDRESS OF BUFFER
  7440.     CIA
  7441.     TAD    XR5        /GET CURRENT BUFFER ADDRESS
  7442.     SZA CLA            /CHECK IF BUFFER IS FULL
  7443.     JMP    UPDATE        /NOPE, UPDATE COUNTERS, AND GET ANOTHER CHAR.
  7444.     CMA            /YES, OUTPUT A 7777 (FILLS LAST FREE LOC)
  7445.     DCA I    XR5
  7446.     TAD I    (LENGTH        /GET REMAINING FREE BLOCKS ON THE DISK
  7447.     SNA CLA            /DO WE STILL HAVE ROOM ON THE DISK
  7448. H8,    JMS I    PERROR        /NO!! TIME TO ABORT OPERATION
  7449.     ISZ I    (LENGTH        /YES, UPDATE FREE BLOCK LENGTH COUNT
  7450.     NOP            /WE WILL SKIP EVENTUALLY
  7451.     JMS I    (WRITE        /WRITE BUFFER OUT
  7452.     CLL CLA CMA        /AC=-1
  7453.     TAD    (BUFFER        /RESET POINTER TO BUFFER
  7454.     DCA    XR5
  7455. UPDATE,    ISZ    COLMN        /INCREMENT COL POSITION
  7456.     TAD    COLMN
  7457.     TAD    (-120        /IS CURRENT COL DONE?
  7458.     SZA CLA
  7459.     JMP    STOR1        /NO GET ANOTHER CHARACTER
  7460.     DCA    COLMN        /YES, RESET COL POSITION
  7461.     ISZ    ROW        /UPDATE FOR NEXT ROW
  7462.     TAD    ROW
  7463.     TAD    (-30        /HAVE WE LOOKED AT ALL THE ROWS?
  7464.     SZA CLA
  7465.     JMP    STOR1        /NO, GET ANOTHER CHARACTER
  7466.     TAD    (BUFFER        /YES, TIME TO DO SOME CHECKS
  7467.     CIA            /2'S COMP OF BUFFER ADDRESS
  7468.     IAC
  7469.     TAD    XR5        /GET CURRENT POINTER TO BUFFER LOCATION
  7470.     SZA CLA            /ARE WE AT THE BEGINING OF THE BUFFER
  7471.     JMP    OK        /NO, SKIP THE NEXT PART
  7472.     DCA I    XR5        /YES, NEED TO OUTPUT A ROW, COL, CHAR TO MAKE
  7473.     DCA I    XR5        /THE VT278 HAPPY.  A PR1 DOESN'T WORK TO WELL
  7474.     DCA I    XR5        /WHEN DIRECTLY FOLLOWED BY A 7777
  7475. OK,    CMA
  7476.     DCA I    XR5        /ALL DONE WRITE A 7777 INTO BUFFER
  7477.     TAD    (JMP I PILOOP    /JMP I 0002 TO GET BACK TO PROGRAM
  7478.     DCA I    XR5        /AFTER PR1 IS COMPLETE
  7479.     TAD I    (LENGTH        /GET FREE BLOCK SPACE
  7480.     SMA CLA            /IF SPACE LEFT WRITE OUT DATA
  7481.     JMP    H8        /OTHERWISE ERROR
  7482.     JMS I    (WRITE        /LETS DO IT TO IT, WRITE OUT BUFFER
  7483.     JMS I    (XCLOSE        /CLOSE THE FILE TO MAKE IT PERMINANT
  7484.     JMP I    PILOOP        /ALL DONE GET OUT
  7485.  
  7486. GETCHR,    0            /GET A CHARACTER FROM PANEL MEMORY
  7487.     CLL CLA            /SET UP THE PR0 COMMAND TO READ PANEL MEMORY
  7488.     TAD    ROW        /GET CURRENT ROW COUNT
  7489.     DCA    X
  7490.     TAD    COLMN        /GET CURRENT COL COUNT
  7491.     DCA    Y
  7492.     PR0            /GET CHAR FROM SCREEN POSITION ROW,COL
  7493. X,    0
  7494. Y,    0
  7495.     JMP I    GETCHR        /LEAVE WITH THE CHARACTER IN AC
  7496.  
  7497. ROW,    0
  7498. COLMN,    0
  7499. BLKCNT,    0
  7500.  
  7501.     PAGE
  7502.  
  7503.  
  7504. CALL,    CLL CLA
  7505.     JMS I    (FIXRGS        /FIX NUMBER PASSED
  7506.     JMS    INQUIR        /SET UP DEV AND FILE NAME
  7507.     JMS    LOOKUP        /DOES FILE EXIST
  7508.     TAD    FILADD        /YUP
  7509.     IAC            /SKIP CCB
  7510.     DCA I    (CALL3        /SAVE IT IN HANDLER CALL
  7511.     STA            /SET NON VALID OVERLAY #
  7512.     DCA I    (OVRLAY
  7513.     JMS I    (PSWAP        /SWAP SYSTEM BACK IN
  7514.     JMP I    (CALL1        /LOAD USER OVERLAY
  7515.  
  7516. XRECAL,    CLL CLA
  7517.     DCA    XR5        /SET UP FOR 40MS DELAY
  7518.     ISZ    XR5
  7519.     JMP    .-1        /KILL .0155 SECONDS TWICE
  7520.     ISZ    XR5        /REQUIRED FOR VT278 TO GIVE TIME
  7521.     JMP    .-1        /FOR THE SCREEN TO SETTLE ON PR CALLS
  7522.     DCA I    (BLKCNT        /INIT BLOCK COUNTER
  7523.     JMS    INQUIR        /LOOK UP DEVICE HANDLER
  7524.     JMS    LOOKUP        /LOOK UP FILE ON DISK
  7525. READ,    CLL CLA
  7526.     TAD I    (BLKCNT        /BUILD BLOCK ADDRESS. BLKCNT=# OF BLOCKS READ
  7527.     TAD    FILADD        /ADD THIS TO THE STARTING BLOCK OF FILE
  7528.     DCA    INBLK        /AND SAVE IT FOR HANDLER READ
  7529.     CIF CDF 0        /CALL HANDLER
  7530.     JMS I    DEVENT        /JMS TO POINTER OF HANDLER ENTRY POINT
  7531.     0200            /READ ONE BLOCK
  7532.     BUFFER            /AND DUMP THE DATA STARTING AT THIS ADDRESS
  7533. INBLK,    0            /BLOCK ADDRESS OF DISK TO BE READ
  7534. HN,    JMS I    PERROR        /BAD READ DON'T TOLLERATE ANY ERRORS
  7535.     ISZ I    (BLKCNT        /UPDATE BLOCK READ COUNTER
  7536.     JMP I    (PANMEM        /DUMP THIS DATA ONTO THE SCREEN
  7537.                 /PANEM WILL RETURN TO READ IF MORE DATA IS
  7538.                 /IS AVAILABLE, OR RETURN TO PILOOP IF ALL DONE
  7539.  
  7540. INQUIR,    0            /LOOK UP A DEVICE HANDLER
  7541.     CLL CLA
  7542.     DCA    DEVENT        /ZERO OUT SO WE WILL IF HANDLER WASN'T IN
  7543.     JMS I    (NAM        /GET DEVN:FILE.EX
  7544.     2311            /DEFAULT EXTENSION  =.SI
  7545. H6,    JMS I    PERROR        /FORMAT OF NAME STRING BAD
  7546.     JMS I    (PSWAP        /RESTORE FIELD 1 (THIS IS ONE OF THOSE HOOKS
  7547.     CDF            /THAT YOUR FATHER WARNED YOU ABOUT)
  7548.     CIF 10
  7549.     JMS I    (USR        /LET THE USR'S DO THEIR THING
  7550.     12
  7551. DEV1,    0
  7552. DEV2,    0            /GETS DEVICE NUMBER
  7553. DEVENT,    0            /GETS ENTRY ADDRESS OF HANDLER
  7554. H1,    JMS I    PERROR        /ERROR BAIL OUT
  7555.     JMS I    (PSWAP
  7556.     TAD    DEVENT        /DID WE FIND A HANDLER ADDRESS
  7557.     SNA CLA
  7558.     JMP    H1        /NO ERROR
  7559.     JMP I    INQUIR        /SURE DID 
  7560.  
  7561.  
  7562. ENTER,    0            /CREATE A TENTIVE FILE ON THE DISK
  7563.     TAD    (XNAME        /GET STARTING LOC OF FILE NAME
  7564.     DCA    OPNBLK        /SAVE IT IN ENTER CALL
  7565.     JMS I    (PSWAP        /DO SOME FIELD SWAPPING
  7566.     TAD    DEVENT-1    /GET DEVICE NUMBER
  7567.     CDF
  7568.     CIF 10
  7569.     JMS I    (USR        /DO SOME USR CALLS
  7570.     3
  7571. OPNBLK,    0            /BLOCK ADDRESS
  7572. LENGTH,    0            /2'S COMP OF BLOCK LENGTH
  7573. H2,    JMS I    PERROR        /ERROR
  7574.     CLL CLA
  7575.     JMS I    (PSWAP        /RESTORE FIELD STUFF
  7576.     JMP I    ENTER
  7577.  
  7578. LOOKUP,    0            /FIND A FILE ON THE DISK
  7579.     CLL CLA
  7580.     TAD    (XNAME        /POINTER TO NAME STRING
  7581.     DCA    FILADD        /SAVE IT FOR CALL
  7582.     JMS I    (PSWAP        /SWAP FIELDS
  7583.     TAD    DEV2        /GET THE DEVICE NUMBER
  7584.     CDF
  7585.     CIF 10
  7586.     JMS I    (USR        /CALL USR ROUTINES
  7587.     2
  7588. FILADD,    0
  7589. FILLEN,    0
  7590. H3,    JMS I    PERROR        /ERROR
  7591.     CLL CLA
  7592.     JMS I    (PSWAP
  7593.     JMP I    LOOKUP
  7594.  
  7595. WRITE,    0            /WRITE OUT 1 BLOCK OF DATA
  7596.     CLL CLA
  7597.     TAD    OPNBLK        /STARTING BLOCK ADDRESS
  7598.     TAD I    (BLKCNT        /PLUS BLOCK COUNT
  7599.     DCA    OUTBLK        /SAVE BLOCK ADDRESS FOR DISK WRITE
  7600.     CDF            /HANDLER CALL
  7601.     CIF 0            /CALL HANDLER
  7602.     JMS I    DEVENT
  7603.     4200            /WRITE OUT 1 BLOCK OF DATA
  7604.     BUFFER            /POINTER TO BUFFER ADDRESS
  7605. OUTBLK,    0
  7606.     JMP    HN        /ERROR
  7607.     ISZ I    (BLKCNT        /UPDATE BLOCK COUNT
  7608.     JMP I    WRITE
  7609.  
  7610.  
  7611. XCLOSE,    0            /MAKE OUR TEMPORY FILE A PERMINANT ONE
  7612.     TAD I    (BLKCNT        /GET BLOCK COUNT
  7613.     DCA    BLOCKS
  7614.     JMS I    (PSWAP        /SWAP FIELD DATA
  7615.     TAD    DEV2        /GET DEVICE NUMBER
  7616.     CDF
  7617.     CIF 10
  7618.     JMS I    (USR        /CALL THE USR ROUTINES
  7619.     4
  7620.     XNAME
  7621. BLOCKS,    0
  7622. H5,    JMS I    PERROR
  7623.     CLL CLA
  7624.     JMS I    (PSWAP        /SWAP BACK FIELD STUFF
  7625.     JMP I    XCLOSE        /OUR FILE IS NOW ON THE DISK
  7626.  
  7627.     PAGE
  7628.  
  7629.     /ROUTINE TO PARSE A FILE NAME OF THE FORM "DEVN:FILENM.EX"
  7630.     /IF DEVN IS SPECIFIED IT WILL BE STRIPPED AND SYS WILL BE USED
  7631.     /CALL+1 = DEFAULT EXTENSION, ASSUMES DEFAULT DEVICE DSK:
  7632.     /RETURN TO CALL+2 IF BAD FILE NAME SYNTAX
  7633.     /RETURN TO CALL+3 IF GOT GOOD NAME
  7634.  
  7635. NAM,    0
  7636.     TAD I    NAM        /GET DEFAULT EXT
  7637.     ISZ    NAM
  7638.     DCA    XEXT        /SAVE IN BUFFER
  7639.     STA            /SET SOME SWITCHES
  7640.     DCA    COLSW
  7641.     STA
  7642.     DCA    DOTSW
  7643.     TAD    PSACM1        /SET POINTER TO SAC NOW
  7644.     DCA    SACXR
  7645. GOTDVC,    TAD    (2331        /NOW GET DEFAULT DEVICE - SYS:
  7646.     DCA I    (DEV1
  7647.     TAD    (2300
  7648.     DCA I    (DEV2
  7649.     TAD    (-4        /SET A WORD COUNT
  7650.     DCA    XR1
  7651.     TAD    (XNAME        /POINT AT NAME BUFFER
  7652.     DCA    TEMP2
  7653.     DCA    XNAME        /ZERO OUT THE NAME NOW
  7654.     DCA    XNAME+1
  7655.     DCA    XNAME+2
  7656. NAMGET,    JMS    NGETCH        /GET A CHAR
  7657.     ISZ    XR1        /TEST COUNT
  7658.     SKP
  7659.     JMP I    NAM        /ERROR RETURN IF PAST FIELD SIZE
  7660.     TAD    AC0        /OK, GET CHAR
  7661.     AND    O77        /6 BITS
  7662.     CLL RTL
  7663.     RTL
  7664.     RTL            /SHIFT LEFT
  7665.     DCA I    TEMP2        /PUT IN BUFFER
  7666.     JMS    NGETCH        /GET ANOTHER CHAR
  7667.     TAD    AC0
  7668.     AND    O77        /6 BITS
  7669.     TAD I    TEMP2        /ADD TO PREV ONE
  7670.     DCA I    TEMP2
  7671.     ISZ    TEMP2        /UP TO NEXT WORD
  7672.     JMP    NAMGET        /DO NEXT WORD
  7673. HAVCOL,    ISZ    COLSW        /SEE IF : SEEN YET
  7674.     JMP I    NAM        /YES, A BADDY
  7675.     TAD    XNAME+2        /SEE IF DEV GT 4 CHARS
  7676.     SNA CLA
  7677.     TAD    XNAME        /ANY DEV THERE
  7678.     SNA CLA
  7679.     JMP I    NAM        /NO, NO GOOD
  7680.     JMP    GOTDVC        /STRIP OFF DEVICE AND GET FILE NAME
  7681. DECPNT,    ISZ    DOTSW        /SEE IF . SEEN YET
  7682.     JMP I    NAM        /YES, ERROR
  7683.     ISZ    COLSW        /DISALLOW FURTHER : TOO
  7684.     NOP
  7685.     TAD    (XEXT        /POINT AT EXTENSION FIELD NOW
  7686.     DCA    TEMP2
  7687.     DCA    XEXT        /ZERO OUT THE DEFAULT EXTENSION
  7688.     AC7776            /ALLOW ONLY ONE WORD
  7689.     DCA    XR1
  7690.     JMP    NAMGET        /GET THE EXTENSION ALREADY
  7691. EONAME,    STA
  7692.     TAD    IOTDEV        /ALL SET, MOVE THE NAME INTO CURRENT IOTABLE
  7693.     DCA    XR1
  7694.     TAD    (DEV1-1
  7695.     DCA    XR2
  7696.     TAD    (-6        /6 WORDS
  7697.     DCA    AC0
  7698.     TAD I    XR2        /GET A PAIR OF CHARS
  7699.     DCA I    XR1        /AND STORE THEM
  7700.     ISZ    AC0
  7701.     JMP    .-3
  7702.     ISZ    NAM        /TAKE SUCCESSFUL RETURN
  7703.     JMP I    NAM
  7704. NGETCH,    0
  7705.     TAD    SACLEN        /SEE IF ANYTHING IN SAC
  7706.     SNA CLA
  7707.     JMP    EONAME        /END OF NAME IF NO
  7708.     ISZ    SACLEN
  7709.     NOP
  7710.     CDF    10
  7711.     TAD I    SACXR        /GET A CHAR
  7712.     CDF
  7713.     DCA    AC0        /SAVE IT
  7714.     TAD    AC0
  7715.     TAD    (-56        /CHECK IF .
  7716.     SNA CLA
  7717.     JMP    DECPNT        /JMP IF YES
  7718.     CLL            /NOW CHECK IF ALPHANUMERIC
  7719.     TAD    AC0
  7720.     TAD    (-60
  7721.     SMA
  7722.     TAD    (60-72
  7723.     SNA
  7724.     JMP    HAVCOL        /JMP IF HAPPENS TO BE :
  7725.     SMA
  7726.     TAD    (72-101
  7727.     SMA
  7728.     TAD    (101-133
  7729.     SNL CLA            /SKP IF A-Z OR 0-9
  7730.     JMP I    NAM        /ELSE WORNG CHAR
  7731.     JMP I    NGETCH
  7732.  
  7733. COLSW,    0
  7734. DOTSW,    0
  7735. XNAME,    ZBLOCK 3
  7736. XEXT,    0
  7737.  
  7738.     PAGE
  7739. /******************** BUFFER AREA FOR STORE AND RECALL *******************
  7740. / IF THIS BUFFER EXCEEDS THE ENDING OVERLAY ADDRESS YOUR DISK WILL PAY FOR
  7741. / YOUR GRAVE MISTAKE.  SO PLEASE TAKE HEED AND HANDLE WITH CARE.
  7742.  
  7743. /                I THANK YOU AND YOUR SOFTWARE THANKS YOU.
  7744.  
  7745.  
  7746. PANMEM,    PR1            /VT278 PR1 INSTRUCTION
  7747. BUFFER,    ZBLOCK 400        /BUFFER CONTAINS ROL;COL;DATA  TERMINATED
  7748.     BUFEND=.-2        /BY A 7777 IF IT IS A FULL BUFFER. IN WHICH
  7749.     JMP I    .+1        /WE END UP HERE, WHERE WE WILL GO BACK TO GET
  7750.     READ            /ANOTHER BUFFER FULL
  7751.  
  7752.  
  7753. /IF THE BUFFER IS NOT FULL THE LAST FEW WORDS LOOK LIKE THE FOLLOWING
  7754.  
  7755.  
  7756. /    7777            /TERMINATE PR1 COMMAND
  7757. /    JMP I    PILOOP        /GOTO BRTS AND GET NEXT INSTRUCTION
  7758.  
  7759.  
  7760.