xdt99: New TI 99 cross-development tools available

+Lee Stewart · August 23, 2020

From PM 1, PeteE said:

The "invalid cross-bank access" is supposed to prevent the programmer from accidentally trying to directly use a symbol that is in another bank. By default, you can only access symbols in a BANK ALL or the same bank. To create a valid cross-bank access, the symbol must be prefixed by "x#". There were quite a few of those, so I elected to disable the error in the assembler instead of updating them all.

There is not much point in trying to keep this compatible with asm994a, so I probably should try to change those. Most all of them (I think) are the branches from bank 0 to body code in other banks, which all use the following (except for the initial label after DATA, which, I believe, all start with ‘_’):

       BL   @BLF2A
       DATA _DIGIT->6000+BANK2

and should be pretty easy to find and replace with the regex mode of notepad++.

From PM, PeteE said:

For non-inverted cartridges, one way would be to use the .IFDEF preprocessor directive to choose between inverted and non ....

This is a touch complicated by the fact that I do some explicit switching of banks, but, fortunately, not many instances of this. I could change those to labels to make it easier to use the preprocessor.

Dealing with PC99 and any emulator that requires individual ROM-bank files may be a bit more complicated but probably doable.

Thanks again.

...lee

+Lee Stewart · August 26, 2020

Well, I got it to assemble, but the program does not work past the title screen. Other than fix all of the errors, I did the following:

       AORG >6000
       BANK ALL
    <bank header that is same in all banks>
       AORG >6048
       BANK 0
    <bank 0 code>
       AORG >7FFE
       DATA >C000
       AORG >6048
       BANK 1
    <bank 1 code>
       AORG >7FFE
MYBANK DATA >8000
       AORG >6048
       BANK 2
    <bank 2 code>
       AORG >7FFE
       DATA >4000
       AORG >6048
       BANK 3
    <bank 3 code>
       AORG >7FFE
       DATA >0000

I have not analyzed the listing any more carefully than checking the header and what is at >7FFE in each bank—everything is where it should be. When I look at the binaries, which are 8 KiB each, there is nothing at >7FFE in the first three. The last one is a wash because it is supposed to be >0000. Any ideas?

...lee

PeteE · August 26, 2020

Hi @Lee Stewart, after each AORG >7FFE, a BANK command is required. I ran into that problem when doing this myself also. I would suggest writing it as:

       AORG >6000
       BANK ALL
    <bank header that is same in all banks>
       BANK 0
    <bank 0 code>
       BANK 1
    <bank 1 code>
       BANK 2
    <bank 2 code>
       BANK 3
    <bank 3 code>
       AORG >7FFE
       BANK 0
MYBANK DATA >C000
       BANK 1
       DATA >8000
       BANK 2
       DATA >4000
       BANK 3
       DATA >0000

The assembler will reset the $ to the same address after the header at the start of each bank, and the same goes for the MYBANK symbol at >7FFE. Does that make sense? The listing file should show that it works.

ralphb · August 26, 2020

I second PeteE's suggestion, although the other way also works.

The problem here is that AORG will not keep the previous bank, but resets it to "non-banked program", which results in a wonky state for banked programs. Thus, you need a BANK after each AORG (the same could probably be said for other *ORGs).

I guess it'll be OK to keep the previous bank, maybe also issue a warning. My TODO list keeps on growing ... ?

+Lee Stewart · August 26, 2020

I have an AORG after a DORG. Once I straightened that out per your instruction, all hell broke loose. I now have those hundreds of cross-bank references to deal with and they are not all so easy to deal with as I thought. I realize that unintentional cross-bank access can be a problem, but the availability of labels from any bank (not part of branches) to all other banks (part of asm994a) is almost a necessity. This might be the deal breaker.

...lee

ralphb · August 26, 2020

The labels you put in shared segments (BANK ALL) are accessible in all banks. And if you know what you're doing, you can do cross-bank accesses by prefixing "x#" to the symbol in question.

This shows some valid use of x#: https://github.com/endlos99/xdt99/blob/master/test/asm/asshbankx.asm

BTW, as all ORGs, AORG + BANK n keeps track of the last used address for that bank and AORG, so in the example, bank 0 and bank 1 have the same addresses. As a rule of thumb: AORG should be followed by BANK, a BANK does not need a previous AORG if that bank has already been written to.

In not entirely sure about your use case: Why would you access a symbol of a different bank, unless that symbol has the same value in all banks? Could you perhaps give a small example?

+Lee Stewart · August 26, 2020

18 minutes ago, ralphb said:

I’m not entirely sure about your use case: Why would you access a symbol of a different bank, unless that symbol has the same value in all banks? Could you perhaps give a small example?

fbForth 2.0’s home bank is Bank 0. The other banks are used to branch to supporting code, but always come back to Bank 0 when the inner and outer interpreters are in control. With over 500 words, there was not enough room to have the whole dictionary in Bank 0, so I put the dictionary linked list of Link fields, Name fields and Parameter field pointers in Bank2, with only the Code Fields and actual Parameter fields in Bank 0. Guess where all of the Parameter field pointers in Bank 2 point with DATA statements. You guessed it—to Bank 0. This is all handled by trampoline code located in low RAM. Here is a short snippet of the headers at the top of the dictionary in Bank 2:

* Dictionary headers have been split from the code and parameter fields in
* bank 0 and placed here in bank 2 along with the guts of the words that
* access them.
       DATA >0       <--end-of-line pfa search marker
;[*** EXECUTE ***
       DATA >0
EXEC_N DATA 7+TERMBT*LSHFT8+'E','XE','CU','TE'+TERMBT
       DATA EXECUT+2    ; pfa ptr
;]*
;[*** LIT ***
       DATA EXEC_N
LIT_N  DATA 3+TERMBT*LSHFT8+'L','IT'+TERMBT
       DATA LIT+2       ; pfa ptr
;]*
;[*** BRANCH ***
       DATA LIT_N
BRAN_N DATA 6+TERMBT*LSHFT8+'B','RA','NC','H '+TERMBT
       DATA BRANCH+2    ; pfa ptr

Here is a snippet from Bank 0 related to the above:

*************************************************************************
*
* EQUates for marker bits in name fields, a byte shifter and replacements 
* for some character combinations the Asm994a assembler chokes on:
*
TERMBT EQU  >0080           Terminator bit
PRECBT EQU  >0040           Precedence bit
SMDGBT EQU  >0020           Smudge bit
LSHFT8 EQU  >0100           Multiplier to get low byte shifted into high byte
*
*************************************************************************
*
;[*** EXECUTE ***    ( cfa --- )
*        DATA >0
* EXEC_N DATA 7+TERMBT*LSHFT8+'E','XE','CU','TE'+TERMBT

EXECUT DATA $+2
       MOV  *SP+,W
       B    @DOEXEC
*
;]*
;[*** LIT ***        ( --- n )
*        DATA EXEC_N
* LIT_N  DATA 3+TERMBT*LSHFT8+'L','IT'+TERMBT

LIT    DATA $+2
       DECT SP
       MOV  *IP+,*SP
       B    *NEXT
*
;]*
;[*** BRANCH ***     ( --- )
*        DATA LIT_N
* BRAN_N DATA 6+TERMBT*LSHFT8+'B','RA','NC','H '+TERMBT

BRANCH DATA $+2
       A    *IP,IP
       B    *NEXT
;]*

Taking the word LIT as an example, the text interpreter would search Bank 2 for the name LIT and, upon finding it, see that the pfa is LIT+2, which address is in Bank 0. The text interpreter will back that up 2 bytes to record the cfa (always Bank 0) as the next execution token. So you see, cross-bank label knowledge is critical to the current design of fbForth 2.0.

...lee

+FarmerPotato · August 26, 2020

25 minutes ago, ralphb said:

The labels you put in shared segments (BANK ALL) are accessible in all banks. And if you know what you're doing, you can do cross-bank accesses by prefixing "x#" to the symbol in question.

This shows some valid use of x#: https://github.com/endlos99/xdt99/blob/master/test/asm/asshbankx.asm

BTW, as all ORGs, AORG + BANK n keeps track of the last used address for that bank and AORG, so in the example, bank 0 and bank 1 have the same addresses. As a rule of thumb: AORG should be followed by BANK, a BANK does not need a previous AORG if that bank has already been written to.

In not entirely sure about your use case: Why would you access a symbol of a different bank, unless that symbol has the same value in all banks? Could you perhaps give a small example?

I want to understand this too!

I have used this code in a 32K cart version of "Bubble Plane", but with GenProg.

Each level data is 16 row by 256 column (4K) RLE compressed (about 2K), in upper banks. Sound lists and char defs are up there too. Game code is all in bank 0.

BANK0 EQU >6000
BANK1 EQU >6002
BANK2 EQU >6004
BANK3 EQU >6006
VDPBUF EQU >0010 * vdpwa address of uncompressed level data, swpb
PADBUF EQU >8320 * 32 byte buffer that we use for moving data from vdp to vdp

* trampoline code common to all banks
LEVELS  EQU $
  DATA BANK1,CHARA1
  DATA BANK1,LEVEL1
  DATA BANK1,LEVEL2
  DATA BANK2,LEVEL3
  DATA BANK2,LEVEL4  * etc where LEVEL labels are each under DORG >6000, but intended for specific upper banks
  DATA BANK3,SNDLST

* move some data from bank to vdp
*  R0 is vdp address
*  R1 is # index to LEVELS

LOADLV EQU $
  ANDI R0,>4000
  SWPB R0
  MOVB R0,*R15 * vdpwa
  SWPB R0
  MOVB R0,*R15  * vdpwa

  SLA R1,2
  AI R1,LEVELS
  MOV *R1,R3  
  MOV *R1,R1
  SETO *R3+  * change bank, but this trampoline code is the same in all of them
* R1 now maps into the bank
  MOV  *R1+,R2  * length of level data

* begin RLE decompressing level data into VDP RAM
LOOP EQU $
* ...
  CI R1,>8000
  JL LOOP
  SETO *R3+  * Cross bank boundary
  LI R1,>6000
  JMP LOOP
* when done:
  SETO @BANK0
  RT

So I guess for xdt99 my source would be

LEVELS 
  DATA BANK1,1#LEVEL1
  DATA BANK1,1#LEVEL2
  DATA BANK2,2#LEVEL3
  DATA BANK2,2#LEVEL4

* source file with charset data
  AORG >6000+BANK 1

* source file with level data continues where charset data left off
  AORG >6000+BANK 1
LEVEL1 DATA ...
LEVEL2 DATA ...   * can I get this to wrap around to >6000 if it crosses a boundary?

  AORG >6000+BANK 2 * because I just know LEVEL3 starts in bank 2
LEVEL3
LEVEL4

* source file with sound data continues where level data left off
  AORG >6000+BANK 3
SNDLST

Can I get xdt99 to have the data wrap around to >6000 in the next bank?

I think GENPROG loaded relocatable 24K level data into 3 8K banks, each with base address >6000, and I had to hardcode what bank each level started in.

+9640News · August 26, 2020

43 minutes ago, FarmerPotato said:

I want to understand this too!

I have used this code in a 32K cart version of "Bubble Plane", but with GenProg.

Each level data is 16 row by 256 column (4K) RLE compressed (about 2K), in upper banks. Sound lists and char defs are up there too. Game code is all in bank 0.


BANK0 EQU >6000
BANK1 EQU >6002
BANK2 EQU >6004
BANK3 EQU >6006
VDPBUF EQU >0010 * vdpwa address of uncompressed level data, swpb
PADBUF EQU >8320 * 32 byte buffer that we use for moving data from vdp to vdp

* trampoline code common to all banks
LEVELS  EQU $
  DATA BANK1,CHARA1
  DATA BANK1,LEVEL1
  DATA BANK1,LEVEL2
  DATA BANK2,LEVEL3
  DATA BANK2,LEVEL4  * etc where LEVEL labels are each under DORG >6000, but intended for specific upper banks
  DATA BANK3,SNDLST

* move some data from bank to vdp
*  R0 is vdp address
*  R1 is # index to LEVELS

LOADLV EQU $
  ANDI R0,>4000
  SWPB R0
  MOVB R0,*R15 * vdpwa
  SWPB R0
  MOVB R0,*R15  * vdpwa

  SLA R1,2
  AI R1,LEVELS
  MOV *R1,R3  
  MOV *R1,R1
  SETO *R3+  * change bank, but this trampoline code is the same in all of them
* R1 now maps into the bank
  MOV  *R1+,R2  * length of level data

* begin RLE decompressing level data into VDP RAM
LOOP EQU $
* ...
  CI R1,>8000
  JL LOOP
  SETO *R3+  * Cross bank boundary
  LI R1,>6000
  JMP LOOP
* when done:
  SETO @BANK0
  RT

So I guess for xdt99 my source would be


LEVELS 
  DATA BANK1,1#LEVEL1
  DATA BANK1,1#LEVEL2
  DATA BANK2,2#LEVEL3
  DATA BANK2,2#LEVEL4


* source file with charset data
  AORG >6000+BANK 1

* source file with level data continues where charset data left off
  AORG >6000+BANK 1
LEVEL1 DATA ...
LEVEL2 DATA ...   * can I get this to wrap around to >6000 if it crosses a boundary?

  AORG >6000+BANK 2 * because I just know LEVEL3 starts in bank 2
LEVEL3
LEVEL4

* source file with sound data continues where level data left off
  AORG >6000+BANK 3
SNDLST

Can I get xdt99 to have the data wrap around to >6000 in the next bank?

I think GENPROG loaded relocatable 24K level data into 3 8K banks, each with base address >6000, and I had to hardcode what bank each level started in.

GenPROG using GenLINK has the ability to use the BLOCK command for where you can load code to a specific range of addresses. It could be a block of only a couple of bytes, to 64K if one so desired. You would also likely use the PAGES command to specify the 8K pages. In the case of MDOS, I believe the PAGES identify to the 8K byte page number.

I think MDOS at the Command Line Interface (CLI) limits you to something with something less than 64K taking into account the first >400 bytes of memory are OS oriented, and there is some restricted memory above >F000.

However, you can use the DSR Load command in MDOS to load a program image file up to the available free memory range if you have previously requested those pages from the Memory DSR.

Nothing says that each 8K block could have been previously identified with a PAGE number, and that block mapped to >6000->7FFF with your page reference being an offset into your list of requested memory pages. I hope that makes sense. Basically, you could have a 1.5 MB program image file loadable from a separate file if you had the extra memory, with each 8K block having been PAGE'd and BLOCK'd to be useable at any memory address range you desired.

In addition, you could also have a BLOCK range to fit any graphics VIDEO range set if you wanted to copy a block of CPU memory to VDP memory for graphics.

Lots of easy options on the MDOS side of things for handling CPU and/or video memory.

Beery

+Lee Stewart · August 27, 2020

11 hours ago, Lee Stewart said:

I have an AORG after a DORG. Once I straightened that out per your instruction, all hell broke loose. I now have those hundreds of cross-bank references to deal with and they are not all so easy to deal with as I thought. I realize that unintentional cross-bank access can be a problem, but the availability of labels from any bank (not part of branches) to all other banks (part of asm994a) is almost a necessity. This might be the deal breaker.

Patching xas99.py to allow “cross-bank access” per @PeteE’s patch, allowed assembly, but the above-quoted solution for handling DORGed code does not work. The four required binaries are, indeed, created and Bank 0 appears to be correct, but the three binaries for Banks 1, 2 and 3 are now misaligned. Bank 0 continues at the proper place after the DORGed code, but the other banks now continue from the “BANK ALL” code at the address where the last “BANK 0” appeared after the DORGed code, which now misaligns each of those three banks by 54 bytes. It is as though the second “BANK 0” were treated like a “BANK ALL”. I want to use XORG, but fear the same complication.

...lee

+Lee Stewart · August 27, 2020

6 hours ago, Lee Stewart said:

Patching xas99.py to allow “cross-bank access” per @PeteE’s patch, allowed assembly, but the above-quoted solution for handling DORGed code does not work. The four required binaries are, indeed, created and Bank 0 appears to be correct, but the three binaries for Banks 1, 2 and 3 are now misaligned. Bank 0 continues at the proper place after the DORGed code, but the other banks now continue from the “BANK ALL” code at the address where the last “BANK 0” appeared after the DORGed code, which now misaligns each of those three banks by 54 bytes. It is as though the second “BANK 0” were treated like a “BANK ALL”. I want to use XORG, but fear the same complication.

The following workaround successfully re-aligns Banks 1, 2 and 3 after the second “BANK 0”:

_AORG_PATCH EQU $    ; workaround anticipating 2nd "BANK 0"
       BANK 0
; Without AORG patch applied farther below, the length of this section of Bank 0
; code is how much misalignment would occur in Banks 1, 2, 3.
   <Bank 0 code>
       DORG 0
   <DORGed code>
       AORG
       BANK 0      ; 2nd "BANK 0" causes misalignment of remaining banks
   <remaining Bank 0 code>
       AORG _AORG_PATCH     ; workaround for 2nd "BANK 0" misalignment
       BANK 1
         .
         .
         .

fbForth 2.0 now boots up properly. I need to compare the binaries with the asm994a-assembled code before continuing with my updates. The MYBANK word (2 bytes) is at >7FFE in every bank. I am a reasonably happy camper.

...lee

+TheBF · August 27, 2020

1 hour ago, Lee Stewart said:
The following workaround successfully re-aligns Banks 1, 2 and 3 after the second “BANK 0”:
_AORG_PATCH EQU $    ; workaround anticipating 2nd "BANK 0"
       BANK 0
; Without AORG patch applied farther below, the length of this section of Bank 0
; code is how much misalignment would occur in Banks 1, 2, 3.
   <Bank 0 code>
       DORG 0
   <DORGed code>
       AORG
       BANK 0      ; 2nd "BANK 0" causes misalignment of remaining banks
   <remaining Bank 0 code>
       AORG _AORG_PATCH     ; workaround for 2nd "BANK 0" misalignment
       BANK 1
         .
         .
         .
fbForth 2.0 now boots up properly. I need to compare the binaries with the asm994a-assembled code before continuing with my updates. The MYBANK word (2 bytes) is at >7FFE in every bank. I am a reasonably happy camper.

...lee

That's great news Lee. Now that it builds what do these new tools buy you?

ralphb · August 27, 2020

20 hours ago, Lee Stewart said:

fbForth 2.0’s home bank is Bank 0. ...

Taking the word LIT as an example, the text interpreter would search Bank 2 for the name LIT and, upon finding it, see that the pfa is LIT+2, which address is in Bank 0. The text interpreter will back that up 2 bytes to record the cfa (always Bank 0) as the next execution token. So you see, cross-bank label knowledge is critical to the current design of fbForth 2.0.

...lee

I see. If that is all, you'd need to prepend all references in bank 2 to bank 0 with x# -- or disable the cross-bank check. I'll make that an option.

But how do you know if an address points to bank 0, 1, 2, ..., or n? The final program doesn't contain labels, just addresses. In your example, it just seems like a convention that the linked list is in bank 2, and interpreters in bank 0.

ralphb · August 27, 2020

2 hours ago, Lee Stewart said:
The following workaround successfully re-aligns Banks 1, 2 and 3 after the second “BANK 0”:
_AORG_PATCH EQU $    ; workaround anticipating 2nd "BANK 0"
       BANK 0
; Without AORG patch applied farther below, the length of this section of Bank 0
; code is how much misalignment would occur in Banks 1, 2, 3.
   <Bank 0 code>
       DORG 0
   <DORGed code>
       AORG
       BANK 0      ; 2nd "BANK 0" causes misalignment of remaining banks
   <remaining Bank 0 code>
       AORG _AORG_PATCH     ; workaround for 2nd "BANK 0" misalignment
       BANK 1
         .
         .
         .
fbForth 2.0 now boots up properly. I need to compare the binaries with the asm994a-assembled code before continuing with my updates. The MYBANK word (2 bytes) is at >7FFE in every bank. I am a reasonably happy camper.

...lee

Congratulations! Patching the DORG should not be necessary, though (I mean, it probably is, but shouldn't). I'll have a look at the default bank handling of the ORGs -- I hope I remember everything I promised. ?

+Lee Stewart · August 27, 2020

2 hours ago, TheBF said:

That's great news Lee. Now that it builds what do these new tools buy you?

Well, for starters, these versatile tools are currently maintained by an accessible author (@ralphb). Not so with asm994a. That was always discouraging, especially when I ran smack dab into its undocumented preprocessor with no diagnostic help other than the fact that my code would not assemble properly until I figured out what words to avoid for my labels.

There are two other important features that xas99 offers me:

Though it is not a lot of code, I only need to maintain the headers in one place now, not four! I always had to remember to make the same changes to four different headers.
Much as I think my device for calculating RAM EQUates, for code to be copied to RAM, was clever and simple, XORG will make my life so much easier because the assembled XORGed code will all have the correct addresses. Troubleshooting is rarely much fun, but this will make it a good deal simpler.

...lee

+Lee Stewart · August 27, 2020

1 hour ago, ralphb said:

I see. If that is all, you'd need to prepend all references in bank 2 to bank 0 with x# -- or disable the cross-bank check. I'll make that an option.

I actually have not counted them all, but there are somewhere near 1000 such labels—not something I want to patch manually with ‘x#’ 1000 times. I will go with disabling the cross-bank check.

1 hour ago, ralphb said:

But how do you know if an address points to bank 0, 1, 2, ..., or n? The final program doesn't contain labels, just addresses. In your example, it just seems like a convention that the linked list is in bank 2, and interpreters in bank 0.

Well, the 500+ pfas in Bank 2 all point to Bank 0 if not the handful that are in RAM. Every other cross-bank address is encoded with the bank ID, which the trampoline code in low RAM knows how to decode, Such a call to trampoline code follows:

       BL   @BLF2A
       DATA _IDDOT->6000+BANK2    ; _IDDOT = >73EA..BANK2 = >4000..result = >53EA

The BLF2A trampoline code extracts the bank code by shifting a copy of the DATA word 13 bits right and adding back >6000. This gets the address to bump to switch to the correct bank. The original has its leftmost 3 bits masked off and >6000 added back to get the routine’s address. Clear as mud, right? Anyway, it works.

Lastly, when the inner (address) interpreter (located in scratchpad RAM) executes the address in an fbForth 2.0 word’s code field, Bank 0 is always mapped in because that is where every code field in ROM resides.

...lee

+Lee Stewart · August 27, 2020

7 hours ago, Lee Stewart said:

fbForth 2.0 now boots up properly. I need to compare the binaries with the asm994a-assembled code before continuing with my updates. The MYBANK word (2 bytes) is at >7FFE in every bank. I am a reasonably happy camper.

All binaries match except for the BSS stretches. It transpires that asm994a writes >FFs there and xas99, >00s. Fortunately there were few of those to walk through.

5 hours ago, ralphb said:

Congratulations! Patching the DORG should not be necessary, though (I mean, it probably is, but shouldn't). I'll have a look at the default bank handling of the ORGs -- I hope I remember everything I promised. ?

Thanks! And now—on to XORGing RAM copies!

...lee

PeteE · August 27, 2020

8 hours ago, ralphb said:

I see. If that is all, you'd need to prepend all references in bank 2 to bank 0 with x# -- or disable the cross-bank check. I'll make that an option.

I would find this option to disable cross-bank checks useful as well.

+Lee Stewart · August 28, 2020

4 hours ago, Lee Stewart said:

Thanks! And now—on to XORGing RAM copies!

Hooboy! I am not sure XORG is going to be the boon I thought it would. I am a bit hamstrung without a column with the target addresses. I changed a lot of code with XORG, which involved about 100 labels in code destined for low RAM. It seemed pretty straightforward, but it blew up when I tried the binary in Classic99. Without a column of target addresses, it is going to be tedious to find what I did wrong. I am going to have to go back to the old code and just change a few labels at a time. Not what I was anticipating. Sorry to be such a PITA.

...lee

ralphb · August 28, 2020

8 hours ago, PeteE said:

I would find this option to disable cross-bank checks useful as well.

I must admit that my mental model of bank switching was a cartridge, with a simple switcheroo in ROM. Also, x# should help the programmer, not frustrate him or her. I'll also try to merge your patch, although I would change the command line interface slightly. ?

ralphb · August 28, 2020

6 hours ago, Lee Stewart said:

Hooboy! I am not sure XORG is going to be the boon I thought it would. I am a bit hamstrung without a column with the target addresses. I changed a lot of code with XORG, which involved about 100 labels in code destined for low RAM. It seemed pretty straightforward, but it blew up when I tried the binary in Classic99. Without a column of target addresses, it is going to be tedious to find what I did wrong. I am going to have to go back to the old code and just change a few labels at a time. Not what I was anticipating. Sorry to be such a PITA.

Without knowing your code, I can only offer some guesses here. Did you copy the XORG area to RAM? XORG just influences the address pointer, but it doesn't move the range to RAM. The pattern is

   li   r0, <target>
   li   r1, xorg_start
   li   r2, xorg_end - xorg_start
!  movb *r1+, *r0+
   dec  r2
   jne	-!
   ... 

xorg_start xorg <target>
   ...
xorg_end aorg

   ... ; normal program continues

Inside the XORG range, any addresses outside the range will remain fixed (as you'd expect). Maybe something goes wrong with your DATA statements with the expressions?

+Lee Stewart · August 28, 2020

44 minutes ago, ralphb said:

Did you copy the XORG area to RAM? XORG just influences the address pointer, but it doesn't move the range to RAM.

I understand and that is what the code does.

44 minutes ago, ralphb said:

Inside the XORG range, any addresses outside the range will remain fixed (as you'd expect). Maybe something goes wrong with your DATA statements with the expressions?

I am sure something like that has happened. The problem is that, without a convenient column of target addresses in the listing, it is well nigh impossible to find the error(s)—certainly not easily. My old code, with its calculated EQUates, serves me better.

Here is the XORGed code:

Spoiler


*     __                  __                __
*    / /  ___ _    ______/ /  ___ _  _____ / /
*   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) / 
*  /____/\___/__,__/   /____/\__/|___/\__/_/  
*                     ____                        __ 
*                    / __/_ _____  ___  ___  ____/ /_
*                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
*                  /___/\_,_/ .__/ .__/\___/_/  \__/ 
*                          /_/  /_/                  
* 
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                   *
* fbForth---                                                        *
*                                                                   *
*       Low-level support routines                                  *
*                                                                   *
*  << Including Trampoline Code, tables & variables:  2606 bytes >> *
*                                                                   *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

LLVSPT   ; <--This is the source copy location for the rest of this code.

$BUFF  EQU  >2010
 
* 4 I/O buffers below ($LO = >3020) 
* Change '4' to number of buffers needed and for which there is room.

$LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers

       XORG $LO      ; calculate destination addresses

*       _____   ____         __  __      ___________ 
*      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
*     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
*    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_| 
*
;[*** Interrupt Service =======================================================
* This routine is executed for every interrupt.  It processes any pending
* speech and souind.  It then looks to see whether a user ISR is installed in 
* ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work 
* only if the user has installed an ISR using the following steps in the fol-
* lowing order:
*
*   (1) Write an ISR with entry point, say MYISR.
*   (2) Determine code field address of MYISR with this high-level Forth:
*           ' MYISR CFA
* <<< Maybe need a word to do #3 >>>
*   (3) Write CFA of MYISR into user variable ISR.
*
* Steps (2)-(3) in high-level Forth are shown below:
*           ' MYISR CFA
*           ISR !
* 
* <<< Perhaps last step above should be by a word that disables interrupts >>>
*
* The console ISR branches to the contents of >83C4 because it is non-zero,
* with the address, INT1, of the fbForth ISR entry point below (also, the
* contents of INTLNK).  This means that the console ISR will branch to INT1
* with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
* process any pending speech and sound.
* 
* If the user's ISR is properly installed, the code that processes the user
* ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
* from Forth's workspace (MAINWS), the code at INT2 will process the user's
* ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
* inner interpreter.
*** ==========================================================================

* ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!

INT1   
       LI   R0,BRSTK          load address of top of Branch Address Stack
* 
* Set up for pending speech
*
       MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
       JEQ  SNDCH1            jump to sound-check if no speech
       INCT R0                increment Branch Stack
*
* Set up for pending sound table #1 (ST#1)
*
SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
       JEQ  SNDCH2            process speech and sound if needed
       LI   R1,x#PLAYT1         load PLAYT1 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
* 
* Set up for pending sound table #2 (ST#2)
*
SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
       JEQ  PRCSPS            process speech and sound if needed
       LI   R1,x#PLAYT2         load PLAYT2 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
*
* Process sound stack if both sound tables idle
*
PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
       JNE  PRSPS2            nope..skip sound stack processing
       LWPI SND1WS            switch to ST#1 WS
       CI   R4,SNDST0         anything on sound stack?
       JEQ  PRSPS1            no..exit sound stack processing
       DECT R4                pop sound stack position
       MOV  *R4,R2            get sound table address from sound stack
       INC  R0                kick off sound processing of ST#1 (R0=1)
PRSPS1 LWPI GPLWS             switch back to GPL WS
* 
* Check for any pending speech and sound
*
PRSPS2 CI   R0,BRSTK          any speech or sound to process?
       JEQ  USRISR            if not, jump to user ISR processing
       LI   R1,BNKRST         yup..load return address
       MOV  R1,*R0            push return address onto Branch Stack
* 
* Process pending speech and sound
*
       MOV  @x#MYBANK,@BANKSV   save bank at interrupt
       CLR  @>6002            switch to bank 2 for speech & sound services
       LI   R7,BRSTK          load top of Branch Stack
       MOV  *R7+,R8           pop speech/sound ISR
       B    *R8               service speech/sound
*
* Restore interrupted bank
*
BNKRST                ; return point for speech and sound ISRs
       MOV  @BANKSV,R0        restore bank at interrupt
       SRL  R0,13             get the bank# to correct position
       AI   R0,>6000          make it a real bank-switch address
       CLR  *R0               switch to the bank at interrupt
*
* Process User ISR if defined
*
USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
       JEQ  INTEX             
*
* Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
* is executed from Forth's WS (MAINWS = >8300), which it does at the end of
* every CODE word, keyboard scan and one or two other places.
* 
       LI   R1,INT2                 Load entry point, INT2
       MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
* 
* The following 2 instructions are copies of the remainder of the console ROM's
* ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
* because we're not going back there!
* 
INTEX  LWPI >83C0             Change to console's ISR WS  
       RTWP                   Return to caller of console ISR
* 
* Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
* before executing user's ISR. INT3 (cleanup routine below) will be inserted
* in address list to get us back here for cleanup after user's ISR has finished.
* User's ISR is executed at the end of this section just before INT3.
* 
INT2   LIMI 0                 Disable interrupts
       MOVB @>83D4,R0         Get copy of VR01
       SRL  R0,8              ...to LSB
       ORI  R0,>100           Set up for VR01
       ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
       BLWP @VWTR             Turn off VDP interrupt
       LI   NEXT,$NEXT        Restore NEXT
       SETO @INTACT           Set Forth "pending interrupt" flag
       DECT R                 Set up return linkage by pushing 
       MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
       LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
       MOV  @$ISR(U),W        Do the user's Forth ISR by executing
       B    @DOEXEC           ...it through Forth's inner interpreter
* 
* Clean up and re-enable interrupts.
*
INT3   DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
       DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
       MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
       CLR  @INTACT           Clear Forth "pending interrupt" flag
       MOVB @>83D4,R0         Prepare to restore VR01 by...
       SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
       AI   R0,>100           ...VR # (01) to MSB
       MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
       BLWP @VWTR             Write VR01
       LIMI 2                 Re-enable interrupts
       B    *NEXT             Continue normal task
;]*
;[*** BKLINK from SYSTEM calls ==========================================
*
BKLINK MOV  @INTACT,R7        Are we in user's ISR?
       JNE  BKLIN1            Don't enable interrupts if so.
       LIMI 2
BKLIN1 B    *LINK
;]*
*      ____         __              _____     ____  
*     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
*    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
*   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
*       /___/                                          
* 
;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================

*       Entry point for low-level system support functions

$SYS$  LIMI 0
       MOV  @SYSTAB(R1),R0
       B    *R0
;]
;[*** SYSTAB -- Vector table for SYSTEM calls ===========================

       DATA BRW          CODE = -20  write block to blocks file
       DATA BRW          CODE = -18  read block from blocks file
       DATA BRW          CODE = -16  create blocks file
       DATA BRW          CODE = -14  use blocks file
       DATA GXY          CODE = -12  GOTOXY
       DATA QKY          CODE = -10  ?KEY
       DATA QTM          CODE =  -8  ?TERMINAL
       DATA CLF          CODE =  -6  CRLF
       DATA EMT          CODE =  -4  EMIT
       DATA KY           CODE =  -2  KEY
SYSTAB DATA SBW          CODE =   0  VSBW
       DATA MBW          CODE =   2  VMBW
       DATA SBR          CODE =   4  VSBR
       DATA MBR          CODE =   6  VMBR
       DATA WTR          CODE =   8  VWTR
       DATA GPL          CODE =  10  GPLLNK
       DATA XML          CODE =  12  XMLLNK
       DATA DSR          CODE =  14  DSRLNK
       DATA CLS$         CODE =  16  CLS
       DATA MVE          CODE =  18  VMOVE
       DATA FILL$        CODE =  20  VFILL
       DATA AOX          CODE =  22  VAND
       DATA AOX          CODE =  24  VOR
       DATA AOX          CODE =  26  VXOR
;]*
;[*== VDP single byte write.                CODE =   0  =================
*
SBW    MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         Character to write
       SWPB R1              Get in left byte
       BLWP @VSBW
       B    @BKLINK
;]*
;[*== VDP multi byte write.                 CODE =   2  =================
*
MBW    MOV  *SP+,R2         Number of bytes to move
       MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         RAM address (source)
       BLWP @VMBW
       B    @BKLINK
;]*
;[*== VDP single byte read.                 CODE =   4  =================
*
SBR    MOV  *SP,R0          VRAM address (source)
       BLWP @VSBR
       SRL  R1,8            Character to right half for Forth
       MOV  R1,*SP          Stack it
       B    @BKLINK
;]*
;[*== VDP multi byte read.                  CODE =   6  =================
*
MBR    MOV  *SP+,R2         Number of bytes to read
       MOV  *SP+,R1         RAM address (destination)
       MOV  *SP+,R0         VRAM address (source)
       BLWP @VMBR
       B    @BKLINK
;]*
;[*== VDP-to-VDP move.                      CODE =  18  =================
*
MVE    MOV  *SP+,R0         Pop cnt to R0
       MOV  *SP+,R2         Pop vdst to R2
       MOV  *SP+,R1         Pop vsrc to R1
       BLWP @VMOVE
       B    @BKLINK
;]*
;[*== VDP register write.                   CODE =   8  =================
*
WTR    MOV  *SP+,R1         VDP register number
       MOV  *SP+,R0         Data for register
       SWPB R1              Get register to left byte
       MOVB R1,R0           Place with data
       BLWP @VWTR
       B    @BKLINK
;]*
;[*== GPL link utility.                     CODE =  10  =================
*
GPL    CLR  R0
       MOVB R0,@KYSTAT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,GPLLNK         to the GPLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== XML link utility.                     CODE =  12  =================
*
XML    LI   R0,>0420        Construct the BLWP instruction
       LI   R1,XMLLNK         to the XMLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== DSR link utility.                     CODE =  14  =================
*
DSR    LI   R0,>0420        Construct the BLWP instruction
       LI   R1,DSRLNK         to the DSRLNK utility
       MOV  *SP+,R2         This datum selects DSR or subroutine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== Screen clearing utility.              CODE =  16  =================
*
CLS$   MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
       MOV  @$SEND(U),R1    End of screen in VRAM
       S    R2,R1           Screen size
       LI   R0,>2000        Blank character
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== VDP fill routine.                     CODE =  20  =================
*
FILL$  MOV  *SP+,R0         Fill character
       SWPB R0                to left byte
       MOV  *SP+,R1         Fill count
       MOV  *SP+,R2         Address to start VRAM fill
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
*========================================================================
FILL1          ; R0=char, R1=cnt, R2=vaddr
       ORI  R2,>4000        Set bit for VDP write
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
FLOOP  MOVB R0,@VDPWD       Write a byte
       DEC  R1
       JNE  FLOOP           Not done, fill another
       B    *LINK
;]*======================================================================
*
*==== VAND -- VDP byte AND routine.         CODE =  22  =================
*==== VOR -- VDP byte OR routine.           CODE =  24  =================
;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
*
AOX    MOV  *SP+,R2         VRAM address
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
       MOVB @VDPRD,R3       Read byte
       MOV  *SP+,R0         Get data to operate with
       SWPB R0                to left byte
*** Now do requested operation *****************
       CI   R1,24
       JEQ  DOOR
       JGT  DOXOR
       INV  R3              These two instructions
       SZC  R3,R0             perform an 'AND'
       JMP  FINAOX
DOOR   SOC  R3,R0             perform 'OR'
       JMP  FINAOX
DOXOR  XOR  R3,R0             perform 'XOR'
FINAOX LI   R1,1
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== KEY routine                           CODE =  -2  =================
*
KY    MOV  @$ALTI(U),R0      alternate input device?
       JEQ  KEY0              jump to keyboard input if not
*
*  R0 now points to PAB for alternate input device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to read one byte.
*
       CLR  R7                prepare to zero status byte
       MOVB R7,@KYSTAT        zero status byte
       INC  R0                point R0 to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       MOV  R0,R1             Set up pointer...
       AI   R1,8              ...to namelength byte of PAB
       MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
       MOV  R0,R3             save pointer (DSRLNK will trash it!)
       BLWP @DSRLNK           get 1 byte from device
       DATA >8
       MOV  R3,R0             restore pointer
       DECT R0                point to one-byte VRAM buffer in front of PAB
       BLWP @VSBR             read character
       SRL  R1,8              move to LSB
       MOV  R1,R0             copy to return register
       B    @BKLINK           return to caller
*
*  Input is comining from the keyboard
*
KEY0   MOV  @KEYCNT,R7
       INC  R7
       JNE  KEY1
       MOV  @CURPO$(U),R0
       BLWP @VSBR             Read character at cursor position...
       MOVB R1,@CURCHR        ...and save it
       LI   R1,>1E00          Place cursor character on screen
       BLWP @VSBW
*
KEY1   BLWP @KSCAN
       MOVB @KYSTAT,R0
       COC  @H2000,R0         check status
       JEQ  KEY2              JMP if key was pressed
*
       CI   R7,100            No key pressed
       JNE  KEY3
       MOVB @CURCHR,R1
       JMP  KEY5
*
KEY3   CI   R7,200
       JNE  KEY4
       CLR  R7
       LI   R1,>1E00          Cursor char
KEY5   MOV  @CURPO$(U),R0
       BLWP @VSBW
KEY4   MOV  R7,@KEYCNT
       MOV  @INTACT,R7        Are we in user's ISR?
       JNE  KEY6              Don't enable interrupts if so.
       LIMI 2
KEY6   DECT IP                This will re-execute KEY
       B    *NEXT
KEY2   SETO @KEYCNT           Key was pressed
       MOV  @CURPO$(U),R0     Restore character at cursor location
       MOVB @CURCHR,R1
       BLWP @VSBW
       MOVB @KYCHAR,R0        Put char in...
       SRL  R0,8              ...LSB of R0
       B    @BKLINK
;]*
;[*== EMIT routine                          CODE =  -4  =================
*
EMT    MOV  R2,R1             copy char to R1 for VSBW
       MOV  @$ALTO(U),R0      alternate output device?
       JEQ  EMIT0             jump to video display output if not
*
*  R0 now points to PAB for alternate output device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to write one byte.
*
       CLR  R7                ALTOUT active
       MOVB R7,@KYSTAT        zero status byte
       DEC  R0                point to one-byte VRAM buffer in front of PAB
       SWPB R1                char to MSB
       BLWP @VSBW             write char to buffer
       INCT R0                point to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       AI   R0,8              Set up pointer to namelength byte of PAB
       MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
       BLWP @DSRLNK           put 1 byte to device
       DATA >8                
       B    @BKLINK           return to caller
*
*  Output is going to the video display
*
EMIT0  CI   R1,7            Is it a bell?
       JNE  NOTBEL
       CLR  R2
       MOVB R2,@KYSTAT
       BLWP @GPLLNK
       DATA >0036           Emit error tone
       JMP  EMEXIT
*
NOTBEL CI   R1,8            Is it a backspace?
       JNE  NOTBS
       LI   R1,>2000
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       JGT  DECCUR
       JMP  EMEXIT
DECCUR DEC  @CURPO$(U)
       JMP  EMEXIT
*
NOTBS  CI   R1,>A           Is it a line feed?
       JNE  NOTLF
       MOV  @$SEND(U),R7
       S    @$SWDTH(U),R7
       C    @CURPO$(U),R7
       JHE  SCRLL
       A    @$SWDTH(U),@CURPO$(u)
       JMP  EMEXIT
SCRLL  MOV  LINK,R7
       BL   @SCROLL
       MOV  R7,LINK
       JMP  EMEXIT
*
*** SCROLLING ROUTINE
*
SCROLL MOV  @$SSTRT(U),R0   VRAM addr
       LI   R1,LINBUF       Line buffer
       MOV  @$SWDTH(U),R2   Count
       A    R2,R0           Start at line 2
SCROL1 BLWP @VMBR
       S    R2,R0           One line back to write
       BLWP @VMBW
       A    R2,R0           Two lines ahead for next read
       A    R2,R0
       C    R0,@$SEND(U)    End of screen?
       JL   SCROL1
       MOV  R2,R1           Blank bottom row of screen
       LI   R0,>2000        Blank
       S    @$SEND(U),R2
       NEG  R2              Now contains address of start of last line
       MOV  LINK,R6
       BL   @FILL1          Write the blanks
       B    *R6
*
NOTLF  CI   R1,>D           Is it a carriage return?
       JNE  NOTCR
       CLR  R0
       MOV  @CURPO$(U),R1
       MOV  R1,R3
       S    @$SSTRT(U),R1   Adjusted for screen not at 0
       MOV  @$SWDTH(U),R2
       DIV  R2,R0
       S    R1,R3
       MOV  R3,@CURPO$(U)
       JMP  EMEXIT
*
NOTCR  SWPB R1              Assume it is a printable character
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       MOV  @$SEND(U),R2
       DEC  R2
       C    R0,R2
       JNE  NOTCR1
       MOV  @$SEND(U),R0
       S    @$SWDTH(U),R0   Was last char on screen. Scroll
       MOV  R0,@CURPO$(U)
       JMP  SCRLL
NOTCR1 INC  R0              No scroll necessary
       MOV  R0,@CURPO$(U)
*
EMEXIT B    @BKLINK
;]*
;[*== CRLF routine                          CODE =  -6  =================
*
CLF    MOV  LINK,R5
       LI   R2,>000D
       BL   @EMT            EMT will alter INT mask via B @BKLINK
       LI   R2,>000A
       LIMI 0               Previous call to EMT altered INT mask
       BL   @EMT
       MOV  R5,LINK
       B    @BKLINK
;]*
;[*== ?TERMINAL routine                     CODE =  -8  =================
* scan for <clear>, <break>, FCTN+4 press
*
QTM    MOV  LINK,R5         save return
       BL   @>0020          branch to console's test for <clear>
       STST R0              store status in R0
       JNE  QTM2            exit if not <clear>
QTM1   BL   @>0020          check for <clear> again
       JEQ  QTM1            loop until not <clear>
QTM2   MOV  R5,LINK         restore return
       ANDI R0,>2000        keep only EQU bit
       B    @BKLINK         return to caller
;]*
;[*== ?KEY routine                          CODE = -10  =================
*
QKY    BLWP @KSCAN
       MOVB @KYCHAR,R0
       SRL  R0,8
       CI   R0,>00FF
       JNE  QKEY1
       CLR  R0
QKEY1  B    @BKLINK
;]*
;[*== GOTOXY routine                        CODE = -12  =================
*
GXY    MPY  @$SWDTH(U),R3
       A    R2,R4           Position within screen
       A    @$SSTRT(U),R4   Add VRAM offset to screen top
       MOV  R4,@CURPO$(U)
       B    @BKLINK
;]
*       ___  __         __     ____  ______ 
*      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
*     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
*    /____/_/\___/\__/_/\_\ /___/_/  \____/ 

*
*== USE blocks file                         CODE = -14  =================
*== CREATE blocks file                      CODE = -16  =================
*== READ block from blocks file             CODE = -18  =================
*== WRITE block to blocks file              CODE = -20  =================
;[*== Block File I/O Support ============================================
*
* BPTOG utility to toggle one of 2 PABs for block file access
*
BPTOG  MOV  @$BPOFF(U),R0	   PAB offset to R0
       LI	R1,70	            Toggle amount
       XOR	R0,R1	            New offset
       MOV	R1,@$BPOFF(U)	   Update offset
*
**xxx** entry point to insure we have correct PAB address
BPSET  MOV  @$DKBUF(U),R0	   Get DISK_BUF address
       A	   @$BPABS(U),R0	   Get BPABS address
*
       A	   @$BPOFF(U),R0     Add current offset
       MOV	R0,@BFPAB	      Update current block file's PAB address
       RT	 	 
*
* CLOSE blocks file
*
BKCLOS MOV  @BFPAB,R0
       LI   R1,$FCLS          Opcode=CLOSE
       BLWP @VSBW
       AI   R0,9              Address of filename's char count
       MOV  R0,@SUBPTR        Point to filename's char count
       BLWP @DSRLNK           Close the file
       DATA 8
       RT                     Deal with error in caller
*
* storage area
*
SVBRET DATA 0                 Storage for LINK coming into BRW
BFPAB  DATA	0	               Storage for current blocks file PAB address...
*	 	 	                     ...will have current PAB on entry
* PAB header storage
*
PABHD  BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
*              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
*	                	                 >03=OUTPUT mode + "
*	                	                 >01=UPDATE mode + "
*	                         BYTE 2,3: save contents of DISK_BUF here
       BYTE	>80	            Record length
       BYTE	>80	            Character count of transfer
       BSS	2	            Record number
*
*** file I/O equates
*
$FOPN  EQU  >0000
$FCLS  EQU  >0100
$FRD   EQU  >0200
$FWRT  EQU  >0300
$FRST  EQU  >0400
$FINP  EQU  5
$FOUT  EQU  3
$FUPD  EQU  1
*
*** BRW -- entry point for block read/write routines
*
BRW    MOV  LINK,@SVBRET   Save LINK address
       MOV	R1,R7	         Save CODE {R1 to R7}
       SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
       AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
       BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
       CI	R7,4	         USE or CREATE?
       JLT	BRW01	         No
       BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
       MOV	@BFPAB,R0	   Load PAB address
       AI	R0,9	         Set to name length byte
       CLR	R2	 
       MOV	*SP+,R1	      Pop bfnaddr to R1
       MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
       INC	R2	            Add 1 to # bytes to copy
       BLWP	@VMBW	         Copy char count & pathname to PAB
*
*** set up PAB for OPEN 
*
BRW01  LI	R1,$FUPD                Opcode=0,mode=update
       CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
       JOP  BRW02                   No
       LI	R1,$FINP                Yes...change mode=input
BRW02  MOV  R1,@PABHD               Put in PAB header
       MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
       CLR  R0
       MOV  R0,@PABHD+6             Set record#=0
       MOV  @BFPAB,R0               VRAM destination
       LI   R1,PABHD                RAM source
       LI   R2,8                    Copy first 8 bytes of PAB header
       BLWP @VMBW                   Do the copy
*
*** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
*
       AI   R0,9                Address of filename's char count in PAB
       MOV  R0,@SUBPTR          Point to-----^^^^
       BLWP @DSRLNK             Open/create the file
       DATA 8
       JEQ  BKERR
       CI   R7,4                READ or WRITE?
       JLT  BRW04               Yes
       JGT  BRWDON              No; =USE; we're done
*
*** write blank records to newly created blocks file [CODE = -16,CREATE]
*
       MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
       SLA  R5,3                Convert #blocks to #records
       MOV  R5,R3               Save
       MOV  R5,R4               Set up counter
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       MOV  R0,@PABHD           Copy to PAB header
BRLOOP S    R4,R5               Calculate next record
       MOV  R5,@PABHD+6         Copy to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       AI   R0,9                Address of filename's char count
       MOV  R0,@SUBPTR          Point to filename's char count
       BLWP @DSRLNK             Write one record of blanks
       DATA 8
       JEQ  BKERR
       MOV  R3,R5               Get #blocks
       DEC  R4                  Count down 1 record
       JNE  BRLOOP              Write another record if not done
       JMP  BRWDON              We're done
*
*** prepare for read/write block
*
BRW04  MOV  *SP+,R5             Pop block# to write
       MOV  *SP+,R6             Pop bufaddr
       DEC  R5                  Block#-1
       SLA  R5,3                Convert to starting record#
       LI   R4,8                Load counter for 8 records
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       LI   R3,VMBW             WRITE vector
       CI   R7,2                Are we writing the block?
       JEQ  BRW05               Yup
       LI   R0,$FRD+$FINP       Nope...set up for READ
       LI   R3,VMBR             READ vector
BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
* 
* READ/WRITE block routine [CODE = -18/-20]
* 
RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0
       MOV  R6,R1               RAM buffer to R1
       LI   R2,128              Bytes to copy
       CI   R7,3                READ?
       JEQ  BRW06               Yup
       BLWP *R3                 Nope...copy record to VRAM
*
* temporarily use CRU register---it should be OK
*
BRW06  MOV  @BFPAB,CRU          PAB address
       AI   CRU,9               Address of filename's char count
       MOV  CRU,@SUBPTR         Point to filename's char count
       BLWP @DSRLNK             Read/write one record
       DATA 8
       JEQ  BKERR
       CI   R7,2                WRITE?
       JEQ  BRW07               Yup...next record
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
       BLWP *R3                 Nope...copy record to RAM buffer
BRW07  INC  R5                  Next record in file
       AI   R6,128              Next record to/from block RAM buffer
       DEC  R4                  Count down 1 record
       JNE  RWLOOP              Read/write another record if not done
       JMP  BRWDON              We're done
*
*** error handling
*
BKERR  MOVB R0,R0               Device error?
       JEQ  BKERR6              Yes, exit with disk error
BKERR9 LI   R6,9                No, exit with file error
       JMP  BKCLN
BKERR8 LI   R6,8                Block# <=0!  exit with range error
       JMP  BKCLN
BKERR6 LI   R6,6
BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
       CI   R7,4                USE or CREATE?
       JLT  BKCLN1              No
       BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
BKCLN1 MOV  R6,R0               Pass error back to caller
       JMP  BKEXIT
BRWDON CLR  R6
       BL   @BKCLOS             Close current blocks file
       JNE  BRWDN1              Error?
       LI   R6,9                Yes...assume it was a file error
BRWDN1 CI   R7,4                (no error)...CREATE?
       JNE  BRWDN2              No...we're done
       BL   @BPTOG              Yes...revert to correct blocks file
BRWDN2 MOV  R6,R0               Error to R0
BKEXIT MOV  @SVBRET,LINK        Restore LINK
       B    @BKLINK
;]
;[* MSGTYP      <<< Support for string typing in various banks >>>
*
* Called with:  BL  @MSGTYP
* 
* R4 and R5 are the only registers that will be preserved
* ..after a call to EMIT---
*
* Input:    R4 = Address of length byte of packed string
*
* We will pass the ASCII value of character to EMIT in R2 without
* insuring it is 7 bits wide.
*
MSGTYP DECT R           Push return address
       MOV  LINK,*R     ...to Forth return stack
       CLR  R5          
       MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
       SWPB R5          Put char count in low byte
MTLOOP CLR  R2
       MOVB *R4+,R2     Copy next char to R2 for EMIT
       SWPB R2          Put char in low byte
       LIMI 0           We need to do this because we're calling EMIT directly
       BL   @EMT        Call EMIT directly
       INC  @$OUT(U)    Increment display line character count
       DEC  R5          Decrement character count for this message
       JNE  MTLOOP      Are we done?
       MOV  *R+,LINK    Yes. Pop return address
       RT               Return to caller
 ;]      
;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
R4$5   MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4,*R5
       RT
;]
*     __  __              _   __         _      __   __   
*    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__ 
*   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
*   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/ 
*              ___      ___          ____    
*             / _ \___ / _/__ ___ __/ / /____
*            / // / -_) _/ _ `/ // / / __(_-<
*           /____/\__/_/ \_,_/\_,_/_/\__/___/

;[*== User Variable defaults ============================================
* 
UBASE0 BSS  6                 BASE OF USER VARIABLES
       DATA UBASE0            06 USER UCONS$
       DATA SPBASE            08 USER S0
       DATA RBASE             0A USER R0 { R0$
       DATA $UVAR             0C USER U0
       DATA SPBASE            0E USER TIB
       DATA 31                10 USER WIDTH
       DATA DPBASE            12 USER DP
       DATA $SYS$             14 USER SYS$
       DATA 0                 16 USER CURPOS
       DATA INT1              18 USER INTLNK
       DATA 1                 1A USER WARNING
       DATA 64                1C USER C/L$ { CL$
       DATA $BUFF             1E USER FIRST$
       DATA $LO               20 USER LIMIT$
       DATA >0380             22 USER COLTAB    Color Table address in VRAM
       DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
       DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
       DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
       DATA >80               2A USER FPB       pushes address of user screen font file PAB
*                                               ...that is this relative distance from DISK_BUF
       DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
       DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
       DATA 40                30 USER SCRN_WIDTH
       DATA 0                 32 USER SCRN_START
       DATA 960               34 USER SCRN_END
       DATA 0                 36 USER ISR       [Note: This used to be INT1]
       DATA 0                 38 USER ALTIN
       DATA 0                 3A USER ALTOUT
       DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
       DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
*                                               ...that is this relative distance from DISK_BUF
       DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
*                                               ...always toggled between 0 and 70
       DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
       DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
*                                                  0 = console font via GPLLNK
       DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
       DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
       DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
*                                                  0 = Symmetric (default)
*                                                 !0 = Floored
$UVAR  BSS  >80               USER VARIABLE AREA
;]
;[*== A Constant ====================================================
*
H2000  DATA >2000
;]*
*    __  ____  _ ___ __         _   __        __             
*   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
*  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
*  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
*                     /___/                                  
* 
;[*== Utility Vectors ===================================================
*
* GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
* DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
XMLLNK DATA UTILWS,XMLENT   ; Link to ROM routines
KSCAN  DATA UTILWS,KSENTR   ; Keyboard scan
VSBW   DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
VMBW   DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
VSBR   DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
VMBR   DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
VMOVE  DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
VWTR   DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
;]*
;[*== XMLENT -- Link to system XML utilities ============================
*
XMLENT MOV  *R14+,@GPLWS+2      Get argument
       LWPI GPLWS               Select GPL workspace
       MOV  R11,@UTILWS+22      Save GPL return address
       MOV  R1,R2               Make a copy of argument
       CI   R1,>8000            Direct address in ALC?
       JH   XML30               We have the address
       SRL  R1,12
       SLA  R1,1
       SLA  R2,4
       SRL  R2,11
       A    @XMLTAB(R1),R2
       MOV  *R2,R2
XML30  BL   *R2
       LWPI UTILWS              Get back to right WS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    ________  __   __   _  ____ __           __  ________
*   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
*  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
* This routine will work with any GROM library slot since it is         *
* indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
* This GPLLNK does NOT require a module to be plugged into the          *
* GROM port so it will work with the Editor/Assembler,                  *
* Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
* CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
* It saves and restores the current GROM Address in case you want       *
* to return back to GROM for Basic or Extended Basic CALL LINKs         *
* or to return to the loading module.                                   *
*                                                                       *
*    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
*                                                 DATA >34              *
*                                                                       *
*    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
*                                                                       *
* 70 Bytes - including the GPLLNK Workspace                             *
*-----------------------------------------------------------------------*

*  GPLWS (>83E0) is GPL workspace
G_R4   EQU  GPLWS+8              GPL workspace R4
G_R6   EQU  GPLWS+12             GPL workspace R6
*  SUBSTK (>8373) is GPL Subroutine stack pointer
LDGADR EQU  >60                  Load & Execute GROM address entry point
XTAB27 EQU  >200E                Low Mem XML table location 27
*                                ..Will contain XMLRTN at startup
GETSTK EQU  >166C              
 
GPLLNK DATA GLNKWS     ; R7       Set up BLWP Vectors
       DATA GLINK1     ; R8     
* RTNADR     <---don't think we need this label
       DATA XMLRTN     ; R9       address where GPL XML returns to us...
*                                ...this address will already be in XTAB27,...
*                                ...>200E, so don't really need it here}
GXMLAD DATA >176C      ; R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
       DATA >50        ; R11      Initialized to >50 where PUTSTK address resides
GLNKWS EQU  $->18      ; GPLLNK's workspace of which only...
       BSS  >08        ; R12-R15  ...registers R7 through R15 are used

GLINK1 MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
       MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
       LWPI GPLWS                Load GPL WS
       BL   *R4                  Save current GROM Address on stack
       MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
       INCT @SUBSTK              Adjust the stack pointer
       B    @LDGADR              Execute our GPL Routine

XMLRTN MOV  @GETSTK,R4           Get GETSTK pointer
       BL   *R4                  Restore GROM address off the stack
       LWPI GLNKWS               Load our WS
       RTWP                      All Done - Return to Caller
;]
*     ___  _______  __   _  ____ __           __  ________
*    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
*   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
*      (Uses console GROM 0's DSRLNK routine)                           *
*      (Do not REF DSRLNK or GPLLNK when using these routines)          *
*      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
*                                                                       *
*      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
*                                                   DATA 8              *
*                                                                       *
*      NOTES: Must be used with a GPLLNK routine                        *
*             Returns ERRORs the same as the E/A DSRLNK                 *
*             EQ bit set on return if error                             *
*             ERROR CODE in caller's MSB of Register 0 on return        *
*                                                                       *
* 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
*-----------------------------------------------------------------------*

PUTSTK EQU  >50                     Push GROM Address to stack pointer
TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
VWA    EQU  >8C02                   VDP Write Address location
VRD    EQU  >8800                   VDP Read Data byte location
G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
GSTAT  EQU  >837C                   GPL Status byte location
                                    
DSRLNK DATA DSRWS,DLINK1            Set BLWP Vectors

DSRWS                      ; Start of DSRLNK workspace
DR3LB  EQU  $+7            ; lower byte of DSRLNK workspace R3
DLINK1 MOV  R12,R12         R0      Have we already looked up the LINK address?
       JNE  DLINK3          R1      YES!  Skip lookup routine
*<<-------------------------------------------------------------------------->>*
* This section of code is only executed once to find the GROM address          *
* for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
* to indicate that the address is found and to be used as a mask for EQ & CND  *
*------------------------------------------------------------------------------*
       LWPI GPLWS           R2,R3   else load GPL workspace
       MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
       BL   *R4             R6
       LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
       MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector

***les*** Note on above instruction:
***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)

       JMP  DLINK2          R11     Jump around R12-R15
       DATA 0               R12     contains >2000 flag when set
       DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
       MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
       MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
       INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
       BL   *R5                     Restore the GROM address off the stack
       LWPI DSRWS                   Reload DSRLNK workspace
       LI   R12,>2000               Set flag to signify DSRLNK address is set
*<<-------------------------------------------------------------------------->>*
DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
       MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
       MOV  @NAMLEN,R3              Save VDP address of Name Length
       AI   R3,-8                   Adjust it to point to PAB Flag byte
       BLWP @GPLLNK                 Execute DSR LINK
DSRADR BYTE >03                     High byte of GPL DSRLNK address
DSRAD1 BYTE >00                     Lower byte of GPL DSRLNK address
*----Error Check & Report to Caller's R0 and EQU bit-------------------------
       MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
       MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
       SZCB R12,R15                 Clear EQ bit for Error Report
       MOVB @VRD,R3                 Get PAB Error Flag
       SRL  R3,5                    Adjust it to 0-7 error code
       MOVB R3,*R13                 Put it into Caller's R0 (msb)
       JNE  SETEQ                   If it's not zero, set EQ bit
       COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
       JNE  DSREND                  No Error, Just return
SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
DSREND RTWP                         All Done - Return to Caller
;]
;[*== KSENTR -- Keyboard Scan (entry point) =============================
*
KSENTR LWPI GPLWS
       MOV  R11,@UTILWS+22      Save GPL return address
       BL   @SCNKEY             Console keyboard scan routine
       LWPI UTILWS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    _   _____  ___    __  ____  _ ___ __  _       
*   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
*   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
*   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
* 
;[*== VDP utilities (entry point) =======================================
*
** VDP single byte write
*
VSBWEN BL   @WVDPWA             Write out address
       MOVB @2(R13),@VDPWD      Write data
       RTWP                     Return to calling program
*                            
** VDP multiple byte write   
*                            
VMBWEN BL   @WVDPWA             Write out address
VWTMOR MOVB *R1+,@VDPWD         Write a byte
       DEC  R2                  Decrement byte count
       JNE  VWTMOR              More to write?
       RTWP                     Return to calling Program
*                            
** VDP single byte read      
*                            
VSBREN BL   @WVDPRA             Write out address
       MOVB @VDPRD,@2(R13)      Read data
       RTWP                     Return to calling program
*                            
** VDP multiple byte read    
*                            
VMBREN BL   @WVDPRA             Write out address
VRDMOR MOVB @VDPRD,*R1+         Read a byte
       DEC  R2                  Decrement byte count
       JNE  VRDMOR              More to read?
       RTWP                     Return to calling program
*                            
** VDP write to register     
*                            
VWTREN MOV  *R13,R1             Get register number and value
       MOVB @1(R13),@VDPWA      Write out value
       ORI  R1,>8000            Set for register write
       MOVB R1,@VDPWA           Write out register number
       RTWP                     Return to calling program
*
** Set up to write to VDP
*
WVDPWA LI   R1,>4000
       JMP  WVDPAD
*
** Set up to read VDP
*
WVDPRA CLR  R1
*
** Write VDP address
*
WVDPAD MOV  *R13,R2             Get VDP address
       MOVB @U_R2LB,@VDPWA      Write low byte of address
       SOC  R1,R2               Properly adjust VDP write bit
       MOVB R2,@VDPWA           Write high byte of address
       MOV  @2(R13),R1          Get CPU RAM address
       MOV  @4(R13),R2          Get byte count
       RT                       Return to calling routine

*
** VDP-to-VDP move.
*
VMOVEN MOV  *R13,R1             Get cnt to R1
       MOV  @2(R13),R2          Get vsrc to R2
       MOV  @4(R13),R3          Get vdst to R3
       ORI  R3,>4000            Prepare for VDP write

** copy cnt bytes from vsrc to vdst

VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
       MOVB R2,@VDPWA           Write MSB of VDP read address
       INC  R2                  Next VDP read address
       MOVB @VDPRD,R0           Read VDP byte
       MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
       MOVB R3,@VDPWA           Write MSB of VDP write address
       INC  R3                  Next VDP write address
       MOVB R0,@VDPWD           Write VDP byte
       DEC  R1                  Decrement count
       JNE  VMVMOR              Repeat if not done
       RTWP                     Return to calling program
;]*
;[*== fbForth Version Message ===========================================
FBFMSG 
* This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
* Also, printing the extra blanks overwrites the font-not-found error message.
       BYTE 17
       TEXT 'fbForth 2.0:     '     
;]
*     __  ___        ___ ____      __   __      _      __            __  
*    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
*   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
*  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
* 
;[*== Modifiable words in Resident Dictionary ===========================
;[*** (ABORT) ***
       DATA x#VLST_N         <--Last word in ROM
PABR_N DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT

PABORT DATA DOCOL
       DATA ABORT,SEMIS
;]*
;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
       DATA PABR_N
FRTH_N DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT

FORTH  DATA DOVOC
FORTHV DATA DPBASE+2    ; vocabulary link field 
FORTHP DATA >81A0       ; pseudo name field
FORTHL DATA 0           ; chronological link field
;]*
;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
       DATA FRTH_N
ASMR_N DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT

ASSM   DATA DOVOC
; Initially points to last word in ASSEMBLER vocabulary in the kernel
ASMV   DATA SASM_N   ; vocabulary link field
       DATA >81A0    ; pseudo name field
ASML   DATA FORTHL   ; chronological link field

*                    
;]*
;]*
*    ___                     __   __       
*   / _ | ___ ___ ___ __ _  / /  / /__ ____
*  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
* /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/   
*     _   __              __        __                _      __            __  
*    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
*    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
*    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
*                                           /___/  
*
*== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
;[*** NEXT, ***      ( --- )
* 1st word in ASSEMBLER vocabulary
*
       DATA FORTHP          <--points to PNF of FORTH
NXT__N DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT

NEXTC  DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
       MOV  @$DP(U),R1        HERE to R1
       MOV  R0,*R1+           compile "B *NEXT"
       MOV  R1,@$DP(U)        update HERE
       MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
       B    *NEXT             back to inner interpreter

* : NEXT,   ( --- )
*    *NEXT B,  ;
;]*
;[*** ;ASM ***       ( --- ) 
* 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
* ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
*
       DATA NXT__N
SASM_N BYTE 4+TERMBT    <--note different name field format
       TEXT ';ASM'
       BYTE ' '+TERMBT

SASM   DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
       JMP  NXT_P          finish up in NEXT,

* : ;ASM   ( --- )
*    *NEXT B,  ;
;]*

;[*== Some Variables (KEYCNT etc.) ======================================

KEYCNT DATA -1              Used in cursor flash logic
INTACT DATA 0               Non-zero during user's interrupt service routine
*
*++ variables used by some graphics primitives
*
$DMODE DATA 0                   ; actual location of variable contents
$DCOL  DATA -1                  ; actual location of variable contents

*===========================================================
;]*
*   ______                         ___            _____        __   
*  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__ 
*   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
*  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/ 
*                    /_/                                            
* 
;[*== Trampoline Code ===================================================
* 
* MYBANK must be at same location in all banks with the code that appears
* in the following table.  The EQUates for BANK0--BANK3 may also be in the
* same places in each bank for convenience, but they only need to appear once.
* 
*       Bank Select MYBANK
*       ---- ------ ------
*       0    >6006  >C000
*       1    >6004  >8000
*       2    >6002  >4000
*       3    >6000  >0000
* 
* Bank0 code will look like this
*
* MYBANK DATA >C000
* BANK0  EQU  >C000
* BANK1  EQU  >8000
* BANK2  EQU  >4000
* BANK3  EQU  >0000
*
* Banks 1--3 will look the same, including labels, and the DATA
* instruction at MYBANK's location will correspond to its bank.
*
* Before a bank is selected, the values above will be shifted right 13
* bits and have >6000 added.
*
;[*** BLBANK ************************************************************
*
* General bank branching routine (32KB ROM, i.e., 4 banks) for a
* branch that is expected to return (not high-level Forth) via RTBANK---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLBANK
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLBANK DECT R               ; reserve space on return stack (R14)
       MOV  *LINK+,CRU      ; copy destination bank address to R12
       MOV  LINK,*R         ; push return address
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
       MOV  CRU,LINK        ; copy destination bank address to R11
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*
;[*** RTBANK ************************************************************
*
* General bank return routine (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTBANK
*
RTBANK MOV  *R+,CRU         ; pop return bank# from return stack to R12
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       MOV  *R+,LINK        ; pop return address from return stack
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to return address
;]*
;[*** BLF2A *************************************************************
*
* High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to bank0 via RTNEXT.  This will
* only(?) be used for the ALC payload of Forth stubs in bank0---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLF2A
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLF2A  MOV  *LINK,LINK      ; copy destination bank address to R11
       MOV  LINK,CRU        ; copy it to R12
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*                           
;[*** RTNEXT ************************************************************
*
* High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4 
* banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTNEXT
*
RTNEXT MOV  @INTACT,CRU       Are we in user's ISR?
       JNE  RTNXT1            Don't enable interrupts if so.
       LIMI 2
RTNXT1 CLR  @>6006          ; switch to bank 0
       B    *NEXT           ; branch to next CFA (in R15)
;]*
;[*** BLA2F *************************************************************
*
* ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to calling bank via RTA2F---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLA2F
*       DATA <Forth cfa in bank0>
*
BLA2F  DECT R               ; reserve space on return stack 
       MOV  *LINK+,W        ; move CFA of Forth routine to W
       MOV  LINK,*R         ; push return address of calling bank
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
       DECT R               ; reserve spot on return stack
       MOV  IP,*R           ; move current IP to return stack
       LI   IP,RTA2F        ; move address of return procedure to IP
       CLR  @>6006          ; switch to bank0
       B    @DOEXEC         ; Execute the Forth routine
;]*
;[*** RTA2F *************************************************************
*
* ALC to high-level Forth bank "return" routine from Forth to calling
* ALC (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called through B *NEXT at end of Forth word's execution in BLA2F
*
RTA2F  DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
       DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
       MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
* Retrieve ALC return info and return to caller...
* ...caller will execute B *NEXT when it finishes
       B    @RTBANK         ; branch to general bank return routine above
;]*
;]***********************************************************************
;[*++ Bank-specific cell-/byte-reading code ++*
;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
*++ Read cell contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKAT  CLR  *R0             ; switch banks
       MOV  *R1,*SP         ; get cell contents of address to stack
       B    @RTNEXT         ; return to inner interpreter
;]*
;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
*++ Read byte contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKCAT CLR  *R0             ; switch banks
       CLR  R2              ; clear R2
       MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
       MOV  R2,*SP          ; get byte contents of address to stack
       B    @RTNEXT         ; return to inner interpreter

;]*

;]*
*         _______   __  _________      ___          __    
*        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
*       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
*      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, / 
*                                                  /___/  
* 
;[*** SAMS! ***      ( --- )
* This calls the SAMS initialization in the startup code in bank 1.
* 
*        DATA SMSQ_N
* SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
* SAMSST DATA $+2
*        BL   @BLF2A
*        DATA _SMSST->6000+BANK1

_SMSST BL   @SMSINI           initialize SAMS card
       B    @RTNEXT           back to inner interpreter
;]*   
;[*== Required strings, tables, variables... ============================
*
*
* Default blocks filename
*
DEFNAM BYTE 12
       TEXT "DSK1.FBLOCKS "
*
* Default colors for all VDP modes---
*     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
*     LSB: Color Table colors (FG/BG)
*
DEFCOL DATA >4F00          ; TEXT80    offset=0
       DATA >4F00          ; TEXT      offset=2
       DATA >F4F4          ; GRAPHICS  offset=4
       DATA >11F4          ; MULTI     offset=6
       DATA >FE10          ; GRAPHICS2 offset=8
       DATA >FEF4          ; SPLIT     offset=10
       DATA >FEF4          ; SPLIT2    offset=12
*
* Default text mode
*
DEFTXT DATA >0001
*
* Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
*
FNTFLG DATA 0              ; font flag initially 0
*
* Speech variables needing initial value (more below LLVEND)
*
SPCSVC DATA 0
*
* Sound Table #1 Workspace for sound variables.  Only using R0..R4
*
SND1WS 
SND1ST DATA 0           ; R0 (sound table status) 0=no table..
                        ; ..1=loading sound bytes..-1=counting
SND1DS DATA SOUND       ; R1 (sound-table byte destination)..
                        ; ..initialized to sound chip
SND1AD DATA 0           ; R2 (sound table address)
SND1CT DATA 0           ; R3 (# of sound bytes to load or..
                        ; ..sound count = seconds * 60)
SND1SP DATA SNDST0      ; R4 (pointer to top of sound stack)..
                        ; ..initialized to bottom of sound stack              
* 
* Sound Table #2 Workspace for sound variables.  Only using R0..R3
*
SND2WS 
SND2ST DATA 0           ; R0 (sound table status) 0=no table..
                        ; ..1=loading sound bytes..-1=counting
SND2DS DATA SOUND       ; R1 (sound-table byte destination) init to sound chip
;]*
* 
* This is the end of low-level support code that gets copied.
*
LLVEND

;[*== Un-initialized Variables and workspaces... =========================
* Start of definitions of variables and workspaces that do not need to
* take up space in ROM because they need no initial values.
*
* Sound Table #2 Workspace for sound variables..continued.
*
SND2AD EQU  SND2WS+4    ; R2 (sound table address)
SND2CT EQU  SND2WS+6    ; R3 (# of sound bytes to load or..
*                       ; ..sound count = seconds * 60)
SDMUTE EQU  SND2WS+8    ; dummy destination for sound byte
* 
* Branch Stack for ISR processing of Speech, 2 Sound Tables and return
*
BRSTK  EQU  SDMUTE+2
*
* Speech variables (more above LLVEND)
* 
SSFLAG EQU  BRSTK+8
SPCNT  EQU  SSFLAG+2
SPADR  EQU  SPCNT+2
BANKSV EQU  SPADR+2
PADSV  EQU  BANKSV+2
*
* Panel window: height, width and screen position...used by PANEL and SCROLL
*
PANWIN EQU  PADSV+12          panel height, width and screen start
 
*== Utility Workspace =================================================
*** General utility workspace registers
UTILWS EQU  PANWIN+6
U_R2LB EQU  UTILWS+5

LINBUF EQU  UTILWS+32
CURCHR EQU  LINBUF+80

*++ variable used by the 40/80-column editor
OLDCUR EQU  CURCHR+2

*++ FILE I/O variables
 
PBADR  EQU  OLDCUR+8
PBBF   EQU  PBADR+2
PBVBF  EQU  PBBF+2
 
*++ Floating Point Math Library variables
FPVARS EQU  PBVBF+2
 
*++ SAMS flag
SAMSFL EQU  FPVARS+22

*++ Bottom of Sound Stack 
*++      This location marks the top of the low-level support code. The Sound
*++      Stack grows upward toward the Return Stack by moving the entire stack
*++      up one cell to make room for the next new bottom entry.
SNDST0 EQU  SAMSFL+2
;]*

       AORG
       BANK 1

and its listing:

Spoiler


     **** ****     > fbForth101_LowLevelSupport.a99
0001               *     __                  __                __
0002               *    / /  ___ _    ______/ /  ___ _  _____ / /
0003               *   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) /
0004               *  /____/\___/__,__/   /____/\__/|___/\__/_/
0005               *                     ____                        __
0006               *                    / __/_ _____  ___  ___  ____/ /_
0007               *                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
0008               *                  /___/\_,_/ .__/ .__/\___/_/  \__/
0009               *                          /_/  /_/
0010               *
0011               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0012               *                                                                   *
0013               * fbForth---                                                        *
0014               *                                                                   *
0015               *       Low-level support routines                                  *
0016               *                                                                   *
0017               *  << Including Trampoline Code, tables & variables:  2606 bytes >> *
0018               *                                                                   *
0019               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0020               
0021               LLVSPT   ; <--This is the source copy location for the rest of this code.
0022               
0023      2010     $BUFF  EQU  >2010
0024               
0025               * 4 I/O buffers below ($LO = >3020)
0026               * Change '4' to number of buffers needed and for which there is room.
0027               
0028      3020     $LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers
0029               
0030                      XORG $LO      ; calculate destination addresses
0031               
0032               *       _____   ____         __  __      ___________
0033               *      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
0034               *     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
0035               *    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_|
0036               *
0037               ;[*** Interrupt Service =======================================================
0038               * This routine is executed for every interrupt.  It processes any pending
0039               * speech and souind.  It then looks to see whether a user ISR is installed in
0040               * ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work
0041               * only if the user has installed an ISR using the following steps in the fol-
0042               * lowing order:
0043               *
0044               *   (1) Write an ISR with entry point, say MYISR.
0045               *   (2) Determine code field address of MYISR with this high-level Forth:
0046               *           ' MYISR CFA
0047               * <<< Maybe need a word to do #3 >>>
0048               *   (3) Write CFA of MYISR into user variable ISR.
0049               *
0050               * Steps (2)-(3) in high-level Forth are shown below:
0051               *           ' MYISR CFA
0052               *           ISR !
0053               *
0054               * <<< Perhaps last step above should be by a word that disables interrupts >>>
0055               *
0056               * The console ISR branches to the contents of >83C4 because it is non-zero,
0057               * with the address, INT1, of the fbForth ISR entry point below (also, the
0058               * contents of INTLNK).  This means that the console ISR will branch to INT1
0059               * with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
0060               * process any pending speech and sound.
0061               *
0062               * If the user's ISR is properly installed, the code that processes the user
0063               * ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
0064               * from Forth's workspace (MAINWS), the code at INT2 will process the user's
0065               * ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
0066               * inner interpreter.
0067               *** ==========================================================================
0068               
0069               * ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!
0070               
0071               INT1
0072 6140 0200  20        LI   R0,BRSTK          load address of top of Branch Address Stack
     6142 3A2A     
0073               *
0074               * Set up for pending speech
0075               *
0076 6144 C420  46        MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
     6146 3A14     
0077 6148 1301  14        JEQ  SNDCH1            jump to sound-check if no speech
0078 614A 05C0  14        INCT R0                increment Branch Stack
0079               *
0080               * Set up for pending sound table #1 (ST#1)
0081               *
0082 614C C0A0  34 SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
     614E 3A16     
0083 6150 1303  14        JEQ  SNDCH2            process speech and sound if needed
0084 6152 0201  20        LI   R1,x#PLAYT1         load PLAYT1 address and...
     6154 7C68     
0085 6156 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0086               *
0087               * Set up for pending sound table #2 (ST#2)
0088               *
0089 6158 C0E0  34 SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
     615A 3A20     
0090 615C 1303  14        JEQ  PRCSPS            process speech and sound if needed
0091 615E 0201  20        LI   R1,x#PLAYT2         load PLAYT2 address and...
     6160 7C6E     
0092 6162 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0093               *
0094               * Process sound stack if both sound tables idle
0095               *
0096 6164 E0C2  18 PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
0097 6166 160A  14        JNE  PRSPS2            nope..skip sound stack processing
0098 6168 02E0  18        LWPI SND1WS            switch to ST#1 WS
     616A 3A16     
0099 616C 0284  22        CI   R4,SNDST0         anything on sound stack?
     616E 3AE4     
0100 6170 1303  14        JEQ  PRSPS1            no..exit sound stack processing
0101 6172 0644  14        DECT R4                pop sound stack position
0102 6174 C094  26        MOV  *R4,R2            get sound table address from sound stack
0103 6176 0580  14        INC  R0                kick off sound processing of ST#1 (R0=1)
0104 6178 02E0  18 PRSPS1 LWPI GPLWS             switch back to GPL WS
     617A 83E0     
0105               *
0106               * Check for any pending speech and sound
0107               *
0108 617C 0280  22 PRSPS2 CI   R0,BRSTK          any speech or sound to process?
     617E 3A2A     
0109 6180 1312  14        JEQ  USRISR            if not, jump to user ISR processing
0110 6182 0201  20        LI   R1,BNKRST         yup..load return address
     6184 307A     
0111 6186 C401  30        MOV  R1,*R0            push return address onto Branch Stack
0112               *
0113               * Process pending speech and sound
0114               *
0115 6188 C820  54        MOV  @x#MYBANK,@BANKSV   save bank at interrupt
     618A 7FFE     
     618C 3A38     
0116 618E 04E0  34        CLR  @>6002            switch to bank 2 for speech & sound services
     6190 6002     
0117 6192 0207  20        LI   R7,BRSTK          load top of Branch Stack
     6194 3A2A     
0118 6196 C237  30        MOV  *R7+,R8           pop speech/sound ISR
0119 6198 0458  20        B    *R8               service speech/sound
0120               *
0121               * Restore interrupted bank
0122               *
0123               BNKRST                ; return point for speech and sound ISRs
0124 619A C020  34        MOV  @BANKSV,R0        restore bank at interrupt
     619C 3A38     
0125 619E 09D0  56        SRL  R0,13             get the bank# to correct position
0126 61A0 0220  22        AI   R0,>6000          make it a real bank-switch address
     61A2 6000     
0127 61A4 04D0  26        CLR  *R0               switch to the bank at interrupt
0128               *
0129               * Process User ISR if defined
0130               *
0131 61A6 C020  34 USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
     61A8 36EA     
0132 61AA 1304  14        JEQ  INTEX
0133               *
0134               * Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
0135               * is executed from Forth's WS (MAINWS = >8300), which it does at the end of
0136               * every CODE word, keyboard scan and one or two other places.
0137               *
0138 61AC 0201  20        LI   R1,INT2                 Load entry point, INT2
     61AE 309A     
0139 61B0 C801  38        MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
     61B2 831E     
0140               *
0141               * The following 2 instructions are copies of the remainder of the console ROM's
0142               * ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
0143               * because we're not going back there!
0144               *
0145 61B4 02E0  18 INTEX  LWPI >83C0             Change to console's ISR WS
     61B6 83C0     
0146 61B8 0380  18        RTWP                   Return to caller of console ISR
0147               *
0148               * Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
0149               * before executing user's ISR. INT3 (cleanup routine below) will be inserted
0150               * in address list to get us back here for cleanup after user's ISR has finished.
0151               * User's ISR is executed at the end of this section just before INT3.
0152               *
0153 61BA 0300  24 INT2   LIMI 0                 Disable interrupts
     61BC 0000     
0154 61BE D020  34        MOVB @>83D4,R0         Get copy of VR01
     61C0 83D4     
0155 61C2 0980  56        SRL  R0,8              ...to LSB
0156 61C4 0260  22        ORI  R0,>100           Set up for VR01
     61C6 0100     
0157 61C8 0240  22        ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
     61CA FFDF     
0158 61CC 0420  54        BLWP @VWTR             Turn off VDP interrupt
     61CE 3752     
0159 61D0 020F  20        LI   NEXT,$NEXT        Restore NEXT
     61D2 833A     
0160 61D4 0720  34        SETO @INTACT           Set Forth "pending interrupt" flag
     61D6 3956     
0161 61D8 064E  14        DECT R                 Set up return linkage by pushing
0162 61DA C78D  30        MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
0163 61DC 020D  20        LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
     61DE 30C8     
0164 61E0 C2A8  34        MOV  @$ISR(U),W        Do the user's Forth ISR by executing
     61E2 0036     
0165 61E4 0460  28        B    @DOEXEC           ...it through Forth's inner interpreter
     61E6 833C     
0166               *
0167               * Clean up and re-enable interrupts.
0168               *
0169 61E8 30CA     INT3   DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
0170 61EA 30CC            DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
0171 61EC C37E  30        MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
0172 61EE 04E0  34        CLR  @INTACT           Clear Forth "pending interrupt" flag
     61F0 3956     
0173 61F2 D020  34        MOVB @>83D4,R0         Prepare to restore VR01 by...
     61F4 83D4     
0174 61F6 0980  56        SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
0175 61F8 0220  22        AI   R0,>100           ...VR # (01) to MSB
     61FA 0100     
0176 61FC D060  34        MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
     61FE 8802     
0177 6200 0420  54        BLWP @VWTR             Write VR01
     6202 3752     
0178 6204 0300  24        LIMI 2                 Re-enable interrupts
     6206 0002     
0179 6208 045F  20        B    *NEXT             Continue normal task
0180               ;]*
0181               ;[*** BKLINK from SYSTEM calls ==========================================
0182               *
0183 620A C1E0  34 BKLINK MOV  @INTACT,R7        Are we in user's ISR?
     620C 3956     
0184 620E 1602  14        JNE  BKLIN1            Don't enable interrupts if so.
0185 6210 0300  24        LIMI 2
     6212 0002     
0186 6214 045B  20 BKLIN1 B    *LINK
0187               ;]*
0188               *      ____         __              _____     ____
0189               *     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
0190               *    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
0191               *   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
0192               *       /___/
0193               *
0194               ;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================
0195               
0196               *       Entry point for low-level system support functions
0197               
0198 6216 0300  24 $SYS$  LIMI 0
     6218 0000     
0199 621A C021  34        MOV  @SYSTAB(R1),R0
     621C 3114     
0200 621E 0450  20        B    *R0
0201               ;]
0202               ;[*** SYSTAB -- Vector table for SYSTEM calls ===========================
0203               
0204 6220 34C6            DATA BRW          CODE = -20  write block to blocks file
0205 6222 34C6            DATA BRW          CODE = -18  read block from blocks file
0206 6224 34C6            DATA BRW          CODE = -16  create blocks file
0207 6226 34C6            DATA BRW          CODE = -14  use blocks file
0208 6228 346C            DATA GXY          CODE = -12  GOTOXY
0209 622A 3456            DATA QKY          CODE = -10  ?KEY
0210 622C 343C            DATA QTM          CODE =  -8  ?TERMINAL
0211 622E 3420            DATA CLF          CODE =  -6  CRLF
0212 6230 3312            DATA EMT          CODE =  -4  EMIT
0213 6232 3260            DATA KY           CODE =  -2  KEY
0214 6234 3130     SYSTAB DATA SBW          CODE =   0  VSBW
0215 6236 313E            DATA MBW          CODE =   2  VMBW
0216 6238 314C            DATA SBR          CODE =   4  VSBR
0217 623A 315A            DATA MBR          CODE =   6  VMBR
0218 623C 3176            DATA WTR          CODE =   8  VWTR
0219 623E 3186            DATA GPL          CODE =  10  GPLLNK
0220 6240 31A6            DATA XML          CODE =  12  XMLLNK
0221 6242 31C0            DATA DSR          CODE =  14  DSRLNK
0222 6244 31DA            DATA CLS$         CODE =  16  CLS
0223 6246 3168            DATA MVE          CODE =  18  VMOVE
0224 6248 31F4            DATA FILL$        CODE =  20  VFILL
0225 624A 3224            DATA AOX          CODE =  22  VAND
0226 624C 3224            DATA AOX          CODE =  24  VOR
0227 624E 3224            DATA AOX          CODE =  26  VXOR
0228               ;]*
0229               ;[*== VDP single byte write.                CODE =   0  =================
0230               *
0231 6250 C039  30 SBW    MOV  *SP+,R0         VRAM address (destination)
0232 6252 C079  30        MOV  *SP+,R1         Character to write
0233 6254 06C1  14        SWPB R1              Get in left byte
0234 6256 0420  54        BLWP @VSBW
     6258 373E     
0235 625A 0460  28        B    @BKLINK
     625C 30EA     
0236               ;]*
0237               ;[*== VDP multi byte write.                 CODE =   2  =================
0238               *
0239 625E C0B9  30 MBW    MOV  *SP+,R2         Number of bytes to move
0240 6260 C039  30        MOV  *SP+,R0         VRAM address (destination)
0241 6262 C079  30        MOV  *SP+,R1         RAM address (source)
0242 6264 0420  54        BLWP @VMBW
     6266 3742     
0243 6268 0460  28        B    @BKLINK
     626A 30EA     
0244               ;]*
0245               ;[*== VDP single byte read.                 CODE =   4  =================
0246               *
0247 626C C019  26 SBR    MOV  *SP,R0          VRAM address (source)
0248 626E 0420  54        BLWP @VSBR
     6270 3746     
0249 6272 0981  56        SRL  R1,8            Character to right half for Forth
0250 6274 C641  30        MOV  R1,*SP          Stack it
0251 6276 0460  28        B    @BKLINK
     6278 30EA     
0252               ;]*
0253               ;[*== VDP multi byte read.                  CODE =   6  =================
0254               *
0255 627A C0B9  30 MBR    MOV  *SP+,R2         Number of bytes to read
0256 627C C079  30        MOV  *SP+,R1         RAM address (destination)
0257 627E C039  30        MOV  *SP+,R0         VRAM address (source)
0258 6280 0420  54        BLWP @VMBR
     6282 374A     
0259 6284 0460  28        B    @BKLINK
     6286 30EA     
0260               ;]*
0261               ;[*== VDP-to-VDP move.                      CODE =  18  =================
0262               *
0263 6288 C039  30 MVE    MOV  *SP+,R0         Pop cnt to R0
0264 628A C0B9  30        MOV  *SP+,R2         Pop vdst to R2
0265 628C C079  30        MOV  *SP+,R1         Pop vsrc to R1
0266 628E 0420  54        BLWP @VMOVE
     6290 374E     
0267 6292 0460  28        B    @BKLINK
     6294 30EA     
0268               ;]*
0269               ;[*== VDP register write.                   CODE =   8  =================
0270               *
0271 6296 C079  30 WTR    MOV  *SP+,R1         VDP register number
0272 6298 C039  30        MOV  *SP+,R0         Data for register
0273 629A 06C1  14        SWPB R1              Get register to left byte
0274 629C D001  18        MOVB R1,R0           Place with data
0275 629E 0420  54        BLWP @VWTR
     62A0 3752     
0276 62A2 0460  28        B    @BKLINK
     62A4 30EA     
0277               ;]*
0278               ;[*== GPL link utility.                     CODE =  10  =================
0279               *
0280 62A6 04C0  14 GPL    CLR  R0
0281 62A8 D800  38        MOVB R0,@KYSTAT
     62AA 837C     
0282 62AC 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62AE 0420     
0283 62B0 0201  20        LI   R1,GPLLNK         to the GPLLNK utility
     62B2 3784     
0284 62B4 C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0285 62B6 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62B8 045B     
0286 62BA C10B  18        MOV  LINK,R4         Save LINK address
0287 62BC 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62BE 8300     
0288 62C0 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0289 62C2 0460  28        B    @BKLINK
     62C4 30EA     
0290               ;]*
0291               ;[*== XML link utility.                     CODE =  12  =================
0292               *
0293 62C6 0200  20 XML    LI   R0,>0420        Construct the BLWP instruction
     62C8 0420     
0294 62CA 0201  20        LI   R1,XMLLNK         to the XMLLNK utility
     62CC 3736     
0295 62CE C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0296 62D0 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62D2 045B     
0297 62D4 C10B  18        MOV  LINK,R4         Save LINK address
0298 62D6 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62D8 8300     
0299 62DA C2C4  18        MOV  R4,LINK           and reconstruct LINK
0300 62DC 0460  28        B    @BKLINK
     62DE 30EA     
0301               ;]*
0302               ;[*== DSR link utility.                     CODE =  14  =================
0303               *
0304 62E0 0200  20 DSR    LI   R0,>0420        Construct the BLWP instruction
     62E2 0420     
0305 62E4 0201  20        LI   R1,DSRLNK         to the DSRLNK utility
     62E6 37BE     
0306 62E8 C0B9  30        MOV  *SP+,R2         This datum selects DSR or subroutine
0307 62EA 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62EC 045B     
0308 62EE C10B  18        MOV  LINK,R4         Save LINK address
0309 62F0 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62F2 8300     
0310 62F4 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0311 62F6 0460  28        B    @BKLINK
     62F8 30EA     
0312               ;]*
0313               ;[*== Screen clearing utility.              CODE =  16  =================
0314               *
0315 62FA C0A8  34 CLS$   MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
     62FC 0032     
0316 62FE C068  34        MOV  @$SEND(U),R1    End of screen in VRAM
     6300 0034     
0317 6302 6042  18        S    R2,R1           Screen size
0318 6304 0200  20        LI   R0,>2000        Blank character
     6306 2000     
0319 6308 C1CB  18        MOV  LINK,R7
0320 630A 06A0  32        BL   @FILL1
     630C 3208     
0321 630E C2C7  18        MOV  R7,LINK
0322 6310 0460  28        B    @BKLINK
     6312 30EA     
0323               ;]*
0324               ;[*== VDP fill routine.                     CODE =  20  =================
0325               *
0326 6314 C039  30 FILL$  MOV  *SP+,R0         Fill character
0327 6316 06C0  14        SWPB R0                to left byte
0328 6318 C079  30        MOV  *SP+,R1         Fill count
0329 631A C0B9  30        MOV  *SP+,R2         Address to start VRAM fill
0330 631C C1CB  18        MOV  LINK,R7
0331 631E 06A0  32        BL   @FILL1
     6320 3208     
0332 6322 C2C7  18        MOV  R7,LINK
0333 6324 0460  28        B    @BKLINK
     6326 30EA     
0334               *========================================================================
0335               FILL1          ; R0=char, R1=cnt, R2=vaddr
0336 6328 0262  22        ORI  R2,>4000        Set bit for VDP write
     632A 4000     
0337 632C 06C2  14        SWPB R2
0338 632E D802  38        MOVB R2,@VDPWA       LS byte first
     6330 8C02     
0339 6332 06C2  14        SWPB R2
0340 6334 D802  38        MOVB R2,@VDPWA       Then MS byte
     6336 8C02     
0341 6338 1000  14        NOP                  Kill time
0342 633A D800  38 FLOOP  MOVB R0,@VDPWD       Write a byte
     633C 8C00     
0343 633E 0601  14        DEC  R1
0344 6340 16FC  14        JNE  FLOOP           Not done, fill another
0345 6342 045B  20        B    *LINK
0346               ;]*======================================================================
0347               *
0348               *==== VAND -- VDP byte AND routine.         CODE =  22  =================
0349               *==== VOR -- VDP byte OR routine.           CODE =  24  =================
0350               ;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
0351               *
0352 6344 C0B9  30 AOX    MOV  *SP+,R2         VRAM address
0353 6346 06C2  14        SWPB R2
0354 6348 D802  38        MOVB R2,@VDPWA       LS byte first
     634A 8C02     
0355 634C 06C2  14        SWPB R2
0356 634E D802  38        MOVB R2,@VDPWA       Then MS byte
     6350 8C02     
0357 6352 1000  14        NOP                  Kill time
0358 6354 D0E0  34        MOVB @VDPRD,R3       Read byte
     6356 8800     
0359 6358 C039  30        MOV  *SP+,R0         Get data to operate with
0360 635A 06C0  14        SWPB R0                to left byte
0361               *** Now do requested operation *****************
0362 635C 0281  22        CI   R1,24
     635E 0018     
0363 6360 1304  14        JEQ  DOOR
0364 6362 1505  14        JGT  DOXOR
0365 6364 0543  14        INV  R3              These two instructions
0366 6366 4003  18        SZC  R3,R0             perform an 'AND'
0367 6368 1003  14        JMP  FINAOX
0368 636A E003  18 DOOR   SOC  R3,R0             perform 'OR'
0369 636C 1001  14        JMP  FINAOX
0370 636E 2803  18 DOXOR  XOR  R3,R0             perform 'XOR'
0371 6370 0201  20 FINAOX LI   R1,1
     6372 0001     
0372 6374 C1CB  18        MOV  LINK,R7
0373 6376 06A0  32        BL   @FILL1
     6378 3208     
0374 637A C2C7  18        MOV  R7,LINK
0375 637C 0460  28        B    @BKLINK
     637E 30EA     
0376               ;]*
0377               ;[*== KEY routine                           CODE =  -2  =================
0378               *
0379 6380 C028  34 KY    MOV  @$ALTI(U),R0      alternate input device?
     6382 0038     
0380 6384 131B  14        JEQ  KEY0              jump to keyboard input if not
0381               *
0382               *  R0 now points to PAB for alternate input device, the one-byte buffer
0383               *  for which must immediately precede its PAB.  PAB must have been set up
0384               *  to read one byte.
0385               *
0386 6386 04C7  14        CLR  R7                prepare to zero status byte
0387 6388 D807  38        MOVB R7,@KYSTAT        zero status byte
     638A 837C     
0388 638C 0580  14        INC  R0                point R0 to Flag/Status byte
0389 638E 0420  54        BLWP @VSBR             read it
     6390 3746     
0390 6392 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6394 1F00     
0391 6396 0420  54        BLWP @VSBW             write it back to PAB
     6398 373E     
0392 639A C040  18        MOV  R0,R1             Set up pointer...
0393 639C 0221  22        AI   R1,8              ...to namelength byte of PAB
     639E 0008     
0394 63A0 C801  38        MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
     63A2 8356     
0395 63A4 C0C0  18        MOV  R0,R3             save pointer (DSRLNK will trash it!)
0396 63A6 0420  54        BLWP @DSRLNK           get 1 byte from device
     63A8 37BE     
0397 63AA 0008            DATA >8
0398 63AC C003  18        MOV  R3,R0             restore pointer
0399 63AE 0640  14        DECT R0                point to one-byte VRAM buffer in front of PAB
0400 63B0 0420  54        BLWP @VSBR             read character
     63B2 3746     
0401 63B4 0981  56        SRL  R1,8              move to LSB
0402 63B6 C001  18        MOV  R1,R0             copy to return register
0403 63B8 0460  28        B    @BKLINK           return to caller
     63BA 30EA     
0404               *
0405               *  Input is comining from the keyboard
0406               *
0407 63BC C1E0  34 KEY0   MOV  @KEYCNT,R7
     63BE 3954     
0408 63C0 0587  14        INC  R7
0409 63C2 160A  14        JNE  KEY1
0410 63C4 C028  34        MOV  @CURPO$(U),R0
     63C6 0016     
0411 63C8 0420  54        BLWP @VSBR             Read character at cursor position...
     63CA 3746     
0412 63CC D801  38        MOVB R1,@CURCHR        ...and save it
     63CE 3ABC     
0413 63D0 0201  20        LI   R1,>1E00          Place cursor character on screen
     63D2 1E00     
0414 63D4 0420  54        BLWP @VSBW
     63D6 373E     
0415               *
0416 63D8 0420  54 KEY1   BLWP @KSCAN
     63DA 373A     
0417 63DC D020  34        MOVB @KYSTAT,R0
     63DE 837C     
0418 63E0 2020  38        COC  @H2000,R0         check status
     63E2 3734     
0419 63E4 1319  14        JEQ  KEY2              JMP if key was pressed
0420               *
0421 63E6 0287  22        CI   R7,100            No key pressed
     63E8 0064     
0422 63EA 1603  14        JNE  KEY3
0423 63EC D060  34        MOVB @CURCHR,R1
     63EE 3ABC     
0424 63F0 1006  14        JMP  KEY5
0425               *
0426 63F2 0287  22 KEY3   CI   R7,200
     63F4 00C8     
0427 63F6 1607  14        JNE  KEY4
0428 63F8 04C7  14        CLR  R7
0429 63FA 0201  20        LI   R1,>1E00          Cursor char
     63FC 1E00     
0430 63FE C028  34 KEY5   MOV  @CURPO$(U),R0
     6400 0016     
0431 6402 0420  54        BLWP @VSBW
     6404 373E     
0432 6406 C807  38 KEY4   MOV  R7,@KEYCNT
     6408 3954     
0433 640A C1E0  34        MOV  @INTACT,R7        Are we in user's ISR?
     640C 3956     
0434 640E 1602  14        JNE  KEY6              Don't enable interrupts if so.
0435 6410 0300  24        LIMI 2
     6412 0002     
0436 6414 064D  14 KEY6   DECT IP                This will re-execute KEY
0437 6416 045F  20        B    *NEXT
0438 6418 0720  34 KEY2   SETO @KEYCNT           Key was pressed
     641A 3954     
0439 641C C028  34        MOV  @CURPO$(U),R0     Restore character at cursor location
     641E 0016     
0440 6420 D060  34        MOVB @CURCHR,R1
     6422 3ABC     
0441 6424 0420  54        BLWP @VSBW
     6426 373E     
0442 6428 D020  34        MOVB @KYCHAR,R0        Put char in...
     642A 8375     
0443 642C 0980  56        SRL  R0,8              ...LSB of R0
0444 642E 0460  28        B    @BKLINK
     6430 30EA     
0445               ;]*
0446               ;[*== EMIT routine                          CODE =  -4  =================
0447               *
0448 6432 C042  18 EMT    MOV  R2,R1             copy char to R1 for VSBW
0449 6434 C028  34        MOV  @$ALTO(U),R0      alternate output device?
     6436 003A     
0450 6438 1317  14        JEQ  EMIT0             jump to video display output if not
0451               *
0452               *  R0 now points to PAB for alternate output device, the one-byte buffer
0453               *  for which must immediately precede its PAB.  PAB must have been set up
0454               *  to write one byte.
0455               *
0456 643A 04C7  14        CLR  R7                ALTOUT active
0457 643C D807  38        MOVB R7,@KYSTAT        zero status byte
     643E 837C     
0458 6440 0600  14        DEC  R0                point to one-byte VRAM buffer in front of PAB
0459 6442 06C1  14        SWPB R1                char to MSB
0460 6444 0420  54        BLWP @VSBW             write char to buffer
     6446 373E     
0461 6448 05C0  14        INCT R0                point to Flag/Status byte
0462 644A 0420  54        BLWP @VSBR             read it
     644C 3746     
0463 644E 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6450 1F00     
0464 6452 0420  54        BLWP @VSBW             write it back to PAB
     6454 373E     
0465 6456 0220  22        AI   R0,8              Set up pointer to namelength byte of PAB
     6458 0008     
0466 645A C800  38        MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
     645C 8356     
0467 645E 0420  54        BLWP @DSRLNK           put 1 byte to device
     6460 37BE     
0468 6462 0008            DATA >8
0469 6464 0460  28        B    @BKLINK           return to caller
     6466 30EA     
0470               *
0471               *  Output is going to the video display
0472               *
0473 6468 0281  22 EMIT0  CI   R1,7            Is it a bell?
     646A 0007     
0474 646C 1607  14        JNE  NOTBEL
0475 646E 04C2  14        CLR  R2
0476 6470 D802  38        MOVB R2,@KYSTAT
     6472 837C     
0477 6474 0420  54        BLWP @GPLLNK
     6476 3784     
0478 6478 0036            DATA >0036           Emit error tone
0479 647A 1060  14        JMP  EMEXIT
0480               *
0481 647C 0281  22 NOTBEL CI   R1,8            Is it a backspace?
     647E 0008     
0482 6480 160B  14        JNE  NOTBS
0483 6482 0201  20        LI   R1,>2000
     6484 2000     
0484 6486 C028  34        MOV  @CURPO$(U),R0
     6488 0016     
0485 648A 0420  54        BLWP @VSBW
     648C 373E     
0486 648E 1501  14        JGT  DECCUR
0487 6490 1055  14        JMP  EMEXIT
0488 6492 0628  34 DECCUR DEC  @CURPO$(U)
     6494 0016     
0489 6496 1052  14        JMP  EMEXIT
0490               *
0491 6498 0281  22 NOTBS  CI   R1,>A           Is it a line feed?
     649A 000A     
0492 649C 162B  14        JNE  NOTLF
0493 649E C1E8  34        MOV  @$SEND(U),R7
     64A0 0034     
0494 64A2 61E8  34        S    @$SWDTH(U),R7
     64A4 0030     
0495 64A6 81E8  34        C    @CURPO$(U),R7
     64A8 0016     
0496 64AA 1404  14        JHE  SCRLL
0497 64AC AA28  54        A    @$SWDTH(U),@CURPO$(u)
     64AE 0030     
     64B0 0016     
0498 64B2 1044  14        JMP  EMEXIT
0499 64B4 C1CB  18 SCRLL  MOV  LINK,R7
0500 64B6 06A0  32        BL   @SCROLL
     64B8 339E     
0501 64BA C2C7  18        MOV  R7,LINK
0502 64BC 103F  14        JMP  EMEXIT
0503               *
0504               *** SCROLLING ROUTINE
0505               *
0506 64BE C028  34 SCROLL MOV  @$SSTRT(U),R0   VRAM addr
     64C0 0032     
0507 64C2 0201  20        LI   R1,LINBUF       Line buffer
     64C4 3A6C     
0508 64C6 C0A8  34        MOV  @$SWDTH(U),R2   Count
     64C8 0030     
0509 64CA A002  18        A    R2,R0           Start at line 2
0510 64CC 0420  54 SCROL1 BLWP @VMBR
     64CE 374A     
0511 64D0 6002  18        S    R2,R0           One line back to write
0512 64D2 0420  54        BLWP @VMBW
     64D4 3742     
0513 64D6 A002  18        A    R2,R0           Two lines ahead for next read
0514 64D8 A002  18        A    R2,R0
0515 64DA 8A00  38        C    R0,@$SEND(U)    End of screen?
     64DC 0034     
0516 64DE 1AF6  14        JL   SCROL1
0517 64E0 C042  18        MOV  R2,R1           Blank bottom row of screen
0518 64E2 0200  20        LI   R0,>2000        Blank
     64E4 2000     
0519 64E6 60A8  34        S    @$SEND(U),R2
     64E8 0034     
0520 64EA 0502  16        NEG  R2              Now contains address of start of last line
0521 64EC C18B  18        MOV  LINK,R6
0522 64EE 06A0  32        BL   @FILL1          Write the blanks
     64F0 3208     
0523 64F2 0456  20        B    *R6
0524               *
0525 64F4 0281  22 NOTLF  CI   R1,>D           Is it a carriage return?
     64F6 000D     
0526 64F8 160D  14        JNE  NOTCR
0527 64FA 04C0  14        CLR  R0
0528 64FC C068  34        MOV  @CURPO$(U),R1
     64FE 0016     
0529 6500 C0C1  18        MOV  R1,R3
0530 6502 6068  34        S    @$SSTRT(U),R1   Adjusted for screen not at 0
     6504 0032     
0531 6506 C0A8  34        MOV  @$SWDTH(U),R2
     6508 0030     
0532 650A 3C02 128        DIV  R2,R0
0533 650C 60C1  18        S    R1,R3
0534 650E CA03  38        MOV  R3,@CURPO$(U)
     6510 0016     
0535 6512 1014  14        JMP  EMEXIT
0536               *
0537 6514 06C1  14 NOTCR  SWPB R1              Assume it is a printable character
0538 6516 C028  34        MOV  @CURPO$(U),R0
     6518 0016     
0539 651A 0420  54        BLWP @VSBW
     651C 373E     
0540 651E C0A8  34        MOV  @$SEND(U),R2
     6520 0034     
0541 6522 0602  14        DEC  R2
0542 6524 8080  18        C    R0,R2
0543 6526 1607  14        JNE  NOTCR1
0544 6528 C028  34        MOV  @$SEND(U),R0
     652A 0034     
0545 652C 6028  34        S    @$SWDTH(U),R0   Was last char on screen. Scroll
     652E 0030     
0546 6530 CA00  38        MOV  R0,@CURPO$(U)
     6532 0016     
0547 6534 10BF  14        JMP  SCRLL
0548 6536 0580  14 NOTCR1 INC  R0              No scroll necessary
0549 6538 CA00  38        MOV  R0,@CURPO$(U)
     653A 0016     
0550               *
0551 653C 0460  28 EMEXIT B    @BKLINK
     653E 30EA     
0552               ;]*
0553               ;[*== CRLF routine                          CODE =  -6  =================
0554               *
0555 6540 C14B  18 CLF    MOV  LINK,R5
0556 6542 0202  20        LI   R2,>000D
     6544 000D     
0557 6546 06A0  32        BL   @EMT            EMT will alter INT mask via B @BKLINK
     6548 3312     
0558 654A 0202  20        LI   R2,>000A
     654C 000A     
0559 654E 0300  24        LIMI 0               Previous call to EMT altered INT mask
     6550 0000     
0560 6552 06A0  32        BL   @EMT
     6554 3312     
0561 6556 C2C5  18        MOV  R5,LINK
0562 6558 0460  28        B    @BKLINK
     655A 30EA     
0563               ;]*
0564               ;[*== ?TERMINAL routine                     CODE =  -8  =================
0565               * scan for <clear>, <break>, FCTN+4 press
0566               *
0567 655C C14B  18 QTM    MOV  LINK,R5         save return
0568 655E 06A0  32        BL   @>0020          branch to console's test for <clear>
     6560 0020     
0569 6562 02C0  12        STST R0              store status in R0
0570 6564 1603  14        JNE  QTM2            exit if not <clear>
0571 6566 06A0  32 QTM1   BL   @>0020          check for <clear> again
     6568 0020     
0572 656A 13FD  14        JEQ  QTM1            loop until not <clear>
0573 656C C2C5  18 QTM2   MOV  R5,LINK         restore return
0574 656E 0240  22        ANDI R0,>2000        keep only EQU bit
     6570 2000     
0575 6572 0460  28        B    @BKLINK         return to caller
     6574 30EA     
0576               ;]*
0577               ;[*== ?KEY routine                          CODE = -10  =================
0578               *
0579 6576 0420  54 QKY    BLWP @KSCAN
     6578 373A     
0580 657A D020  34        MOVB @KYCHAR,R0
     657C 8375     
0581 657E 0980  56        SRL  R0,8
0582 6580 0280  22        CI   R0,>00FF
     6582 00FF     
0583 6584 1601  14        JNE  QKEY1
0584 6586 04C0  14        CLR  R0
0585 6588 0460  28 QKEY1  B    @BKLINK
     658A 30EA     
0586               ;]*
0587               ;[*== GOTOXY routine                        CODE = -12  =================
0588               *
0589 658C 38E8  72 GXY    MPY  @$SWDTH(U),R3
     658E 0030     
0590 6590 A102  18        A    R2,R4           Position within screen
0591 6592 A128  34        A    @$SSTRT(U),R4   Add VRAM offset to screen top
     6594 0032     
0592 6596 CA04  38        MOV  R4,@CURPO$(U)
     6598 0016     
0593 659A 0460  28        B    @BKLINK
     659C 30EA     
0594               ;]
0595               *       ___  __         __     ____  ______
0596               *      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
0597               *     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
0598               *    /____/_/\___/\__/_/\_\ /___/_/  \____/
0599               
0600               *
0601               *== USE blocks file                         CODE = -14  =================
0602               *== CREATE blocks file                      CODE = -16  =================
0603               *== READ block from blocks file             CODE = -18  =================
0604               *== WRITE block to blocks file              CODE = -20  =================
0605               ;[*== Block File I/O Support ============================================
0606               *
0607               * BPTOG utility to toggle one of 2 PABs for block file access
0608               *
0609 659E C028  34 BPTOG  MOV  @$BPOFF(U),R0	   PAB offset to R0
     65A0 0040     
0610 65A2 0201  20        LI	R1,70	            Toggle amount
     65A4 0046     
0611 65A6 2840  18        XOR	R0,R1	            New offset
0612 65A8 CA01  38        MOV	R1,@$BPOFF(U)	   Update offset
     65AA 0040     
0613               *
0614               **xxx** entry point to insure we have correct PAB address
0615 65AC C028  34 BPSET  MOV  @$DKBUF(U),R0	   Get DISK_BUF address
     65AE 002C     
0616 65B0 A028  34        A	   @$BPABS(U),R0	   Get BPABS address
     65B2 003E     
0617               *
0618 65B4 A028  34        A	   @$BPOFF(U),R0     Add current offset
     65B6 0040     
0619 65B8 C800  38        MOV	R0,@BFPAB	      Update current block file's PAB address
     65BA 34BC     
0620 65BC 045B  20        RT
0621               *
0622               * CLOSE blocks file
0623               *
0624 65BE C020  34 BKCLOS MOV  @BFPAB,R0
     65C0 34BC     
0625 65C2 0201  20        LI   R1,$FCLS          Opcode=CLOSE
     65C4 0100     
0626 65C6 0420  54        BLWP @VSBW
     65C8 373E     
0627 65CA 0220  22        AI   R0,9              Address of filename's char count
     65CC 0009     
0628 65CE C800  38        MOV  R0,@SUBPTR        Point to filename's char count
     65D0 8356     
0629 65D2 0420  54        BLWP @DSRLNK           Close the file
     65D4 37BE     
0630 65D6 0008            DATA 8
0631 65D8 045B  20        RT                     Deal with error in caller
0632               *
0633               * storage area
0634               *
0635 65DA 0000     SVBRET DATA 0                 Storage for LINK coming into BRW
0636 65DC 0000     BFPAB  DATA	0	               Storage for current blocks file PAB address...
0637               *	 	 	                     ...will have current PAB on entry
0638               * PAB header storage
0639               *
0640 65DE          PABHD  BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
0641               *              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
0642               *	                	                 >03=OUTPUT mode + "
0643               *	                	                 >01=UPDATE mode + "
0644               *	                         BYTE 2,3: save contents of DISK_BUF here
0645 65E2 80              BYTE	>80	            Record length
0646 65E3   80            BYTE	>80	            Character count of transfer
0647 65E4                 BSS	2	            Record number
0648               *
0649               *** file I/O equates
0650               *
0651      0000     $FOPN  EQU  >0000
0652      0100     $FCLS  EQU  >0100
0653      0200     $FRD   EQU  >0200
0654      0300     $FWRT  EQU  >0300
0655      0400     $FRST  EQU  >0400
0656      0005     $FINP  EQU  5
0657      0003     $FOUT  EQU  3
0658      0001     $FUPD  EQU  1
0659               *
0660               *** BRW -- entry point for block read/write routines
0661               *
0662 65E6 C80B  38 BRW    MOV  LINK,@SVBRET   Save LINK address
     65E8 34BA     
0663 65EA C1C1  18        MOV	R1,R7	         Save CODE {R1 to R7}
0664 65EC 0817  56        SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
0665 65EE 0227  22        AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
     65F0 000C     
0666 65F2 06A0  32        BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
     65F4 348C     
0667 65F6 0287  22        CI	R7,4	         USE or CREATE?
     65F8 0004     
0668 65FA 110D  14        JLT	BRW01	         No
0669 65FC 06A0  32        BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
     65FE 347E     
0670 6600 C020  34        MOV	@BFPAB,R0	   Load PAB address
     6602 34BC     
0671 6604 0220  22        AI	R0,9	         Set to name length byte
     6606 0009     
0672 6608 04C2  14        CLR	R2
0673 660A C079  30        MOV	*SP+,R1	      Pop bfnaddr to R1
0674 660C D811  46        MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
     660E 8305     
0675 6610 0582  14        INC	R2	            Add 1 to # bytes to copy
0676 6612 0420  54        BLWP	@VMBW	         Copy char count & pathname to PAB
     6614 3742     
0677               *
0678               *** set up PAB for OPEN
0679               *
0680 6616 0201  20 BRW01  LI	R1,$FUPD                Opcode=0,mode=update
     6618 0001     
0681 661A 9820  54        CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
     661C 830F     
     661E 830F     
0682 6620 1C02  14        JOP  BRW02                   No
0683 6622 0201  20        LI	R1,$FINP                Yes...change mode=input
     6624 0005     
0684 6626 C801  38 BRW02  MOV  R1,@PABHD               Put in PAB header
     6628 34BE     
0685 662A C828  54        MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
     662C 002C     
     662E 34C0     
0686 6630 04C0  14        CLR  R0
0687 6632 C800  38        MOV  R0,@PABHD+6             Set record#=0
     6634 34C4     
0688 6636 C020  34        MOV  @BFPAB,R0               VRAM destination
     6638 34BC     
0689 663A 0201  20        LI   R1,PABHD                RAM source
     663C 34BE     
0690 663E 0202  20        LI   R2,8                    Copy first 8 bytes of PAB header
     6640 0008     
0691 6642 0420  54        BLWP @VMBW                   Do the copy
     6644 3742     
0692               *
0693               *** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
0694               *
0695 6646 0220  22        AI   R0,9                Address of filename's char count in PAB
     6648 0009     
0696 664A C800  38        MOV  R0,@SUBPTR          Point to-----^^^^
     664C 8356     
0697 664E 0420  54        BLWP @DSRLNK             Open/create the file
     6650 37BE     
0698 6652 0008            DATA 8
0699 6654 135F  14        JEQ  BKERR
0700 6656 0287  22        CI   R7,4                READ or WRITE?
     6658 0004     
0701 665A 1120  14        JLT  BRW04               Yes
0702 665C 156E  14        JGT  BRWDON              No; =USE; we're done
0703               *
0704               *** write blank records to newly created blocks file [CODE = -16,CREATE]
0705               *
0706 665E C179  30        MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
0707 6660 0A35  56        SLA  R5,3                Convert #blocks to #records
0708 6662 C0C5  18        MOV  R5,R3               Save
0709 6664 C105  18        MOV  R5,R4               Set up counter
0710 6666 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     6668 0301     
0711 666A C800  38        MOV  R0,@PABHD           Copy to PAB header
     666C 34BE     
0712 666E 6144  18 BRLOOP S    R4,R5               Calculate next record
0713 6670 C805  38        MOV  R5,@PABHD+6         Copy to PAB header
     6672 34C4     
0714 6674 C020  34        MOV  @BFPAB,R0           VRAM destination
     6676 34BC     
0715 6678 0201  20        LI   R1,PABHD            RAM source
     667A 34BE     
0716 667C 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     667E 0008     
0717 6680 0420  54        BLWP @VMBW               Do the copy
     6682 3742     
0718 6684 0220  22        AI   R0,9                Address of filename's char count
     6686 0009     
0719 6688 C800  38        MOV  R0,@SUBPTR          Point to filename's char count
     668A 8356     
0720 668C 0420  54        BLWP @DSRLNK             Write one record of blanks
     668E 37BE     
0721 6690 0008            DATA 8
0722 6692 1340  14        JEQ  BKERR
0723 6694 C143  18        MOV  R3,R5               Get #blocks
0724 6696 0604  14        DEC  R4                  Count down 1 record
0725 6698 16EA  14        JNE  BRLOOP              Write another record if not done
0726 669A 104F  14        JMP  BRWDON              We're done
0727               *
0728               *** prepare for read/write block
0729               *
0730 669C C179  30 BRW04  MOV  *SP+,R5             Pop block# to write
0731 669E C1B9  30        MOV  *SP+,R6             Pop bufaddr
0732 66A0 0605  14        DEC  R5                  Block#-1
0733 66A2 0A35  56        SLA  R5,3                Convert to starting record#
0734 66A4 0204  20        LI   R4,8                Load counter for 8 records
     66A6 0008     
0735 66A8 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     66AA 0301     
0736 66AC 0203  20        LI   R3,VMBW             WRITE vector
     66AE 3742     
0737 66B0 0287  22        CI   R7,2                Are we writing the block?
     66B2 0002     
0738 66B4 1304  14        JEQ  BRW05               Yup
0739 66B6 0200  20        LI   R0,$FRD+$FINP       Nope...set up for READ
     66B8 0205     
0740 66BA 0203  20        LI   R3,VMBR             READ vector
     66BC 374A     
0741 66BE C800  38 BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
     66C0 34BE     
0742               *
0743               * READ/WRITE block routine [CODE = -18/-20]
0744               *
0745 66C2 C805  38 RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
     66C4 34C4     
0746 66C6 C020  34        MOV  @BFPAB,R0           VRAM destination
     66C8 34BC     
0747 66CA 0201  20        LI   R1,PABHD            RAM source
     66CC 34BE     
0748 66CE 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     66D0 0008     
0749 66D2 0420  54        BLWP @VMBW               Do the copy
     66D4 3742     
0750 66D6 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0
     66D8 002C     
0751 66DA C046  18        MOV  R6,R1               RAM buffer to R1
0752 66DC 0202  20        LI   R2,128              Bytes to copy
     66DE 0080     
0753 66E0 0287  22        CI   R7,3                READ?
     66E2 0003     
0754 66E4 1301  14        JEQ  BRW06               Yup
0755 66E6 0413  42        BLWP *R3                 Nope...copy record to VRAM
0756               *
0757               * temporarily use CRU register---it should be OK
0758               *
0759 66E8 C320  34 BRW06  MOV  @BFPAB,CRU          PAB address
     66EA 34BC     
0760 66EC 022C  22        AI   CRU,9               Address of filename's char count
     66EE 0009     
0761 66F0 C80C  38        MOV  CRU,@SUBPTR         Point to filename's char count
     66F2 8356     
0762 66F4 0420  54        BLWP @DSRLNK             Read/write one record
     66F6 37BE     
0763 66F8 0008            DATA 8
0764 66FA 130C  14        JEQ  BKERR
0765 66FC 0287  22        CI   R7,2                WRITE?
     66FE 0002     
0766 6700 1303  14        JEQ  BRW07               Yup...next record
0767 6702 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
     6704 002C     
0768 6706 0413  42        BLWP *R3                 Nope...copy record to RAM buffer
0769 6708 0585  14 BRW07  INC  R5                  Next record in file
0770 670A 0226  22        AI   R6,128              Next record to/from block RAM buffer
     670C 0080     
0771 670E 0604  14        DEC  R4                  Count down 1 record
0772 6710 16D8  14        JNE  RWLOOP              Read/write another record if not done
0773 6712 1013  14        JMP  BRWDON              We're done
0774               *
0775               *** error handling
0776               *
0777 6714 D000  18 BKERR  MOVB R0,R0               Device error?
0778 6716 1306  14        JEQ  BKERR6              Yes, exit with disk error
0779 6718 0206  20 BKERR9 LI   R6,9                No, exit with file error
     671A 0009     
0780 671C 1005  14        JMP  BKCLN
0781 671E 0206  20 BKERR8 LI   R6,8                Block# <=0!  exit with range error
     6720 0008     
0782 6722 1002  14        JMP  BKCLN
0783 6724 0206  20 BKERR6 LI   R6,6
     6726 0006     
0784 6728 06A0  32 BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
     672A 349E     
0785 672C 0287  22        CI   R7,4                USE or CREATE?
     672E 0004     
0786 6730 1102  14        JLT  BKCLN1              No
0787 6732 06A0  32        BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
     6734 347E     
0788 6736 C006  18 BKCLN1 MOV  R6,R0               Pass error back to caller
0789 6738 100C  14        JMP  BKEXIT
0790 673A 04C6  14 BRWDON CLR  R6
0791 673C 06A0  32        BL   @BKCLOS             Close current blocks file
     673E 349E     
0792 6740 1602  14        JNE  BRWDN1              Error?
0793 6742 0206  20        LI   R6,9                Yes...assume it was a file error
     6744 0009     
0794 6746 0287  22 BRWDN1 CI   R7,4                (no error)...CREATE?
     6748 0004     
0795 674A 1602  14        JNE  BRWDN2              No...we're done
0796 674C 06A0  32        BL   @BPTOG              Yes...revert to correct blocks file
     674E 347E     
0797 6750 C006  18 BRWDN2 MOV  R6,R0               Error to R0
0798 6752 C2E0  34 BKEXIT MOV  @SVBRET,LINK        Restore LINK
     6754 34BA     
0799 6756 0460  28        B    @BKLINK
     6758 30EA     
0800               ;]
0801               ;[* MSGTYP      <<< Support for string typing in various banks >>>
0802               *
0803               * Called with:  BL  @MSGTYP
0804               *
0805               * R4 and R5 are the only registers that will be preserved
0806               * ..after a call to EMIT---
0807               *
0808               * Input:    R4 = Address of length byte of packed string
0809               *
0810               * We will pass the ASCII value of character to EMIT in R2 without
0811               * insuring it is 7 bits wide.
0812               *
0813 675A 064E  14 MSGTYP DECT R           Push return address
0814 675C C78B  30        MOV  LINK,*R     ...to Forth return stack
0815 675E 04C5  14        CLR  R5
0816 6760 D174  28        MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
0817 6762 06C5  14        SWPB R5          Put char count in low byte
0818 6764 04C2  14 MTLOOP CLR  R2
0819 6766 D0B4  28        MOVB *R4+,R2     Copy next char to R2 for EMIT
0820 6768 06C2  14        SWPB R2          Put char in low byte
0821 676A 0300  24        LIMI 0           We need to do this because we're calling EMIT directly
     676C 0000     
0822 676E 06A0  32        BL   @EMT        Call EMIT directly
     6770 3312     
0823 6772 05A8  34        INC  @$OUT(U)    Increment display line character count
     6774 0052     
0824 6776 0605  14        DEC  R5          Decrement character count for this message
0825 6778 16F5  14        JNE  MTLOOP      Are we done?
0826 677A C2FE  30        MOV  *R+,LINK    Yes. Pop return address
0827 677C 045B  20        RT               Return to caller
0828                ;]
0829               ;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
0830 677E CD74  46 R4$5   MOV  *R4+,*R5+
0831 6780 CD74  46        MOV  *R4+,*R5+
0832 6782 CD74  46        MOV  *R4+,*R5+
0833 6784 C554  38        MOV  *R4,*R5
0834 6786 045B  20        RT
0835               ;]
0836               *     __  __              _   __         _      __   __
0837               *    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__
0838               *   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
0839               *   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/
0840               *              ___      ___          ____
0841               *             / _ \___ / _/__ ___ __/ / /____
0842               *            / // / -_) _/ _ `/ // / / __(_-<
0843               *           /____/\__/_/ \_,_/\_,_/_/\__/___/
0844               
0845               ;[*== User Variable defaults ============================================
0846               *
0847 6788          UBASE0 BSS  6                 BASE OF USER VARIABLES
0848 678E 3668            DATA UBASE0            06 USER UCONS$
0849 6790 FFA0            DATA SPBASE            08 USER S0
0850 6792 3FFE            DATA RBASE             0A USER R0 { R0$
0851 6794 36B4            DATA $UVAR             0C USER U0
0852 6796 FFA0            DATA SPBASE            0E USER TIB
0853 6798 001F            DATA 31                10 USER WIDTH
0854 679A A000            DATA DPBASE            12 USER DP
0855 679C 30F6            DATA $SYS$             14 USER SYS$
0856 679E 0000            DATA 0                 16 USER CURPOS
0857 67A0 3020            DATA INT1              18 USER INTLNK
0858 67A2 0001            DATA 1                 1A USER WARNING
0859 67A4 0040            DATA 64                1C USER C/L$ { CL$
0860 67A6 2010            DATA $BUFF             1E USER FIRST$
0861 67A8 3020            DATA $LO               20 USER LIMIT$
0862 67AA 0380            DATA >0380             22 USER COLTAB    Color Table address in VRAM
0863 67AC 0300            DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
0864 67AE 0780            DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
0865 67B0 0800            DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
0866 67B2 0080            DATA >80               2A USER FPB       pushes address of user screen font file PAB
0867               *                                               ...that is this relative distance from DISK_BUF
0868 67B4 1000            DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
0869 67B6 0460            DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
0870 67B8 0028            DATA 40                30 USER SCRN_WIDTH
0871 67BA 0000            DATA 0                 32 USER SCRN_START
0872 67BC 03C0            DATA 960               34 USER SCRN_END
0873 67BE 0000            DATA 0                 36 USER ISR       [Note: This used to be INT1]
0874 67C0 0000            DATA 0                 38 USER ALTIN
0875 67C2 0000            DATA 0                 3A USER ALTOUT
0876 67C4 0001            DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
0877 67C6 00C6            DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
0878               *                                               ...that is this relative distance from DISK_BUF
0879 67C8 0000            DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
0880               *                                               ...always toggled between 0 and 70
0881 67CA 0800            DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
0882 67CC FFFF            DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
0883               *                                                  0 = console font via GPLLNK
0884 67CE 0000            DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
0885 67D0 0000            DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
0886 67D2 0000            DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
0887               *                                                  0 = Symmetric (default)
0888               *                                                 !0 = Floored
0889 67D4          $UVAR  BSS  >80               USER VARIABLE AREA
0890               ;]
0891               ;[*== A Constant ====================================================
0892               *
0893 6854 2000     H2000  DATA >2000
0894               ;]*
0895               *    __  ____  _ ___ __         _   __        __
0896               *   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
0897               *  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
0898               *  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
0899               *                     /___/
0900               *
0901               ;[*== Utility Vectors ===================================================
0902               *
0903               * GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
0904               * DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
0905 6856 3A4C     XMLLNK DATA UTILWS,XMLENT   ; Link to ROM routines
     6858 3756     
0906 685A 3A4C     KSCAN  DATA UTILWS,KSENTR   ; Keyboard scan
     685C 3832     
0907 685E 3A4C     VSBW   DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
     6860 3848     
0908 6862 3A4C     VMBW   DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
     6864 3854     
0909 6866 3A4C     VSBR   DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
     6868 3862     
0910 686A 3A4C     VMBR   DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
     686C 386E     
0911 686E 3A4C     VMOVE  DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
     6870 38AE     
0912 6872 3A4C     VWTR   DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
     6874 387C     
0913               ;]*
0914               ;[*== XMLENT -- Link to system XML utilities ============================
0915               *
0916 6876 C83E  50 XMLENT MOV  *R14+,@GPLWS+2      Get argument
     6878 83E2     
0917 687A 02E0  18        LWPI GPLWS               Select GPL workspace
     687C 83E0     
0918 687E C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6880 3A62     
0919 6882 C081  18        MOV  R1,R2               Make a copy of argument
0920 6884 0281  22        CI   R1,>8000            Direct address in ALC?
     6886 8000     
0921 6888 1B07  14        JH   XML30               We have the address
0922 688A 09C1  56        SRL  R1,12
0923 688C 0A11  56        SLA  R1,1
0924 688E 0A42  56        SLA  R2,4
0925 6890 09B2  56        SRL  R2,11
0926 6892 A0A1  34        A    @XMLTAB(R1),R2
     6894 0CFA     
0927 6896 C092  26        MOV  *R2,R2
0928 6898 0692  24 XML30  BL   *R2
0929 689A 02E0  18        LWPI UTILWS              Get back to right WS
     689C 3A4C     
0930 689E C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     68A0 83F6     
0931 68A2 0380  18        RTWP
0932               ;]*
0933               *    ________  __   __   _  ____ __           __  ________
0934               *   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
0935               *  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ /
0936               *  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
0937               *
0938               *-----------------------------------------------------------------------*
0939               ;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
0940               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
0941               *                                                                       *
0942               * This routine will work with any GROM library slot since it is         *
0943               * indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
0944               * This GPLLNK does NOT require a module to be plugged into the          *
0945               * GROM port so it will work with the Editor/Assembler,                  *
0946               * Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
0947               * CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
0948               * It saves and restores the current GROM Address in case you want       *
0949               * to return back to GROM for Basic or Extended Basic CALL LINKs         *
0950               * or to return to the loading module.                                   *
0951               *                                                                       *
0952               *    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
0953               *                                                 DATA >34              *
0954               *                                                                       *
0955               *    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
0956               *                                                                       *
0957               * 70 Bytes - including the GPLLNK Workspace                             *
0958               *-----------------------------------------------------------------------*
0959               
0960               *  GPLWS (>83E0) is GPL workspace
0961      83E8     G_R4   EQU  GPLWS+8              GPL workspace R4
0962      83EC     G_R6   EQU  GPLWS+12             GPL workspace R6
0963               *  SUBSTK (>8373) is GPL Subroutine stack pointer
0964      0060     LDGADR EQU  >60                  Load & Execute GROM address entry point
0965      200E     XTAB27 EQU  >200E                Low Mem XML table location 27
0966               *                                ..Will contain XMLRTN at startup
0967      166C     GETSTK EQU  >166C
0968               
0969 68A4 3776     GPLLNK DATA GLNKWS     ; R7       Set up BLWP Vectors
0970 68A6 3796            DATA GLINK1     ; R8
0971               * RTNADR     <---don't think we need this label
0972 68A8 37B2            DATA XMLRTN     ; R9       address where GPL XML returns to us...
0973               *                                ...this address will already be in XTAB27,...
0974               *                                ...>200E, so don't really need it here}
0975 68AA 176C     GXMLAD DATA >176C      ; R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
0976 68AC 0050            DATA >50        ; R11      Initialized to >50 where PUTSTK address resides
0977      3776     GLNKWS EQU  $->18      ; GPLLNK's workspace of which only...
0978 68AE                 BSS  >08        ; R12-R15  ...registers R7 through R15 are used
0979               
0980 68B6 C81B  46 GLINK1 MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
     68B8 83E8     
0981 68BA C83E  50        MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
     68BC 83EC     
0982 68BE 02E0  18        LWPI GPLWS                Load GPL WS
     68C0 83E0     
0983 68C2 0694  24        BL   *R4                  Save current GROM Address on stack
0984 68C4 C920  54        MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
     68C6 378A     
     68C8 8302     
0985 68CA 05E0  34        INCT @SUBSTK              Adjust the stack pointer
     68CC 8373     
0986 68CE 0460  28        B    @LDGADR              Execute our GPL Routine
     68D0 0060     
0987               
0988 68D2 C120  34 XMLRTN MOV  @GETSTK,R4           Get GETSTK pointer
     68D4 166C     
0989 68D6 0694  24        BL   *R4                  Restore GROM address off the stack
0990 68D8 02E0  18        LWPI GLNKWS               Load our WS
     68DA 3776     
0991 68DC 0380  18        RTWP                      All Done - Return to Caller
0992               ;]
0993               *     ___  _______  __   _  ____ __           __  ________
0994               *    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
0995               *   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ /
0996               *  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
0997               *
0998               *-----------------------------------------------------------------------*
0999               ;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
1000               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
1001               *                                                                       *
1002               *      (Uses console GROM 0's DSRLNK routine)                           *
1003               *      (Do not REF DSRLNK or GPLLNK when using these routines)          *
1004               *      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
1005               *                                                                       *
1006               *      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
1007               *                                                   DATA 8              *
1008               *                                                                       *
1009               *      NOTES: Must be used with a GPLLNK routine                        *
1010               *             Returns ERRORs the same as the E/A DSRLNK                 *
1011               *             EQ bit set on return if error                             *
1012               *             ERROR CODE in caller's MSB of Register 0 on return        *
1013               *                                                                       *
1014               * 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
1015               *-----------------------------------------------------------------------*
1016               
1017      0050     PUTSTK EQU  >50                     Push GROM Address to stack pointer
1018      836D     TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
1019      8356     NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
1020      8C02     VWA    EQU  >8C02                   VDP Write Address location
1021      8800     VRD    EQU  >8800                   VDP Read Data byte location
1022      83E9     G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
1023      837C     GSTAT  EQU  >837C                   GPL Status byte location
1024               
1025 68DE 37C2     DSRLNK DATA DSRWS,DLINK1            Set BLWP Vectors
     68E0 37C2     
1026               
1027               DSRWS                      ; Start of DSRLNK workspace
1028      37C9     DR3LB  EQU  $+7            ; lower byte of DSRLNK workspace R3
1029 68E2 C30C  18 DLINK1 MOV  R12,R12         R0      Have we already looked up the LINK address?
1030 68E4 161C  14        JNE  DLINK3          R1      YES!  Skip lookup routine
1031               *<<-------------------------------------------------------------------------->>*
1032               * This section of code is only executed once to find the GROM address          *
1033               * for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
1034               * to indicate that the address is found and to be used as a mask for EQ & CND  *
1035               *------------------------------------------------------------------------------*
1036 68E6 02E0  18        LWPI GPLWS           R2,R3   else load GPL workspace
     68E8 83E0     
1037 68EA C120  34        MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
     68EC 0050     
1038 68EE 0694  24        BL   *R4             R6
1039 68F0 0204  20        LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
     68F2 0011     
1040 68F4 DB44  38        MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector
     68F6 0402     
1041               
1042               ***les*** Note on above instruction:
1043               ***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
1044               ***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)
1045               
1046 68F8 1004  14        JMP  DLINK2          R11     Jump around R12-R15
1047 68FA 0000            DATA 0               R12     contains >2000 flag when set
1048 68FC 0000            DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
     68FE 0000     
     6900 0000     
1049 6902 DB60  54 DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
     6904 83E9     
     6906 0402     
1050 6908 C160  34        MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
     690A 166C     
1051 690C D81D  46        MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
     690E 3811     
1052 6910 05E0  34        INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
     6912 3810     
1053 6914 0695  24        BL   *R5                     Restore the GROM address off the stack
1054 6916 02E0  18        LWPI DSRWS                   Reload DSRLNK workspace
     6918 37C2     
1055 691A 020C  20        LI   R12,>2000               Set flag to signify DSRLNK address is set
     691C 2000     
1056               *<<-------------------------------------------------------------------------->>*
1057 691E 058E  14 DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
1058 6920 D83E  48        MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
     6922 836D     
1059 6924 C0E0  34        MOV  @NAMLEN,R3              Save VDP address of Name Length
     6926 8356     
1060 6928 0223  22        AI   R3,-8                   Adjust it to point to PAB Flag byte
     692A FFF8     
1061 692C 0420  54        BLWP @GPLLNK                 Execute DSR LINK
     692E 3784     
1062 6930 03       DSRADR BYTE >03                     High byte of GPL DSRLNK address
1063 6931   00     DSRAD1 BYTE >00                     Lower byte of GPL DSRLNK address
1064               *----Error Check & Report to Caller's R0 and EQU bit-------------------------
1065 6932 D820  54        MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
     6934 37C9     
     6936 8C02     
1066 6938 D803  38        MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
     693A 8C02     
1067 693C 53CC  18        SZCB R12,R15                 Clear EQ bit for Error Report
1068 693E D0E0  34        MOVB @VRD,R3                 Get PAB Error Flag
     6940 8800     
1069 6942 0953  56        SRL  R3,5                    Adjust it to 0-7 error code
1070 6944 D743  30        MOVB R3,*R13                 Put it into Caller's R0 (msb)
1071 6946 1603  14        JNE  SETEQ                   If it's not zero, set EQ bit
1072 6948 2320  38        COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
     694A 837C     
1073 694C 1601  14        JNE  DSREND                  No Error, Just return
1074 694E F3CC  18 SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
1075 6950 0380  18 DSREND RTWP                         All Done - Return to Caller
1076               ;]
1077               ;[*== KSENTR -- Keyboard Scan (entry point) =============================
1078               *
1079 6952 02E0  18 KSENTR LWPI GPLWS
     6954 83E0     
1080 6956 C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6958 3A62     
1081 695A 06A0  32        BL   @SCNKEY             Console keyboard scan routine
     695C 000E     
1082 695E 02E0  18        LWPI UTILWS
     6960 3A4C     
1083 6962 C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     6964 83F6     
1084 6966 0380  18        RTWP
1085               ;]*
1086               *    _   _____  ___    __  ____  _ ___ __  _
1087               *   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
1088               *   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
1089               *   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
1090               *
1091               ;[*== VDP utilities (entry point) =======================================
1092               *
1093               ** VDP single byte write
1094               *
1095 6968 06A0  32 VSBWEN BL   @WVDPWA             Write out address
     696A 388E     
1096 696C D82D  54        MOVB @2(R13),@VDPWD      Write data
     696E 0002     
     6970 8C00     
1097 6972 0380  18        RTWP                     Return to calling program
1098               *
1099               ** VDP multiple byte write
1100               *
1101 6974 06A0  32 VMBWEN BL   @WVDPWA             Write out address
     6976 388E     
1102 6978 D831  48 VWTMOR MOVB *R1+,@VDPWD         Write a byte
     697A 8C00     
1103 697C 0602  14        DEC  R2                  Decrement byte count
1104 697E 16FC  14        JNE  VWTMOR              More to write?
1105 6980 0380  18        RTWP                     Return to calling Program
1106               *
1107               ** VDP single byte read
1108               *
1109 6982 06A0  32 VSBREN BL   @WVDPRA             Write out address
     6984 3894     
1110 6986 DB60  54        MOVB @VDPRD,@2(R13)      Read data
     6988 8800     
     698A 0002     
1111 698C 0380  18        RTWP                     Return to calling program
1112               *
1113               ** VDP multiple byte read
1114               *
1115 698E 06A0  32 VMBREN BL   @WVDPRA             Write out address
     6990 3894     
1116 6992 DC60  48 VRDMOR MOVB @VDPRD,*R1+         Read a byte
     6994 8800     
1117 6996 0602  14        DEC  R2                  Decrement byte count
1118 6998 16FC  14        JNE  VRDMOR              More to read?
1119 699A 0380  18        RTWP                     Return to calling program
1120               *
1121               ** VDP write to register
1122               *
1123 699C C05D  26 VWTREN MOV  *R13,R1             Get register number and value
1124 699E D82D  54        MOVB @1(R13),@VDPWA      Write out value
     69A0 0001     
     69A2 8C02     
1125 69A4 0261  22        ORI  R1,>8000            Set for register write
     69A6 8000     
1126 69A8 D801  38        MOVB R1,@VDPWA           Write out register number
     69AA 8C02     
1127 69AC 0380  18        RTWP                     Return to calling program
1128               *
1129               ** Set up to write to VDP
1130               *
1131 69AE 0201  20 WVDPWA LI   R1,>4000
     69B0 4000     
1132 69B2 1001  14        JMP  WVDPAD
1133               *
1134               ** Set up to read VDP
1135               *
1136 69B4 04C1  14 WVDPRA CLR  R1
1137               *
1138               ** Write VDP address
1139               *
1140 69B6 C09D  26 WVDPAD MOV  *R13,R2             Get VDP address
1141 69B8 D820  54        MOVB @U_R2LB,@VDPWA      Write low byte of address
     69BA 3A51     
     69BC 8C02     
1142 69BE E081  18        SOC  R1,R2               Properly adjust VDP write bit
1143 69C0 D802  38        MOVB R2,@VDPWA           Write high byte of address
     69C2 8C02     
1144 69C4 C06D  34        MOV  @2(R13),R1          Get CPU RAM address
     69C6 0002     
1145 69C8 C0AD  34        MOV  @4(R13),R2          Get byte count
     69CA 0004     
1146 69CC 045B  20        RT                       Return to calling routine
1147               
1148               *
1149               ** VDP-to-VDP move.
1150               *
1151 69CE C05D  26 VMOVEN MOV  *R13,R1             Get cnt to R1
1152 69D0 C0AD  34        MOV  @2(R13),R2          Get vsrc to R2
     69D2 0002     
1153 69D4 C0ED  34        MOV  @4(R13),R3          Get vdst to R3
     69D6 0004     
1154 69D8 0263  22        ORI  R3,>4000            Prepare for VDP write
     69DA 4000     
1155               
1156               ** copy cnt bytes from vsrc to vdst
1157               
1158 69DC D820  54 VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
     69DE 3A51     
     69E0 8C02     
1159 69E2 D802  38        MOVB R2,@VDPWA           Write MSB of VDP read address
     69E4 8C02     
1160 69E6 0582  14        INC  R2                  Next VDP read address
1161 69E8 D020  34        MOVB @VDPRD,R0           Read VDP byte
     69EA 8800     
1162 69EC D820  54        MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
     69EE 3A53     
     69F0 8C02     
1163 69F2 D803  38        MOVB R3,@VDPWA           Write MSB of VDP write address
     69F4 8C02     
1164 69F6 0583  14        INC  R3                  Next VDP write address
1165 69F8 D800  38        MOVB R0,@VDPWD           Write VDP byte
     69FA 8C00     
1166 69FC 0601  14        DEC  R1                  Decrement count
1167 69FE 16EE  14        JNE  VMVMOR              Repeat if not done
1168 6A00 0380  18        RTWP                     Return to calling program
1169               ;]*
1170               ;[*== fbForth Version Message ===========================================
1171               FBFMSG
1172               * This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
1173               * Also, printing the extra blanks overwrites the font-not-found error message.
1174 6A02 11              BYTE 17
1175 6A03   66            TEXT 'fbForth 2.0:     '
     6A04 6246     
     6A06 6F72     
     6A08 7468     
     6A0A 2032     
     6A0C 2E30     
     6A0E 3A20     
     6A10 2020     
     6A12 2020     
1176               ;]
1177               *     __  ___        ___ ____      __   __      _      __            __
1178               *    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
1179               *   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
1180               *  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
1181               *
1182               ;[*== Modifiable words in Resident Dictionary ===========================
1183               ;[*** (ABORT) ***
1184 6A14 73CC            DATA x#VLST_N         <--Last word in ROM
1185 6A16 8728     PABR_N DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT
     6A18 4142     
     6A1A 4F52     
     6A1C 54A9     
1186               
1187 6A1E 8334     PABORT DATA DOCOL
1188 6A20 6ADE            DATA ABORT,SEMIS
     6A22 6358     
1189               ;]*
1190               ;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
1191 6A24 38F6            DATA PABR_N
1192 6A26 C546     FRTH_N DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT
     6A28 4F52     
     6A2A 54C8     
1193               
1194 6A2C 7218     FORTH  DATA DOVOC
1195 6A2E A002     FORTHV DATA DPBASE+2    ; vocabulary link field
1196 6A30 81A0     FORTHP DATA >81A0       ; pseudo name field
1197 6A32 0000     FORTHL DATA 0           ; chronological link field
1198               ;]*
1199               ;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
1200 6A34 3906            DATA FRTH_N
1201 6A36 C941     ASMR_N DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT
     6A38 5353     
     6A3A 454D     
     6A3C 424C     
     6A3E 45D2     
1202               
1203 6A40 7218     ASSM   DATA DOVOC
1204               ; Initially points to last word in ASSEMBLER vocabulary in the kernel
1205 6A42 394A     ASMV   DATA SASM_N   ; vocabulary link field
1206 6A44 81A0            DATA >81A0    ; pseudo name field
1207 6A46 3912     ASML   DATA FORTHL   ; chronological link field
1208               
1209               *
1210               ;]*
1211               ;]*
1212               *    ___                     __   __
1213               *   / _ | ___ ___ ___ __ _  / /  / /__ ____
1214               *  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
1215               * /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/
1216               *     _   __              __        __                _      __            __
1217               *    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
1218               *    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
1219               *    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
1220               *                                           /___/
1221               *
1222               *== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
1223               ;[*** NEXT, ***      ( --- )
1224               * 1st word in ASSEMBLER vocabulary
1225               *
1226 6A48 3910            DATA FORTHP          <--points to PNF of FORTH
1227 6A4A 854E     NXT__N DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT
     6A4C 4558     
     6A4E 54AC     
1228               
1229 6A50 3932     NEXTC  DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
1230 6A52 0200  20 NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
     6A54 045F     
1231 6A56 C068  34        MOV  @$DP(U),R1        HERE to R1
     6A58 0012     
1232 6A5A CC40  34        MOV  R0,*R1+           compile "B *NEXT"
1233 6A5C CA01  38        MOV  R1,@$DP(U)        update HERE
     6A5E 0012     
1234 6A60 CA28  54        MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
     6A62 0058     
     6A64 0056     
1235 6A66 045F  20        B    *NEXT             back to inner interpreter
1236               
1237               * : NEXT,   ( --- )
1238               *    *NEXT B,  ;
1239               ;]*
1240               ;[*** ;ASM ***       ( --- )
1241               * 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
1242               * ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
1243               *
1244 6A68 392A            DATA NXT__N
1245 6A6A 84       SASM_N BYTE 4+TERMBT    <--note different name field format
1246 6A6B   3B            TEXT ';ASM'
     6A6C 4153     
     6A6E 4D       
1247 6A6F   A0            BYTE ' '+TERMBT
1248               
1249 6A70 3952     SASM   DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
1250 6A72 10EF  14        JMP  NXT_P          finish up in NEXT,
1251               
1252               * : ;ASM   ( --- )
1253               *    *NEXT B,  ;
1254               ;]*
1255               
1256               ;[*== Some Variables (KEYCNT etc.) ======================================
1257               
1258 6A74 FFFF     KEYCNT DATA -1              Used in cursor flash logic
1259 6A76 0000     INTACT DATA 0               Non-zero during user's interrupt service routine
1260               *
1261               *++ variables used by some graphics primitives
1262               *
1263 6A78 0000     $DMODE DATA 0                   ; actual location of variable contents
1264 6A7A FFFF     $DCOL  DATA -1                  ; actual location of variable contents
1265               
1266               *===========================================================
1267               ;]*
1268               *   ______                         ___            _____        __
1269               *  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__
1270               *   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
1271               *  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/
1272               *                    /_/
1273               *
1274               ;[*== Trampoline Code ===================================================
1275               *
1276               * MYBANK must be at same location in all banks with the code that appears
1277               * in the following table.  The EQUates for BANK0--BANK3 may also be in the
1278               * same places in each bank for convenience, but they only need to appear once.
1279               *
1280               *       Bank Select MYBANK
1281               *       ---- ------ ------
1282               *       0    >6006  >C000
1283               *       1    >6004  >8000
1284               *       2    >6002  >4000
1285               *       3    >6000  >0000
1286               *
1287               * Bank0 code will look like this
1288               *
1289               * MYBANK DATA >C000
1290               * BANK0  EQU  >C000
1291               * BANK1  EQU  >8000
1292               * BANK2  EQU  >4000
1293               * BANK3  EQU  >0000
1294               *
1295               * Banks 1--3 will look the same, including labels, and the DATA
1296               * instruction at MYBANK's location will correspond to its bank.
1297               *
1298               * Before a bank is selected, the values above will be shifted right 13
1299               * bits and have >6000 added.
1300               *
1301               ;[*** BLBANK ************************************************************
1302               *
1303               * General bank branching routine (32KB ROM, i.e., 4 banks) for a
1304               * branch that is expected to return (not high-level Forth) via RTBANK---
1305               *   --put in scratchpad or low RAM
1306               *   --called by
1307               *       BL    @BLBANK
1308               *       DATA  dst_addr - >6000 + bank# in left 2 bits
1309               *
1310 6A7C 064E  14 BLBANK DECT R               ; reserve space on return stack (R14)
1311 6A7E C33B  30        MOV  *LINK+,CRU      ; copy destination bank address to R12
1312 6A80 C78B  30        MOV  LINK,*R         ; push return address
1313 6A82 064E  14        DECT R               ; reserve space on return stack
1314 6A84 C7A0  46        MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
     6A86 7FFE     
1315 6A88 C2CC  18        MOV  CRU,LINK        ; copy destination bank address to R11
1316 6A8A 024B  22        ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
     6A8C 1FFF     
1317 6A8E 022B  22        AI   LINK,>6000      ; make it a real address
     6A90 6000     
1318 6A92 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1319 6A94 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6A96 6000     
1320 6A98 04DC  26        CLR  *CRU            ; switch to destination bank
1321 6A9A 045B  20        B    *LINK           ; branch to destination address
1322               ;]*
1323               ;[*** RTBANK ************************************************************
1324               *
1325               * General bank return routine (32KB ROM, i.e., 4 banks)---
1326               *   --put in scratchpad or low RAM
1327               *   --called by
1328               *       B   @RTBANK
1329               *
1330 6A9C C33E  30 RTBANK MOV  *R+,CRU         ; pop return bank# from return stack to R12
1331 6A9E 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1332 6AA0 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6AA2 6000     
1333 6AA4 C2FE  30        MOV  *R+,LINK        ; pop return address from return stack
1334 6AA6 04DC  26        CLR  *CRU            ; switch to destination bank
1335 6AA8 045B  20        B    *LINK           ; branch to return address
1336               ;]*
1337               ;[*** BLF2A *************************************************************
1338               *
1339               * High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
1340               * banks) that is expected to return to bank0 via RTNEXT.  This will
1341               * only(?) be used for the ALC payload of Forth stubs in bank0---
1342               *   --put in scratchpad or low RAM
1343               *   --called by
1344               *       BL    @BLF2A
1345               *       DATA  dst_addr - >6000 + bank# in left 2 bits
1346               *
1347 6AAA C2DB  26 BLF2A  MOV  *LINK,LINK      ; copy destination bank address to R11
1348 6AAC C30B  18        MOV  LINK,CRU        ; copy it to R12
1349 6AAE 024B  22        ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
     6AB0 1FFF     
1350 6AB2 022B  22        AI   LINK,>6000      ; make it a real address
     6AB4 6000     
1351 6AB6 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1352 6AB8 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6ABA 6000     
1353 6ABC 04DC  26        CLR  *CRU            ; switch to destination bank
1354 6ABE 045B  20        B    *LINK           ; branch to destination address
1355               ;]*
1356               ;[*** RTNEXT ************************************************************
1357               *
1358               * High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4
1359               * banks)---
1360               *   --put in scratchpad or low RAM
1361               *   --called by
1362               *       B   @RTNEXT
1363               *
1364 6AC0 C320  34 RTNEXT MOV  @INTACT,CRU       Are we in user's ISR?
     6AC2 3956     
1365 6AC4 1602  14        JNE  RTNXT1            Don't enable interrupts if so.
1366 6AC6 0300  24        LIMI 2
     6AC8 0002     
1367 6ACA 04E0  34 RTNXT1 CLR  @>6006          ; switch to bank 0
     6ACC 6006     
1368 6ACE 045F  20        B    *NEXT           ; branch to next CFA (in R15)
1369               ;]*
1370               ;[*** BLA2F *************************************************************
1371               *
1372               * ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
1373               * banks) that is expected to return to calling bank via RTA2F---
1374               *   --put in scratchpad or low RAM
1375               *   --called by
1376               *       BL    @BLA2F
1377               *       DATA <Forth cfa in bank0>
1378               *
1379 6AD0 064E  14 BLA2F  DECT R               ; reserve space on return stack
1380 6AD2 C2BB  30        MOV  *LINK+,W        ; move CFA of Forth routine to W
1381 6AD4 C78B  30        MOV  LINK,*R         ; push return address of calling bank
1382 6AD6 064E  14        DECT R               ; reserve space on return stack
1383 6AD8 C7A0  46        MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
     6ADA 7FFE     
1384 6ADC 064E  14        DECT R               ; reserve spot on return stack
1385 6ADE C78D  30        MOV  IP,*R           ; move current IP to return stack
1386 6AE0 020D  20        LI   IP,RTA2F        ; move address of return procedure to IP
     6AE2 39CC     
1387 6AE4 04E0  34        CLR  @>6006          ; switch to bank0
     6AE6 6006     
1388 6AE8 0460  28        B    @DOEXEC         ; Execute the Forth routine
     6AEA 833C     
1389               ;]*
1390               ;[*** RTA2F *************************************************************
1391               *
1392               * ALC to high-level Forth bank "return" routine from Forth to calling
1393               * ALC (32KB ROM, i.e., 4 banks)---
1394               *   --put in scratchpad or low RAM
1395               *   --called through B *NEXT at end of Forth word's execution in BLA2F
1396               *
1397 6AEC 39CE     RTA2F  DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
1398 6AEE 39D0            DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
1399 6AF0 C37E  30        MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
1400               * Retrieve ALC return info and return to caller...
1401               * ...caller will execute B *NEXT when it finishes
1402 6AF2 0460  28        B    @RTBANK         ; branch to general bank return routine above
     6AF4 397C     
1403               ;]*
1404               ;]***********************************************************************
1405               ;[*++ Bank-specific cell-/byte-reading code ++*
1406               ;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
1407               *++ Read cell contents of address in Bank bank# or RAM.
1408               *++ Register inputs:
1409               *++     R0:  bank-switch address
1410               *++     R1:  address in bank# to be read
1411               
1412 6AF6 04D0  26 _BKAT  CLR  *R0             ; switch banks
1413 6AF8 C651  38        MOV  *R1,*SP         ; get cell contents of address to stack
1414 6AFA 0460  28        B    @RTNEXT         ; return to inner interpreter
     6AFC 39A0     
1415               ;]*
1416               ;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
1417               *++ Read byte contents of address in Bank bank# or RAM.
1418               *++ Register inputs:
1419               *++     R0:  bank-switch address
1420               *++     R1:  address in bank# to be read
1421               
1422 6AFE 04D0  26 _BKCAT CLR  *R0             ; switch banks
1423 6B00 04C2  14        CLR  R2              ; clear R2
1424 6B02 D811  46        MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
     6B04 8305     
1425 6B06 C642  30        MOV  R2,*SP          ; get byte contents of address to stack
1426 6B08 0460  28        B    @RTNEXT         ; return to inner interpreter
     6B0A 39A0     
1427               
1428               ;]*
1429               
1430               ;]*
1431               *         _______   __  _________      ___          __
1432               *        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
1433               *       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
1434               *      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, /
1435               *                                                  /___/
1436               *
1437               ;[*** SAMS! ***      ( --- )
1438               * This calls the SAMS initialization in the startup code in bank 1.
1439               *
1440               *        DATA SMSQ_N
1441               * SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
1442               * SAMSST DATA $+2
1443               *        BL   @BLF2A
1444               *        DATA _SMSST->6000+BANK1
1445               
1446 6B0C 06A0  32 _SMSST BL   @SMSINI           initialize SAMS card
     6B0E 610C     
1447 6B10 0460  28        B    @RTNEXT           back to inner interpreter
     6B12 39A0     
1448               ;]*
1449               ;[*== Required strings, tables, variables... ============================
1450               *
1451               *
1452               * Default blocks filename
1453               *
1454 6B14 0C       DEFNAM BYTE 12
1455 6B15   44            TEXT "DSK1.FBLOCKS "
     6B16 534B     
     6B18 312E     
     6B1A 4642     
     6B1C 4C4F     
     6B1E 434B     
     6B20 5320     
1456               *
1457               * Default colors for all VDP modes---
1458               *     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
1459               *     LSB: Color Table colors (FG/BG)
1460               *
1461 6B22 4F00     DEFCOL DATA >4F00          ; TEXT80    offset=0
1462 6B24 4F00            DATA >4F00          ; TEXT      offset=2
1463 6B26 F4F4            DATA >F4F4          ; GRAPHICS  offset=4
1464 6B28 11F4            DATA >11F4          ; MULTI     offset=6
1465 6B2A FE10            DATA >FE10          ; GRAPHICS2 offset=8
1466 6B2C FEF4            DATA >FEF4          ; SPLIT     offset=10
1467 6B2E FEF4            DATA >FEF4          ; SPLIT2    offset=12
1468               *
1469               * Default text mode
1470               *
1471 6B30 0001     DEFTXT DATA >0001
1472               *
1473               * Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
1474               *
1475 6B32 0000     FNTFLG DATA 0              ; font flag initially 0
1476               *
1477               * Speech variables needing initial value (more below LLVEND)
1478               *
1479 6B34 0000     SPCSVC DATA 0
1480               *
1481               * Sound Table #1 Workspace for sound variables.  Only using R0..R4
1482               *
1483               SND1WS
1484 6B36 0000     SND1ST DATA 0           ; R0 (sound table status) 0=no table..
1485                                       ; ..1=loading sound bytes..-1=counting
1486 6B38 8400     SND1DS DATA SOUND       ; R1 (sound-table byte destination)..
1487                                       ; ..initialized to sound chip
1488 6B3A 0000     SND1AD DATA 0           ; R2 (sound table address)
1489 6B3C 0000     SND1CT DATA 0           ; R3 (# of sound bytes to load or..
1490                                       ; ..sound count = seconds * 60)
1491 6B3E 3AE4     SND1SP DATA SNDST0      ; R4 (pointer to top of sound stack)..
1492                                       ; ..initialized to bottom of sound stack
1493               *
1494               * Sound Table #2 Workspace for sound variables.  Only using R0..R3
1495               *
1496               SND2WS
1497 6B40 0000     SND2ST DATA 0           ; R0 (sound table status) 0=no table..
1498                                       ; ..1=loading sound bytes..-1=counting
1499 6B42 8400     SND2DS DATA SOUND       ; R1 (sound-table byte destination) init to sound chip
1500               ;]*
1501               *
1502               * This is the end of low-level support code that gets copied.
1503               *
1504               LLVEND
1505               
1506               ;[*== Un-initialized Variables and workspaces... =========================
1507               * Start of definitions of variables and workspaces that do not need to
1508               * take up space in ROM because they need no initial values.
1509               *
1510               * Sound Table #2 Workspace for sound variables..continued.
1511               *
1512      3A24     SND2AD EQU  SND2WS+4    ; R2 (sound table address)
1513      3A26     SND2CT EQU  SND2WS+6    ; R3 (# of sound bytes to load or..
1514               *                       ; ..sound count = seconds * 60)
1515      3A28     SDMUTE EQU  SND2WS+8    ; dummy destination for sound byte
1516               *
1517               * Branch Stack for ISR processing of Speech, 2 Sound Tables and return
1518               *
1519      3A2A     BRSTK  EQU  SDMUTE+2
1520               *
1521               * Speech variables (more above LLVEND)
1522               *
1523      3A32     SSFLAG EQU  BRSTK+8
1524      3A34     SPCNT  EQU  SSFLAG+2
1525      3A36     SPADR  EQU  SPCNT+2
1526      3A38     BANKSV EQU  SPADR+2
1527      3A3A     PADSV  EQU  BANKSV+2
1528               *
1529               * Panel window: height, width and screen position...used by PANEL and SCROLL
1530               *
1531      3A46     PANWIN EQU  PADSV+12          panel height, width and screen start
1532               
1533               *== Utility Workspace =================================================
1534               *** General utility workspace registers
1535      3A4C     UTILWS EQU  PANWIN+6
1536      3A51     U_R2LB EQU  UTILWS+5
1537               
1538      3A6C     LINBUF EQU  UTILWS+32
1539      3ABC     CURCHR EQU  LINBUF+80
1540               
1541               *++ variable used by the 40/80-column editor
1542      3ABE     OLDCUR EQU  CURCHR+2
1543               
1544               *++ FILE I/O variables
1545               
1546      3AC6     PBADR  EQU  OLDCUR+8
1547      3AC8     PBBF   EQU  PBADR+2
1548      3ACA     PBVBF  EQU  PBBF+2
1549               
1550               *++ Floating Point Math Library variables
1551      3ACC     FPVARS EQU  PBVBF+2
1552               
1553               *++ SAMS flag
1554      3AE2     SAMSFL EQU  FPVARS+22
1555               
1556               *++ Bottom of Sound Stack
1557               *++      This location marks the top of the low-level support code. The Sound
1558               *++      Stack grows upward toward the Return Stack by moving the entire stack
1559               *++      up one cell to make room for the next new bottom entry.
1560      3AE4     SNDST0 EQU  SAMSFL+2
1561               ;]*
1562               
1563                      AORG
1564                      BANK 1

Here is the code it replaced:

Spoiler


*     __                  __                __
*    / /  ___ _    ______/ /  ___ _  _____ / /
*   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) / 
*  /____/\___/__,__/   /____/\__/|___/\__/_/  
*                     ____                        __ 
*                    / __/_ _____  ___  ___  ____/ /_
*                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
*                  /___/\_,_/ .__/ .__/\___/_/  \__/ 
*                          /_/  /_/                  
* 
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                   *
* fbForth---                                                        *
*                                                                   *
*       Low-level support routines                                  *
*                                                                   *
*  << Including Trampoline Code, tables & variables:  2606 bytes >> *
*                                                                   *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

LLVSPT   ; <--This is the source copy location for the rest of this code.

$BUFF  EQU  >2010
 
* 4 I/O buffers below ($LO = >3020) 
* Change '4' to number of buffers needed and for which there is room.

$LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers
*       _____   ____         __  __      ___________ 
*      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
*     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
*    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_| 
*
;[*** Interrupt Service =======================================================
* This routine is executed for every interrupt.  It processes any pending
* speech and souind.  It then looks to see whether a user ISR is installed in 
* ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work 
* only if the user has installed an ISR using the following steps in the fol-
* lowing order:
*
*   (1) Write an ISR with entry point, say MYISR.
*   (2) Determine code field address of MYISR with this high-level Forth:
*           ' MYISR CFA
* <<< Maybe need a word to do #3 >>>
*   (3) Write CFA of MYISR into user variable ISR.
*
* Steps (2)-(3) in high-level Forth are shown below:
*           ' MYISR CFA
*           ISR !
* 
* <<< Perhaps last step above should be by a word that disables interrupts >>>
*
* The console ISR branches to the contents of >83C4 because it is non-zero,
* with the address, INT1, of the fbForth ISR entry point below (also, the
* contents of INTLNK).  This means that the console ISR will branch to INT1
* with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
* process any pending speech and sound.
* 
* If the user's ISR is properly installed, the code that processes the user
* ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
* from Forth's workspace (MAINWS), the code at INT2 will process the user's
* ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
* inner interpreter.
*** ==========================================================================

* ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!

INT1   EQU  $LO+$-LLVSPT
       LI   R0,BRSTK          load address of top of Branch Address Stack
* 
* Set up for pending speech
*
       MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
       JEQ  SNDCH1            jump to sound-check if no speech
       INCT R0                increment Branch Stack
*
* Set up for pending sound table #1 (ST#1)
*
SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
       JEQ  SNDCH2            process speech and sound if needed
       LI   R1,x#PLAYT1         load PLAYT1 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
* 
* Set up for pending sound table #2 (ST#2)
*
SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
       JEQ  PRCSPS            process speech and sound if needed
       LI   R1,x#PLAYT2         load PLAYT2 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
*
* Process sound stack if both sound tables idle
*
PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
       JNE  PRSPS2            nope..skip sound stack processing
       LWPI SND1WS            switch to ST#1 WS
       CI   R4,SNDST0         anything on sound stack?
       JEQ  PRSPS1            no..exit sound stack processing
       DECT R4                pop sound stack position
       MOV  *R4,R2            get sound table address from sound stack
       INC  R0                kick off sound processing of ST#1 (R0=1)
PRSPS1 LWPI GPLWS             switch back to GPL WS
* 
* Check for any pending speech and sound
*
PRSPS2 CI   R0,BRSTK          any speech or sound to process?
       JEQ  USRISR            if not, jump to user ISR processing
       LI   R1,BNKRST         yup..load return address
       MOV  R1,*R0            push return address onto Branch Stack
* 
* Process pending speech and sound
*
       MOV  @x#MYBANK,@BANKSV   save bank at interrupt
       CLR  @>6002            switch to bank 2 for speech & sound services
       LI   R7,BRSTK          load top of Branch Stack
       MOV  *R7+,R8           pop speech/sound ISR
       B    *R8               service speech/sound
*
* Restore interrupted bank
*
BNKRST EQU  $LO+$-LLVSPT      return point for speech and sound ISRs
       MOV  @BANKSV,R0        restore bank at interrupt
       SRL  R0,13             get the bank# to correct position
       AI   R0,>6000          make it a real bank-switch address
       CLR  *R0               switch to the bank at interrupt
*
* Process User ISR if defined
*
USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
       JEQ  INTEX             
*
* Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
* is executed from Forth's WS (MAINWS = >8300), which it does at the end of
* every CODE word, keyboard scan and one or two other places.
* 
       LI   R1,INT2                 Load entry point, INT2
       MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
* 
* The following 2 instructions are copies of the remainder of the console ROM's
* ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
* because we're not going back there!
* 
INTEX  LWPI >83C0             Change to console's ISR WS  
       RTWP                   Return to caller of console ISR
* 
* Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
* before executing user's ISR. INT3 (cleanup routine below) will be inserted
* in address list to get us back here for cleanup after user's ISR has finished.
* User's ISR is executed at the end of this section just before INT3.
* 
INT2   EQU  $LO+$-LLVSPT
       LIMI 0                 Disable interrupts
       MOVB @>83D4,R0         Get copy of VR01
       SRL  R0,8              ...to LSB
       ORI  R0,>100           Set up for VR01
       ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
       BLWP @VWTR             Turn off VDP interrupt
       LI   NEXT,$NEXT        Restore NEXT
       SETO @INTACT           Set Forth "pending interrupt" flag
       DECT R                 Set up return linkage by pushing 
       MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
       LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
       MOV  @$ISR(U),W        Do the user's Forth ISR by executing
       B    @DOEXEC           ...it through Forth's inner interpreter
* 
* Clean up and re-enable interrupts.
*
INT3   EQU  $LO+$-LLVSPT    
       DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
       DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
       MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
       CLR  @INTACT           Clear Forth "pending interrupt" flag
       MOVB @>83D4,R0         Prepare to restore VR01 by...
       SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
       AI   R0,>100           ...VR # (01) to MSB
       MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
       BLWP @VWTR             Write VR01
       LIMI 2                 Re-enable interrupts
       B    *NEXT             Continue normal task
;]*
;[*** BKLINK from SYSTEM calls ==========================================
*
BKLINK EQU  $LO+$-LLVSPT
       MOV  @INTACT,R7        Are we in user's ISR?
       JNE  BKLIN1            Don't enable interrupts if so.
       LIMI 2
BKLIN1 B    *LINK
;]*
*      ____         __              _____     ____  
*     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
*    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
*   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
*       /___/                                          
* 
;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================

*       Entry point for low-level system support functions

$SYS$  EQU  $LO+$-LLVSPT
       LIMI 0
       MOV  @SYSTAB(R1),R0
       B    *R0
;]
;[*** SYSTAB -- Vector table for SYSTEM calls ===========================

       DATA BRW          CODE = -20  write block to blocks file
       DATA BRW          CODE = -18  read block from blocks file
       DATA BRW          CODE = -16  create blocks file
       DATA BRW          CODE = -14  use blocks file
       DATA GXY          CODE = -12  GOTOXY
       DATA QKY          CODE = -10  ?KEY
       DATA QTM          CODE =  -8  ?TERMINAL
       DATA CLF          CODE =  -6  CRLF
       DATA EMT          CODE =  -4  EMIT
       DATA KY           CODE =  -2  KEY
SYSTAB EQU  $LO+$-LLVSPT
       DATA SBW          CODE =   0  VSBW
       DATA MBW          CODE =   2  VMBW
       DATA SBR          CODE =   4  VSBR
       DATA MBR          CODE =   6  VMBR
       DATA WTR          CODE =   8  VWTR
       DATA GPL          CODE =  10  GPLLNK
       DATA XML          CODE =  12  XMLLNK
       DATA DSR          CODE =  14  DSRLNK
       DATA CLS$         CODE =  16  CLS
       DATA MVE          CODE =  18  VMOVE
       DATA FILL$        CODE =  20  VFILL
       DATA AOX          CODE =  22  VAND
       DATA AOX          CODE =  24  VOR
       DATA AOX          CODE =  26  VXOR
;]*
;[*== VDP single byte write.                CODE =   0  =================
*
SBW    EQU  $LO+$-LLVSPT
       MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         Character to write
       SWPB R1              Get in left byte
       BLWP @VSBW
       B    @BKLINK
;]*
;[*== VDP multi byte write.                 CODE =   2  =================
*
MBW    EQU  $LO+$-LLVSPT
       MOV  *SP+,R2         Number of bytes to move
       MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         RAM address (source)
       BLWP @VMBW
       B    @BKLINK
;]*
;[*== VDP single byte read.                 CODE =   4  =================
*
SBR    EQU  $LO+$-LLVSPT
       MOV  *SP,R0          VRAM address (source)
       BLWP @VSBR
       SRL  R1,8            Character to right half for Forth
       MOV  R1,*SP          Stack it
       B    @BKLINK
;]*
;[*== VDP multi byte read.                  CODE =   6  =================
*
MBR    EQU  $LO+$-LLVSPT
       MOV  *SP+,R2         Number of bytes to read
       MOV  *SP+,R1         RAM address (destination)
       MOV  *SP+,R0         VRAM address (source)
       BLWP @VMBR
       B    @BKLINK
;]*
;[*== VDP-to-VDP move.                      CODE =  18  =================
*
MVE    EQU  $LO+$-LLVSPT
       MOV  *SP+,R0         Pop cnt to R0
       MOV  *SP+,R2         Pop vdst to R2
       MOV  *SP+,R1         Pop vsrc to R1
       BLWP @VMOVE
       B    @BKLINK
;]*
;[*== VDP register write.                   CODE =   8  =================
*
WTR    EQU  $LO+$-LLVSPT
       MOV  *SP+,R1         VDP register number
       MOV  *SP+,R0         Data for register
       SWPB R1              Get register to left byte
       MOVB R1,R0           Place with data
       BLWP @VWTR
       B    @BKLINK
;]*
;[*== GPL link utility.                     CODE =  10  =================
*
GPL    EQU  $LO+$-LLVSPT
       CLR  R0
       MOVB R0,@KYSTAT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,GPLLNK         to the GPLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== XML link utility.                     CODE =  12  =================
*
XML    EQU  $LO+$-LLVSPT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,XMLLNK         to the XMLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== DSR link utility.                     CODE =  14  =================
*
DSR    EQU  $LO+$-LLVSPT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,DSRLNK         to the DSRLNK utility
       MOV  *SP+,R2         This datum selects DSR or subroutine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== Screen clearing utility.              CODE =  16  =================
*
CLS$   EQU  $LO+$-LLVSPT
       MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
       MOV  @$SEND(U),R1    End of screen in VRAM
       S    R2,R1           Screen size
       LI   R0,>2000        Blank character
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== VDP fill routine.                     CODE =  20  =================
*
FILL$  EQU  $LO+$-LLVSPT
       MOV  *SP+,R0         Fill character
       SWPB R0                to left byte
       MOV  *SP+,R1         Fill count
       MOV  *SP+,R2         Address to start VRAM fill
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
*========================================================================
FILL1  EQU  $LO+$-LLVSPT    R0=char, R1=cnt, R2=vaddr
       ORI  R2,>4000        Set bit for VDP write
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
FLOOP  MOVB R0,@VDPWD       Write a byte
       DEC  R1
       JNE  FLOOP           Not done, fill another
       B    *LINK
;]*======================================================================
*
*==== VAND -- VDP byte AND routine.         CODE =  22  =================
*==== VOR -- VDP byte OR routine.           CODE =  24  =================
;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
*
AOX    EQU  $LO+$-LLVSPT
       MOV  *SP+,R2         VRAM address
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
       MOVB @VDPRD,R3       Read byte
       MOV  *SP+,R0         Get data to operate with
       SWPB R0                to left byte
*** Now do requested operation *****************
       CI   R1,24
       JEQ  DOOR
       JGT  DOXOR
       INV  R3              These two instructions
       SZC  R3,R0             perform an 'AND'
       JMP  FINAOX
DOOR   SOC  R3,R0             perform 'OR'
       JMP  FINAOX
DOXOR  XOR  R3,R0             perform 'XOR'
FINAOX LI   R1,1
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== KEY routine                           CODE =  -2  =================
*
KY    EQU  $LO+$-LLVSPT
       MOV  @$ALTI(U),R0      alternate input device?
       JEQ  KEY0              jump to keyboard input if not
*
*  R0 now points to PAB for alternate input device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to read one byte.
*
       CLR  R7                prepare to zero status byte
       MOVB R7,@KYSTAT        zero status byte
       INC  R0                point R0 to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       MOV  R0,R1             Set up pointer...
       AI   R1,8              ...to namelength byte of PAB
       MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
       MOV  R0,R3             save pointer (DSRLNK will trash it!)
       BLWP @DSRLNK           get 1 byte from device
       DATA >8
       MOV  R3,R0             restore pointer
       DECT R0                point to one-byte VRAM buffer in front of PAB
       BLWP @VSBR             read character
       SRL  R1,8              move to LSB
       MOV  R1,R0             copy to return register
       B    @BKLINK           return to caller
*
*  Input is comining from the keyboard
*
KEY0   MOV  @KEYCNT,R7
       INC  R7
       JNE  KEY1
       MOV  @CURPO$(U),R0
       BLWP @VSBR             Read character at cursor position...
       MOVB R1,@CURCHR        ...and save it
       LI   R1,>1E00          Place cursor character on screen
       BLWP @VSBW
*
KEY1   BLWP @KSCAN
       MOVB @KYSTAT,R0
       COC  @H2000,R0         check status
       JEQ  KEY2              JMP if key was pressed
*
       CI   R7,100            No key pressed
       JNE  KEY3
       MOVB @CURCHR,R1
       JMP  KEY5
*
KEY3   CI   R7,200
       JNE  KEY4
       CLR  R7
       LI   R1,>1E00          Cursor char
KEY5   MOV  @CURPO$(U),R0
       BLWP @VSBW
KEY4   MOV  R7,@KEYCNT
       MOV  @INTACT,R7        Are we in user's ISR?
       JNE  KEY6              Don't enable interrupts if so.
       LIMI 2
KEY6   DECT IP                This will re-execute KEY
       B    *NEXT
KEY2   SETO @KEYCNT           Key was pressed
       MOV  @CURPO$(U),R0     Restore character at cursor location
       MOVB @CURCHR,R1
       BLWP @VSBW
       MOVB @KYCHAR,R0        Put char in...
       SRL  R0,8              ...LSB of R0
       B    @BKLINK
;]*
;[*== EMIT routine                          CODE =  -4  =================
*
EMT    EQU  $LO+$-LLVSPT
       MOV  R2,R1             copy char to R1 for VSBW
       MOV  @$ALTO(U),R0      alternate output device?
       JEQ  EMIT0             jump to video display output if not
*
*  R0 now points to PAB for alternate output device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to write one byte.
*
       CLR  R7                ALTOUT active
       MOVB R7,@KYSTAT        zero status byte
       DEC  R0                point to one-byte VRAM buffer in front of PAB
       SWPB R1                char to MSB
       BLWP @VSBW             write char to buffer
       INCT R0                point to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       AI   R0,8              Set up pointer to namelength byte of PAB
       MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
       BLWP @DSRLNK           put 1 byte to device
       DATA >8                
       B    @BKLINK           return to caller
*
*  Output is going to the video display
*
EMIT0  CI   R1,7            Is it a bell?
       JNE  NOTBEL
       CLR  R2
       MOVB R2,@KYSTAT
       BLWP @GPLLNK
       DATA >0036           Emit error tone
       JMP  EMEXIT
*
NOTBEL CI   R1,8            Is it a backspace?
       JNE  NOTBS
       LI   R1,>2000
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       JGT  DECCUR
       JMP  EMEXIT
DECCUR DEC  @CURPO$(U)
       JMP  EMEXIT
*
NOTBS  CI   R1,>A           Is it a line feed?
       JNE  NOTLF
       MOV  @$SEND(U),R7
       S    @$SWDTH(U),R7
       C    @CURPO$(U),R7
       JHE  SCRLL
       A    @$SWDTH(U),@CURPO$(u)
       JMP  EMEXIT
SCRLL  MOV  LINK,R7
       BL   @SCROLL
       MOV  R7,LINK
       JMP  EMEXIT
*
*** SCROLLING ROUTINE
*
SCROLL EQU  $LO+$-LLVSPT
       MOV  @$SSTRT(U),R0   VRAM addr
       LI   R1,LINBUF       Line buffer
       MOV  @$SWDTH(U),R2   Count
       A    R2,R0           Start at line 2
SCROL1 BLWP @VMBR
       S    R2,R0           One line back to write
       BLWP @VMBW
       A    R2,R0           Two lines ahead for next read
       A    R2,R0
       C    R0,@$SEND(U)    End of screen?
       JL   SCROL1
       MOV  R2,R1           Blank bottom row of screen
       LI   R0,>2000        Blank
       S    @$SEND(U),R2
       NEG  R2              Now contains address of start of last line
       MOV  LINK,R6
       BL   @FILL1          Write the blanks
       B    *R6
*
NOTLF  CI   R1,>D           Is it a carriage return?
       JNE  NOTCR
       CLR  R0
       MOV  @CURPO$(U),R1
       MOV  R1,R3
       S    @$SSTRT(U),R1   Adjusted for screen not at 0
       MOV  @$SWDTH(U),R2
       DIV  R2,R0
       S    R1,R3
       MOV  R3,@CURPO$(U)
       JMP  EMEXIT
*
NOTCR  SWPB R1              Assume it is a printable character
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       MOV  @$SEND(U),R2
       DEC  R2
       C    R0,R2
       JNE  NOTCR1
       MOV  @$SEND(U),R0
       S    @$SWDTH(U),R0   Was last char on screen. Scroll
       MOV  R0,@CURPO$(U)
       JMP  SCRLL
NOTCR1 INC  R0              No scroll necessary
       MOV  R0,@CURPO$(U)
*
EMEXIT B    @BKLINK
;]*
;[*== CRLF routine                          CODE =  -6  =================
*
CLF    EQU  $LO+$-LLVSPT
       MOV  LINK,R5
       LI   R2,>000D
       BL   @EMT            EMT will alter INT mask via B @BKLINK
       LI   R2,>000A
       LIMI 0               Previous call to EMT altered INT mask
       BL   @EMT
       MOV  R5,LINK
       B    @BKLINK
;]*
;[*== ?TERMINAL routine                     CODE =  -8  =================
* scan for <clear>, <break>, FCTN+4 press
*
QTM    EQU  $LO+$-LLVSPT
       MOV  LINK,R5         save return
       BL   @>0020          branch to console's test for <clear>
       STST R0              store status in R0
       JNE  QTM2            exit if not <clear>
QTM1   BL   @>0020          check for <clear> again
       JEQ  QTM1            loop until not <clear>
QTM2   MOV  R5,LINK         restore return
       ANDI R0,>2000        keep only EQU bit
       B    @BKLINK         return to caller
;]*
;[*== ?KEY routine                          CODE = -10  =================
*
QKY    EQU  $LO+$-LLVSPT
       BLWP @KSCAN
       MOVB @KYCHAR,R0
       SRL  R0,8
       CI   R0,>00FF
       JNE  QKEY1
       CLR  R0
QKEY1  B    @BKLINK
;]*
;[*== GOTOXY routine                        CODE = -12  =================
*
GXY    EQU  $LO+$-LLVSPT
       MPY  @$SWDTH(U),R3
       A    R2,R4           Position within screen
       A    @$SSTRT(U),R4   Add VRAM offset to screen top
       MOV  R4,@CURPO$(U)
       B    @BKLINK
;]
*       ___  __         __     ____  ______ 
*      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
*     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
*    /____/_/\___/\__/_/\_\ /___/_/  \____/ 

*
*== USE blocks file                         CODE = -14  =================
*== CREATE blocks file                      CODE = -16  =================
*== READ block from blocks file             CODE = -18  =================
*== WRITE block to blocks file              CODE = -20  =================
;[*== Block File I/O Support ============================================
*
* BPTOG utility to toggle one of 2 PABs for block file access
*
BPTOG  EQU  $LO+$-LLVSPT
       MOV  @$BPOFF(U),R0	   PAB offset to R0
       LI	R1,70	            Toggle amount
       XOR	R0,R1	            New offset
       MOV	R1,@$BPOFF(U)	   Update offset
*
**xxx** entry point to insure we have correct PAB address
BPSET  EQU  $LO+$-LLVSPT
       MOV  @$DKBUF(U),R0	   Get DISK_BUF address
       A	   @$BPABS(U),R0	   Get BPABS address
*
       A	   @$BPOFF(U),R0     Add current offset
       MOV	R0,@BFPAB	      Update current block file's PAB address
       RT	 	 
*
* CLOSE blocks file
*
BKCLOS EQU  $LO+$-LLVSPT
       MOV  @BFPAB,R0
       LI   R1,$FCLS          Opcode=CLOSE
       BLWP @VSBW
       AI   R0,9              Address of filename's char count
       MOV  R0,@SUBPTR        Point to filename's char count
       BLWP @DSRLNK           Close the file
       DATA 8
       RT                     Deal with error in caller
*
* storage area
*
SVBRET EQU  $LO+$-LLVSPT
       DATA 0                 Storage for LINK coming into BRW
BFPAB  EQU  $LO+$-LLVSPT
       DATA	0	               Storage for current blocks file PAB address...
*	 	 	                     ...will have current PAB on entry
* PAB header storage
*
PABHD  EQU  $LO+$-LLVSPT
       BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
*              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
*	                	                 >03=OUTPUT mode + "
*	                	                 >01=UPDATE mode + "
*	                         BYTE 2,3: save contents of DISK_BUF here
       BYTE	>80	            Record length
       BYTE	>80	            Character count of transfer
       BSS	2	            Record number
*
*** file I/O equates
*
$FOPN  EQU  >0000
$FCLS  EQU  >0100
$FRD   EQU  >0200
$FWRT  EQU  >0300
$FRST  EQU  >0400
$FINP  EQU  5
$FOUT  EQU  3
$FUPD  EQU  1
*
*** BRW -- entry point for block read/write routines
*
BRW    EQU  $LO+$-LLVSPT
       MOV  LINK,@SVBRET   Save LINK address
       MOV	R1,R7	         Save CODE {R1 to R7}
       SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
       AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
       BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
       CI	R7,4	         USE or CREATE?
       JLT	BRW01	         No
       BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
       MOV	@BFPAB,R0	   Load PAB address
       AI	R0,9	         Set to name length byte
       CLR	R2	 
       MOV	*SP+,R1	      Pop bfnaddr to R1
       MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
       INC	R2	            Add 1 to # bytes to copy
       BLWP	@VMBW	         Copy char count & pathname to PAB
*
*** set up PAB for OPEN 
*
BRW01  LI	R1,$FUPD                Opcode=0,mode=update
       CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
       JOP  BRW02                   No
       LI	R1,$FINP                Yes...change mode=input
BRW02  MOV  R1,@PABHD               Put in PAB header
       MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
       CLR  R0
       MOV  R0,@PABHD+6             Set record#=0
       MOV  @BFPAB,R0               VRAM destination
       LI   R1,PABHD                RAM source
       LI   R2,8                    Copy first 8 bytes of PAB header
       BLWP @VMBW                   Do the copy
*
*** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
*
       AI   R0,9                Address of filename's char count in PAB
       MOV  R0,@SUBPTR          Point to-----^^^^
       BLWP @DSRLNK             Open/create the file
       DATA 8
       JEQ  BKERR
       CI   R7,4                READ or WRITE?
       JLT  BRW04               Yes
       JGT  BRWDON              No; =USE; we're done
*
*** write blank records to newly created blocks file [CODE = -16,CREATE]
*
       MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
       SLA  R5,3                Convert #blocks to #records
       MOV  R5,R3               Save
       MOV  R5,R4               Set up counter
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       MOV  R0,@PABHD           Copy to PAB header
BRLOOP S    R4,R5               Calculate next record
       MOV  R5,@PABHD+6         Copy to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       AI   R0,9                Address of filename's char count
       MOV  R0,@SUBPTR          Point to filename's char count
       BLWP @DSRLNK             Write one record of blanks
       DATA 8
       JEQ  BKERR
       MOV  R3,R5               Get #blocks
       DEC  R4                  Count down 1 record
       JNE  BRLOOP              Write another record if not done
       JMP  BRWDON              We're done
*
*** prepare for read/write block
*
BRW04  MOV  *SP+,R5             Pop block# to write
       MOV  *SP+,R6             Pop bufaddr
       DEC  R5                  Block#-1
       SLA  R5,3                Convert to starting record#
       LI   R4,8                Load counter for 8 records
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       LI   R3,VMBW             WRITE vector
       CI   R7,2                Are we writing the block?
       JEQ  BRW05               Yup
       LI   R0,$FRD+$FINP       Nope...set up for READ
       LI   R3,VMBR             READ vector
BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
* 
* READ/WRITE block routine [CODE = -18/-20]
* 
RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0
       MOV  R6,R1               RAM buffer to R1
       LI   R2,128              Bytes to copy
       CI   R7,3                READ?
       JEQ  BRW06               Yup
       BLWP *R3                 Nope...copy record to VRAM
*
* temporarily use CRU register---it should be OK
*
BRW06  MOV  @BFPAB,CRU          PAB address
       AI   CRU,9               Address of filename's char count
       MOV  CRU,@SUBPTR         Point to filename's char count
       BLWP @DSRLNK             Read/write one record
       DATA 8
       JEQ  BKERR
       CI   R7,2                WRITE?
       JEQ  BRW07               Yup...next record
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
       BLWP *R3                 Nope...copy record to RAM buffer
BRW07  INC  R5                  Next record in file
       AI   R6,128              Next record to/from block RAM buffer
       DEC  R4                  Count down 1 record
       JNE  RWLOOP              Read/write another record if not done
       JMP  BRWDON              We're done
*
*** error handling
*
BKERR  MOVB R0,R0               Device error?
       JEQ  BKERR6              Yes, exit with disk error
BKERR9 LI   R6,9                No, exit with file error
       JMP  BKCLN
BKERR8 LI   R6,8                Block# <=0!  exit with range error
       JMP  BKCLN
BKERR6 LI   R6,6
BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
       CI   R7,4                USE or CREATE?
       JLT  BKCLN1              No
       BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
BKCLN1 MOV  R6,R0               Pass error back to caller
       JMP  BKEXIT
BRWDON CLR  R6
       BL   @BKCLOS             Close current blocks file
       JNE  BRWDN1              Error?
       LI   R6,9                Yes...assume it was a file error
BRWDN1 CI   R7,4                (no error)...CREATE?
       JNE  BRWDN2              No...we're done
       BL   @BPTOG              Yes...revert to correct blocks file
BRWDN2 MOV  R6,R0               Error to R0
BKEXIT MOV  @SVBRET,LINK        Restore LINK
       B    @BKLINK
;]
;[* MSGTYP      <<< Support for string typing in various banks >>>
*
* Called with:  BL  @MSGTYP
* 
* R4 and R5 are the only registers that will be preserved
* ..after a call to EMIT---
*
* Input:    R4 = Address of length byte of packed string
*
* We will pass the ASCII value of character to EMIT in R2 without
* insuring it is 7 bits wide.
*
MSGTYP EQU  $LO+$-LLVSPT
       DECT R           Push return address
       MOV  LINK,*R     ...to Forth return stack
       CLR  R5          
       MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
       SWPB R5          Put char count in low byte
MTLOOP CLR  R2
       MOVB *R4+,R2     Copy next char to R2 for EMIT
       SWPB R2          Put char in low byte
       LIMI 0           We need to do this because we're calling EMIT directly
       BL   @EMT        Call EMIT directly
       INC  @$OUT(U)    Increment display line character count
       DEC  R5          Decrement character count for this message
       JNE  MTLOOP      Are we done?
       MOV  *R+,LINK    Yes. Pop return address
       RT               Return to caller
 ;]      
;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
R4$5   EQU  $LO+$-LLVSPT
       MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4,*R5
       RT
;]
*     __  __              _   __         _      __   __   
*    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__ 
*   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
*   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/ 
*              ___      ___          ____    
*             / _ \___ / _/__ ___ __/ / /____
*            / // / -_) _/ _ `/ // / / __(_-<
*           /____/\__/_/ \_,_/\_,_/_/\__/___/

;[*== User Variable defaults ============================================
* 
UBASE0 EQU  $LO+$-LLVSPT
       BSS  6                 BASE OF USER VARIABLES
       DATA UBASE0            06 USER UCONS$
       DATA SPBASE            08 USER S0
       DATA RBASE             0A USER R0 { R0$
       DATA $UVAR             0C USER U0
       DATA SPBASE            0E USER TIB
       DATA 31                10 USER WIDTH
       DATA DPBASE            12 USER DP
       DATA $SYS$             14 USER SYS$
       DATA 0                 16 USER CURPOS
       DATA INT1              18 USER INTLNK
       DATA 1                 1A USER WARNING
       DATA 64                1C USER C/L$ { CL$
       DATA $BUFF             1E USER FIRST$
       DATA $LO               20 USER LIMIT$
       DATA >0380             22 USER COLTAB    Color Table address in VRAM
       DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
       DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
       DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
       DATA >80               2A USER FPB       pushes address of user screen font file PAB
*                                               ...that is this relative distance from DISK_BUF
       DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
       DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
       DATA 40                30 USER SCRN_WIDTH
       DATA 0                 32 USER SCRN_START
       DATA 960               34 USER SCRN_END
       DATA 0                 36 USER ISR       [Note: This used to be INT1]
       DATA 0                 38 USER ALTIN
       DATA 0                 3A USER ALTOUT
       DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
       DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
*                                               ...that is this relative distance from DISK_BUF
       DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
*                                               ...always toggled between 0 and 70
       DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
       DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
*                                                  0 = console font via GPLLNK
       DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
       DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
       DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
*                                                  0 = Symmetric (default)
*                                                 !0 = Floored
$UVAR  EQU  $LO+$-LLVSPT
       BSS  >80               USER VARIABLE AREA
;]
;[*== A Constant ====================================================
*
H2000  EQU  $LO+$-LLVSPT
       DATA >2000
;]*
*    __  ____  _ ___ __         _   __        __             
*   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
*  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
*  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
*                     /___/                                  
* 
;[*== Utility Vectors ===================================================
*
* GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
* DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
XMLLNK EQU  $LO+$-LLVSPT
       DATA UTILWS,XMLENT   ; Link to ROM routines
KSCAN  EQU  $LO+$-LLVSPT
       DATA UTILWS,KSENTR   ; Keyboard scan
VSBW   EQU  $LO+$-LLVSPT
       DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
VMBW   EQU  $LO+$-LLVSPT
       DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
VSBR   EQU  $LO+$-LLVSPT
       DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
VMBR   EQU  $LO+$-LLVSPT
       DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
VMOVE  EQU  $LO+$-LLVSPT
       DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
VWTR   EQU  $LO+$-LLVSPT
       DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
;]*
;[*== XMLENT -- Link to system XML utilities ============================
*
XMLENT EQU  $LO+$-LLVSPT
       MOV  *R14+,@GPLWS+2      Get argument
       LWPI GPLWS               Select GPL workspace
       MOV  R11,@UTILWS+22      Save GPL return address
       MOV  R1,R2               Make a copy of argument
       CI   R1,>8000            Direct address in ALC?
       JH   XML30               We have the address
       SRL  R1,12
       SLA  R1,1
       SLA  R2,4
       SRL  R2,11
       A    @XMLTAB(R1),R2
       MOV  *R2,R2
XML30  BL   *R2
       LWPI UTILWS              Get back to right WS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    ________  __   __   _  ____ __           __  ________
*   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
*  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
* This routine will work with any GROM library slot since it is         *
* indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
* This GPLLNK does NOT require a module to be plugged into the          *
* GROM port so it will work with the Editor/Assembler,                  *
* Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
* CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
* It saves and restores the current GROM Address in case you want       *
* to return back to GROM for Basic or Extended Basic CALL LINKs         *
* or to return to the loading module.                                   *
*                                                                       *
*    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
*                                                 DATA >34              *
*                                                                       *
*    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
*                                                                       *
* 70 Bytes - including the GPLLNK Workspace                             *
*-----------------------------------------------------------------------*

*  GPLWS (>83E0) is GPL workspace
G_R4   EQU  GPLWS+8              GPL workspace R4
G_R6   EQU  GPLWS+12             GPL workspace R6
*  SUBSTK (>8373) is GPL Subroutine stack pointer
LDGADR EQU  >60                  Load & Execute GROM address entry point
XTAB27 EQU  >200E                Low Mem XML table location 27
*                                ..Will contain XMLRTN at startup
GETSTK EQU  >166C              
 
GPLLNK EQU  $LO+$-LLVSPT
       DATA GLNKWS      R7       Set up BLWP Vectors
       DATA GLINK1      R8     
* RTNADR EQU  $LO+$-LLVSPT    <---don't think we need this label
       DATA XMLRTN      R9       address where GPL XML returns to us...
*                                ...this address will already be in XTAB27,...
*                                ...>200E, so don't really need it here}
GXMLAD EQU  $LO+$-LLVSPT
       DATA >176C       R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
       DATA >50         R11      Initialized to >50 where PUTSTK address resides
GLNKWS EQU  $LO+$-LLVSPT->18     GPLLNK's workspace of which only...
       BSS  >08         R12-R15  ...registers R7 through R15 are used

GLINK1 EQU  $LO+$-LLVSPT
       MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
       MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
       LWPI GPLWS                Load GPL WS
       BL   *R4                  Save current GROM Address on stack
       MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
       INCT @SUBSTK              Adjust the stack pointer
       B    @LDGADR              Execute our GPL Routine

XMLRTN EQU  $LO+$-LLVSPT
       MOV  @GETSTK,R4           Get GETSTK pointer
       BL   *R4                  Restore GROM address off the stack
       LWPI GLNKWS               Load our WS
       RTWP                      All Done - Return to Caller
;]
*     ___  _______  __   _  ____ __           __  ________
*    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
*   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
*      (Uses console GROM 0's DSRLNK routine)                           *
*      (Do not REF DSRLNK or GPLLNK when using these routines)          *
*      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
*                                                                       *
*      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
*                                                   DATA 8              *
*                                                                       *
*      NOTES: Must be used with a GPLLNK routine                        *
*             Returns ERRORs the same as the E/A DSRLNK                 *
*             EQ bit set on return if error                             *
*             ERROR CODE in caller's MSB of Register 0 on return        *
*                                                                       *
* 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
*-----------------------------------------------------------------------*

PUTSTK EQU  >50                     Push GROM Address to stack pointer
TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
VWA    EQU  >8C02                   VDP Write Address location
VRD    EQU  >8800                   VDP Read Data byte location
G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
GSTAT  EQU  >837C                   GPL Status byte location
                                    
DSRLNK EQU  $LO+$-LLVSPT
       DATA DSRWS,DLINK1            Set BLWP Vectors

DSRWS  EQU  $LO+$-LLVSPT            Start of DSRLNK workspace
DR3LB  EQU  DSRWS+7                 lower byte of DSRLNK workspace R3
DLINK1 EQU  $LO+$-LLVSPT
       MOV  R12,R12         R0      Have we already looked up the LINK address?
       JNE  DLINK3          R1      YES!  Skip lookup routine
*<<-------------------------------------------------------------------------->>*
* This section of code is only executed once to find the GROM address          *
* for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
* to indicate that the address is found and to be used as a mask for EQ & CND  *
*------------------------------------------------------------------------------*
       LWPI GPLWS           R2,R3   else load GPL workspace
       MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
       BL   *R4             R6
       LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
       MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector

***les*** Note on above instruction:
***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)

       JMP  DLINK2          R11     Jump around R12-R15
       DATA 0               R12     contains >2000 flag when set
       DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
       MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
       MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
       INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
       BL   *R5                     Restore the GROM address off the stack
       LWPI DSRWS                   Reload DSRLNK workspace
       LI   R12,>2000               Set flag to signify DSRLNK address is set
*<<-------------------------------------------------------------------------->>*
DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
       MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
       MOV  @NAMLEN,R3              Save VDP address of Name Length
       AI   R3,-8                   Adjust it to point to PAB Flag byte
       BLWP @GPLLNK                 Execute DSR LINK
DSRADR EQU  $LO+$-LLVSPT
       BYTE >03                     High byte of GPL DSRLNK address
DSRAD1 EQU  $LO+$-LLVSPT
       BYTE >00                     Lower byte of GPL DSRLNK address
*----Error Check & Report to Caller's R0 and EQU bit-------------------------
       MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
       MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
       SZCB R12,R15                 Clear EQ bit for Error Report
       MOVB @VRD,R3                 Get PAB Error Flag
       SRL  R3,5                    Adjust it to 0-7 error code
       MOVB R3,*R13                 Put it into Caller's R0 (msb)
       JNE  SETEQ                   If it's not zero, set EQ bit
       COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
       JNE  DSREND                  No Error, Just return
SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
DSREND RTWP                         All Done - Return to Caller
;]
;[*== KSENTR -- Keyboard Scan (entry point) =============================
*
KSENTR EQU  $LO+$-LLVSPT
       LWPI GPLWS
       MOV  R11,@UTILWS+22      Save GPL return address
       BL   @SCNKEY             Console keyboard scan routine
       LWPI UTILWS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    _   _____  ___    __  ____  _ ___ __  _       
*   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
*   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
*   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
* 
;[*== VDP utilities (entry point) =======================================
*
** VDP single byte write
*
VSBWEN EQU  $LO+$-LLVSPT
       BL   @WVDPWA             Write out address
       MOVB @2(R13),@VDPWD      Write data
       RTWP                     Return to calling program
*                            
** VDP multiple byte write   
*                            
VMBWEN EQU  $LO+$-LLVSPT
       BL   @WVDPWA             Write out address
VWTMOR MOVB *R1+,@VDPWD         Write a byte
       DEC  R2                  Decrement byte count
       JNE  VWTMOR              More to write?
       RTWP                     Return to calling Program
*                            
** VDP single byte read      
*                            
VSBREN EQU  $LO+$-LLVSPT
       BL   @WVDPRA             Write out address
       MOVB @VDPRD,@2(R13)      Read data
       RTWP                     Return to calling program
*                            
** VDP multiple byte read    
*                            
VMBREN EQU  $LO+$-LLVSPT
       BL   @WVDPRA             Write out address
VRDMOR MOVB @VDPRD,*R1+         Read a byte
       DEC  R2                  Decrement byte count
       JNE  VRDMOR              More to read?
       RTWP                     Return to calling program
*                            
** VDP write to register     
*                            
VWTREN EQU  $LO+$-LLVSPT
       MOV  *R13,R1             Get register number and value
       MOVB @1(R13),@VDPWA      Write out value
       ORI  R1,>8000            Set for register write
       MOVB R1,@VDPWA           Write out register number
       RTWP                     Return to calling program
*
** Set up to write to VDP
*
WVDPWA EQU  $LO+$-LLVSPT
       LI   R1,>4000
       JMP  WVDPAD
*
** Set up to read VDP
*
WVDPRA EQU  $LO+$-LLVSPT
       CLR  R1
*
** Write VDP address
*
WVDPAD MOV  *R13,R2             Get VDP address
       MOVB @U_R2LB,@VDPWA      Write low byte of address
       SOC  R1,R2               Properly adjust VDP write bit
       MOVB R2,@VDPWA           Write high byte of address
       MOV  @2(R13),R1          Get CPU RAM address
       MOV  @4(R13),R2          Get byte count
       RT                       Return to calling routine

*
** VDP-to-VDP move.
*
VMOVEN EQU  $LO+$-LLVSPT
       MOV  *R13,R1             Get cnt to R1
       MOV  @2(R13),R2          Get vsrc to R2
       MOV  @4(R13),R3          Get vdst to R3
       ORI  R3,>4000            Prepare for VDP write

** copy cnt bytes from vsrc to vdst

VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
       MOVB R2,@VDPWA           Write MSB of VDP read address
       INC  R2                  Next VDP read address
       MOVB @VDPRD,R0           Read VDP byte
       MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
       MOVB R3,@VDPWA           Write MSB of VDP write address
       INC  R3                  Next VDP write address
       MOVB R0,@VDPWD           Write VDP byte
       DEC  R1                  Decrement count
       JNE  VMVMOR              Repeat if not done
       RTWP                     Return to calling program
;]*
;[*== fbForth Version Message ===========================================
FBFMSG EQU  $LO+$-LLVSPT
* This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
* Also, printing the extra blanks overwrites the font-not-found error message.
       BYTE 17
       TEXT 'fbForth 2.0:     '     
;]
*     __  ___        ___ ____      __   __      _      __            __  
*    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
*   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
*  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
* 
;[*== Modifiable words in Resident Dictionary ===========================
;[*** (ABORT) ***
       DATA x#VLST_N         <--Last word in ROM
PABR_N EQU  $LO+$-LLVSPT
       DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT

PABORT EQU  $LO+$-LLVSPT
       DATA DOCOL
       DATA ABORT,SEMIS
;]*
;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
       DATA PABR_N
FRTH_N EQU  $LO+$-LLVSPT
       DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT

FORTHV EQU  $LO+$-LLVSPT+2          ; vocabulary link field 
FORTHP EQU  $LO+$-LLVSPT+4          ; pseudo name field
FORTHL EQU  $LO+$-LLVSPT+6          ; chronological link field
FORTH  EQU  $LO+$-LLVSPT
       DATA DOVOC
       DATA DPBASE+2,>81A0,0        ; (may need to modify)
;]*
;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
       DATA FRTH_N
ASMR_N EQU  $LO+$-LLVSPT
       DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT

ASMV   EQU  $LO+$-LLVSPT+2          ; vocabulary link field
ASML   EQU  $LO+$-LLVSPT+6          ; chronological link field
ASSM   EQU  $LO+$-LLVSPT
       DATA DOVOC
       DATA SASM_N,>81A0,FORTHL     ; <--ASMV initially points to last word in
*                                   ;    ...ASSEMBLER vocabulary in the kernel
;]*
;]*
*    ___                     __   __       
*   / _ | ___ ___ ___ __ _  / /  / /__ ____
*  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
* /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/   
*     _   __              __        __                _      __            __  
*    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
*    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
*    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
*                                           /___/  
*
*== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
;[*** NEXT, ***      ( --- )
* 1st word in ASSEMBLER vocabulary
*
       DATA FORTHP          <--points to PNF of FORTH
NXT__N EQU  $LO+$-LLVSPT
       DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT

NEXTC  EQU  $LO+$-LLVSPT
       DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
       MOV  @$DP(U),R1        HERE to R1
       MOV  R0,*R1+           compile "B *NEXT"
       MOV  R1,@$DP(U)        update HERE
       MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
       B    *NEXT             back to inner interpreter

* : NEXT,   ( --- )
*    *NEXT B,  ;
;]*
;[*** ;ASM ***       ( --- ) 
* 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
* ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
*
       DATA NXT__N
SASM_N EQU  $LO+$-LLVSPT
       BYTE 4+TERMBT    <--note different name field format
       TEXT ';ASM'
       BYTE ' '+TERMBT

SASM   EQU  $LO+$-LLVSPT
       DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
       JMP  NXT_P          finish up in NEXT,

* : ;ASM   ( --- )
*    *NEXT B,  ;
;]*

;[*== Some Variables (KEYCNT etc.) ======================================

KEYCNT EQU  $LO+$-LLVSPT
       DATA -1              Used in cursor flash logic
INTACT EQU  $LO+$-LLVSPT
       DATA 0               Non-zero during user's interrupt service routine
*
*++ variables used by some graphics primitives
*
$DMODE EQU  $LO+$-LLVSPT
       DATA 0                   ; actual location of variable contents
$DCOL  EQU  $LO+$-LLVSPT
       DATA -1                  ; actual location of variable contents

*===========================================================
;]*
*   ______                         ___            _____        __   
*  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__ 
*   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
*  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/ 
*                    /_/                                            
* 
;[*== Trampoline Code ===================================================
* 
* MYBANK must be at same location in all banks with the code that appears
* in the following table.  The EQUates for BANK0--BANK3 may also be in the
* same places in each bank for convenience, but they only need to appear once.
* 
*       Bank Select MYBANK
*       ---- ------ ------
*       0    >6006  >C000
*       1    >6004  >8000
*       2    >6002  >4000
*       3    >6000  >0000
* 
* Bank0 code will look like this
*
* MYBANK DATA >C000
* BANK0  EQU  >C000
* BANK1  EQU  >8000
* BANK2  EQU  >4000
* BANK3  EQU  >0000
*
* Banks 1--3 will look the same, including labels, and the DATA
* instruction at MYBANK's location will correspond to its bank.
*
* Before a bank is selected, the values above will be shifted right 13
* bits and have >6000 added.
*
;[*** BLBANK ************************************************************
*
* General bank branching routine (32KB ROM, i.e., 4 banks) for a
* branch that is expected to return (not high-level Forth) via RTBANK---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLBANK
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLBANK EQU  $LO+$-LLVSPT
       DECT R               ; reserve space on return stack (R14)
       MOV  *LINK+,CRU      ; copy destination bank address to R12
       MOV  LINK,*R         ; push return address
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
       MOV  CRU,LINK        ; copy destination bank address to R11
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*
;[*** RTBANK ************************************************************
*
* General bank return routine (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTBANK
*
RTBANK EQU  $LO+$-LLVSPT
       MOV  *R+,CRU         ; pop return bank# from return stack to R12
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       MOV  *R+,LINK        ; pop return address from return stack
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to return address
;]*
;[*** BLF2A *************************************************************
*
* High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to bank0 via RTNEXT.  This will
* only(?) be used for the ALC payload of Forth stubs in bank0---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLF2A
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLF2A  EQU  $LO+$-LLVSPT
       MOV  *LINK,LINK      ; copy destination bank address to R11
       MOV  LINK,CRU        ; copy it to R12
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*                           
;[*** RTNEXT ************************************************************
*
* High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4 
* banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTNEXT
*
RTNEXT EQU  $LO+$-LLVSPT
       MOV  @INTACT,CRU       Are we in user's ISR?
       JNE  RTNXT1            Don't enable interrupts if so.
       LIMI 2
RTNXT1 CLR  @>6006          ; switch to bank 0
       B    *NEXT           ; branch to next CFA (in R15)
;]*
;[*** BLA2F *************************************************************
*
* ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to calling bank via RTA2F---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLA2F
*       DATA <Forth cfa in bank0>
*
BLA2F  EQU  $LO+$-LLVSPT
       DECT R               ; reserve space on return stack 
       MOV  *LINK+,W        ; move CFA of Forth routine to W
       MOV  LINK,*R         ; push return address of calling bank
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
       DECT R               ; reserve spot on return stack
       MOV  IP,*R           ; move current IP to return stack
       LI   IP,RTA2F        ; move address of return procedure to IP
       CLR  @>6006          ; switch to bank0
       B    @DOEXEC         ; Execute the Forth routine
;]*
;[*** RTA2F *************************************************************
*
* ALC to high-level Forth bank "return" routine from Forth to calling
* ALC (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called through B *NEXT at end of Forth word's execution in BLA2F
*
RTA2F  EQU  $LO+$-LLVSPT
       DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
       DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
       MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
* Retrieve ALC return info and return to caller...
* ...caller will execute B *NEXT when it finishes
       B    @RTBANK         ; branch to general bank return routine above
;]*
;]***********************************************************************
;[*++ Bank-specific cell-/byte-reading code ++*
;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
*++ Read cell contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKAT  EQU  $LO+$-LLVSPT
       CLR  *R0             ; switch banks
       MOV  *R1,*SP         ; get cell contents of address to stack
       B    @RTNEXT         ; return to inner interpreter
;]*
;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
*++ Read byte contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKCAT EQU  $LO+$-LLVSPT
       CLR  *R0             ; switch banks
       CLR  R2              ; clear R2
       MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
       MOV  R2,*SP          ; get byte contents of address to stack
       B    @RTNEXT         ; return to inner interpreter

;]*

;]*
*         _______   __  _________      ___          __    
*        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
*       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
*      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, / 
*                                                  /___/  
* 
;[*** SAMS! ***      ( --- )
* This calls the SAMS initialization in the startup code in bank 1.
* 
*        DATA SMSQ_N
* SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
* SAMSST DATA $+2
*        BL   @BLF2A
*        DATA _SMSST->6000+BANK1

_SMSST BL   @SMSINI           initialize SAMS card
       B    @RTNEXT           back to inner interpreter
;]*   
;[*== Required strings, tables, variables... ============================
*
*
* Default blocks filename
*
DEFNAM EQU  $LO+$-LLVSPT
       BYTE 12
       TEXT "DSK1.FBLOCKS "
*
* Default colors for all VDP modes---
*     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
*     LSB: Color Table colors (FG/BG)
*
DEFCOL EQU  $LO+$-LLVSPT
       DATA >4F00          ; TEXT80    offset=0
       DATA >4F00          ; TEXT      offset=2
       DATA >F4F4          ; GRAPHICS  offset=4
       DATA >11F4          ; MULTI     offset=6
       DATA >FE10          ; GRAPHICS2 offset=8
       DATA >FEF4          ; SPLIT     offset=10
       DATA >FEF4          ; SPLIT2    offset=12
*
* Default text mode
*
DEFTXT EQU  $LO+$-LLVSPT
       DATA >0001
*
* Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
*
FNTFLG EQU  $LO+$-LLVSPT
       DATA 0              ; font flag initially 0
*
* Speech variables needing initial value (more below LLVEND)
*
SPCSVC EQU  $LO+$-LLVSPT
       DATA 0
*
* Sound Table #1 Workspace for sound variables.  Only using R0..R4
*
SND1WS EQU  $LO+$-LLVSPT
SND1ST EQU  SND1WS         R0 (sound table status) 0=no table; 1=loading sound...
       DATA 0              ...bytes; -1=counting
SND1DS EQU  SND1WS+2       R1 (sound-table byte destination)...
       DATA SOUND          ...initialized to sound chip
SND1AD EQU  SND1WS+4       R2 (sound table address)
       DATA 0
SND1CT EQU  SND1WS+6       R3 (# of sound bytes to load or...
       DATA 0              ...sound count = seconds * 60)
SND1SP EQU  SND1WS+8       R4 (pointer to top of sound stack)
       DATA SNDST0         initialized to bottom of sound stack              
* 
* Sound Table #2 Workspace for sound variables.  Only using R0..R3
*
SND2WS EQU  $LO+$-LLVSPT
SND2ST EQU  SND2WS         R0 (sound table status) 0=no table  ; 1=loading sound...
       DATA 0              ...bytes; -1=counting
SND2DS EQU  SND2WS+2       R1 (sound-table byte destination)...
       DATA SOUND          ...initialized to sound chip
;]*
* 
* This is the end of low-level support code that gets copied.
*
LLVEND

;[*== Un-initialized Variables and workspaces... =========================
* Start of definitions of variables and workspaces that do not need to
* take up space in ROM because they need no initial values.
*
* Sound Table #2 Workspace for sound variables..continued.
*
SND2AD EQU  SND2WS+4       R2 (sound table address)
SND2CT EQU  SND2WS+6       R3 (# of sound bytes to load or...
*                          ...sound count = seconds * 60)
SDMUTE EQU  SND2WS+8       dummy destination for sound byte
* 
* Branch Stack for ISR processing of Speech, 2 Sound Tables and return
*
BRSTK  EQU  SDMUTE+2
*
* Speech variables (more above LLVEND)
* 
SSFLAG EQU  BRSTK+8
SPCNT  EQU  SSFLAG+2
SPADR  EQU  SPCNT+2
BANKSV EQU  SPADR+2
PADSV  EQU  BANKSV+2
*
* Panel window: height, width and screen position...used by PANEL and SCROLL
*
PANWIN EQU  PADSV+12          panel height, width and screen start
 
*== Utility Workspace =================================================
*** General utility workspace registers
UTILWS EQU  PANWIN+6
U_R2LB EQU  UTILWS+5

LINBUF EQU  UTILWS+32
CURCHR EQU  LINBUF+80

*++ variable used by the 40/80-column editor
OLDCUR EQU  CURCHR+2

*++ FILE I/O variables
 
PBADR  EQU  OLDCUR+8
PBBF   EQU  PBADR+2
PBVBF  EQU  PBBF+2
 
*++ Floating Point Math Library variables
FPVARS EQU  PBVBF+2
 
*++ SAMS flag
SAMSFL EQU  FPVARS+22

*++ Bottom of Sound Stack 
*++      This location marks the top of the low-level support code. The Sound
*++      Stack grows upward toward the Return Stack by moving the entire stack
*++      up one cell to make room for the next new bottom entry.
SNDST0 EQU  SAMSFL+2
;]*

and its listing:

Spoiler


0105                      COPY "Bank1\fbForth101_LowLevelSupport.a99"
     **** ****     > fbForth101_LowLevelSupport.a99
0001               *     __                  __                __
0002               *    / /  ___ _    ______/ /  ___ _  _____ / /
0003               *   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) /
0004               *  /____/\___/__,__/   /____/\__/|___/\__/_/
0005               *                     ____                        __
0006               *                    / __/_ _____  ___  ___  ____/ /_
0007               *                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
0008               *                  /___/\_,_/ .__/ .__/\___/_/  \__/
0009               *                          /_/  /_/
0010               *
0011               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0012               *                                                                   *
0013               * fbForth---                                                        *
0014               *                                                                   *
0015               *       Low-level support routines                                  *
0016               *                                                                   *
0017               *  << Including Trampoline Code, tables & variables:  2606 bytes >> *
0018               *                                                                   *
0019               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0020               
0021               LLVSPT   ; <--This is the source copy location for the rest of this code.
0022               
0023      2010     $BUFF  EQU  >2010
0024               
0025               * 4 I/O buffers below ($LO = >3020)
0026               * Change '4' to number of buffers needed and for which there is room.
0027               
0028      3020     $LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers
0029               *       _____   ____         __  __      ___________
0030               *      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
0031               *     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
0032               *    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_|
0033               *
0034               ;[*** Interrupt Service =======================================================
0035               * This routine is executed for every interrupt.  It processes any pending
0036               * speech and souind.  It then looks to see whether a user ISR is installed in
0037               * ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work
0038               * only if the user has installed an ISR using the following steps in the fol-
0039               * lowing order:
0040               *
0041               *   (1) Write an ISR with entry point, say MYISR.
0042               *   (2) Determine code field address of MYISR with this high-level Forth:
0043               *           ' MYISR CFA
0044               * <<< Maybe need a word to do #3 >>>
0045               *   (3) Write CFA of MYISR into user variable ISR.
0046               *
0047               * Steps (2)-(3) in high-level Forth are shown below:
0048               *           ' MYISR CFA
0049               *           ISR !
0050               *
0051               * <<< Perhaps last step above should be by a word that disables interrupts >>>
0052               *
0053               * The console ISR branches to the contents of >83C4 because it is non-zero,
0054               * with the address, INT1, of the fbForth ISR entry point below (also, the
0055               * contents of INTLNK).  This means that the console ISR will branch to INT1
0056               * with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
0057               * process any pending speech and sound.
0058               *
0059               * If the user's ISR is properly installed, the code that processes the user
0060               * ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
0061               * from Forth's workspace (MAINWS), the code at INT2 will process the user's
0062               * ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
0063               * inner interpreter.
0064               *** ==========================================================================
0065               
0066               * ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!
0067               
0068      3020     INT1   EQU  $LO+$-LLVSPT
0069 6140 0200  20        LI   R0,BRSTK          load address of top of Branch Address Stack
     6142 3A2A     
0070               *
0071               * Set up for pending speech
0072               *
0073 6144 C420  46        MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
     6146 3A14     
0074 6148 1301  14        JEQ  SNDCH1            jump to sound-check if no speech
0075 614A 05C0  14        INCT R0                increment Branch Stack
0076               *
0077               * Set up for pending sound table #1 (ST#1)
0078               *
0079 614C C0A0  34 SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
     614E 3A16     
0080 6150 1303  14        JEQ  SNDCH2            process speech and sound if needed
0081 6152 0201  20        LI   R1,x#PLAYT1         load PLAYT1 address and...
     6154 7C68     
0082 6156 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0083               *
0084               * Set up for pending sound table #2 (ST#2)
0085               *
0086 6158 C0E0  34 SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
     615A 3A20     
0087 615C 1303  14        JEQ  PRCSPS            process speech and sound if needed
0088 615E 0201  20        LI   R1,x#PLAYT2         load PLAYT2 address and...
     6160 7C6E     
0089 6162 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0090               *
0091               * Process sound stack if both sound tables idle
0092               *
0093 6164 E0C2  18 PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
0094 6166 160A  14        JNE  PRSPS2            nope..skip sound stack processing
0095 6168 02E0  18        LWPI SND1WS            switch to ST#1 WS
     616A 3A16     
0096 616C 0284  22        CI   R4,SNDST0         anything on sound stack?
     616E 3AE4     
0097 6170 1303  14        JEQ  PRSPS1            no..exit sound stack processing
0098 6172 0644  14        DECT R4                pop sound stack position
0099 6174 C094  26        MOV  *R4,R2            get sound table address from sound stack
0100 6176 0580  14        INC  R0                kick off sound processing of ST#1 (R0=1)
0101 6178 02E0  18 PRSPS1 LWPI GPLWS             switch back to GPL WS
     617A 83E0     
0102               *
0103               * Check for any pending speech and sound
0104               *
0105 617C 0280  22 PRSPS2 CI   R0,BRSTK          any speech or sound to process?
     617E 3A2A     
0106 6180 1312  14        JEQ  USRISR            if not, jump to user ISR processing
0107 6182 0201  20        LI   R1,BNKRST         yup..load return address
     6184 307A     
0108 6186 C401  30        MOV  R1,*R0            push return address onto Branch Stack
0109               *
0110               * Process pending speech and sound
0111               *
0112 6188 C820  54        MOV  @x#MYBANK,@BANKSV   save bank at interrupt
     618A 7FFE     
     618C 3A38     
0113 618E 04E0  34        CLR  @>6002            switch to bank 2 for speech & sound services
     6190 6002     
0114 6192 0207  20        LI   R7,BRSTK          load top of Branch Stack
     6194 3A2A     
0115 6196 C237  30        MOV  *R7+,R8           pop speech/sound ISR
0116 6198 0458  20        B    *R8               service speech/sound
0117               *
0118               * Restore interrupted bank
0119               *
0120      307A     BNKRST EQU  $LO+$-LLVSPT      return point for speech and sound ISRs
0121 619A C020  34        MOV  @BANKSV,R0        restore bank at interrupt
     619C 3A38     
0122 619E 09D0  56        SRL  R0,13             get the bank# to correct position
0123 61A0 0220  22        AI   R0,>6000          make it a real bank-switch address
     61A2 6000     
0124 61A4 04D0  26        CLR  *R0               switch to the bank at interrupt
0125               *
0126               * Process User ISR if defined
0127               *
0128 61A6 C020  34 USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
     61A8 36EA     
0129 61AA 1304  14        JEQ  INTEX
0130               *
0131               * Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
0132               * is executed from Forth's WS (MAINWS = >8300), which it does at the end of
0133               * every CODE word, keyboard scan and one or two other places.
0134               *
0135 61AC 0201  20        LI   R1,INT2                 Load entry point, INT2
     61AE 309A     
0136 61B0 C801  38        MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
     61B2 831E     
0137               *
0138               * The following 2 instructions are copies of the remainder of the console ROM's
0139               * ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
0140               * because we're not going back there!
0141               *
0142 61B4 02E0  18 INTEX  LWPI >83C0             Change to console's ISR WS
     61B6 83C0     
0143 61B8 0380  18        RTWP                   Return to caller of console ISR
0144               *
0145               * Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
0146               * before executing user's ISR. INT3 (cleanup routine below) will be inserted
0147               * in address list to get us back here for cleanup after user's ISR has finished.
0148               * User's ISR is executed at the end of this section just before INT3.
0149               *
0150      309A     INT2   EQU  $LO+$-LLVSPT
0151 61BA 0300  24        LIMI 0                 Disable interrupts
     61BC 0000     
0152 61BE D020  34        MOVB @>83D4,R0         Get copy of VR01
     61C0 83D4     
0153 61C2 0980  56        SRL  R0,8              ...to LSB
0154 61C4 0260  22        ORI  R0,>100           Set up for VR01
     61C6 0100     
0155 61C8 0240  22        ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
     61CA FFDF     
0156 61CC 0420  54        BLWP @VWTR             Turn off VDP interrupt
     61CE 3752     
0157 61D0 020F  20        LI   NEXT,$NEXT        Restore NEXT
     61D2 833A     
0158 61D4 0720  34        SETO @INTACT           Set Forth "pending interrupt" flag
     61D6 3956     
0159 61D8 064E  14        DECT R                 Set up return linkage by pushing
0160 61DA C78D  30        MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
0161 61DC 020D  20        LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
     61DE 30C8     
0162 61E0 C2A8  34        MOV  @$ISR(U),W        Do the user's Forth ISR by executing
     61E2 0036     
0163 61E4 0460  28        B    @DOEXEC           ...it through Forth's inner interpreter
     61E6 833C     
0164               *
0165               * Clean up and re-enable interrupts.
0166               *
0167      30C8     INT3   EQU  $LO+$-LLVSPT
0168 61E8 30CA            DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
0169 61EA 30CC            DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
0170 61EC C37E  30        MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
0171 61EE 04E0  34        CLR  @INTACT           Clear Forth "pending interrupt" flag
     61F0 3956     
0172 61F2 D020  34        MOVB @>83D4,R0         Prepare to restore VR01 by...
     61F4 83D4     
0173 61F6 0980  56        SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
0174 61F8 0220  22        AI   R0,>100           ...VR # (01) to MSB
     61FA 0100     
0175 61FC D060  34        MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
     61FE 8802     
0176 6200 0420  54        BLWP @VWTR             Write VR01
     6202 3752     
0177 6204 0300  24        LIMI 2                 Re-enable interrupts
     6206 0002     
0178 6208 045F  20        B    *NEXT             Continue normal task
0179               ;]*
0180               ;[*** BKLINK from SYSTEM calls ==========================================
0181               *
0182      30EA     BKLINK EQU  $LO+$-LLVSPT
0183 620A C1E0  34        MOV  @INTACT,R7        Are we in user's ISR?
     620C 3956     
0184 620E 1602  14        JNE  BKLIN1            Don't enable interrupts if so.
0185 6210 0300  24        LIMI 2
     6212 0002     
0186 6214 045B  20 BKLIN1 B    *LINK
0187               ;]*
0188               *      ____         __              _____     ____
0189               *     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
0190               *    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
0191               *   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
0192               *       /___/
0193               *
0194               ;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================
0195               
0196               *       Entry point for low-level system support functions
0197               
0198      30F6     $SYS$  EQU  $LO+$-LLVSPT
0199 6216 0300  24        LIMI 0
     6218 0000     
0200 621A C021  34        MOV  @SYSTAB(R1),R0
     621C 3114     
0201 621E 0450  20        B    *R0
0202               ;]
0203               ;[*** SYSTAB -- Vector table for SYSTEM calls ===========================
0204               
0205 6220 34C6            DATA BRW          CODE = -20  write block to blocks file
0206 6222 34C6            DATA BRW          CODE = -18  read block from blocks file
0207 6224 34C6            DATA BRW          CODE = -16  create blocks file
0208 6226 34C6            DATA BRW          CODE = -14  use blocks file
0209 6228 346C            DATA GXY          CODE = -12  GOTOXY
0210 622A 3456            DATA QKY          CODE = -10  ?KEY
0211 622C 343C            DATA QTM          CODE =  -8  ?TERMINAL
0212 622E 3420            DATA CLF          CODE =  -6  CRLF
0213 6230 3312            DATA EMT          CODE =  -4  EMIT
0214 6232 3260            DATA KY           CODE =  -2  KEY
0215      3114     SYSTAB EQU  $LO+$-LLVSPT
0216 6234 3130            DATA SBW          CODE =   0  VSBW
0217 6236 313E            DATA MBW          CODE =   2  VMBW
0218 6238 314C            DATA SBR          CODE =   4  VSBR
0219 623A 315A            DATA MBR          CODE =   6  VMBR
0220 623C 3176            DATA WTR          CODE =   8  VWTR
0221 623E 3186            DATA GPL          CODE =  10  GPLLNK
0222 6240 31A6            DATA XML          CODE =  12  XMLLNK
0223 6242 31C0            DATA DSR          CODE =  14  DSRLNK
0224 6244 31DA            DATA CLS$         CODE =  16  CLS
0225 6246 3168            DATA MVE          CODE =  18  VMOVE
0226 6248 31F4            DATA FILL$        CODE =  20  VFILL
0227 624A 3224            DATA AOX          CODE =  22  VAND
0228 624C 3224            DATA AOX          CODE =  24  VOR
0229 624E 3224            DATA AOX          CODE =  26  VXOR
0230               ;]*
0231               ;[*== VDP single byte write.                CODE =   0  =================
0232               *
0233      3130     SBW    EQU  $LO+$-LLVSPT
0234 6250 C039  30        MOV  *SP+,R0         VRAM address (destination)
0235 6252 C079  30        MOV  *SP+,R1         Character to write
0236 6254 06C1  14        SWPB R1              Get in left byte
0237 6256 0420  54        BLWP @VSBW
     6258 373E     
0238 625A 0460  28        B    @BKLINK
     625C 30EA     
0239               ;]*
0240               ;[*== VDP multi byte write.                 CODE =   2  =================
0241               *
0242      313E     MBW    EQU  $LO+$-LLVSPT
0243 625E C0B9  30        MOV  *SP+,R2         Number of bytes to move
0244 6260 C039  30        MOV  *SP+,R0         VRAM address (destination)
0245 6262 C079  30        MOV  *SP+,R1         RAM address (source)
0246 6264 0420  54        BLWP @VMBW
     6266 3742     
0247 6268 0460  28        B    @BKLINK
     626A 30EA     
0248               ;]*
0249               ;[*== VDP single byte read.                 CODE =   4  =================
0250               *
0251      314C     SBR    EQU  $LO+$-LLVSPT
0252 626C C019  26        MOV  *SP,R0          VRAM address (source)
0253 626E 0420  54        BLWP @VSBR
     6270 3746     
0254 6272 0981  56        SRL  R1,8            Character to right half for Forth
0255 6274 C641  30        MOV  R1,*SP          Stack it
0256 6276 0460  28        B    @BKLINK
     6278 30EA     
0257               ;]*
0258               ;[*== VDP multi byte read.                  CODE =   6  =================
0259               *
0260      315A     MBR    EQU  $LO+$-LLVSPT
0261 627A C0B9  30        MOV  *SP+,R2         Number of bytes to read
0262 627C C079  30        MOV  *SP+,R1         RAM address (destination)
0263 627E C039  30        MOV  *SP+,R0         VRAM address (source)
0264 6280 0420  54        BLWP @VMBR
     6282 374A     
0265 6284 0460  28        B    @BKLINK
     6286 30EA     
0266               ;]*
0267               ;[*== VDP-to-VDP move.                      CODE =  18  =================
0268               *
0269      3168     MVE    EQU  $LO+$-LLVSPT
0270 6288 C039  30        MOV  *SP+,R0         Pop cnt to R0
0271 628A C0B9  30        MOV  *SP+,R2         Pop vdst to R2
0272 628C C079  30        MOV  *SP+,R1         Pop vsrc to R1
0273 628E 0420  54        BLWP @VMOVE
     6290 374E     
0274 6292 0460  28        B    @BKLINK
     6294 30EA     
0275               ;]*
0276               ;[*== VDP register write.                   CODE =   8  =================
0277               *
0278      3176     WTR    EQU  $LO+$-LLVSPT
0279 6296 C079  30        MOV  *SP+,R1         VDP register number
0280 6298 C039  30        MOV  *SP+,R0         Data for register
0281 629A 06C1  14        SWPB R1              Get register to left byte
0282 629C D001  18        MOVB R1,R0           Place with data
0283 629E 0420  54        BLWP @VWTR
     62A0 3752     
0284 62A2 0460  28        B    @BKLINK
     62A4 30EA     
0285               ;]*
0286               ;[*== GPL link utility.                     CODE =  10  =================
0287               *
0288      3186     GPL    EQU  $LO+$-LLVSPT
0289 62A6 04C0  14        CLR  R0
0290 62A8 D800  38        MOVB R0,@KYSTAT
     62AA 837C     
0291 62AC 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62AE 0420     
0292 62B0 0201  20        LI   R1,GPLLNK         to the GPLLNK utility
     62B2 3784     
0293 62B4 C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0294 62B6 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62B8 045B     
0295 62BA C10B  18        MOV  LINK,R4         Save LINK address
0296 62BC 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62BE 8300     
0297 62C0 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0298 62C2 0460  28        B    @BKLINK
     62C4 30EA     
0299               ;]*
0300               ;[*== XML link utility.                     CODE =  12  =================
0301               *
0302      31A6     XML    EQU  $LO+$-LLVSPT
0303 62C6 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62C8 0420     
0304 62CA 0201  20        LI   R1,XMLLNK         to the XMLLNK utility
     62CC 3736     
0305 62CE C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0306 62D0 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62D2 045B     
0307 62D4 C10B  18        MOV  LINK,R4         Save LINK address
0308 62D6 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62D8 8300     
0309 62DA C2C4  18        MOV  R4,LINK           and reconstruct LINK
0310 62DC 0460  28        B    @BKLINK
     62DE 30EA     
0311               ;]*
0312               ;[*== DSR link utility.                     CODE =  14  =================
0313               *
0314      31C0     DSR    EQU  $LO+$-LLVSPT
0315 62E0 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62E2 0420     
0316 62E4 0201  20        LI   R1,DSRLNK         to the DSRLNK utility
     62E6 37BE     
0317 62E8 C0B9  30        MOV  *SP+,R2         This datum selects DSR or subroutine
0318 62EA 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62EC 045B     
0319 62EE C10B  18        MOV  LINK,R4         Save LINK address
0320 62F0 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62F2 8300     
0321 62F4 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0322 62F6 0460  28        B    @BKLINK
     62F8 30EA     
0323               ;]*
0324               ;[*== Screen clearing utility.              CODE =  16  =================
0325               *
0326      31DA     CLS$   EQU  $LO+$-LLVSPT
0327 62FA C0A8  34        MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
     62FC 0032     
0328 62FE C068  34        MOV  @$SEND(U),R1    End of screen in VRAM
     6300 0034     
0329 6302 6042  18        S    R2,R1           Screen size
0330 6304 0200  20        LI   R0,>2000        Blank character
     6306 2000     
0331 6308 C1CB  18        MOV  LINK,R7
0332 630A 06A0  32        BL   @FILL1
     630C 3208     
0333 630E C2C7  18        MOV  R7,LINK
0334 6310 0460  28        B    @BKLINK
     6312 30EA     
0335               ;]*
0336               ;[*== VDP fill routine.                     CODE =  20  =================
0337               *
0338      31F4     FILL$  EQU  $LO+$-LLVSPT
0339 6314 C039  30        MOV  *SP+,R0         Fill character
0340 6316 06C0  14        SWPB R0                to left byte
0341 6318 C079  30        MOV  *SP+,R1         Fill count
0342 631A C0B9  30        MOV  *SP+,R2         Address to start VRAM fill
0343 631C C1CB  18        MOV  LINK,R7
0344 631E 06A0  32        BL   @FILL1
     6320 3208     
0345 6322 C2C7  18        MOV  R7,LINK
0346 6324 0460  28        B    @BKLINK
     6326 30EA     
0347               *========================================================================
0348      3208     FILL1  EQU  $LO+$-LLVSPT    R0=char, R1=cnt, R2=vaddr
0349 6328 0262  22        ORI  R2,>4000        Set bit for VDP write
     632A 4000     
0350 632C 06C2  14        SWPB R2
0351 632E D802  38        MOVB R2,@VDPWA       LS byte first
     6330 8C02     
0352 6332 06C2  14        SWPB R2
0353 6334 D802  38        MOVB R2,@VDPWA       Then MS byte
     6336 8C02     
0354 6338 1000  14        NOP                  Kill time
0355 633A D800  38 FLOOP  MOVB R0,@VDPWD       Write a byte
     633C 8C00     
0356 633E 0601  14        DEC  R1
0357 6340 16FC  14        JNE  FLOOP           Not done, fill another
0358 6342 045B  20        B    *LINK
0359               ;]*======================================================================
0360               *
0361               *==== VAND -- VDP byte AND routine.         CODE =  22  =================
0362               *==== VOR -- VDP byte OR routine.           CODE =  24  =================
0363               ;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
0364               *
0365      3224     AOX    EQU  $LO+$-LLVSPT
0366 6344 C0B9  30        MOV  *SP+,R2         VRAM address
0367 6346 06C2  14        SWPB R2
0368 6348 D802  38        MOVB R2,@VDPWA       LS byte first
     634A 8C02     
0369 634C 06C2  14        SWPB R2
0370 634E D802  38        MOVB R2,@VDPWA       Then MS byte
     6350 8C02     
0371 6352 1000  14        NOP                  Kill time
0372 6354 D0E0  34        MOVB @VDPRD,R3       Read byte
     6356 8800     
0373 6358 C039  30        MOV  *SP+,R0         Get data to operate with
0374 635A 06C0  14        SWPB R0                to left byte
0375               *** Now do requested operation *****************
0376 635C 0281  22        CI   R1,24
     635E 0018     
0377 6360 1304  14        JEQ  DOOR
0378 6362 1505  14        JGT  DOXOR
0379 6364 0543  14        INV  R3              These two instructions
0380 6366 4003  18        SZC  R3,R0             perform an 'AND'
0381 6368 1003  14        JMP  FINAOX
0382 636A E003  18 DOOR   SOC  R3,R0             perform 'OR'
0383 636C 1001  14        JMP  FINAOX
0384 636E 2803  18 DOXOR  XOR  R3,R0             perform 'XOR'
0385 6370 0201  20 FINAOX LI   R1,1
     6372 0001     
0386 6374 C1CB  18        MOV  LINK,R7
0387 6376 06A0  32        BL   @FILL1
     6378 3208     
0388 637A C2C7  18        MOV  R7,LINK
0389 637C 0460  28        B    @BKLINK
     637E 30EA     
0390               ;]*
0391               ;[*== KEY routine                           CODE =  -2  =================
0392               *
0393      3260     KY    EQU  $LO+$-LLVSPT
0394 6380 C028  34        MOV  @$ALTI(U),R0      alternate input device?
     6382 0038     
0395 6384 131B  14        JEQ  KEY0              jump to keyboard input if not
0396               *
0397               *  R0 now points to PAB for alternate input device, the one-byte buffer
0398               *  for which must immediately precede its PAB.  PAB must have been set up
0399               *  to read one byte.
0400               *
0401 6386 04C7  14        CLR  R7                prepare to zero status byte
0402 6388 D807  38        MOVB R7,@KYSTAT        zero status byte
     638A 837C     
0403 638C 0580  14        INC  R0                point R0 to Flag/Status byte
0404 638E 0420  54        BLWP @VSBR             read it
     6390 3746     
0405 6392 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6394 1F00     
0406 6396 0420  54        BLWP @VSBW             write it back to PAB
     6398 373E     
0407 639A C040  18        MOV  R0,R1             Set up pointer...
0408 639C 0221  22        AI   R1,8              ...to namelength byte of PAB
     639E 0008     
0409 63A0 C801  38        MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
     63A2 8356     
0410 63A4 C0C0  18        MOV  R0,R3             save pointer (DSRLNK will trash it!)
0411 63A6 0420  54        BLWP @DSRLNK           get 1 byte from device
     63A8 37BE     
0412 63AA 0008            DATA >8
0413 63AC C003  18        MOV  R3,R0             restore pointer
0414 63AE 0640  14        DECT R0                point to one-byte VRAM buffer in front of PAB
0415 63B0 0420  54        BLWP @VSBR             read character
     63B2 3746     
0416 63B4 0981  56        SRL  R1,8              move to LSB
0417 63B6 C001  18        MOV  R1,R0             copy to return register
0418 63B8 0460  28        B    @BKLINK           return to caller
     63BA 30EA     
0419               *
0420               *  Input is comining from the keyboard
0421               *
0422 63BC C1E0  34 KEY0   MOV  @KEYCNT,R7
     63BE 3954     
0423 63C0 0587  14        INC  R7
0424 63C2 160A  14        JNE  KEY1
0425 63C4 C028  34        MOV  @CURPO$(U),R0
     63C6 0016     
0426 63C8 0420  54        BLWP @VSBR             Read character at cursor position...
     63CA 3746     
0427 63CC D801  38        MOVB R1,@CURCHR        ...and save it
     63CE 3ABC     
0428 63D0 0201  20        LI   R1,>1E00          Place cursor character on screen
     63D2 1E00     
0429 63D4 0420  54        BLWP @VSBW
     63D6 373E     
0430               *
0431 63D8 0420  54 KEY1   BLWP @KSCAN
     63DA 373A     
0432 63DC D020  34        MOVB @KYSTAT,R0
     63DE 837C     
0433 63E0 2020  38        COC  @H2000,R0         check status
     63E2 3734     
0434 63E4 1319  14        JEQ  KEY2              JMP if key was pressed
0435               *
0436 63E6 0287  22        CI   R7,100            No key pressed
     63E8 0064     
0437 63EA 1603  14        JNE  KEY3
0438 63EC D060  34        MOVB @CURCHR,R1
     63EE 3ABC     
0439 63F0 1006  14        JMP  KEY5
0440               *
0441 63F2 0287  22 KEY3   CI   R7,200
     63F4 00C8     
0442 63F6 1607  14        JNE  KEY4
0443 63F8 04C7  14        CLR  R7
0444 63FA 0201  20        LI   R1,>1E00          Cursor char
     63FC 1E00     
0445 63FE C028  34 KEY5   MOV  @CURPO$(U),R0
     6400 0016     
0446 6402 0420  54        BLWP @VSBW
     6404 373E     
0447 6406 C807  38 KEY4   MOV  R7,@KEYCNT
     6408 3954     
0448 640A C1E0  34        MOV  @INTACT,R7        Are we in user's ISR?
     640C 3956     
0449 640E 1602  14        JNE  KEY6              Don't enable interrupts if so.
0450 6410 0300  24        LIMI 2
     6412 0002     
0451 6414 064D  14 KEY6   DECT IP                This will re-execute KEY
0452 6416 045F  20        B    *NEXT
0453 6418 0720  34 KEY2   SETO @KEYCNT           Key was pressed
     641A 3954     
0454 641C C028  34        MOV  @CURPO$(U),R0     Restore character at cursor location
     641E 0016     
0455 6420 D060  34        MOVB @CURCHR,R1
     6422 3ABC     
0456 6424 0420  54        BLWP @VSBW
     6426 373E     
0457 6428 D020  34        MOVB @KYCHAR,R0        Put char in...
     642A 8375     
0458 642C 0980  56        SRL  R0,8              ...LSB of R0
0459 642E 0460  28        B    @BKLINK
     6430 30EA     
0460               ;]*
0461               ;[*== EMIT routine                          CODE =  -4  =================
0462               *
0463      3312     EMT    EQU  $LO+$-LLVSPT
0464 6432 C042  18        MOV  R2,R1             copy char to R1 for VSBW
0465 6434 C028  34        MOV  @$ALTO(U),R0      alternate output device?
     6436 003A     
0466 6438 1317  14        JEQ  EMIT0             jump to video display output if not
0467               *
0468               *  R0 now points to PAB for alternate output device, the one-byte buffer
0469               *  for which must immediately precede its PAB.  PAB must have been set up
0470               *  to write one byte.
0471               *
0472 643A 04C7  14        CLR  R7                ALTOUT active
0473 643C D807  38        MOVB R7,@KYSTAT        zero status byte
     643E 837C     
0474 6440 0600  14        DEC  R0                point to one-byte VRAM buffer in front of PAB
0475 6442 06C1  14        SWPB R1                char to MSB
0476 6444 0420  54        BLWP @VSBW             write char to buffer
     6446 373E     
0477 6448 05C0  14        INCT R0                point to Flag/Status byte
0478 644A 0420  54        BLWP @VSBR             read it
     644C 3746     
0479 644E 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6450 1F00     
0480 6452 0420  54        BLWP @VSBW             write it back to PAB
     6454 373E     
0481 6456 0220  22        AI   R0,8              Set up pointer to namelength byte of PAB
     6458 0008     
0482 645A C800  38        MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
     645C 8356     
0483 645E 0420  54        BLWP @DSRLNK           put 1 byte to device
     6460 37BE     
0484 6462 0008            DATA >8
0485 6464 0460  28        B    @BKLINK           return to caller
     6466 30EA     
0486               *
0487               *  Output is going to the video display
0488               *
0489 6468 0281  22 EMIT0  CI   R1,7            Is it a bell?
     646A 0007     
0490 646C 1607  14        JNE  NOTBEL
0491 646E 04C2  14        CLR  R2
0492 6470 D802  38        MOVB R2,@KYSTAT
     6472 837C     
0493 6474 0420  54        BLWP @GPLLNK
     6476 3784     
0494 6478 0036            DATA >0036           Emit error tone
0495 647A 1060  14        JMP  EMEXIT
0496               *
0497 647C 0281  22 NOTBEL CI   R1,8            Is it a backspace?
     647E 0008     
0498 6480 160B  14        JNE  NOTBS
0499 6482 0201  20        LI   R1,>2000
     6484 2000     
0500 6486 C028  34        MOV  @CURPO$(U),R0
     6488 0016     
0501 648A 0420  54        BLWP @VSBW
     648C 373E     
0502 648E 1501  14        JGT  DECCUR
0503 6490 1055  14        JMP  EMEXIT
0504 6492 0628  34 DECCUR DEC  @CURPO$(U)
     6494 0016     
0505 6496 1052  14        JMP  EMEXIT
0506               *
0507 6498 0281  22 NOTBS  CI   R1,>A           Is it a line feed?
     649A 000A     
0508 649C 162B  14        JNE  NOTLF
0509 649E C1E8  34        MOV  @$SEND(U),R7
     64A0 0034     
0510 64A2 61E8  34        S    @$SWDTH(U),R7
     64A4 0030     
0511 64A6 81E8  34        C    @CURPO$(U),R7
     64A8 0016     
0512 64AA 1404  14        JHE  SCRLL
0513 64AC AA28  54        A    @$SWDTH(U),@CURPO$(u)
     64AE 0030     
     64B0 0016     
0514 64B2 1044  14        JMP  EMEXIT
0515 64B4 C1CB  18 SCRLL  MOV  LINK,R7
0516 64B6 06A0  32        BL   @SCROLL
     64B8 339E     
0517 64BA C2C7  18        MOV  R7,LINK
0518 64BC 103F  14        JMP  EMEXIT
0519               *
0520               *** SCROLLING ROUTINE
0521               *
0522      339E     SCROLL EQU  $LO+$-LLVSPT
0523 64BE C028  34        MOV  @$SSTRT(U),R0   VRAM addr
     64C0 0032     
0524 64C2 0201  20        LI   R1,LINBUF       Line buffer
     64C4 3A6C     
0525 64C6 C0A8  34        MOV  @$SWDTH(U),R2   Count
     64C8 0030     
0526 64CA A002  18        A    R2,R0           Start at line 2
0527 64CC 0420  54 SCROL1 BLWP @VMBR
     64CE 374A     
0528 64D0 6002  18        S    R2,R0           One line back to write
0529 64D2 0420  54        BLWP @VMBW
     64D4 3742     
0530 64D6 A002  18        A    R2,R0           Two lines ahead for next read
0531 64D8 A002  18        A    R2,R0
0532 64DA 8A00  38        C    R0,@$SEND(U)    End of screen?
     64DC 0034     
0533 64DE 1AF6  14        JL   SCROL1
0534 64E0 C042  18        MOV  R2,R1           Blank bottom row of screen
0535 64E2 0200  20        LI   R0,>2000        Blank
     64E4 2000     
0536 64E6 60A8  34        S    @$SEND(U),R2
     64E8 0034     
0537 64EA 0502  16        NEG  R2              Now contains address of start of last line
0538 64EC C18B  18        MOV  LINK,R6
0539 64EE 06A0  32        BL   @FILL1          Write the blanks
     64F0 3208     
0540 64F2 0456  20        B    *R6
0541               *
0542 64F4 0281  22 NOTLF  CI   R1,>D           Is it a carriage return?
     64F6 000D     
0543 64F8 160D  14        JNE  NOTCR
0544 64FA 04C0  14        CLR  R0
0545 64FC C068  34        MOV  @CURPO$(U),R1
     64FE 0016     
0546 6500 C0C1  18        MOV  R1,R3
0547 6502 6068  34        S    @$SSTRT(U),R1   Adjusted for screen not at 0
     6504 0032     
0548 6506 C0A8  34        MOV  @$SWDTH(U),R2
     6508 0030     
0549 650A 3C02 128        DIV  R2,R0
0550 650C 60C1  18        S    R1,R3
0551 650E CA03  38        MOV  R3,@CURPO$(U)
     6510 0016     
0552 6512 1014  14        JMP  EMEXIT
0553               *
0554 6514 06C1  14 NOTCR  SWPB R1              Assume it is a printable character
0555 6516 C028  34        MOV  @CURPO$(U),R0
     6518 0016     
0556 651A 0420  54        BLWP @VSBW
     651C 373E     
0557 651E C0A8  34        MOV  @$SEND(U),R2
     6520 0034     
0558 6522 0602  14        DEC  R2
0559 6524 8080  18        C    R0,R2
0560 6526 1607  14        JNE  NOTCR1
0561 6528 C028  34        MOV  @$SEND(U),R0
     652A 0034     
0562 652C 6028  34        S    @$SWDTH(U),R0   Was last char on screen. Scroll
     652E 0030     
0563 6530 CA00  38        MOV  R0,@CURPO$(U)
     6532 0016     
0564 6534 10BF  14        JMP  SCRLL
0565 6536 0580  14 NOTCR1 INC  R0              No scroll necessary
0566 6538 CA00  38        MOV  R0,@CURPO$(U)
     653A 0016     
0567               *
0568 653C 0460  28 EMEXIT B    @BKLINK
     653E 30EA     
0569               ;]*
0570               ;[*== CRLF routine                          CODE =  -6  =================
0571               *
0572      3420     CLF    EQU  $LO+$-LLVSPT
0573 6540 C14B  18        MOV  LINK,R5
0574 6542 0202  20        LI   R2,>000D
     6544 000D     
0575 6546 06A0  32        BL   @EMT            EMT will alter INT mask via B @BKLINK
     6548 3312     
0576 654A 0202  20        LI   R2,>000A
     654C 000A     
0577 654E 0300  24        LIMI 0               Previous call to EMT altered INT mask
     6550 0000     
0578 6552 06A0  32        BL   @EMT
     6554 3312     
0579 6556 C2C5  18        MOV  R5,LINK
0580 6558 0460  28        B    @BKLINK
     655A 30EA     
0581               ;]*
0582               ;[*== ?TERMINAL routine                     CODE =  -8  =================
0583               * scan for <clear>, <break>, FCTN+4 press
0584               *
0585      343C     QTM    EQU  $LO+$-LLVSPT
0586 655C C14B  18        MOV  LINK,R5         save return
0587 655E 06A0  32        BL   @>0020          branch to console's test for <clear>
     6560 0020     
0588 6562 02C0  12        STST R0              store status in R0
0589 6564 1603  14        JNE  QTM2            exit if not <clear>
0590 6566 06A0  32 QTM1   BL   @>0020          check for <clear> again
     6568 0020     
0591 656A 13FD  14        JEQ  QTM1            loop until not <clear>
0592 656C C2C5  18 QTM2   MOV  R5,LINK         restore return
0593 656E 0240  22        ANDI R0,>2000        keep only EQU bit
     6570 2000     
0594 6572 0460  28        B    @BKLINK         return to caller
     6574 30EA     
0595               ;]*
0596               ;[*== ?KEY routine                          CODE = -10  =================
0597               *
0598      3456     QKY    EQU  $LO+$-LLVSPT
0599 6576 0420  54        BLWP @KSCAN
     6578 373A     
0600 657A D020  34        MOVB @KYCHAR,R0
     657C 8375     
0601 657E 0980  56        SRL  R0,8
0602 6580 0280  22        CI   R0,>00FF
     6582 00FF     
0603 6584 1601  14        JNE  QKEY1
0604 6586 04C0  14        CLR  R0
0605 6588 0460  28 QKEY1  B    @BKLINK
     658A 30EA     
0606               ;]*
0607               ;[*== GOTOXY routine                        CODE = -12  =================
0608               *
0609      346C     GXY    EQU  $LO+$-LLVSPT
0610 658C 38E8  72        MPY  @$SWDTH(U),R3
     658E 0030     
0611 6590 A102  18        A    R2,R4           Position within screen
0612 6592 A128  34        A    @$SSTRT(U),R4   Add VRAM offset to screen top
     6594 0032     
0613 6596 CA04  38        MOV  R4,@CURPO$(U)
     6598 0016     
0614 659A 0460  28        B    @BKLINK
     659C 30EA     
0615               ;]
0616               *       ___  __         __     ____  ______
0617               *      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
0618               *     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
0619               *    /____/_/\___/\__/_/\_\ /___/_/  \____/
0620               
0621               *
0622               *== USE blocks file                         CODE = -14  =================
0623               *== CREATE blocks file                      CODE = -16  =================
0624               *== READ block from blocks file             CODE = -18  =================
0625               *== WRITE block to blocks file              CODE = -20  =================
0626               ;[*== Block File I/O Support ============================================
0627               *
0628               * BPTOG utility to toggle one of 2 PABs for block file access
0629               *
0630      347E     BPTOG  EQU  $LO+$-LLVSPT
0631 659E C028  34        MOV  @$BPOFF(U),R0	   PAB offset to R0
     65A0 0040     
0632 65A2 0201  20        LI	R1,70	            Toggle amount
     65A4 0046     
0633 65A6 2840  18        XOR	R0,R1	            New offset
0634 65A8 CA01  38        MOV	R1,@$BPOFF(U)	   Update offset
     65AA 0040     
0635               *
0636               **xxx** entry point to insure we have correct PAB address
0637      348C     BPSET  EQU  $LO+$-LLVSPT
0638 65AC C028  34        MOV  @$DKBUF(U),R0	   Get DISK_BUF address
     65AE 002C     
0639 65B0 A028  34        A	   @$BPABS(U),R0	   Get BPABS address
     65B2 003E     
0640               *
0641 65B4 A028  34        A	   @$BPOFF(U),R0     Add current offset
     65B6 0040     
0642 65B8 C800  38        MOV	R0,@BFPAB	      Update current block file's PAB address
     65BA 34BC     
0643 65BC 045B  20        RT
0644               *
0645               * CLOSE blocks file
0646               *
0647      349E     BKCLOS EQU  $LO+$-LLVSPT
0648 65BE C020  34        MOV  @BFPAB,R0
     65C0 34BC     
0649 65C2 0201  20        LI   R1,$FCLS          Opcode=CLOSE
     65C4 0100     
0650 65C6 0420  54        BLWP @VSBW
     65C8 373E     
0651 65CA 0220  22        AI   R0,9              Address of filename's char count
     65CC 0009     
0652 65CE C800  38        MOV  R0,@SUBPTR        Point to filename's char count
     65D0 8356     
0653 65D2 0420  54        BLWP @DSRLNK           Close the file
     65D4 37BE     
0654 65D6 0008            DATA 8
0655 65D8 045B  20        RT                     Deal with error in caller
0656               *
0657               * storage area
0658               *
0659      34BA     SVBRET EQU  $LO+$-LLVSPT
0660 65DA 0000            DATA 0                 Storage for LINK coming into BRW
0661      34BC     BFPAB  EQU  $LO+$-LLVSPT
0662 65DC 0000            DATA	0	               Storage for current blocks file PAB address...
0663               *	 	 	                     ...will have current PAB on entry
0664               * PAB header storage
0665               *
0666      34BE     PABHD  EQU  $LO+$-LLVSPT
0667 65DE                 BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
0668               *              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
0669               *	                	                 >03=OUTPUT mode + "
0670               *	                	                 >01=UPDATE mode + "
0671               *	                         BYTE 2,3: save contents of DISK_BUF here
0672 65E2 80              BYTE	>80	            Record length
0673 65E3   80            BYTE	>80	            Character count of transfer
0674 65E4                 BSS	2	            Record number
0675               *
0676               *** file I/O equates
0677               *
0678      0000     $FOPN  EQU  >0000
0679      0100     $FCLS  EQU  >0100
0680      0200     $FRD   EQU  >0200
0681      0300     $FWRT  EQU  >0300
0682      0400     $FRST  EQU  >0400
0683      0005     $FINP  EQU  5
0684      0003     $FOUT  EQU  3
0685      0001     $FUPD  EQU  1
0686               *
0687               *** BRW -- entry point for block read/write routines
0688               *
0689      34C6     BRW    EQU  $LO+$-LLVSPT
0690 65E6 C80B  38        MOV  LINK,@SVBRET   Save LINK address
     65E8 34BA     
0691 65EA C1C1  18        MOV	R1,R7	         Save CODE {R1 to R7}
0692 65EC 0817  56        SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
0693 65EE 0227  22        AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
     65F0 000C     
0694 65F2 06A0  32        BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
     65F4 348C     
0695 65F6 0287  22        CI	R7,4	         USE or CREATE?
     65F8 0004     
0696 65FA 110D  14        JLT	BRW01	         No
0697 65FC 06A0  32        BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
     65FE 347E     
0698 6600 C020  34        MOV	@BFPAB,R0	   Load PAB address
     6602 34BC     
0699 6604 0220  22        AI	R0,9	         Set to name length byte
     6606 0009     
0700 6608 04C2  14        CLR	R2
0701 660A C079  30        MOV	*SP+,R1	      Pop bfnaddr to R1
0702 660C D811  46        MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
     660E 8305     
0703 6610 0582  14        INC	R2	            Add 1 to # bytes to copy
0704 6612 0420  54        BLWP	@VMBW	         Copy char count & pathname to PAB
     6614 3742     
0705               *
0706               *** set up PAB for OPEN
0707               *
0708 6616 0201  20 BRW01  LI	R1,$FUPD                Opcode=0,mode=update
     6618 0001     
0709 661A 9820  54        CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
     661C 830F     
     661E 830F     
0710 6620 1C02  14        JOP  BRW02                   No
0711 6622 0201  20        LI	R1,$FINP                Yes...change mode=input
     6624 0005     
0712 6626 C801  38 BRW02  MOV  R1,@PABHD               Put in PAB header
     6628 34BE     
0713 662A C828  54        MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
     662C 002C     
     662E 34C0     
0714 6630 04C0  14        CLR  R0
0715 6632 C800  38        MOV  R0,@PABHD+6             Set record#=0
     6634 34C4     
0716 6636 C020  34        MOV  @BFPAB,R0               VRAM destination
     6638 34BC     
0717 663A 0201  20        LI   R1,PABHD                RAM source
     663C 34BE     
0718 663E 0202  20        LI   R2,8                    Copy first 8 bytes of PAB header
     6640 0008     
0719 6642 0420  54        BLWP @VMBW                   Do the copy
     6644 3742     
0720               *
0721               *** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
0722               *
0723 6646 0220  22        AI   R0,9                Address of filename's char count in PAB
     6648 0009     
0724 664A C800  38        MOV  R0,@SUBPTR          Point to-----^^^^
     664C 8356     
0725 664E 0420  54        BLWP @DSRLNK             Open/create the file
     6650 37BE     
0726 6652 0008            DATA 8
0727 6654 135F  14        JEQ  BKERR
0728 6656 0287  22        CI   R7,4                READ or WRITE?
     6658 0004     
0729 665A 1120  14        JLT  BRW04               Yes
0730 665C 156E  14        JGT  BRWDON              No; =USE; we're done
0731               *
0732               *** write blank records to newly created blocks file [CODE = -16,CREATE]
0733               *
0734 665E C179  30        MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
0735 6660 0A35  56        SLA  R5,3                Convert #blocks to #records
0736 6662 C0C5  18        MOV  R5,R3               Save
0737 6664 C105  18        MOV  R5,R4               Set up counter
0738 6666 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     6668 0301     
0739 666A C800  38        MOV  R0,@PABHD           Copy to PAB header
     666C 34BE     
0740 666E 6144  18 BRLOOP S    R4,R5               Calculate next record
0741 6670 C805  38        MOV  R5,@PABHD+6         Copy to PAB header
     6672 34C4     
0742 6674 C020  34        MOV  @BFPAB,R0           VRAM destination
     6676 34BC     
0743 6678 0201  20        LI   R1,PABHD            RAM source
     667A 34BE     
0744 667C 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     667E 0008     
0745 6680 0420  54        BLWP @VMBW               Do the copy
     6682 3742     
0746 6684 0220  22        AI   R0,9                Address of filename's char count
     6686 0009     
0747 6688 C800  38        MOV  R0,@SUBPTR          Point to filename's char count
     668A 8356     
0748 668C 0420  54        BLWP @DSRLNK             Write one record of blanks
     668E 37BE     
0749 6690 0008            DATA 8
0750 6692 1340  14        JEQ  BKERR
0751 6694 C143  18        MOV  R3,R5               Get #blocks
0752 6696 0604  14        DEC  R4                  Count down 1 record
0753 6698 16EA  14        JNE  BRLOOP              Write another record if not done
0754 669A 104F  14        JMP  BRWDON              We're done
0755               *
0756               *** prepare for read/write block
0757               *
0758 669C C179  30 BRW04  MOV  *SP+,R5             Pop block# to write
0759 669E C1B9  30        MOV  *SP+,R6             Pop bufaddr
0760 66A0 0605  14        DEC  R5                  Block#-1
0761 66A2 0A35  56        SLA  R5,3                Convert to starting record#
0762 66A4 0204  20        LI   R4,8                Load counter for 8 records
     66A6 0008     
0763 66A8 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     66AA 0301     
0764 66AC 0203  20        LI   R3,VMBW             WRITE vector
     66AE 3742     
0765 66B0 0287  22        CI   R7,2                Are we writing the block?
     66B2 0002     
0766 66B4 1304  14        JEQ  BRW05               Yup
0767 66B6 0200  20        LI   R0,$FRD+$FINP       Nope...set up for READ
     66B8 0205     
0768 66BA 0203  20        LI   R3,VMBR             READ vector
     66BC 374A     
0769 66BE C800  38 BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
     66C0 34BE     
0770               *
0771               * READ/WRITE block routine [CODE = -18/-20]
0772               *
0773 66C2 C805  38 RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
     66C4 34C4     
0774 66C6 C020  34        MOV  @BFPAB,R0           VRAM destination
     66C8 34BC     
0775 66CA 0201  20        LI   R1,PABHD            RAM source
     66CC 34BE     
0776 66CE 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     66D0 0008     
0777 66D2 0420  54        BLWP @VMBW               Do the copy
     66D4 3742     
0778 66D6 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0
     66D8 002C     
0779 66DA C046  18        MOV  R6,R1               RAM buffer to R1
0780 66DC 0202  20        LI   R2,128              Bytes to copy
     66DE 0080     
0781 66E0 0287  22        CI   R7,3                READ?
     66E2 0003     
0782 66E4 1301  14        JEQ  BRW06               Yup
0783 66E6 0413  42        BLWP *R3                 Nope...copy record to VRAM
0784               *
0785               * temporarily use CRU register---it should be OK
0786               *
0787 66E8 C320  34 BRW06  MOV  @BFPAB,CRU          PAB address
     66EA 34BC     
0788 66EC 022C  22        AI   CRU,9               Address of filename's char count
     66EE 0009     
0789 66F0 C80C  38        MOV  CRU,@SUBPTR         Point to filename's char count
     66F2 8356     
0790 66F4 0420  54        BLWP @DSRLNK             Read/write one record
     66F6 37BE     
0791 66F8 0008            DATA 8
0792 66FA 130C  14        JEQ  BKERR
0793 66FC 0287  22        CI   R7,2                WRITE?
     66FE 0002     
0794 6700 1303  14        JEQ  BRW07               Yup...next record
0795 6702 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
     6704 002C     
0796 6706 0413  42        BLWP *R3                 Nope...copy record to RAM buffer
0797 6708 0585  14 BRW07  INC  R5                  Next record in file
0798 670A 0226  22        AI   R6,128              Next record to/from block RAM buffer
     670C 0080     
0799 670E 0604  14        DEC  R4                  Count down 1 record
0800 6710 16D8  14        JNE  RWLOOP              Read/write another record if not done
0801 6712 1013  14        JMP  BRWDON              We're done
0802               *
0803               *** error handling
0804               *
0805 6714 D000  18 BKERR  MOVB R0,R0               Device error?
0806 6716 1306  14        JEQ  BKERR6              Yes, exit with disk error
0807 6718 0206  20 BKERR9 LI   R6,9                No, exit with file error
     671A 0009     
0808 671C 1005  14        JMP  BKCLN
0809 671E 0206  20 BKERR8 LI   R6,8                Block# <=0!  exit with range error
     6720 0008     
0810 6722 1002  14        JMP  BKCLN
0811 6724 0206  20 BKERR6 LI   R6,6
     6726 0006     
0812 6728 06A0  32 BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
     672A 349E     
0813 672C 0287  22        CI   R7,4                USE or CREATE?
     672E 0004     
0814 6730 1102  14        JLT  BKCLN1              No
0815 6732 06A0  32        BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
     6734 347E     
0816 6736 C006  18 BKCLN1 MOV  R6,R0               Pass error back to caller
0817 6738 100C  14        JMP  BKEXIT
0818 673A 04C6  14 BRWDON CLR  R6
0819 673C 06A0  32        BL   @BKCLOS             Close current blocks file
     673E 349E     
0820 6740 1602  14        JNE  BRWDN1              Error?
0821 6742 0206  20        LI   R6,9                Yes...assume it was a file error
     6744 0009     
0822 6746 0287  22 BRWDN1 CI   R7,4                (no error)...CREATE?
     6748 0004     
0823 674A 1602  14        JNE  BRWDN2              No...we're done
0824 674C 06A0  32        BL   @BPTOG              Yes...revert to correct blocks file
     674E 347E     
0825 6750 C006  18 BRWDN2 MOV  R6,R0               Error to R0
0826 6752 C2E0  34 BKEXIT MOV  @SVBRET,LINK        Restore LINK
     6754 34BA     
0827 6756 0460  28        B    @BKLINK
     6758 30EA     
0828               ;]
0829               ;[* MSGTYP      <<< Support for string typing in various banks >>>
0830               *
0831               * Called with:  BL  @MSGTYP
0832               *
0833               * R4 and R5 are the only registers that will be preserved
0834               * ..after a call to EMIT---
0835               *
0836               * Input:    R4 = Address of length byte of packed string
0837               *
0838               * We will pass the ASCII value of character to EMIT in R2 without
0839               * insuring it is 7 bits wide.
0840               *
0841      363A     MSGTYP EQU  $LO+$-LLVSPT
0842 675A 064E  14        DECT R           Push return address
0843 675C C78B  30        MOV  LINK,*R     ...to Forth return stack
0844 675E 04C5  14        CLR  R5
0845 6760 D174  28        MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
0846 6762 06C5  14        SWPB R5          Put char count in low byte
0847 6764 04C2  14 MTLOOP CLR  R2
0848 6766 D0B4  28        MOVB *R4+,R2     Copy next char to R2 for EMIT
0849 6768 06C2  14        SWPB R2          Put char in low byte
0850 676A 0300  24        LIMI 0           We need to do this because we're calling EMIT directly
     676C 0000     
0851 676E 06A0  32        BL   @EMT        Call EMIT directly
     6770 3312     
0852 6772 05A8  34        INC  @$OUT(U)    Increment display line character count
     6774 0052     
0853 6776 0605  14        DEC  R5          Decrement character count for this message
0854 6778 16F5  14        JNE  MTLOOP      Are we done?
0855 677A C2FE  30        MOV  *R+,LINK    Yes. Pop return address
0856 677C 045B  20        RT               Return to caller
0857                ;]
0858               ;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
0859      365E     R4$5   EQU  $LO+$-LLVSPT
0860 677E CD74  46        MOV  *R4+,*R5+
0861 6780 CD74  46        MOV  *R4+,*R5+
0862 6782 CD74  46        MOV  *R4+,*R5+
0863 6784 C554  38        MOV  *R4,*R5
0864 6786 045B  20        RT
0865               ;]
0866               *     __  __              _   __         _      __   __
0867               *    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__
0868               *   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
0869               *   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/
0870               *              ___      ___          ____
0871               *             / _ \___ / _/__ ___ __/ / /____
0872               *            / // / -_) _/ _ `/ // / / __(_-<
0873               *           /____/\__/_/ \_,_/\_,_/_/\__/___/
0874               
0875               ;[*== User Variable defaults ============================================
0876               *
0877      3668     UBASE0 EQU  $LO+$-LLVSPT
0878 6788                 BSS  6                 BASE OF USER VARIABLES
0879 678E 3668            DATA UBASE0            06 USER UCONS$
0880 6790 FFA0            DATA SPBASE            08 USER S0
0881 6792 3FFE            DATA RBASE             0A USER R0 { R0$
0882 6794 36B4            DATA $UVAR             0C USER U0
0883 6796 FFA0            DATA SPBASE            0E USER TIB
0884 6798 001F            DATA 31                10 USER WIDTH
0885 679A A000            DATA DPBASE            12 USER DP
0886 679C 30F6            DATA $SYS$             14 USER SYS$
0887 679E 0000            DATA 0                 16 USER CURPOS
0888 67A0 3020            DATA INT1              18 USER INTLNK
0889 67A2 0001            DATA 1                 1A USER WARNING
0890 67A4 0040            DATA 64                1C USER C/L$ { CL$
0891 67A6 2010            DATA $BUFF             1E USER FIRST$
0892 67A8 3020            DATA $LO               20 USER LIMIT$
0893 67AA 0380            DATA >0380             22 USER COLTAB    Color Table address in VRAM
0894 67AC 0300            DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
0895 67AE 0780            DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
0896 67B0 0800            DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
0897 67B2 0080            DATA >80               2A USER FPB       pushes address of user screen font file PAB
0898               *                                               ...that is this relative distance from DISK_BUF
0899 67B4 1000            DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
0900 67B6 0460            DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
0901 67B8 0028            DATA 40                30 USER SCRN_WIDTH
0902 67BA 0000            DATA 0                 32 USER SCRN_START
0903 67BC 03C0            DATA 960               34 USER SCRN_END
0904 67BE 0000            DATA 0                 36 USER ISR       [Note: This used to be INT1]
0905 67C0 0000            DATA 0                 38 USER ALTIN
0906 67C2 0000            DATA 0                 3A USER ALTOUT
0907 67C4 0001            DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
0908 67C6 00C6            DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
0909               *                                               ...that is this relative distance from DISK_BUF
0910 67C8 0000            DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
0911               *                                               ...always toggled between 0 and 70
0912 67CA 0800            DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
0913 67CC FFFF            DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
0914               *                                                  0 = console font via GPLLNK
0915 67CE 0000            DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
0916 67D0 0000            DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
0917 67D2 0000            DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
0918               *                                                  0 = Symmetric (default)
0919               *                                                 !0 = Floored
0920      36B4     $UVAR  EQU  $LO+$-LLVSPT
0921 67D4                 BSS  >80               USER VARIABLE AREA
0922               ;]
0923               ;[*== A Constant ====================================================
0924               *
0925      3734     H2000  EQU  $LO+$-LLVSPT
0926 6854 2000            DATA >2000
0927               ;]*
0928               *    __  ____  _ ___ __         _   __        __
0929               *   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
0930               *  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
0931               *  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
0932               *                     /___/
0933               *
0934               ;[*== Utility Vectors ===================================================
0935               *
0936               * GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
0937               * DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
0938      3736     XMLLNK EQU  $LO+$-LLVSPT
0939 6856 3A4C            DATA UTILWS,XMLENT   ; Link to ROM routines
     6858 3756     
0940      373A     KSCAN  EQU  $LO+$-LLVSPT
0941 685A 3A4C            DATA UTILWS,KSENTR   ; Keyboard scan
     685C 3832     
0942      373E     VSBW   EQU  $LO+$-LLVSPT
0943 685E 3A4C            DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
     6860 3848     
0944      3742     VMBW   EQU  $LO+$-LLVSPT
0945 6862 3A4C            DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
     6864 3854     
0946      3746     VSBR   EQU  $LO+$-LLVSPT
0947 6866 3A4C            DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
     6868 3862     
0948      374A     VMBR   EQU  $LO+$-LLVSPT
0949 686A 3A4C            DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
     686C 386E     
0950      374E     VMOVE  EQU  $LO+$-LLVSPT
0951 686E 3A4C            DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
     6870 38AE     
0952      3752     VWTR   EQU  $LO+$-LLVSPT
0953 6872 3A4C            DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
     6874 387C     
0954               ;]*
0955               ;[*== XMLENT -- Link to system XML utilities ============================
0956               *
0957      3756     XMLENT EQU  $LO+$-LLVSPT
0958 6876 C83E  50        MOV  *R14+,@GPLWS+2      Get argument
     6878 83E2     
0959 687A 02E0  18        LWPI GPLWS               Select GPL workspace
     687C 83E0     
0960 687E C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6880 3A62     
0961 6882 C081  18        MOV  R1,R2               Make a copy of argument
0962 6884 0281  22        CI   R1,>8000            Direct address in ALC?
     6886 8000     
0963 6888 1B07  14        JH   XML30               We have the address
0964 688A 09C1  56        SRL  R1,12
0965 688C 0A11  56        SLA  R1,1
0966 688E 0A42  56        SLA  R2,4
0967 6890 09B2  56        SRL  R2,11
0968 6892 A0A1  34        A    @XMLTAB(R1),R2
     6894 0CFA     
0969 6896 C092  26        MOV  *R2,R2
0970 6898 0692  24 XML30  BL   *R2
0971 689A 02E0  18        LWPI UTILWS              Get back to right WS
     689C 3A4C     
0972 689E C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     68A0 83F6     
0973 68A2 0380  18        RTWP
0974               ;]*
0975               *    ________  __   __   _  ____ __           __  ________
0976               *   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
0977               *  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ /
0978               *  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
0979               *
0980               *-----------------------------------------------------------------------*
0981               ;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
0982               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
0983               *                                                                       *
0984               * This routine will work with any GROM library slot since it is         *
0985               * indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
0986               * This GPLLNK does NOT require a module to be plugged into the          *
0987               * GROM port so it will work with the Editor/Assembler,                  *
0988               * Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
0989               * CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
0990               * It saves and restores the current GROM Address in case you want       *
0991               * to return back to GROM for Basic or Extended Basic CALL LINKs         *
0992               * or to return to the loading module.                                   *
0993               *                                                                       *
0994               *    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
0995               *                                                 DATA >34              *
0996               *                                                                       *
0997               *    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
0998               *                                                                       *
0999               * 70 Bytes - including the GPLLNK Workspace                             *
1000               *-----------------------------------------------------------------------*
1001               
1002               *  GPLWS (>83E0) is GPL workspace
1003      83E8     G_R4   EQU  GPLWS+8              GPL workspace R4
1004      83EC     G_R6   EQU  GPLWS+12             GPL workspace R6
1005               *  SUBSTK (>8373) is GPL Subroutine stack pointer
1006      0060     LDGADR EQU  >60                  Load & Execute GROM address entry point
1007      200E     XTAB27 EQU  >200E                Low Mem XML table location 27
1008               *                                ..Will contain XMLRTN at startup
1009      166C     GETSTK EQU  >166C
1010               
1011      3784     GPLLNK EQU  $LO+$-LLVSPT
1012 68A4 3776            DATA GLNKWS      R7       Set up BLWP Vectors
1013 68A6 3796            DATA GLINK1      R8
1014               * RTNADR EQU  $LO+$-LLVSPT    <---don't think we need this label
1015 68A8 37B2            DATA XMLRTN      R9       address where GPL XML returns to us...
1016               *                                ...this address will already be in XTAB27,...
1017               *                                ...>200E, so don't really need it here}
1018      378A     GXMLAD EQU  $LO+$-LLVSPT
1019 68AA 176C            DATA >176C       R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
1020 68AC 0050            DATA >50         R11      Initialized to >50 where PUTSTK address resides
1021      3776     GLNKWS EQU  $LO+$-LLVSPT->18     GPLLNK's workspace of which only...
1022 68AE                 BSS  >08         R12-R15  ...registers R7 through R15 are used
1023               
1024      3796     GLINK1 EQU  $LO+$-LLVSPT
1025 68B6 C81B  46        MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
     68B8 83E8     
1026 68BA C83E  50        MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
     68BC 83EC     
1027 68BE 02E0  18        LWPI GPLWS                Load GPL WS
     68C0 83E0     
1028 68C2 0694  24        BL   *R4                  Save current GROM Address on stack
1029 68C4 C920  54        MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
     68C6 378A     
     68C8 8302     
1030 68CA 05E0  34        INCT @SUBSTK              Adjust the stack pointer
     68CC 8373     
1031 68CE 0460  28        B    @LDGADR              Execute our GPL Routine
     68D0 0060     
1032               
1033      37B2     XMLRTN EQU  $LO+$-LLVSPT
1034 68D2 C120  34        MOV  @GETSTK,R4           Get GETSTK pointer
     68D4 166C     
1035 68D6 0694  24        BL   *R4                  Restore GROM address off the stack
1036 68D8 02E0  18        LWPI GLNKWS               Load our WS
     68DA 3776     
1037 68DC 0380  18        RTWP                      All Done - Return to Caller
1038               ;]
1039               *     ___  _______  __   _  ____ __           __  ________
1040               *    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
1041               *   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ /
1042               *  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
1043               *
1044               *-----------------------------------------------------------------------*
1045               ;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
1046               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
1047               *                                                                       *
1048               *      (Uses console GROM 0's DSRLNK routine)                           *
1049               *      (Do not REF DSRLNK or GPLLNK when using these routines)          *
1050               *      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
1051               *                                                                       *
1052               *      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
1053               *                                                   DATA 8              *
1054               *                                                                       *
1055               *      NOTES: Must be used with a GPLLNK routine                        *
1056               *             Returns ERRORs the same as the E/A DSRLNK                 *
1057               *             EQ bit set on return if error                             *
1058               *             ERROR CODE in caller's MSB of Register 0 on return        *
1059               *                                                                       *
1060               * 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
1061               *-----------------------------------------------------------------------*
1062               
1063      0050     PUTSTK EQU  >50                     Push GROM Address to stack pointer
1064      836D     TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
1065      8356     NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
1066      8C02     VWA    EQU  >8C02                   VDP Write Address location
1067      8800     VRD    EQU  >8800                   VDP Read Data byte location
1068      83E9     G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
1069      837C     GSTAT  EQU  >837C                   GPL Status byte location
1070               
1071      37BE     DSRLNK EQU  $LO+$-LLVSPT
1072 68DE 37C2            DATA DSRWS,DLINK1            Set BLWP Vectors
     68E0 37C2     
1073               
1074      37C2     DSRWS  EQU  $LO+$-LLVSPT            Start of DSRLNK workspace
1075      37C9     DR3LB  EQU  DSRWS+7                 lower byte of DSRLNK workspace R3
1076      37C2     DLINK1 EQU  $LO+$-LLVSPT
1077 68E2 C30C  18        MOV  R12,R12         R0      Have we already looked up the LINK address?
1078 68E4 161C  14        JNE  DLINK3          R1      YES!  Skip lookup routine
1079               *<<-------------------------------------------------------------------------->>*
1080               * This section of code is only executed once to find the GROM address          *
1081               * for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
1082               * to indicate that the address is found and to be used as a mask for EQ & CND  *
1083               *------------------------------------------------------------------------------*
1084 68E6 02E0  18        LWPI GPLWS           R2,R3   else load GPL workspace
     68E8 83E0     
1085 68EA C120  34        MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
     68EC 0050     
1086 68EE 0694  24        BL   *R4             R6
1087 68F0 0204  20        LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
     68F2 0011     
1088 68F4 DB44  38        MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector
     68F6 0402     
1089               
1090               ***les*** Note on above instruction:
1091               ***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
1092               ***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)
1093               
1094 68F8 1004  14        JMP  DLINK2          R11     Jump around R12-R15
1095 68FA 0000            DATA 0               R12     contains >2000 flag when set
1096 68FC 0000            DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
     68FE 0000     
     6900 0000     
1097 6902 DB60  54 DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
     6904 83E9     
     6906 0402     
1098 6908 C160  34        MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
     690A 166C     
1099 690C D81D  46        MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
     690E 3811     
1100 6910 05E0  34        INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
     6912 3810     
1101 6914 0695  24        BL   *R5                     Restore the GROM address off the stack
1102 6916 02E0  18        LWPI DSRWS                   Reload DSRLNK workspace
     6918 37C2     
1103 691A 020C  20        LI   R12,>2000               Set flag to signify DSRLNK address is set
     691C 2000     
1104               *<<-------------------------------------------------------------------------->>*
1105 691E 058E  14 DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
1106 6920 D83E  48        MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
     6922 836D     
1107 6924 C0E0  34        MOV  @NAMLEN,R3              Save VDP address of Name Length
     6926 8356     
1108 6928 0223  22        AI   R3,-8                   Adjust it to point to PAB Flag byte
     692A FFF8     
1109 692C 0420  54        BLWP @GPLLNK                 Execute DSR LINK
     692E 3784     
1110      3810     DSRADR EQU  $LO+$-LLVSPT
1111 6930 03              BYTE >03                     High byte of GPL DSRLNK address
1112      3811     DSRAD1 EQU  $LO+$-LLVSPT
1113 6931   00            BYTE >00                     Lower byte of GPL DSRLNK address
1114               *----Error Check & Report to Caller's R0 and EQU bit-------------------------
1115 6932 D820  54        MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
     6934 37C9     
     6936 8C02     
1116 6938 D803  38        MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
     693A 8C02     
1117 693C 53CC  18        SZCB R12,R15                 Clear EQ bit for Error Report
1118 693E D0E0  34        MOVB @VRD,R3                 Get PAB Error Flag
     6940 8800     
1119 6942 0953  56        SRL  R3,5                    Adjust it to 0-7 error code
1120 6944 D743  30        MOVB R3,*R13                 Put it into Caller's R0 (msb)
1121 6946 1603  14        JNE  SETEQ                   If it's not zero, set EQ bit
1122 6948 2320  38        COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
     694A 837C     
1123 694C 1601  14        JNE  DSREND                  No Error, Just return
1124 694E F3CC  18 SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
1125 6950 0380  18 DSREND RTWP                         All Done - Return to Caller
1126               ;]
1127               ;[*== KSENTR -- Keyboard Scan (entry point) =============================
1128               *
1129      3832     KSENTR EQU  $LO+$-LLVSPT
1130 6952 02E0  18        LWPI GPLWS
     6954 83E0     
1131 6956 C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6958 3A62     
1132 695A 06A0  32        BL   @SCNKEY             Console keyboard scan routine
     695C 000E     
1133 695E 02E0  18        LWPI UTILWS
     6960 3A4C     
1134 6962 C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     6964 83F6     
1135 6966 0380  18        RTWP
1136               ;]*
1137               *    _   _____  ___    __  ____  _ ___ __  _
1138               *   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
1139               *   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
1140               *   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
1141               *
1142               ;[*== VDP utilities (entry point) =======================================
1143               *
1144               ** VDP single byte write
1145               *
1146      3848     VSBWEN EQU  $LO+$-LLVSPT
1147 6968 06A0  32        BL   @WVDPWA             Write out address
     696A 388E     
1148 696C D82D  54        MOVB @2(R13),@VDPWD      Write data
     696E 0002     
     6970 8C00     
1149 6972 0380  18        RTWP                     Return to calling program
1150               *
1151               ** VDP multiple byte write
1152               *
1153      3854     VMBWEN EQU  $LO+$-LLVSPT
1154 6974 06A0  32        BL   @WVDPWA             Write out address
     6976 388E     
1155 6978 D831  48 VWTMOR MOVB *R1+,@VDPWD         Write a byte
     697A 8C00     
1156 697C 0602  14        DEC  R2                  Decrement byte count
1157 697E 16FC  14        JNE  VWTMOR              More to write?
1158 6980 0380  18        RTWP                     Return to calling Program
1159               *
1160               ** VDP single byte read
1161               *
1162      3862     VSBREN EQU  $LO+$-LLVSPT
1163 6982 06A0  32        BL   @WVDPRA             Write out address
     6984 3894     
1164 6986 DB60  54        MOVB @VDPRD,@2(R13)      Read data
     6988 8800     
     698A 0002     
1165 698C 0380  18        RTWP                     Return to calling program
1166               *
1167               ** VDP multiple byte read
1168               *
1169      386E     VMBREN EQU  $LO+$-LLVSPT
1170 698E 06A0  32        BL   @WVDPRA             Write out address
     6990 3894     
1171 6992 DC60  48 VRDMOR MOVB @VDPRD,*R1+         Read a byte
     6994 8800     
1172 6996 0602  14        DEC  R2                  Decrement byte count
1173 6998 16FC  14        JNE  VRDMOR              More to read?
1174 699A 0380  18        RTWP                     Return to calling program
1175               *
1176               ** VDP write to register
1177               *
1178      387C     VWTREN EQU  $LO+$-LLVSPT
1179 699C C05D  26        MOV  *R13,R1             Get register number and value
1180 699E D82D  54        MOVB @1(R13),@VDPWA      Write out value
     69A0 0001     
     69A2 8C02     
1181 69A4 0261  22        ORI  R1,>8000            Set for register write
     69A6 8000     
1182 69A8 D801  38        MOVB R1,@VDPWA           Write out register number
     69AA 8C02     
1183 69AC 0380  18        RTWP                     Return to calling program
1184               *
1185               ** Set up to write to VDP
1186               *
1187      388E     WVDPWA EQU  $LO+$-LLVSPT
1188 69AE 0201  20        LI   R1,>4000
     69B0 4000     
1189 69B2 1001  14        JMP  WVDPAD
1190               *
1191               ** Set up to read VDP
1192               *
1193      3894     WVDPRA EQU  $LO+$-LLVSPT
1194 69B4 04C1  14        CLR  R1
1195               *
1196               ** Write VDP address
1197               *
1198 69B6 C09D  26 WVDPAD MOV  *R13,R2             Get VDP address
1199 69B8 D820  54        MOVB @U_R2LB,@VDPWA      Write low byte of address
     69BA 3A51     
     69BC 8C02     
1200 69BE E081  18        SOC  R1,R2               Properly adjust VDP write bit
1201 69C0 D802  38        MOVB R2,@VDPWA           Write high byte of address
     69C2 8C02     
1202 69C4 C06D  34        MOV  @2(R13),R1          Get CPU RAM address
     69C6 0002     
1203 69C8 C0AD  34        MOV  @4(R13),R2          Get byte count
     69CA 0004     
1204 69CC 045B  20        RT                       Return to calling routine
1205               
1206               *
1207               ** VDP-to-VDP move.
1208               *
1209      38AE     VMOVEN EQU  $LO+$-LLVSPT
1210 69CE C05D  26        MOV  *R13,R1             Get cnt to R1
1211 69D0 C0AD  34        MOV  @2(R13),R2          Get vsrc to R2
     69D2 0002     
1212 69D4 C0ED  34        MOV  @4(R13),R3          Get vdst to R3
     69D6 0004     
1213 69D8 0263  22        ORI  R3,>4000            Prepare for VDP write
     69DA 4000     
1214               
1215               ** copy cnt bytes from vsrc to vdst
1216               
1217 69DC D820  54 VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
     69DE 3A51     
     69E0 8C02     
1218 69E2 D802  38        MOVB R2,@VDPWA           Write MSB of VDP read address
     69E4 8C02     
1219 69E6 0582  14        INC  R2                  Next VDP read address
1220 69E8 D020  34        MOVB @VDPRD,R0           Read VDP byte
     69EA 8800     
1221 69EC D820  54        MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
     69EE 3A53     
     69F0 8C02     
1222 69F2 D803  38        MOVB R3,@VDPWA           Write MSB of VDP write address
     69F4 8C02     
1223 69F6 0583  14        INC  R3                  Next VDP write address
1224 69F8 D800  38        MOVB R0,@VDPWD           Write VDP byte
     69FA 8C00     
1225 69FC 0601  14        DEC  R1                  Decrement count
1226 69FE 16EE  14        JNE  VMVMOR              Repeat if not done
1227 6A00 0380  18        RTWP                     Return to calling program
1228               ;]*
1229               ;[*== fbForth Version Message ===========================================
1230      38E2     FBFMSG EQU  $LO+$-LLVSPT
1231               * This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
1232               * Also, printing the extra blanks overwrites the font-not-found error message.
1233 6A02 11              BYTE 17
1234 6A03   66            TEXT 'fbForth 2.0:     '
     6A04 6246     
     6A06 6F72     
     6A08 7468     
     6A0A 2032     
     6A0C 2E30     
     6A0E 3A20     
     6A10 2020     
     6A12 2020     
1235               ;]
1236               *     __  ___        ___ ____      __   __      _      __            __
1237               *    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
1238               *   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
1239               *  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
1240               *
1241               ;[*== Modifiable words in Resident Dictionary ===========================
1242               ;[*** (ABORT) ***
1243 6A14 73CC            DATA x#VLST_N         <--Last word in ROM
1244      38F6     PABR_N EQU  $LO+$-LLVSPT
1245 6A16 8728            DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT
     6A18 4142     
     6A1A 4F52     
     6A1C 54A9     
1246               
1247      38FE     PABORT EQU  $LO+$-LLVSPT
1248 6A1E 8334            DATA DOCOL
1249 6A20 6ADE            DATA ABORT,SEMIS
     6A22 6358     
1250               ;]*
1251               ;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
1252 6A24 38F6            DATA PABR_N
1253      3906     FRTH_N EQU  $LO+$-LLVSPT
1254 6A26 C546            DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT
     6A28 4F52     
     6A2A 54C8     
1255               
1256      390E     FORTHV EQU  $LO+$-LLVSPT+2          ; vocabulary link field
1257      3910     FORTHP EQU  $LO+$-LLVSPT+4          ; pseudo name field
1258      3912     FORTHL EQU  $LO+$-LLVSPT+6          ; chronological link field
1259      390C     FORTH  EQU  $LO+$-LLVSPT
1260 6A2C 7218            DATA DOVOC
1261 6A2E A002            DATA DPBASE+2,>81A0,0        ; (may need to modify)
     6A30 81A0     
     6A32 0000     
1262               ;]*
1263               ;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
1264 6A34 3906            DATA FRTH_N
1265      3916     ASMR_N EQU  $LO+$-LLVSPT
1266 6A36 C941            DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT
     6A38 5353     
     6A3A 454D     
     6A3C 424C     
     6A3E 45D2     
1267               
1268      3922     ASMV   EQU  $LO+$-LLVSPT+2          ; vocabulary link field
1269      3926     ASML   EQU  $LO+$-LLVSPT+6          ; chronological link field
1270      3920     ASSM   EQU  $LO+$-LLVSPT
1271 6A40 7218            DATA DOVOC
1272 6A42 394A            DATA SASM_N,>81A0,FORTHL     ; <--ASMV initially points to last word in
     6A44 81A0     
     6A46 3912     
1273               *                                   ;    ...ASSEMBLER vocabulary in the kernel
1274               ;]*
1275               ;]*
1276               *    ___                     __   __
1277               *   / _ | ___ ___ ___ __ _  / /  / /__ ____
1278               *  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
1279               * /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/
1280               *     _   __              __        __                _      __            __
1281               *    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
1282               *    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
1283               *    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
1284               *                                           /___/
1285               *
1286               *== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
1287               ;[*** NEXT, ***      ( --- )
1288               * 1st word in ASSEMBLER vocabulary
1289               *
1290 6A48 3910            DATA FORTHP          <--points to PNF of FORTH
1291      392A     NXT__N EQU  $LO+$-LLVSPT
1292 6A4A 854E            DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT
     6A4C 4558     
     6A4E 54AC     
1293               
1294      3930     NEXTC  EQU  $LO+$-LLVSPT
1295 6A50 3932            DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
1296 6A52 0200  20 NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
     6A54 045F     
1297 6A56 C068  34        MOV  @$DP(U),R1        HERE to R1
     6A58 0012     
1298 6A5A CC40  34        MOV  R0,*R1+           compile "B *NEXT"
1299 6A5C CA01  38        MOV  R1,@$DP(U)        update HERE
     6A5E 0012     
1300 6A60 CA28  54        MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
     6A62 0058     
     6A64 0056     
1301 6A66 045F  20        B    *NEXT             back to inner interpreter
1302               
1303               * : NEXT,   ( --- )
1304               *    *NEXT B,  ;
1305               ;]*
1306               ;[*** ;ASM ***       ( --- )
1307               * 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
1308               * ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
1309               *
1310 6A68 392A            DATA NXT__N
1311      394A     SASM_N EQU  $LO+$-LLVSPT
1312 6A6A 84              BYTE 4+TERMBT    <--note different name field format
1313 6A6B   3B            TEXT ';ASM'
     6A6C 4153     
     6A6E 4D       
1314 6A6F   A0            BYTE ' '+TERMBT
1315               
1316      3950     SASM   EQU  $LO+$-LLVSPT
1317 6A70 3952            DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
1318 6A72 10EF  14        JMP  NXT_P          finish up in NEXT,
1319               
1320               * : ;ASM   ( --- )
1321               *    *NEXT B,  ;
1322               ;]*
1323               
1324               ;[*== Some Variables (KEYCNT etc.) ======================================
1325               
1326      3954     KEYCNT EQU  $LO+$-LLVSPT
1327 6A74 FFFF            DATA -1              Used in cursor flash logic
1328      3956     INTACT EQU  $LO+$-LLVSPT
1329 6A76 0000            DATA 0               Non-zero during user's interrupt service routine
1330               *
1331               *++ variables used by some graphics primitives
1332               *
1333      3958     $DMODE EQU  $LO+$-LLVSPT
1334 6A78 0000            DATA 0                   ; actual location of variable contents
1335      395A     $DCOL  EQU  $LO+$-LLVSPT
1336 6A7A FFFF            DATA -1                  ; actual location of variable contents
1337               
1338               *===========================================================
1339               ;]*
1340               *   ______                         ___            _____        __
1341               *  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__
1342               *   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
1343               *  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/
1344               *                    /_/
1345               *
1346               ;[*== Trampoline Code ===================================================
1347               *
1348               * MYBANK must be at same location in all banks with the code that appears
1349               * in the following table.  The EQUates for BANK0--BANK3 may also be in the
1350               * same places in each bank for convenience, but they only need to appear once.
1351               *
1352               *       Bank Select MYBANK
1353               *       ---- ------ ------
1354               *       0    >6006  >C000
1355               *       1    >6004  >8000
1356               *       2    >6002  >4000
1357               *       3    >6000  >0000
1358               *
1359               * Bank0 code will look like this
1360               *
1361               * MYBANK DATA >C000
1362               * BANK0  EQU  >C000
1363               * BANK1  EQU  >8000
1364               * BANK2  EQU  >4000
1365               * BANK3  EQU  >0000
1366               *
1367               * Banks 1--3 will look the same, including labels, and the DATA
1368               * instruction at MYBANK's location will correspond to its bank.
1369               *
1370               * Before a bank is selected, the values above will be shifted right 13
1371               * bits and have >6000 added.
1372               *
1373               ;[*** BLBANK ************************************************************
1374               *
1375               * General bank branching routine (32KB ROM, i.e., 4 banks) for a
1376               * branch that is expected to return (not high-level Forth) via RTBANK---
1377               *   --put in scratchpad or low RAM
1378               *   --called by
1379               *       BL    @BLBANK
1380               *       DATA  dst_addr - >6000 + bank# in left 2 bits
1381               *
1382      395C     BLBANK EQU  $LO+$-LLVSPT
1383 6A7C 064E  14        DECT R               ; reserve space on return stack (R14)
1384 6A7E C33B  30        MOV  *LINK+,CRU      ; copy destination bank address to R12
1385 6A80 C78B  30        MOV  LINK,*R         ; push return address
1386 6A82 064E  14        DECT R               ; reserve space on return stack
1387 6A84 C7A0  46        MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
     6A86 7FFE     
1388 6A88 C2CC  18        MOV  CRU,LINK        ; copy destination bank address to R11
1389 6A8A 024B  22        ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
     6A8C 1FFF     
1390 6A8E 022B  22        AI   LINK,>6000      ; make it a real address
     6A90 6000     
1391 6A92 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1392 6A94 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6A96 6000     
1393 6A98 04DC  26        CLR  *CRU            ; switch to destination bank
1394 6A9A 045B  20        B    *LINK           ; branch to destination address
1395               ;]*
1396               ;[*** RTBANK ************************************************************
1397               *
1398               * General bank return routine (32KB ROM, i.e., 4 banks)---
1399               *   --put in scratchpad or low RAM
1400               *   --called by
1401               *       B   @RTBANK
1402               *
1403      397C     RTBANK EQU  $LO+$-LLVSPT
1404 6A9C C33E  30        MOV  *R+,CRU         ; pop return bank# from return stack to R12
1405 6A9E 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1406 6AA0 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6AA2 6000     
1407 6AA4 C2FE  30        MOV  *R+,LINK        ; pop return address from return stack
1408 6AA6 04DC  26        CLR  *CRU            ; switch to destination bank
1409 6AA8 045B  20        B    *LINK           ; branch to return address
1410               ;]*
1411               ;[*** BLF2A *************************************************************
1412               *
1413               * High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
1414               * banks) that is expected to return to bank0 via RTNEXT.  This will
1415               * only(?) be used for the ALC payload of Forth stubs in bank0---
1416               *   --put in scratchpad or low RAM
1417               *   --called by
1418               *       BL    @BLF2A
1419               *       DATA  dst_addr - >6000 + bank# in left 2 bits
1420               *
1421      398A     BLF2A  EQU  $LO+$-LLVSPT
1422 6AAA C2DB  26        MOV  *LINK,LINK      ; copy destination bank address to R11
1423 6AAC C30B  18        MOV  LINK,CRU        ; copy it to R12
1424 6AAE 024B  22        ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
     6AB0 1FFF     
1425 6AB2 022B  22        AI   LINK,>6000      ; make it a real address
     6AB4 6000     
1426 6AB6 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1427 6AB8 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6ABA 6000     
1428 6ABC 04DC  26        CLR  *CRU            ; switch to destination bank
1429 6ABE 045B  20        B    *LINK           ; branch to destination address
1430               ;]*
1431               ;[*** RTNEXT ************************************************************
1432               *
1433               * High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4
1434               * banks)---
1435               *   --put in scratchpad or low RAM
1436               *   --called by
1437               *       B   @RTNEXT
1438               *
1439      39A0     RTNEXT EQU  $LO+$-LLVSPT
1440 6AC0 C320  34        MOV  @INTACT,CRU       Are we in user's ISR?
     6AC2 3956     
1441 6AC4 1602  14        JNE  RTNXT1            Don't enable interrupts if so.
1442 6AC6 0300  24        LIMI 2
     6AC8 0002     
1443 6ACA 04E0  34 RTNXT1 CLR  @>6006          ; switch to bank 0
     6ACC 6006     
1444 6ACE 045F  20        B    *NEXT           ; branch to next CFA (in R15)
1445               ;]*
1446               ;[*** BLA2F *************************************************************
1447               *
1448               * ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
1449               * banks) that is expected to return to calling bank via RTA2F---
1450               *   --put in scratchpad or low RAM
1451               *   --called by
1452               *       BL    @BLA2F
1453               *       DATA <Forth cfa in bank0>
1454               *
1455      39B0     BLA2F  EQU  $LO+$-LLVSPT
1456 6AD0 064E  14        DECT R               ; reserve space on return stack
1457 6AD2 C2BB  30        MOV  *LINK+,W        ; move CFA of Forth routine to W
1458 6AD4 C78B  30        MOV  LINK,*R         ; push return address of calling bank
1459 6AD6 064E  14        DECT R               ; reserve space on return stack
1460 6AD8 C7A0  46        MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
     6ADA 7FFE     
1461 6ADC 064E  14        DECT R               ; reserve spot on return stack
1462 6ADE C78D  30        MOV  IP,*R           ; move current IP to return stack
1463 6AE0 020D  20        LI   IP,RTA2F        ; move address of return procedure to IP
     6AE2 39CC     
1464 6AE4 04E0  34        CLR  @>6006          ; switch to bank0
     6AE6 6006     
1465 6AE8 0460  28        B    @DOEXEC         ; Execute the Forth routine
     6AEA 833C     
1466               ;]*
1467               ;[*** RTA2F *************************************************************
1468               *
1469               * ALC to high-level Forth bank "return" routine from Forth to calling
1470               * ALC (32KB ROM, i.e., 4 banks)---
1471               *   --put in scratchpad or low RAM
1472               *   --called through B *NEXT at end of Forth word's execution in BLA2F
1473               *
1474      39CC     RTA2F  EQU  $LO+$-LLVSPT
1475 6AEC 39CE            DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
1476 6AEE 39D0            DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
1477 6AF0 C37E  30        MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
1478               * Retrieve ALC return info and return to caller...
1479               * ...caller will execute B *NEXT when it finishes
1480 6AF2 0460  28        B    @RTBANK         ; branch to general bank return routine above
     6AF4 397C     
1481               ;]*
1482               ;]***********************************************************************
1483               ;[*++ Bank-specific cell-/byte-reading code ++*
1484               ;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
1485               *++ Read cell contents of address in Bank bank# or RAM.
1486               *++ Register inputs:
1487               *++     R0:  bank-switch address
1488               *++     R1:  address in bank# to be read
1489               
1490      39D6     _BKAT  EQU  $LO+$-LLVSPT
1491 6AF6 04D0  26        CLR  *R0             ; switch banks
1492 6AF8 C651  38        MOV  *R1,*SP         ; get cell contents of address to stack
1493 6AFA 0460  28        B    @RTNEXT         ; return to inner interpreter
     6AFC 39A0     
1494               ;]*
1495               ;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
1496               *++ Read byte contents of address in Bank bank# or RAM.
1497               *++ Register inputs:
1498               *++     R0:  bank-switch address
1499               *++     R1:  address in bank# to be read
1500               
1501      39DE     _BKCAT EQU  $LO+$-LLVSPT
1502 6AFE 04D0  26        CLR  *R0             ; switch banks
1503 6B00 04C2  14        CLR  R2              ; clear R2
1504 6B02 D811  46        MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
     6B04 8305     
1505 6B06 C642  30        MOV  R2,*SP          ; get byte contents of address to stack
1506 6B08 0460  28        B    @RTNEXT         ; return to inner interpreter
     6B0A 39A0     
1507               
1508               ;]*
1509               
1510               ;]*
1511               *         _______   __  _________      ___          __
1512               *        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
1513               *       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
1514               *      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, /
1515               *                                                  /___/
1516               *
1517               ;[*** SAMS! ***      ( --- )
1518               * This calls the SAMS initialization in the startup code in bank 1.
1519               *
1520               *        DATA SMSQ_N
1521               * SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
1522               * SAMSST DATA $+2
1523               *        BL   @BLF2A
1524               *        DATA _SMSST->6000+BANK1
1525               
1526 6B0C 06A0  32 _SMSST BL   @SMSINI           initialize SAMS card
     6B0E 610C     
1527 6B10 0460  28        B    @RTNEXT           back to inner interpreter
     6B12 39A0     
1528               ;]*
1529               ;[*== Required strings, tables, variables... ============================
1530               *
1531               *
1532               * Default blocks filename
1533               *
1534      39F4     DEFNAM EQU  $LO+$-LLVSPT
1535 6B14 0C              BYTE 12
1536 6B15   44            TEXT "DSK1.FBLOCKS "
     6B16 534B     
     6B18 312E     
     6B1A 4642     
     6B1C 4C4F     
     6B1E 434B     
     6B20 5320     
1537               *
1538               * Default colors for all VDP modes---
1539               *     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
1540               *     LSB: Color Table colors (FG/BG)
1541               *
1542      3A02     DEFCOL EQU  $LO+$-LLVSPT
1543 6B22 4F00            DATA >4F00          ; TEXT80    offset=0
1544 6B24 4F00            DATA >4F00          ; TEXT      offset=2
1545 6B26 F4F4            DATA >F4F4          ; GRAPHICS  offset=4
1546 6B28 11F4            DATA >11F4          ; MULTI     offset=6
1547 6B2A FE10            DATA >FE10          ; GRAPHICS2 offset=8
1548 6B2C FEF4            DATA >FEF4          ; SPLIT     offset=10
1549 6B2E FEF4            DATA >FEF4          ; SPLIT2    offset=12
1550               *
1551               * Default text mode
1552               *
1553      3A10     DEFTXT EQU  $LO+$-LLVSPT
1554 6B30 0001            DATA >0001
1555               *
1556               * Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
1557               *
1558      3A12     FNTFLG EQU  $LO+$-LLVSPT
1559 6B32 0000            DATA 0              ; font flag initially 0
1560               *
1561               * Speech variables needing initial value (more below LLVEND)
1562               *
1563      3A14     SPCSVC EQU  $LO+$-LLVSPT
1564 6B34 0000            DATA 0
1565               *
1566               * Sound Table #1 Workspace for sound variables.  Only using R0..R4
1567               *
1568      3A16     SND1WS EQU  $LO+$-LLVSPT
1569      3A16     SND1ST EQU  SND1WS         R0 (sound table status) 0=no table; 1=loading sound...
1570 6B36 0000            DATA 0              ...bytes; -1=counting
1571      3A18     SND1DS EQU  SND1WS+2       R1 (sound-table byte destination)...
1572 6B38 8400            DATA SOUND          ...initialized to sound chip
1573      3A1A     SND1AD EQU  SND1WS+4       R2 (sound table address)
1574 6B3A 0000            DATA 0
1575      3A1C     SND1CT EQU  SND1WS+6       R3 (# of sound bytes to load or...
1576 6B3C 0000            DATA 0              ...sound count = seconds * 60)
1577      3A1E     SND1SP EQU  SND1WS+8       R4 (pointer to top of sound stack)
1578 6B3E 3AE4            DATA SNDST0         initialized to bottom of sound stack
1579               *
1580               * Sound Table #2 Workspace for sound variables.  Only using R0..R3
1581               *
1582      3A20     SND2WS EQU  $LO+$-LLVSPT
1583      3A20     SND2ST EQU  SND2WS         R0 (sound table status) 0=no table  ; 1=loading sound...
1584 6B40 0000            DATA 0              ...bytes; -1=counting
1585      3A22     SND2DS EQU  SND2WS+2       R1 (sound-table byte destination)...
1586 6B42 8400            DATA SOUND          ...initialized to sound chip
1587               ;]*
1588               *
1589               * This is the end of low-level support code that gets copied.
1590               *
1591               LLVEND
1592               
1593               ;[*== Un-initialized Variables and workspaces... =========================
1594               * Start of definitions of variables and workspaces that do not need to
1595               * take up space in ROM because they need no initial values.
1596               *
1597               * Sound Table #2 Workspace for sound variables..continued.
1598               *
1599      3A24     SND2AD EQU  SND2WS+4       R2 (sound table address)
1600      3A26     SND2CT EQU  SND2WS+6       R3 (# of sound bytes to load or...
1601               *                          ...sound count = seconds * 60)
1602      3A28     SDMUTE EQU  SND2WS+8       dummy destination for sound byte
1603               *
1604               * Branch Stack for ISR processing of Speech, 2 Sound Tables and return
1605               *
1606      3A2A     BRSTK  EQU  SDMUTE+2
1607               *
1608               * Speech variables (more above LLVEND)
1609               *
1610      3A32     SSFLAG EQU  BRSTK+8
1611      3A34     SPCNT  EQU  SSFLAG+2
1612      3A36     SPADR  EQU  SPCNT+2
1613      3A38     BANKSV EQU  SPADR+2
1614      3A3A     PADSV  EQU  BANKSV+2
1615               *
1616               * Panel window: height, width and screen position...used by PANEL and SCROLL
1617               *
1618      3A46     PANWIN EQU  PADSV+12          panel height, width and screen start
1619               
1620               *== Utility Workspace =================================================
1621               *** General utility workspace registers
1622      3A4C     UTILWS EQU  PANWIN+6
1623      3A51     U_R2LB EQU  UTILWS+5
1624               
1625      3A6C     LINBUF EQU  UTILWS+32
1626      3ABC     CURCHR EQU  LINBUF+80
1627               
1628               *++ variable used by the 40/80-column editor
1629      3ABE     OLDCUR EQU  CURCHR+2
1630               
1631               *++ FILE I/O variables
1632               
1633      3AC6     PBADR  EQU  OLDCUR+8
1634      3AC8     PBBF   EQU  PBADR+2
1635      3ACA     PBVBF  EQU  PBBF+2
1636               
1637               *++ Floating Point Math Library variables
1638      3ACC     FPVARS EQU  PBVBF+2
1639               
1640               *++ SAMS flag
1641      3AE2     SAMSFL EQU  FPVARS+22
1642               
1643               *++ Bottom of Sound Stack
1644               *++      This location marks the top of the low-level support code. The Sound
1645               *++      Stack grows upward toward the Return Stack by moving the entire stack
1646               *++      up one cell to make room for the next new bottom entry.
1647      3AE4     SNDST0 EQU  SAMSFL+2
1648               ;]*

...lee

ralphb · August 28, 2020

It's only a guess, but I think the AORG followed immediately by BANK could be confusing the move. I assume you didn't include to code to copy the XORG range?

Also, how do you know where the end of the XORG range is? I'd attach labels to XORG and AORG, and use those labels as boundaries for the code to copy.

+Lee Stewart · August 28, 2020

5 hours ago, ralphb said:

It's only a guess, but I think the AORG followed immediately by BANK could be confusing the move. I assume you didn't include to code to copy the XORG range?

If I do not follow AORG with BANK, the same thing that happened to DORG is the result. The copy code is in the file that precedes this one and it uses the labels described below.

5 hours ago, ralphb said:

Also, how do you know where the end of the XORG range is? I'd attach labels to XORG and AORG, and use those labels as boundaries for the code to copy.

The XORG range is bracketed with labels LLVSPT above it and LLVEND below it. Those labels are, in fact, attached to the XORG and AORG directives, respectively (just not visually), because there is no machine code generated between label and directive. ~~Those labels also have proper ROM addresses: LLVSPT = >6140 and LLVEND = >6B44.~~ [EDIT: Actually, I was wrong! LLVSPT was >6140, a proper ROM address, but the symbol list showed LLVEND to have >3A24! More info in a later post.]

...lee

Edited August 28, 2020 by Lee Stewart
Correction

HOME AUTOMATION · August 28, 2020

6 hours ago, Lee Stewart said:

Here is the XORGed code:

Reveal hidden contents



*     __                  __                __
*    / /  ___ _    ______/ /  ___ _  _____ / /
*   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) / 
*  /____/\___/__,__/   /____/\__/|___/\__/_/  
*                     ____                        __ 
*                    / __/_ _____  ___  ___  ____/ /_
*                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
*                  /___/\_,_/ .__/ .__/\___/_/  \__/ 
*                          /_/  /_/                  
* 
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                   *
* fbForth---                                                        *
*                                                                   *
*       Low-level support routines                                  *
*                                                                   *
*  << Including Trampoline Code, tables & variables:  2606 bytes >> *
*                                                                   *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

LLVSPT   ; <--This is the source copy location for the rest of this code.

$BUFF  EQU  >2010
 
* 4 I/O buffers below ($LO = >3020) 
* Change '4' to number of buffers needed and for which there is room.

$LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers

       XORG $LO      ; calculate destination addresses

*       _____   ____         __  __      ___________ 
*      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
*     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
*    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_| 
*
;[*** Interrupt Service =======================================================
* This routine is executed for every interrupt.  It processes any pending
* speech and souind.  It then looks to see whether a user ISR is installed in 
* ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work 
* only if the user has installed an ISR using the following steps in the fol-
* lowing order:
*
*   (1) Write an ISR with entry point, say MYISR.
*   (2) Determine code field address of MYISR with this high-level Forth:
*           ' MYISR CFA
* <<< Maybe need a word to do #3 >>>
*   (3) Write CFA of MYISR into user variable ISR.
*
* Steps (2)-(3) in high-level Forth are shown below:
*           ' MYISR CFA
*           ISR !
* 
* <<< Perhaps last step above should be by a word that disables interrupts >>>
*
* The console ISR branches to the contents of >83C4 because it is non-zero,
* with the address, INT1, of the fbForth ISR entry point below (also, the
* contents of INTLNK).  This means that the console ISR will branch to INT1
* with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
* process any pending speech and sound.
* 
* If the user's ISR is properly installed, the code that processes the user
* ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
* from Forth's workspace (MAINWS), the code at INT2 will process the user's
* ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
* inner interpreter.
*** ==========================================================================

* ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!

INT1   
       LI   R0,BRSTK          load address of top of Branch Address Stack
* 
* Set up for pending speech
*
       MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
       JEQ  SNDCH1            jump to sound-check if no speech
       INCT R0                increment Branch Stack
*
* Set up for pending sound table #1 (ST#1)
*
SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
       JEQ  SNDCH2            process speech and sound if needed
       LI   R1,x#PLAYT1         load PLAYT1 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
* 
* Set up for pending sound table #2 (ST#2)
*
SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
       JEQ  PRCSPS            process speech and sound if needed
       LI   R1,x#PLAYT2         load PLAYT2 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
*
* Process sound stack if both sound tables idle
*
PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
       JNE  PRSPS2            nope..skip sound stack processing
       LWPI SND1WS            switch to ST#1 WS
       CI   R4,SNDST0         anything on sound stack?
       JEQ  PRSPS1            no..exit sound stack processing
       DECT R4                pop sound stack position
       MOV  *R4,R2            get sound table address from sound stack
       INC  R0                kick off sound processing of ST#1 (R0=1)
PRSPS1 LWPI GPLWS             switch back to GPL WS
* 
* Check for any pending speech and sound
*
PRSPS2 CI   R0,BRSTK          any speech or sound to process?
       JEQ  USRISR            if not, jump to user ISR processing
       LI   R1,BNKRST         yup..load return address
       MOV  R1,*R0            push return address onto Branch Stack
* 
* Process pending speech and sound
*
       MOV  @x#MYBANK,@BANKSV   save bank at interrupt
       CLR  @>6002            switch to bank 2 for speech & sound services
       LI   R7,BRSTK          load top of Branch Stack
       MOV  *R7+,R8           pop speech/sound ISR
       B    *R8               service speech/sound
*
* Restore interrupted bank
*
BNKRST                ; return point for speech and sound ISRs
       MOV  @BANKSV,R0        restore bank at interrupt
       SRL  R0,13             get the bank# to correct position
       AI   R0,>6000          make it a real bank-switch address
       CLR  *R0               switch to the bank at interrupt
*
* Process User ISR if defined
*
USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
       JEQ  INTEX             
*
* Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
* is executed from Forth's WS (MAINWS = >8300), which it does at the end of
* every CODE word, keyboard scan and one or two other places.
* 
       LI   R1,INT2                 Load entry point, INT2
       MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
* 
* The following 2 instructions are copies of the remainder of the console ROM's
* ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
* because we're not going back there!
* 
INTEX  LWPI >83C0             Change to console's ISR WS  
       RTWP                   Return to caller of console ISR
* 
* Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
* before executing user's ISR. INT3 (cleanup routine below) will be inserted
* in address list to get us back here for cleanup after user's ISR has finished.
* User's ISR is executed at the end of this section just before INT3.
* 
INT2   LIMI 0                 Disable interrupts
       MOVB @>83D4,R0         Get copy of VR01
       SRL  R0,8              ...to LSB
       ORI  R0,>100           Set up for VR01
       ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
       BLWP @VWTR             Turn off VDP interrupt
       LI   NEXT,$NEXT        Restore NEXT
       SETO @INTACT           Set Forth "pending interrupt" flag
       DECT R                 Set up return linkage by pushing 
       MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
       LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
       MOV  @$ISR(U),W        Do the user's Forth ISR by executing
       B    @DOEXEC           ...it through Forth's inner interpreter
* 
* Clean up and re-enable interrupts.
*
INT3   DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
       DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
       MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
       CLR  @INTACT           Clear Forth "pending interrupt" flag
       MOVB @>83D4,R0         Prepare to restore VR01 by...
       SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
       AI   R0,>100           ...VR # (01) to MSB
       MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
       BLWP @VWTR             Write VR01
       LIMI 2                 Re-enable interrupts
       B    *NEXT             Continue normal task
;]*
;[*** BKLINK from SYSTEM calls ==========================================
*
BKLINK MOV  @INTACT,R7        Are we in user's ISR?
       JNE  BKLIN1            Don't enable interrupts if so.
       LIMI 2
BKLIN1 B    *LINK
;]*
*      ____         __              _____     ____  
*     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
*    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
*   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
*       /___/                                          
* 
;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================

*       Entry point for low-level system support functions

$SYS$  LIMI 0
       MOV  @SYSTAB(R1),R0
       B    *R0
;]
;[*** SYSTAB -- Vector table for SYSTEM calls ===========================

       DATA BRW          CODE = -20  write block to blocks file
       DATA BRW          CODE = -18  read block from blocks file
       DATA BRW          CODE = -16  create blocks file
       DATA BRW          CODE = -14  use blocks file
       DATA GXY          CODE = -12  GOTOXY
       DATA QKY          CODE = -10  ?KEY
       DATA QTM          CODE =  -8  ?TERMINAL
       DATA CLF          CODE =  -6  CRLF
       DATA EMT          CODE =  -4  EMIT
       DATA KY           CODE =  -2  KEY
SYSTAB DATA SBW          CODE =   0  VSBW
       DATA MBW          CODE =   2  VMBW
       DATA SBR          CODE =   4  VSBR
       DATA MBR          CODE =   6  VMBR
       DATA WTR          CODE =   8  VWTR
       DATA GPL          CODE =  10  GPLLNK
       DATA XML          CODE =  12  XMLLNK
       DATA DSR          CODE =  14  DSRLNK
       DATA CLS$         CODE =  16  CLS
       DATA MVE          CODE =  18  VMOVE
       DATA FILL$        CODE =  20  VFILL
       DATA AOX          CODE =  22  VAND
       DATA AOX          CODE =  24  VOR
       DATA AOX          CODE =  26  VXOR
;]*
;[*== VDP single byte write.                CODE =   0  =================
*
SBW    MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         Character to write
       SWPB R1              Get in left byte
       BLWP @VSBW
       B    @BKLINK
;]*
;[*== VDP multi byte write.                 CODE =   2  =================
*
MBW    MOV  *SP+,R2         Number of bytes to move
       MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         RAM address (source)
       BLWP @VMBW
       B    @BKLINK
;]*
;[*== VDP single byte read.                 CODE =   4  =================
*
SBR    MOV  *SP,R0          VRAM address (source)
       BLWP @VSBR
       SRL  R1,8            Character to right half for Forth
       MOV  R1,*SP          Stack it
       B    @BKLINK
;]*
;[*== VDP multi byte read.                  CODE =   6  =================
*
MBR    MOV  *SP+,R2         Number of bytes to read
       MOV  *SP+,R1         RAM address (destination)
       MOV  *SP+,R0         VRAM address (source)
       BLWP @VMBR
       B    @BKLINK
;]*
;[*== VDP-to-VDP move.                      CODE =  18  =================
*
MVE    MOV  *SP+,R0         Pop cnt to R0
       MOV  *SP+,R2         Pop vdst to R2
       MOV  *SP+,R1         Pop vsrc to R1
       BLWP @VMOVE
       B    @BKLINK
;]*
;[*== VDP register write.                   CODE =   8  =================
*
WTR    MOV  *SP+,R1         VDP register number
       MOV  *SP+,R0         Data for register
       SWPB R1              Get register to left byte
       MOVB R1,R0           Place with data
       BLWP @VWTR
       B    @BKLINK
;]*
;[*== GPL link utility.                     CODE =  10  =================
*
GPL    CLR  R0
       MOVB R0,@KYSTAT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,GPLLNK         to the GPLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== XML link utility.                     CODE =  12  =================
*
XML    LI   R0,>0420        Construct the BLWP instruction
       LI   R1,XMLLNK         to the XMLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== DSR link utility.                     CODE =  14  =================
*
DSR    LI   R0,>0420        Construct the BLWP instruction
       LI   R1,DSRLNK         to the DSRLNK utility
       MOV  *SP+,R2         This datum selects DSR or subroutine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== Screen clearing utility.              CODE =  16  =================
*
CLS$   MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
       MOV  @$SEND(U),R1    End of screen in VRAM
       S    R2,R1           Screen size
       LI   R0,>2000        Blank character
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== VDP fill routine.                     CODE =  20  =================
*
FILL$  MOV  *SP+,R0         Fill character
       SWPB R0                to left byte
       MOV  *SP+,R1         Fill count
       MOV  *SP+,R2         Address to start VRAM fill
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
*========================================================================
FILL1          ; R0=char, R1=cnt, R2=vaddr
       ORI  R2,>4000        Set bit for VDP write
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
FLOOP  MOVB R0,@VDPWD       Write a byte
       DEC  R1
       JNE  FLOOP           Not done, fill another
       B    *LINK
;]*======================================================================
*
*==== VAND -- VDP byte AND routine.         CODE =  22  =================
*==== VOR -- VDP byte OR routine.           CODE =  24  =================
;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
*
AOX    MOV  *SP+,R2         VRAM address
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
       MOVB @VDPRD,R3       Read byte
       MOV  *SP+,R0         Get data to operate with
       SWPB R0                to left byte
*** Now do requested operation *****************
       CI   R1,24
       JEQ  DOOR
       JGT  DOXOR
       INV  R3              These two instructions
       SZC  R3,R0             perform an 'AND'
       JMP  FINAOX
DOOR   SOC  R3,R0             perform 'OR'
       JMP  FINAOX
DOXOR  XOR  R3,R0             perform 'XOR'
FINAOX LI   R1,1
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== KEY routine                           CODE =  -2  =================
*
KY    MOV  @$ALTI(U),R0      alternate input device?
       JEQ  KEY0              jump to keyboard input if not
*
*  R0 now points to PAB for alternate input device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to read one byte.
*
       CLR  R7                prepare to zero status byte
       MOVB R7,@KYSTAT        zero status byte
       INC  R0                point R0 to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       MOV  R0,R1             Set up pointer...
       AI   R1,8              ...to namelength byte of PAB
       MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
       MOV  R0,R3             save pointer (DSRLNK will trash it!)
       BLWP @DSRLNK           get 1 byte from device
       DATA >8
       MOV  R3,R0             restore pointer
       DECT R0                point to one-byte VRAM buffer in front of PAB
       BLWP @VSBR             read character
       SRL  R1,8              move to LSB
       MOV  R1,R0             copy to return register
       B    @BKLINK           return to caller
*
*  Input is comining from the keyboard
*
KEY0   MOV  @KEYCNT,R7
       INC  R7
       JNE  KEY1
       MOV  @CURPO$(U),R0
       BLWP @VSBR             Read character at cursor position...
       MOVB R1,@CURCHR        ...and save it
       LI   R1,>1E00          Place cursor character on screen
       BLWP @VSBW
*
KEY1   BLWP @KSCAN
       MOVB @KYSTAT,R0
       COC  @H2000,R0         check status
       JEQ  KEY2              JMP if key was pressed
*
       CI   R7,100            No key pressed
       JNE  KEY3
       MOVB @CURCHR,R1
       JMP  KEY5
*
KEY3   CI   R7,200
       JNE  KEY4
       CLR  R7
       LI   R1,>1E00          Cursor char
KEY5   MOV  @CURPO$(U),R0
       BLWP @VSBW
KEY4   MOV  R7,@KEYCNT
       MOV  @INTACT,R7        Are we in user's ISR?
       JNE  KEY6              Don't enable interrupts if so.
       LIMI 2
KEY6   DECT IP                This will re-execute KEY
       B    *NEXT
KEY2   SETO @KEYCNT           Key was pressed
       MOV  @CURPO$(U),R0     Restore character at cursor location
       MOVB @CURCHR,R1
       BLWP @VSBW
       MOVB @KYCHAR,R0        Put char in...
       SRL  R0,8              ...LSB of R0
       B    @BKLINK
;]*
;[*== EMIT routine                          CODE =  -4  =================
*
EMT    MOV  R2,R1             copy char to R1 for VSBW
       MOV  @$ALTO(U),R0      alternate output device?
       JEQ  EMIT0             jump to video display output if not
*
*  R0 now points to PAB for alternate output device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to write one byte.
*
       CLR  R7                ALTOUT active
       MOVB R7,@KYSTAT        zero status byte
       DEC  R0                point to one-byte VRAM buffer in front of PAB
       SWPB R1                char to MSB
       BLWP @VSBW             write char to buffer
       INCT R0                point to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       AI   R0,8              Set up pointer to namelength byte of PAB
       MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
       BLWP @DSRLNK           put 1 byte to device
       DATA >8                
       B    @BKLINK           return to caller
*
*  Output is going to the video display
*
EMIT0  CI   R1,7            Is it a bell?
       JNE  NOTBEL
       CLR  R2
       MOVB R2,@KYSTAT
       BLWP @GPLLNK
       DATA >0036           Emit error tone
       JMP  EMEXIT
*
NOTBEL CI   R1,8            Is it a backspace?
       JNE  NOTBS
       LI   R1,>2000
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       JGT  DECCUR
       JMP  EMEXIT
DECCUR DEC  @CURPO$(U)
       JMP  EMEXIT
*
NOTBS  CI   R1,>A           Is it a line feed?
       JNE  NOTLF
       MOV  @$SEND(U),R7
       S    @$SWDTH(U),R7
       C    @CURPO$(U),R7
       JHE  SCRLL
       A    @$SWDTH(U),@CURPO$(u)
       JMP  EMEXIT
SCRLL  MOV  LINK,R7
       BL   @SCROLL
       MOV  R7,LINK
       JMP  EMEXIT
*
*** SCROLLING ROUTINE
*
SCROLL MOV  @$SSTRT(U),R0   VRAM addr
       LI   R1,LINBUF       Line buffer
       MOV  @$SWDTH(U),R2   Count
       A    R2,R0           Start at line 2
SCROL1 BLWP @VMBR
       S    R2,R0           One line back to write
       BLWP @VMBW
       A    R2,R0           Two lines ahead for next read
       A    R2,R0
       C    R0,@$SEND(U)    End of screen?
       JL   SCROL1
       MOV  R2,R1           Blank bottom row of screen
       LI   R0,>2000        Blank
       S    @$SEND(U),R2
       NEG  R2              Now contains address of start of last line
       MOV  LINK,R6
       BL   @FILL1          Write the blanks
       B    *R6
*
NOTLF  CI   R1,>D           Is it a carriage return?
       JNE  NOTCR
       CLR  R0
       MOV  @CURPO$(U),R1
       MOV  R1,R3
       S    @$SSTRT(U),R1   Adjusted for screen not at 0
       MOV  @$SWDTH(U),R2
       DIV  R2,R0
       S    R1,R3
       MOV  R3,@CURPO$(U)
       JMP  EMEXIT
*
NOTCR  SWPB R1              Assume it is a printable character
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       MOV  @$SEND(U),R2
       DEC  R2
       C    R0,R2
       JNE  NOTCR1
       MOV  @$SEND(U),R0
       S    @$SWDTH(U),R0   Was last char on screen. Scroll
       MOV  R0,@CURPO$(U)
       JMP  SCRLL
NOTCR1 INC  R0              No scroll necessary
       MOV  R0,@CURPO$(U)
*
EMEXIT B    @BKLINK
;]*
;[*== CRLF routine                          CODE =  -6  =================
*
CLF    MOV  LINK,R5
       LI   R2,>000D
       BL   @EMT            EMT will alter INT mask via B @BKLINK
       LI   R2,>000A
       LIMI 0               Previous call to EMT altered INT mask
       BL   @EMT
       MOV  R5,LINK
       B    @BKLINK
;]*
;[*== ?TERMINAL routine                     CODE =  -8  =================
* scan for <clear>, <break>, FCTN+4 press
*
QTM    MOV  LINK,R5         save return
       BL   @>0020          branch to console's test for <clear>
       STST R0              store status in R0
       JNE  QTM2            exit if not <clear>
QTM1   BL   @>0020          check for <clear> again
       JEQ  QTM1            loop until not <clear>
QTM2   MOV  R5,LINK         restore return
       ANDI R0,>2000        keep only EQU bit
       B    @BKLINK         return to caller
;]*
;[*== ?KEY routine                          CODE = -10  =================
*
QKY    BLWP @KSCAN
       MOVB @KYCHAR,R0
       SRL  R0,8
       CI   R0,>00FF
       JNE  QKEY1
       CLR  R0
QKEY1  B    @BKLINK
;]*
;[*== GOTOXY routine                        CODE = -12  =================
*
GXY    MPY  @$SWDTH(U),R3
       A    R2,R4           Position within screen
       A    @$SSTRT(U),R4   Add VRAM offset to screen top
       MOV  R4,@CURPO$(U)
       B    @BKLINK
;]
*       ___  __         __     ____  ______ 
*      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
*     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
*    /____/_/\___/\__/_/\_\ /___/_/  \____/ 

*
*== USE blocks file                         CODE = -14  =================
*== CREATE blocks file                      CODE = -16  =================
*== READ block from blocks file             CODE = -18  =================
*== WRITE block to blocks file              CODE = -20  =================
;[*== Block File I/O Support ============================================
*
* BPTOG utility to toggle one of 2 PABs for block file access
*
BPTOG  MOV  @$BPOFF(U),R0	   PAB offset to R0
       LI	R1,70	            Toggle amount
       XOR	R0,R1	            New offset
       MOV	R1,@$BPOFF(U)	   Update offset
*
**xxx** entry point to insure we have correct PAB address
BPSET  MOV  @$DKBUF(U),R0	   Get DISK_BUF address
       A	   @$BPABS(U),R0	   Get BPABS address
*
       A	   @$BPOFF(U),R0     Add current offset
       MOV	R0,@BFPAB	      Update current block file's PAB address
       RT	 	 
*
* CLOSE blocks file
*
BKCLOS MOV  @BFPAB,R0
       LI   R1,$FCLS          Opcode=CLOSE
       BLWP @VSBW
       AI   R0,9              Address of filename's char count
       MOV  R0,@SUBPTR        Point to filename's char count
       BLWP @DSRLNK           Close the file
       DATA 8
       RT                     Deal with error in caller
*
* storage area
*
SVBRET DATA 0                 Storage for LINK coming into BRW
BFPAB  DATA	0	               Storage for current blocks file PAB address...
*	 	 	                     ...will have current PAB on entry
* PAB header storage
*
PABHD  BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
*              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
*	                	                 >03=OUTPUT mode + "
*	                	                 >01=UPDATE mode + "
*	                         BYTE 2,3: save contents of DISK_BUF here
       BYTE	>80	            Record length
       BYTE	>80	            Character count of transfer
       BSS	2	            Record number
*
*** file I/O equates
*
$FOPN  EQU  >0000
$FCLS  EQU  >0100
$FRD   EQU  >0200
$FWRT  EQU  >0300
$FRST  EQU  >0400
$FINP  EQU  5
$FOUT  EQU  3
$FUPD  EQU  1
*
*** BRW -- entry point for block read/write routines
*
BRW    MOV  LINK,@SVBRET   Save LINK address
       MOV	R1,R7	         Save CODE {R1 to R7}
       SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
       AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
       BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
       CI	R7,4	         USE or CREATE?
       JLT	BRW01	         No
       BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
       MOV	@BFPAB,R0	   Load PAB address
       AI	R0,9	         Set to name length byte
       CLR	R2	 
       MOV	*SP+,R1	      Pop bfnaddr to R1
       MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
       INC	R2	            Add 1 to # bytes to copy
       BLWP	@VMBW	         Copy char count & pathname to PAB
*
*** set up PAB for OPEN 
*
BRW01  LI	R1,$FUPD                Opcode=0,mode=update
       CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
       JOP  BRW02                   No
       LI	R1,$FINP                Yes...change mode=input
BRW02  MOV  R1,@PABHD               Put in PAB header
       MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
       CLR  R0
       MOV  R0,@PABHD+6             Set record#=0
       MOV  @BFPAB,R0               VRAM destination
       LI   R1,PABHD                RAM source
       LI   R2,8                    Copy first 8 bytes of PAB header
       BLWP @VMBW                   Do the copy
*
*** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
*
       AI   R0,9                Address of filename's char count in PAB
       MOV  R0,@SUBPTR          Point to-----^^^^
       BLWP @DSRLNK             Open/create the file
       DATA 8
       JEQ  BKERR
       CI   R7,4                READ or WRITE?
       JLT  BRW04               Yes
       JGT  BRWDON              No; =USE; we're done
*
*** write blank records to newly created blocks file [CODE = -16,CREATE]
*
       MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
       SLA  R5,3                Convert #blocks to #records
       MOV  R5,R3               Save
       MOV  R5,R4               Set up counter
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       MOV  R0,@PABHD           Copy to PAB header
BRLOOP S    R4,R5               Calculate next record
       MOV  R5,@PABHD+6         Copy to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       AI   R0,9                Address of filename's char count
       MOV  R0,@SUBPTR          Point to filename's char count
       BLWP @DSRLNK             Write one record of blanks
       DATA 8
       JEQ  BKERR
       MOV  R3,R5               Get #blocks
       DEC  R4                  Count down 1 record
       JNE  BRLOOP              Write another record if not done
       JMP  BRWDON              We're done
*
*** prepare for read/write block
*
BRW04  MOV  *SP+,R5             Pop block# to write
       MOV  *SP+,R6             Pop bufaddr
       DEC  R5                  Block#-1
       SLA  R5,3                Convert to starting record#
       LI   R4,8                Load counter for 8 records
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       LI   R3,VMBW             WRITE vector
       CI   R7,2                Are we writing the block?
       JEQ  BRW05               Yup
       LI   R0,$FRD+$FINP       Nope...set up for READ
       LI   R3,VMBR             READ vector
BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
* 
* READ/WRITE block routine [CODE = -18/-20]
* 
RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0
       MOV  R6,R1               RAM buffer to R1
       LI   R2,128              Bytes to copy
       CI   R7,3                READ?
       JEQ  BRW06               Yup
       BLWP *R3                 Nope...copy record to VRAM
*
* temporarily use CRU register---it should be OK
*
BRW06  MOV  @BFPAB,CRU          PAB address
       AI   CRU,9               Address of filename's char count
       MOV  CRU,@SUBPTR         Point to filename's char count
       BLWP @DSRLNK             Read/write one record
       DATA 8
       JEQ  BKERR
       CI   R7,2                WRITE?
       JEQ  BRW07               Yup...next record
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
       BLWP *R3                 Nope...copy record to RAM buffer
BRW07  INC  R5                  Next record in file
       AI   R6,128              Next record to/from block RAM buffer
       DEC  R4                  Count down 1 record
       JNE  RWLOOP              Read/write another record if not done
       JMP  BRWDON              We're done
*
*** error handling
*
BKERR  MOVB R0,R0               Device error?
       JEQ  BKERR6              Yes, exit with disk error
BKERR9 LI   R6,9                No, exit with file error
       JMP  BKCLN
BKERR8 LI   R6,8                Block# <=0!  exit with range error
       JMP  BKCLN
BKERR6 LI   R6,6
BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
       CI   R7,4                USE or CREATE?
       JLT  BKCLN1              No
       BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
BKCLN1 MOV  R6,R0               Pass error back to caller
       JMP  BKEXIT
BRWDON CLR  R6
       BL   @BKCLOS             Close current blocks file
       JNE  BRWDN1              Error?
       LI   R6,9                Yes...assume it was a file error
BRWDN1 CI   R7,4                (no error)...CREATE?
       JNE  BRWDN2              No...we're done
       BL   @BPTOG              Yes...revert to correct blocks file
BRWDN2 MOV  R6,R0               Error to R0
BKEXIT MOV  @SVBRET,LINK        Restore LINK
       B    @BKLINK
;]
;[* MSGTYP      <<< Support for string typing in various banks >>>
*
* Called with:  BL  @MSGTYP
* 
* R4 and R5 are the only registers that will be preserved
* ..after a call to EMIT---
*
* Input:    R4 = Address of length byte of packed string
*
* We will pass the ASCII value of character to EMIT in R2 without
* insuring it is 7 bits wide.
*
MSGTYP DECT R           Push return address
       MOV  LINK,*R     ...to Forth return stack
       CLR  R5          
       MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
       SWPB R5          Put char count in low byte
MTLOOP CLR  R2
       MOVB *R4+,R2     Copy next char to R2 for EMIT
       SWPB R2          Put char in low byte
       LIMI 0           We need to do this because we're calling EMIT directly
       BL   @EMT        Call EMIT directly
       INC  @$OUT(U)    Increment display line character count
       DEC  R5          Decrement character count for this message
       JNE  MTLOOP      Are we done?
       MOV  *R+,LINK    Yes. Pop return address
       RT               Return to caller
 ;]      
;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
R4$5   MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4,*R5
       RT
;]
*     __  __              _   __         _      __   __   
*    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__ 
*   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
*   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/ 
*              ___      ___          ____    
*             / _ \___ / _/__ ___ __/ / /____
*            / // / -_) _/ _ `/ // / / __(_-<
*           /____/\__/_/ \_,_/\_,_/_/\__/___/

;[*== User Variable defaults ============================================
* 
UBASE0 BSS  6                 BASE OF USER VARIABLES
       DATA UBASE0            06 USER UCONS$
       DATA SPBASE            08 USER S0
       DATA RBASE             0A USER R0 { R0$
       DATA $UVAR             0C USER U0
       DATA SPBASE            0E USER TIB
       DATA 31                10 USER WIDTH
       DATA DPBASE            12 USER DP
       DATA $SYS$             14 USER SYS$
       DATA 0                 16 USER CURPOS
       DATA INT1              18 USER INTLNK
       DATA 1                 1A USER WARNING
       DATA 64                1C USER C/L$ { CL$
       DATA $BUFF             1E USER FIRST$
       DATA $LO               20 USER LIMIT$
       DATA >0380             22 USER COLTAB    Color Table address in VRAM
       DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
       DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
       DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
       DATA >80               2A USER FPB       pushes address of user screen font file PAB
*                                               ...that is this relative distance from DISK_BUF
       DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
       DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
       DATA 40                30 USER SCRN_WIDTH
       DATA 0                 32 USER SCRN_START
       DATA 960               34 USER SCRN_END
       DATA 0                 36 USER ISR       [Note: This used to be INT1]
       DATA 0                 38 USER ALTIN
       DATA 0                 3A USER ALTOUT
       DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
       DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
*                                               ...that is this relative distance from DISK_BUF
       DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
*                                               ...always toggled between 0 and 70
       DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
       DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
*                                                  0 = console font via GPLLNK
       DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
       DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
       DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
*                                                  0 = Symmetric (default)
*                                                 !0 = Floored
$UVAR  BSS  >80               USER VARIABLE AREA
;]
;[*== A Constant ====================================================
*
H2000  DATA >2000
;]*
*    __  ____  _ ___ __         _   __        __             
*   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
*  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
*  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
*                     /___/                                  
* 
;[*== Utility Vectors ===================================================
*
* GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
* DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
XMLLNK DATA UTILWS,XMLENT   ; Link to ROM routines
KSCAN  DATA UTILWS,KSENTR   ; Keyboard scan
VSBW   DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
VMBW   DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
VSBR   DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
VMBR   DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
VMOVE  DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
VWTR   DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
;]*
;[*== XMLENT -- Link to system XML utilities ============================
*
XMLENT MOV  *R14+,@GPLWS+2      Get argument
       LWPI GPLWS               Select GPL workspace
       MOV  R11,@UTILWS+22      Save GPL return address
       MOV  R1,R2               Make a copy of argument
       CI   R1,>8000            Direct address in ALC?
       JH   XML30               We have the address
       SRL  R1,12
       SLA  R1,1
       SLA  R2,4
       SRL  R2,11
       A    @XMLTAB(R1),R2
       MOV  *R2,R2
XML30  BL   *R2
       LWPI UTILWS              Get back to right WS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    ________  __   __   _  ____ __           __  ________
*   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
*  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
* This routine will work with any GROM library slot since it is         *
* indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
* This GPLLNK does NOT require a module to be plugged into the          *
* GROM port so it will work with the Editor/Assembler,                  *
* Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
* CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
* It saves and restores the current GROM Address in case you want       *
* to return back to GROM for Basic or Extended Basic CALL LINKs         *
* or to return to the loading module.                                   *
*                                                                       *
*    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
*                                                 DATA >34              *
*                                                                       *
*    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
*                                                                       *
* 70 Bytes - including the GPLLNK Workspace                             *
*-----------------------------------------------------------------------*

*  GPLWS (>83E0) is GPL workspace
G_R4   EQU  GPLWS+8              GPL workspace R4
G_R6   EQU  GPLWS+12             GPL workspace R6
*  SUBSTK (>8373) is GPL Subroutine stack pointer
LDGADR EQU  >60                  Load & Execute GROM address entry point
XTAB27 EQU  >200E                Low Mem XML table location 27
*                                ..Will contain XMLRTN at startup
GETSTK EQU  >166C              
 
GPLLNK DATA GLNKWS     ; R7       Set up BLWP Vectors
       DATA GLINK1     ; R8     
* RTNADR     <---don't think we need this label
       DATA XMLRTN     ; R9       address where GPL XML returns to us...
*                                ...this address will already be in XTAB27,...
*                                ...>200E, so don't really need it here}
GXMLAD DATA >176C      ; R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
       DATA >50        ; R11      Initialized to >50 where PUTSTK address resides
GLNKWS EQU  $->18      ; GPLLNK's workspace of which only...
       BSS  >08        ; R12-R15  ...registers R7 through R15 are used

GLINK1 MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
       MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
       LWPI GPLWS                Load GPL WS
       BL   *R4                  Save current GROM Address on stack
       MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
       INCT @SUBSTK              Adjust the stack pointer
       B    @LDGADR              Execute our GPL Routine

XMLRTN MOV  @GETSTK,R4           Get GETSTK pointer
       BL   *R4                  Restore GROM address off the stack
       LWPI GLNKWS               Load our WS
       RTWP                      All Done - Return to Caller
;]
*     ___  _______  __   _  ____ __           __  ________
*    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
*   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
*      (Uses console GROM 0's DSRLNK routine)                           *
*      (Do not REF DSRLNK or GPLLNK when using these routines)          *
*      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
*                                                                       *
*      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
*                                                   DATA 8              *
*                                                                       *
*      NOTES: Must be used with a GPLLNK routine                        *
*             Returns ERRORs the same as the E/A DSRLNK                 *
*             EQ bit set on return if error                             *
*             ERROR CODE in caller's MSB of Register 0 on return        *
*                                                                       *
* 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
*-----------------------------------------------------------------------*

PUTSTK EQU  >50                     Push GROM Address to stack pointer
TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
VWA    EQU  >8C02                   VDP Write Address location
VRD    EQU  >8800                   VDP Read Data byte location
G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
GSTAT  EQU  >837C                   GPL Status byte location
                                    
DSRLNK DATA DSRWS,DLINK1            Set BLWP Vectors

DSRWS                      ; Start of DSRLNK workspace
DR3LB  EQU  $+7            ; lower byte of DSRLNK workspace R3
DLINK1 MOV  R12,R12         R0      Have we already looked up the LINK address?
       JNE  DLINK3          R1      YES!  Skip lookup routine
*<<-------------------------------------------------------------------------->>*
* This section of code is only executed once to find the GROM address          *
* for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
* to indicate that the address is found and to be used as a mask for EQ & CND  *
*------------------------------------------------------------------------------*
       LWPI GPLWS           R2,R3   else load GPL workspace
       MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
       BL   *R4             R6
       LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
       MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector

***les*** Note on above instruction:
***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)

       JMP  DLINK2          R11     Jump around R12-R15
       DATA 0               R12     contains >2000 flag when set
       DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
       MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
       MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
       INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
       BL   *R5                     Restore the GROM address off the stack
       LWPI DSRWS                   Reload DSRLNK workspace
       LI   R12,>2000               Set flag to signify DSRLNK address is set
*<<-------------------------------------------------------------------------->>*
DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
       MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
       MOV  @NAMLEN,R3              Save VDP address of Name Length
       AI   R3,-8                   Adjust it to point to PAB Flag byte
       BLWP @GPLLNK                 Execute DSR LINK
DSRADR BYTE >03                     High byte of GPL DSRLNK address
DSRAD1 BYTE >00                     Lower byte of GPL DSRLNK address
*----Error Check & Report to Caller's R0 and EQU bit-------------------------
       MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
       MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
       SZCB R12,R15                 Clear EQ bit for Error Report
       MOVB @VRD,R3                 Get PAB Error Flag
       SRL  R3,5                    Adjust it to 0-7 error code
       MOVB R3,*R13                 Put it into Caller's R0 (msb)
       JNE  SETEQ                   If it's not zero, set EQ bit
       COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
       JNE  DSREND                  No Error, Just return
SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
DSREND RTWP                         All Done - Return to Caller
;]
;[*== KSENTR -- Keyboard Scan (entry point) =============================
*
KSENTR LWPI GPLWS
       MOV  R11,@UTILWS+22      Save GPL return address
       BL   @SCNKEY             Console keyboard scan routine
       LWPI UTILWS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    _   _____  ___    __  ____  _ ___ __  _       
*   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
*   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
*   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
* 
;[*== VDP utilities (entry point) =======================================
*
** VDP single byte write
*
VSBWEN BL   @WVDPWA             Write out address
       MOVB @2(R13),@VDPWD      Write data
       RTWP                     Return to calling program
*                            
** VDP multiple byte write   
*                            
VMBWEN BL   @WVDPWA             Write out address
VWTMOR MOVB *R1+,@VDPWD         Write a byte
       DEC  R2                  Decrement byte count
       JNE  VWTMOR              More to write?
       RTWP                     Return to calling Program
*                            
** VDP single byte read      
*                            
VSBREN BL   @WVDPRA             Write out address
       MOVB @VDPRD,@2(R13)      Read data
       RTWP                     Return to calling program
*                            
** VDP multiple byte read    
*                            
VMBREN BL   @WVDPRA             Write out address
VRDMOR MOVB @VDPRD,*R1+         Read a byte
       DEC  R2                  Decrement byte count
       JNE  VRDMOR              More to read?
       RTWP                     Return to calling program
*                            
** VDP write to register     
*                            
VWTREN MOV  *R13,R1             Get register number and value
       MOVB @1(R13),@VDPWA      Write out value
       ORI  R1,>8000            Set for register write
       MOVB R1,@VDPWA           Write out register number
       RTWP                     Return to calling program
*
** Set up to write to VDP
*
WVDPWA LI   R1,>4000
       JMP  WVDPAD
*
** Set up to read VDP
*
WVDPRA CLR  R1
*
** Write VDP address
*
WVDPAD MOV  *R13,R2             Get VDP address
       MOVB @U_R2LB,@VDPWA      Write low byte of address
       SOC  R1,R2               Properly adjust VDP write bit
       MOVB R2,@VDPWA           Write high byte of address
       MOV  @2(R13),R1          Get CPU RAM address
       MOV  @4(R13),R2          Get byte count
       RT                       Return to calling routine

*
** VDP-to-VDP move.
*
VMOVEN MOV  *R13,R1             Get cnt to R1
       MOV  @2(R13),R2          Get vsrc to R2
       MOV  @4(R13),R3          Get vdst to R3
       ORI  R3,>4000            Prepare for VDP write

** copy cnt bytes from vsrc to vdst

VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
       MOVB R2,@VDPWA           Write MSB of VDP read address
       INC  R2                  Next VDP read address
       MOVB @VDPRD,R0           Read VDP byte
       MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
       MOVB R3,@VDPWA           Write MSB of VDP write address
       INC  R3                  Next VDP write address
       MOVB R0,@VDPWD           Write VDP byte
       DEC  R1                  Decrement count
       JNE  VMVMOR              Repeat if not done
       RTWP                     Return to calling program
;]*
;[*== fbForth Version Message ===========================================
FBFMSG 
* This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
* Also, printing the extra blanks overwrites the font-not-found error message.
       BYTE 17
       TEXT 'fbForth 2.0:     '     
;]
*     __  ___        ___ ____      __   __      _      __            __  
*    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
*   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
*  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
* 
;[*== Modifiable words in Resident Dictionary ===========================
;[*** (ABORT) ***
       DATA x#VLST_N         <--Last word in ROM
PABR_N DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT

PABORT DATA DOCOL
       DATA ABORT,SEMIS
;]*
;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
       DATA PABR_N
FRTH_N DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT

FORTH  DATA DOVOC
FORTHV DATA DPBASE+2    ; vocabulary link field 
FORTHP DATA >81A0       ; pseudo name field
FORTHL DATA 0           ; chronological link field
;]*
;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
       DATA FRTH_N
ASMR_N DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT

ASSM   DATA DOVOC
; Initially points to last word in ASSEMBLER vocabulary in the kernel
ASMV   DATA SASM_N   ; vocabulary link field
       DATA >81A0    ; pseudo name field
ASML   DATA FORTHL   ; chronological link field

*                    
;]*
;]*
*    ___                     __   __       
*   / _ | ___ ___ ___ __ _  / /  / /__ ____
*  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
* /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/   
*     _   __              __        __                _      __            __  
*    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
*    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
*    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
*                                           /___/  
*
*== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
;[*** NEXT, ***      ( --- )
* 1st word in ASSEMBLER vocabulary
*
       DATA FORTHP          <--points to PNF of FORTH
NXT__N DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT

NEXTC  DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
       MOV  @$DP(U),R1        HERE to R1
       MOV  R0,*R1+           compile "B *NEXT"
       MOV  R1,@$DP(U)        update HERE
       MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
       B    *NEXT             back to inner interpreter

* : NEXT,   ( --- )
*    *NEXT B,  ;
;]*
;[*** ;ASM ***       ( --- ) 
* 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
* ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
*
       DATA NXT__N
SASM_N BYTE 4+TERMBT    <--note different name field format
       TEXT ';ASM'
       BYTE ' '+TERMBT

SASM   DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
       JMP  NXT_P          finish up in NEXT,

* : ;ASM   ( --- )
*    *NEXT B,  ;
;]*

;[*== Some Variables (KEYCNT etc.) ======================================

KEYCNT DATA -1              Used in cursor flash logic
INTACT DATA 0               Non-zero during user's interrupt service routine
*
*++ variables used by some graphics primitives
*
$DMODE DATA 0                   ; actual location of variable contents
$DCOL  DATA -1                  ; actual location of variable contents

*===========================================================
;]*
*   ______                         ___            _____        __   
*  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__ 
*   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
*  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/ 
*                    /_/                                            
* 
;[*== Trampoline Code ===================================================
* 
* MYBANK must be at same location in all banks with the code that appears
* in the following table.  The EQUates for BANK0--BANK3 may also be in the
* same places in each bank for convenience, but they only need to appear once.
* 
*       Bank Select MYBANK
*       ---- ------ ------
*       0    >6006  >C000
*       1    >6004  >8000
*       2    >6002  >4000
*       3    >6000  >0000
* 
* Bank0 code will look like this
*
* MYBANK DATA >C000
* BANK0  EQU  >C000
* BANK1  EQU  >8000
* BANK2  EQU  >4000
* BANK3  EQU  >0000
*
* Banks 1--3 will look the same, including labels, and the DATA
* instruction at MYBANK's location will correspond to its bank.
*
* Before a bank is selected, the values above will be shifted right 13
* bits and have >6000 added.
*
;[*** BLBANK ************************************************************
*
* General bank branching routine (32KB ROM, i.e., 4 banks) for a
* branch that is expected to return (not high-level Forth) via RTBANK---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLBANK
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLBANK DECT R               ; reserve space on return stack (R14)
       MOV  *LINK+,CRU      ; copy destination bank address to R12
       MOV  LINK,*R         ; push return address
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
       MOV  CRU,LINK        ; copy destination bank address to R11
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*
;[*** RTBANK ************************************************************
*
* General bank return routine (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTBANK
*
RTBANK MOV  *R+,CRU         ; pop return bank# from return stack to R12
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       MOV  *R+,LINK        ; pop return address from return stack
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to return address
;]*
;[*** BLF2A *************************************************************
*
* High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to bank0 via RTNEXT.  This will
* only(?) be used for the ALC payload of Forth stubs in bank0---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLF2A
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLF2A  MOV  *LINK,LINK      ; copy destination bank address to R11
       MOV  LINK,CRU        ; copy it to R12
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*                           
;[*** RTNEXT ************************************************************
*
* High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4 
* banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTNEXT
*
RTNEXT MOV  @INTACT,CRU       Are we in user's ISR?
       JNE  RTNXT1            Don't enable interrupts if so.
       LIMI 2
RTNXT1 CLR  @>6006          ; switch to bank 0
       B    *NEXT           ; branch to next CFA (in R15)
;]*
;[*** BLA2F *************************************************************
*
* ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to calling bank via RTA2F---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLA2F
*       DATA <Forth cfa in bank0>
*
BLA2F  DECT R               ; reserve space on return stack 
       MOV  *LINK+,W        ; move CFA of Forth routine to W
       MOV  LINK,*R         ; push return address of calling bank
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
       DECT R               ; reserve spot on return stack
       MOV  IP,*R           ; move current IP to return stack
       LI   IP,RTA2F        ; move address of return procedure to IP
       CLR  @>6006          ; switch to bank0
       B    @DOEXEC         ; Execute the Forth routine
;]*
;[*** RTA2F *************************************************************
*
* ALC to high-level Forth bank "return" routine from Forth to calling
* ALC (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called through B *NEXT at end of Forth word's execution in BLA2F
*
RTA2F  DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
       DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
       MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
* Retrieve ALC return info and return to caller...
* ...caller will execute B *NEXT when it finishes
       B    @RTBANK         ; branch to general bank return routine above
;]*
;]***********************************************************************
;[*++ Bank-specific cell-/byte-reading code ++*
;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
*++ Read cell contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKAT  CLR  *R0             ; switch banks
       MOV  *R1,*SP         ; get cell contents of address to stack
       B    @RTNEXT         ; return to inner interpreter
;]*
;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
*++ Read byte contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKCAT CLR  *R0             ; switch banks
       CLR  R2              ; clear R2
       MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
       MOV  R2,*SP          ; get byte contents of address to stack
       B    @RTNEXT         ; return to inner interpreter

;]*

;]*
*         _______   __  _________      ___          __    
*        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
*       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
*      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, / 
*                                                  /___/  
* 
;[*** SAMS! ***      ( --- )
* This calls the SAMS initialization in the startup code in bank 1.
* 
*        DATA SMSQ_N
* SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
* SAMSST DATA $+2
*        BL   @BLF2A
*        DATA _SMSST->6000+BANK1

_SMSST BL   @SMSINI           initialize SAMS card
       B    @RTNEXT           back to inner interpreter
;]*   
;[*== Required strings, tables, variables... ============================
*
*
* Default blocks filename
*
DEFNAM BYTE 12
       TEXT "DSK1.FBLOCKS "
*
* Default colors for all VDP modes---
*     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
*     LSB: Color Table colors (FG/BG)
*
DEFCOL DATA >4F00          ; TEXT80    offset=0
       DATA >4F00          ; TEXT      offset=2
       DATA >F4F4          ; GRAPHICS  offset=4
       DATA >11F4          ; MULTI     offset=6
       DATA >FE10          ; GRAPHICS2 offset=8
       DATA >FEF4          ; SPLIT     offset=10
       DATA >FEF4          ; SPLIT2    offset=12
*
* Default text mode
*
DEFTXT DATA >0001
*
* Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
*
FNTFLG DATA 0              ; font flag initially 0
*
* Speech variables needing initial value (more below LLVEND)
*
SPCSVC DATA 0
*
* Sound Table #1 Workspace for sound variables.  Only using R0..R4
*
SND1WS 
SND1ST DATA 0           ; R0 (sound table status) 0=no table..
                        ; ..1=loading sound bytes..-1=counting
SND1DS DATA SOUND       ; R1 (sound-table byte destination)..
                        ; ..initialized to sound chip
SND1AD DATA 0           ; R2 (sound table address)
SND1CT DATA 0           ; R3 (# of sound bytes to load or..
                        ; ..sound count = seconds * 60)
SND1SP DATA SNDST0      ; R4 (pointer to top of sound stack)..
                        ; ..initialized to bottom of sound stack              
* 
* Sound Table #2 Workspace for sound variables.  Only using R0..R3
*
SND2WS 
SND2ST DATA 0           ; R0 (sound table status) 0=no table..
                        ; ..1=loading sound bytes..-1=counting
SND2DS DATA SOUND       ; R1 (sound-table byte destination) init to sound chip
;]*
* 
* This is the end of low-level support code that gets copied.
*
LLVEND

;[*== Un-initialized Variables and workspaces... =========================
* Start of definitions of variables and workspaces that do not need to
* take up space in ROM because they need no initial values.
*
* Sound Table #2 Workspace for sound variables..continued.
*
SND2AD EQU  SND2WS+4    ; R2 (sound table address)
SND2CT EQU  SND2WS+6    ; R3 (# of sound bytes to load or..
*                       ; ..sound count = seconds * 60)
SDMUTE EQU  SND2WS+8    ; dummy destination for sound byte
* 
* Branch Stack for ISR processing of Speech, 2 Sound Tables and return
*
BRSTK  EQU  SDMUTE+2
*
* Speech variables (more above LLVEND)
* 
SSFLAG EQU  BRSTK+8
SPCNT  EQU  SSFLAG+2
SPADR  EQU  SPCNT+2
BANKSV EQU  SPADR+2
PADSV  EQU  BANKSV+2
*
* Panel window: height, width and screen position...used by PANEL and SCROLL
*
PANWIN EQU  PADSV+12          panel height, width and screen start
 
*== Utility Workspace =================================================
*** General utility workspace registers
UTILWS EQU  PANWIN+6
U_R2LB EQU  UTILWS+5

LINBUF EQU  UTILWS+32
CURCHR EQU  LINBUF+80

*++ variable used by the 40/80-column editor
OLDCUR EQU  CURCHR+2

*++ FILE I/O variables
 
PBADR  EQU  OLDCUR+8
PBBF   EQU  PBADR+2
PBVBF  EQU  PBBF+2
 
*++ Floating Point Math Library variables
FPVARS EQU  PBVBF+2
 
*++ SAMS flag
SAMSFL EQU  FPVARS+22

*++ Bottom of Sound Stack 
*++      This location marks the top of the low-level support code. The Sound
*++      Stack grows upward toward the Return Stack by moving the entire stack
*++      up one cell to make room for the next new bottom entry.
SNDST0 EQU  SAMSFL+2
;]*

       AORG
       BANK 1

and its listing:

Reveal hidden contents



     **** ****     > fbForth101_LowLevelSupport.a99
0001               *     __                  __                __
0002               *    / /  ___ _    ______/ /  ___ _  _____ / /
0003               *   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) /
0004               *  /____/\___/__,__/   /____/\__/|___/\__/_/
0005               *                     ____                        __
0006               *                    / __/_ _____  ___  ___  ____/ /_
0007               *                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
0008               *                  /___/\_,_/ .__/ .__/\___/_/  \__/
0009               *                          /_/  /_/
0010               *
0011               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0012               *                                                                   *
0013               * fbForth---                                                        *
0014               *                                                                   *
0015               *       Low-level support routines                                  *
0016               *                                                                   *
0017               *  << Including Trampoline Code, tables & variables:  2606 bytes >> *
0018               *                                                                   *
0019               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0020               
0021               LLVSPT   ; <--This is the source copy location for the rest of this code.
0022               
0023      2010     $BUFF  EQU  >2010
0024               
0025               * 4 I/O buffers below ($LO = >3020)
0026               * Change '4' to number of buffers needed and for which there is room.
0027               
0028      3020     $LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers
0029               
0030                      XORG $LO      ; calculate destination addresses
0031               
0032               *       _____   ____         __  __      ___________
0033               *      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
0034               *     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
0035               *    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_|
0036               *
0037               ;[*** Interrupt Service =======================================================
0038               * This routine is executed for every interrupt.  It processes any pending
0039               * speech and souind.  It then looks to see whether a user ISR is installed in
0040               * ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work
0041               * only if the user has installed an ISR using the following steps in the fol-
0042               * lowing order:
0043               *
0044               *   (1) Write an ISR with entry point, say MYISR.
0045               *   (2) Determine code field address of MYISR with this high-level Forth:
0046               *           ' MYISR CFA
0047               * <<< Maybe need a word to do #3 >>>
0048               *   (3) Write CFA of MYISR into user variable ISR.
0049               *
0050               * Steps (2)-(3) in high-level Forth are shown below:
0051               *           ' MYISR CFA
0052               *           ISR !
0053               *
0054               * <<< Perhaps last step above should be by a word that disables interrupts >>>
0055               *
0056               * The console ISR branches to the contents of >83C4 because it is non-zero,
0057               * with the address, INT1, of the fbForth ISR entry point below (also, the
0058               * contents of INTLNK).  This means that the console ISR will branch to INT1
0059               * with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
0060               * process any pending speech and sound.
0061               *
0062               * If the user's ISR is properly installed, the code that processes the user
0063               * ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
0064               * from Forth's workspace (MAINWS), the code at INT2 will process the user's
0065               * ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
0066               * inner interpreter.
0067               *** ==========================================================================
0068               
0069               * ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!
0070               
0071               INT1
0072 6140 0200  20        LI   R0,BRSTK          load address of top of Branch Address Stack
     6142 3A2A     
0073               *
0074               * Set up for pending speech
0075               *
0076 6144 C420  46        MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
     6146 3A14     
0077 6148 1301  14        JEQ  SNDCH1            jump to sound-check if no speech
0078 614A 05C0  14        INCT R0                increment Branch Stack
0079               *
0080               * Set up for pending sound table #1 (ST#1)
0081               *
0082 614C C0A0  34 SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
     614E 3A16     
0083 6150 1303  14        JEQ  SNDCH2            process speech and sound if needed
0084 6152 0201  20        LI   R1,x#PLAYT1         load PLAYT1 address and...
     6154 7C68     
0085 6156 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0086               *
0087               * Set up for pending sound table #2 (ST#2)
0088               *
0089 6158 C0E0  34 SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
     615A 3A20     
0090 615C 1303  14        JEQ  PRCSPS            process speech and sound if needed
0091 615E 0201  20        LI   R1,x#PLAYT2         load PLAYT2 address and...
     6160 7C6E     
0092 6162 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0093               *
0094               * Process sound stack if both sound tables idle
0095               *
0096 6164 E0C2  18 PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
0097 6166 160A  14        JNE  PRSPS2            nope..skip sound stack processing
0098 6168 02E0  18        LWPI SND1WS            switch to ST#1 WS
     616A 3A16     
0099 616C 0284  22        CI   R4,SNDST0         anything on sound stack?
     616E 3AE4     
0100 6170 1303  14        JEQ  PRSPS1            no..exit sound stack processing
0101 6172 0644  14        DECT R4                pop sound stack position
0102 6174 C094  26        MOV  *R4,R2            get sound table address from sound stack
0103 6176 0580  14        INC  R0                kick off sound processing of ST#1 (R0=1)
0104 6178 02E0  18 PRSPS1 LWPI GPLWS             switch back to GPL WS
     617A 83E0     
0105               *
0106               * Check for any pending speech and sound
0107               *
0108 617C 0280  22 PRSPS2 CI   R0,BRSTK          any speech or sound to process?
     617E 3A2A     
0109 6180 1312  14        JEQ  USRISR            if not, jump to user ISR processing
0110 6182 0201  20        LI   R1,BNKRST         yup..load return address
     6184 307A     
0111 6186 C401  30        MOV  R1,*R0            push return address onto Branch Stack
0112               *
0113               * Process pending speech and sound
0114               *
0115 6188 C820  54        MOV  @x#MYBANK,@BANKSV   save bank at interrupt
     618A 7FFE     
     618C 3A38     
0116 618E 04E0  34        CLR  @>6002            switch to bank 2 for speech & sound services
     6190 6002     
0117 6192 0207  20        LI   R7,BRSTK          load top of Branch Stack
     6194 3A2A     
0118 6196 C237  30        MOV  *R7+,R8           pop speech/sound ISR
0119 6198 0458  20        B    *R8               service speech/sound
0120               *
0121               * Restore interrupted bank
0122               *
0123               BNKRST                ; return point for speech and sound ISRs
0124 619A C020  34        MOV  @BANKSV,R0        restore bank at interrupt
     619C 3A38     
0125 619E 09D0  56        SRL  R0,13             get the bank# to correct position
0126 61A0 0220  22        AI   R0,>6000          make it a real bank-switch address
     61A2 6000     
0127 61A4 04D0  26        CLR  *R0               switch to the bank at interrupt
0128               *
0129               * Process User ISR if defined
0130               *
0131 61A6 C020  34 USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
     61A8 36EA     
0132 61AA 1304  14        JEQ  INTEX
0133               *
0134               * Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
0135               * is executed from Forth's WS (MAINWS = >8300), which it does at the end of
0136               * every CODE word, keyboard scan and one or two other places.
0137               *
0138 61AC 0201  20        LI   R1,INT2                 Load entry point, INT2
     61AE 309A     
0139 61B0 C801  38        MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
     61B2 831E     
0140               *
0141               * The following 2 instructions are copies of the remainder of the console ROM's
0142               * ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
0143               * because we're not going back there!
0144               *
0145 61B4 02E0  18 INTEX  LWPI >83C0             Change to console's ISR WS
     61B6 83C0     
0146 61B8 0380  18        RTWP                   Return to caller of console ISR
0147               *
0148               * Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
0149               * before executing user's ISR. INT3 (cleanup routine below) will be inserted
0150               * in address list to get us back here for cleanup after user's ISR has finished.
0151               * User's ISR is executed at the end of this section just before INT3.
0152               *
0153 61BA 0300  24 INT2   LIMI 0                 Disable interrupts
     61BC 0000     
0154 61BE D020  34        MOVB @>83D4,R0         Get copy of VR01
     61C0 83D4     
0155 61C2 0980  56        SRL  R0,8              ...to LSB
0156 61C4 0260  22        ORI  R0,>100           Set up for VR01
     61C6 0100     
0157 61C8 0240  22        ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
     61CA FFDF     
0158 61CC 0420  54        BLWP @VWTR             Turn off VDP interrupt
     61CE 3752     
0159 61D0 020F  20        LI   NEXT,$NEXT        Restore NEXT
     61D2 833A     
0160 61D4 0720  34        SETO @INTACT           Set Forth "pending interrupt" flag
     61D6 3956     
0161 61D8 064E  14        DECT R                 Set up return linkage by pushing
0162 61DA C78D  30        MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
0163 61DC 020D  20        LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
     61DE 30C8     
0164 61E0 C2A8  34        MOV  @$ISR(U),W        Do the user's Forth ISR by executing
     61E2 0036     
0165 61E4 0460  28        B    @DOEXEC           ...it through Forth's inner interpreter
     61E6 833C     
0166               *
0167               * Clean up and re-enable interrupts.
0168               *
0169 61E8 30CA     INT3   DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
0170 61EA 30CC            DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
0171 61EC C37E  30        MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
0172 61EE 04E0  34        CLR  @INTACT           Clear Forth "pending interrupt" flag
     61F0 3956     
0173 61F2 D020  34        MOVB @>83D4,R0         Prepare to restore VR01 by...
     61F4 83D4     
0174 61F6 0980  56        SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
0175 61F8 0220  22        AI   R0,>100           ...VR # (01) to MSB
     61FA 0100     
0176 61FC D060  34        MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
     61FE 8802     
0177 6200 0420  54        BLWP @VWTR             Write VR01
     6202 3752     
0178 6204 0300  24        LIMI 2                 Re-enable interrupts
     6206 0002     
0179 6208 045F  20        B    *NEXT             Continue normal task
0180               ;]*
0181               ;[*** BKLINK from SYSTEM calls ==========================================
0182               *
0183 620A C1E0  34 BKLINK MOV  @INTACT,R7        Are we in user's ISR?
     620C 3956     
0184 620E 1602  14        JNE  BKLIN1            Don't enable interrupts if so.
0185 6210 0300  24        LIMI 2
     6212 0002     
0186 6214 045B  20 BKLIN1 B    *LINK
0187               ;]*
0188               *      ____         __              _____     ____
0189               *     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
0190               *    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
0191               *   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
0192               *       /___/
0193               *
0194               ;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================
0195               
0196               *       Entry point for low-level system support functions
0197               
0198 6216 0300  24 $SYS$  LIMI 0
     6218 0000     
0199 621A C021  34        MOV  @SYSTAB(R1),R0
     621C 3114     
0200 621E 0450  20        B    *R0
0201               ;]
0202               ;[*** SYSTAB -- Vector table for SYSTEM calls ===========================
0203               
0204 6220 34C6            DATA BRW          CODE = -20  write block to blocks file
0205 6222 34C6            DATA BRW          CODE = -18  read block from blocks file
0206 6224 34C6            DATA BRW          CODE = -16  create blocks file
0207 6226 34C6            DATA BRW          CODE = -14  use blocks file
0208 6228 346C            DATA GXY          CODE = -12  GOTOXY
0209 622A 3456            DATA QKY          CODE = -10  ?KEY
0210 622C 343C            DATA QTM          CODE =  -8  ?TERMINAL
0211 622E 3420            DATA CLF          CODE =  -6  CRLF
0212 6230 3312            DATA EMT          CODE =  -4  EMIT
0213 6232 3260            DATA KY           CODE =  -2  KEY
0214 6234 3130     SYSTAB DATA SBW          CODE =   0  VSBW
0215 6236 313E            DATA MBW          CODE =   2  VMBW
0216 6238 314C            DATA SBR          CODE =   4  VSBR
0217 623A 315A            DATA MBR          CODE =   6  VMBR
0218 623C 3176            DATA WTR          CODE =   8  VWTR
0219 623E 3186            DATA GPL          CODE =  10  GPLLNK
0220 6240 31A6            DATA XML          CODE =  12  XMLLNK
0221 6242 31C0            DATA DSR          CODE =  14  DSRLNK
0222 6244 31DA            DATA CLS$         CODE =  16  CLS
0223 6246 3168            DATA MVE          CODE =  18  VMOVE
0224 6248 31F4            DATA FILL$        CODE =  20  VFILL
0225 624A 3224            DATA AOX          CODE =  22  VAND
0226 624C 3224            DATA AOX          CODE =  24  VOR
0227 624E 3224            DATA AOX          CODE =  26  VXOR
0228               ;]*
0229               ;[*== VDP single byte write.                CODE =   0  =================
0230               *
0231 6250 C039  30 SBW    MOV  *SP+,R0         VRAM address (destination)
0232 6252 C079  30        MOV  *SP+,R1         Character to write
0233 6254 06C1  14        SWPB R1              Get in left byte
0234 6256 0420  54        BLWP @VSBW
     6258 373E     
0235 625A 0460  28        B    @BKLINK
     625C 30EA     
0236               ;]*
0237               ;[*== VDP multi byte write.                 CODE =   2  =================
0238               *
0239 625E C0B9  30 MBW    MOV  *SP+,R2         Number of bytes to move
0240 6260 C039  30        MOV  *SP+,R0         VRAM address (destination)
0241 6262 C079  30        MOV  *SP+,R1         RAM address (source)
0242 6264 0420  54        BLWP @VMBW
     6266 3742     
0243 6268 0460  28        B    @BKLINK
     626A 30EA     
0244               ;]*
0245               ;[*== VDP single byte read.                 CODE =   4  =================
0246               *
0247 626C C019  26 SBR    MOV  *SP,R0          VRAM address (source)
0248 626E 0420  54        BLWP @VSBR
     6270 3746     
0249 6272 0981  56        SRL  R1,8            Character to right half for Forth
0250 6274 C641  30        MOV  R1,*SP          Stack it
0251 6276 0460  28        B    @BKLINK
     6278 30EA     
0252               ;]*
0253               ;[*== VDP multi byte read.                  CODE =   6  =================
0254               *
0255 627A C0B9  30 MBR    MOV  *SP+,R2         Number of bytes to read
0256 627C C079  30        MOV  *SP+,R1         RAM address (destination)
0257 627E C039  30        MOV  *SP+,R0         VRAM address (source)
0258 6280 0420  54        BLWP @VMBR
     6282 374A     
0259 6284 0460  28        B    @BKLINK
     6286 30EA     
0260               ;]*
0261               ;[*== VDP-to-VDP move.                      CODE =  18  =================
0262               *
0263 6288 C039  30 MVE    MOV  *SP+,R0         Pop cnt to R0
0264 628A C0B9  30        MOV  *SP+,R2         Pop vdst to R2
0265 628C C079  30        MOV  *SP+,R1         Pop vsrc to R1
0266 628E 0420  54        BLWP @VMOVE
     6290 374E     
0267 6292 0460  28        B    @BKLINK
     6294 30EA     
0268               ;]*
0269               ;[*== VDP register write.                   CODE =   8  =================
0270               *
0271 6296 C079  30 WTR    MOV  *SP+,R1         VDP register number
0272 6298 C039  30        MOV  *SP+,R0         Data for register
0273 629A 06C1  14        SWPB R1              Get register to left byte
0274 629C D001  18        MOVB R1,R0           Place with data
0275 629E 0420  54        BLWP @VWTR
     62A0 3752     
0276 62A2 0460  28        B    @BKLINK
     62A4 30EA     
0277               ;]*
0278               ;[*== GPL link utility.                     CODE =  10  =================
0279               *
0280 62A6 04C0  14 GPL    CLR  R0
0281 62A8 D800  38        MOVB R0,@KYSTAT
     62AA 837C     
0282 62AC 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62AE 0420     
0283 62B0 0201  20        LI   R1,GPLLNK         to the GPLLNK utility
     62B2 3784     
0284 62B4 C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0285 62B6 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62B8 045B     
0286 62BA C10B  18        MOV  LINK,R4         Save LINK address
0287 62BC 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62BE 8300     
0288 62C0 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0289 62C2 0460  28        B    @BKLINK
     62C4 30EA     
0290               ;]*
0291               ;[*== XML link utility.                     CODE =  12  =================
0292               *
0293 62C6 0200  20 XML    LI   R0,>0420        Construct the BLWP instruction
     62C8 0420     
0294 62CA 0201  20        LI   R1,XMLLNK         to the XMLLNK utility
     62CC 3736     
0295 62CE C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0296 62D0 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62D2 045B     
0297 62D4 C10B  18        MOV  LINK,R4         Save LINK address
0298 62D6 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62D8 8300     
0299 62DA C2C4  18        MOV  R4,LINK           and reconstruct LINK
0300 62DC 0460  28        B    @BKLINK
     62DE 30EA     
0301               ;]*
0302               ;[*== DSR link utility.                     CODE =  14  =================
0303               *
0304 62E0 0200  20 DSR    LI   R0,>0420        Construct the BLWP instruction
     62E2 0420     
0305 62E4 0201  20        LI   R1,DSRLNK         to the DSRLNK utility
     62E6 37BE     
0306 62E8 C0B9  30        MOV  *SP+,R2         This datum selects DSR or subroutine
0307 62EA 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62EC 045B     
0308 62EE C10B  18        MOV  LINK,R4         Save LINK address
0309 62F0 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62F2 8300     
0310 62F4 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0311 62F6 0460  28        B    @BKLINK
     62F8 30EA     
0312               ;]*
0313               ;[*== Screen clearing utility.              CODE =  16  =================
0314               *
0315 62FA C0A8  34 CLS$   MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
     62FC 0032     
0316 62FE C068  34        MOV  @$SEND(U),R1    End of screen in VRAM
     6300 0034     
0317 6302 6042  18        S    R2,R1           Screen size
0318 6304 0200  20        LI   R0,>2000        Blank character
     6306 2000     
0319 6308 C1CB  18        MOV  LINK,R7
0320 630A 06A0  32        BL   @FILL1
     630C 3208     
0321 630E C2C7  18        MOV  R7,LINK
0322 6310 0460  28        B    @BKLINK
     6312 30EA     
0323               ;]*
0324               ;[*== VDP fill routine.                     CODE =  20  =================
0325               *
0326 6314 C039  30 FILL$  MOV  *SP+,R0         Fill character
0327 6316 06C0  14        SWPB R0                to left byte
0328 6318 C079  30        MOV  *SP+,R1         Fill count
0329 631A C0B9  30        MOV  *SP+,R2         Address to start VRAM fill
0330 631C C1CB  18        MOV  LINK,R7
0331 631E 06A0  32        BL   @FILL1
     6320 3208     
0332 6322 C2C7  18        MOV  R7,LINK
0333 6324 0460  28        B    @BKLINK
     6326 30EA     
0334               *========================================================================
0335               FILL1          ; R0=char, R1=cnt, R2=vaddr
0336 6328 0262  22        ORI  R2,>4000        Set bit for VDP write
     632A 4000     
0337 632C 06C2  14        SWPB R2
0338 632E D802  38        MOVB R2,@VDPWA       LS byte first
     6330 8C02     
0339 6332 06C2  14        SWPB R2
0340 6334 D802  38        MOVB R2,@VDPWA       Then MS byte
     6336 8C02     
0341 6338 1000  14        NOP                  Kill time
0342 633A D800  38 FLOOP  MOVB R0,@VDPWD       Write a byte
     633C 8C00     
0343 633E 0601  14        DEC  R1
0344 6340 16FC  14        JNE  FLOOP           Not done, fill another
0345 6342 045B  20        B    *LINK
0346               ;]*======================================================================
0347               *
0348               *==== VAND -- VDP byte AND routine.         CODE =  22  =================
0349               *==== VOR -- VDP byte OR routine.           CODE =  24  =================
0350               ;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
0351               *
0352 6344 C0B9  30 AOX    MOV  *SP+,R2         VRAM address
0353 6346 06C2  14        SWPB R2
0354 6348 D802  38        MOVB R2,@VDPWA       LS byte first
     634A 8C02     
0355 634C 06C2  14        SWPB R2
0356 634E D802  38        MOVB R2,@VDPWA       Then MS byte
     6350 8C02     
0357 6352 1000  14        NOP                  Kill time
0358 6354 D0E0  34        MOVB @VDPRD,R3       Read byte
     6356 8800     
0359 6358 C039  30        MOV  *SP+,R0         Get data to operate with
0360 635A 06C0  14        SWPB R0                to left byte
0361               *** Now do requested operation *****************
0362 635C 0281  22        CI   R1,24
     635E 0018     
0363 6360 1304  14        JEQ  DOOR
0364 6362 1505  14        JGT  DOXOR
0365 6364 0543  14        INV  R3              These two instructions
0366 6366 4003  18        SZC  R3,R0             perform an 'AND'
0367 6368 1003  14        JMP  FINAOX
0368 636A E003  18 DOOR   SOC  R3,R0             perform 'OR'
0369 636C 1001  14        JMP  FINAOX
0370 636E 2803  18 DOXOR  XOR  R3,R0             perform 'XOR'
0371 6370 0201  20 FINAOX LI   R1,1
     6372 0001     
0372 6374 C1CB  18        MOV  LINK,R7
0373 6376 06A0  32        BL   @FILL1
     6378 3208     
0374 637A C2C7  18        MOV  R7,LINK
0375 637C 0460  28        B    @BKLINK
     637E 30EA     
0376               ;]*
0377               ;[*== KEY routine                           CODE =  -2  =================
0378               *
0379 6380 C028  34 KY    MOV  @$ALTI(U),R0      alternate input device?
     6382 0038     
0380 6384 131B  14        JEQ  KEY0              jump to keyboard input if not
0381               *
0382               *  R0 now points to PAB for alternate input device, the one-byte buffer
0383               *  for which must immediately precede its PAB.  PAB must have been set up
0384               *  to read one byte.
0385               *
0386 6386 04C7  14        CLR  R7                prepare to zero status byte
0387 6388 D807  38        MOVB R7,@KYSTAT        zero status byte
     638A 837C     
0388 638C 0580  14        INC  R0                point R0 to Flag/Status byte
0389 638E 0420  54        BLWP @VSBR             read it
     6390 3746     
0390 6392 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6394 1F00     
0391 6396 0420  54        BLWP @VSBW             write it back to PAB
     6398 373E     
0392 639A C040  18        MOV  R0,R1             Set up pointer...
0393 639C 0221  22        AI   R1,8              ...to namelength byte of PAB
     639E 0008     
0394 63A0 C801  38        MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
     63A2 8356     
0395 63A4 C0C0  18        MOV  R0,R3             save pointer (DSRLNK will trash it!)
0396 63A6 0420  54        BLWP @DSRLNK           get 1 byte from device
     63A8 37BE     
0397 63AA 0008            DATA >8
0398 63AC C003  18        MOV  R3,R0             restore pointer
0399 63AE 0640  14        DECT R0                point to one-byte VRAM buffer in front of PAB
0400 63B0 0420  54        BLWP @VSBR             read character
     63B2 3746     
0401 63B4 0981  56        SRL  R1,8              move to LSB
0402 63B6 C001  18        MOV  R1,R0             copy to return register
0403 63B8 0460  28        B    @BKLINK           return to caller
     63BA 30EA     
0404               *
0405               *  Input is comining from the keyboard
0406               *
0407 63BC C1E0  34 KEY0   MOV  @KEYCNT,R7
     63BE 3954     
0408 63C0 0587  14        INC  R7
0409 63C2 160A  14        JNE  KEY1
0410 63C4 C028  34        MOV  @CURPO$(U),R0
     63C6 0016     
0411 63C8 0420  54        BLWP @VSBR             Read character at cursor position...
     63CA 3746     
0412 63CC D801  38        MOVB R1,@CURCHR        ...and save it
     63CE 3ABC     
0413 63D0 0201  20        LI   R1,>1E00          Place cursor character on screen
     63D2 1E00     
0414 63D4 0420  54        BLWP @VSBW
     63D6 373E     
0415               *
0416 63D8 0420  54 KEY1   BLWP @KSCAN
     63DA 373A     
0417 63DC D020  34        MOVB @KYSTAT,R0
     63DE 837C     
0418 63E0 2020  38        COC  @H2000,R0         check status
     63E2 3734     
0419 63E4 1319  14        JEQ  KEY2              JMP if key was pressed
0420               *
0421 63E6 0287  22        CI   R7,100            No key pressed
     63E8 0064     
0422 63EA 1603  14        JNE  KEY3
0423 63EC D060  34        MOVB @CURCHR,R1
     63EE 3ABC     
0424 63F0 1006  14        JMP  KEY5
0425               *
0426 63F2 0287  22 KEY3   CI   R7,200
     63F4 00C8     
0427 63F6 1607  14        JNE  KEY4
0428 63F8 04C7  14        CLR  R7
0429 63FA 0201  20        LI   R1,>1E00          Cursor char
     63FC 1E00     
0430 63FE C028  34 KEY5   MOV  @CURPO$(U),R0
     6400 0016     
0431 6402 0420  54        BLWP @VSBW
     6404 373E     
0432 6406 C807  38 KEY4   MOV  R7,@KEYCNT
     6408 3954     
0433 640A C1E0  34        MOV  @INTACT,R7        Are we in user's ISR?
     640C 3956     
0434 640E 1602  14        JNE  KEY6              Don't enable interrupts if so.
0435 6410 0300  24        LIMI 2
     6412 0002     
0436 6414 064D  14 KEY6   DECT IP                This will re-execute KEY
0437 6416 045F  20        B    *NEXT
0438 6418 0720  34 KEY2   SETO @KEYCNT           Key was pressed
     641A 3954     
0439 641C C028  34        MOV  @CURPO$(U),R0     Restore character at cursor location
     641E 0016     
0440 6420 D060  34        MOVB @CURCHR,R1
     6422 3ABC     
0441 6424 0420  54        BLWP @VSBW
     6426 373E     
0442 6428 D020  34        MOVB @KYCHAR,R0        Put char in...
     642A 8375     
0443 642C 0980  56        SRL  R0,8              ...LSB of R0
0444 642E 0460  28        B    @BKLINK
     6430 30EA     
0445               ;]*
0446               ;[*== EMIT routine                          CODE =  -4  =================
0447               *
0448 6432 C042  18 EMT    MOV  R2,R1             copy char to R1 for VSBW
0449 6434 C028  34        MOV  @$ALTO(U),R0      alternate output device?
     6436 003A     
0450 6438 1317  14        JEQ  EMIT0             jump to video display output if not
0451               *
0452               *  R0 now points to PAB for alternate output device, the one-byte buffer
0453               *  for which must immediately precede its PAB.  PAB must have been set up
0454               *  to write one byte.
0455               *
0456 643A 04C7  14        CLR  R7                ALTOUT active
0457 643C D807  38        MOVB R7,@KYSTAT        zero status byte
     643E 837C     
0458 6440 0600  14        DEC  R0                point to one-byte VRAM buffer in front of PAB
0459 6442 06C1  14        SWPB R1                char to MSB
0460 6444 0420  54        BLWP @VSBW             write char to buffer
     6446 373E     
0461 6448 05C0  14        INCT R0                point to Flag/Status byte
0462 644A 0420  54        BLWP @VSBR             read it
     644C 3746     
0463 644E 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6450 1F00     
0464 6452 0420  54        BLWP @VSBW             write it back to PAB
     6454 373E     
0465 6456 0220  22        AI   R0,8              Set up pointer to namelength byte of PAB
     6458 0008     
0466 645A C800  38        MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
     645C 8356     
0467 645E 0420  54        BLWP @DSRLNK           put 1 byte to device
     6460 37BE     
0468 6462 0008            DATA >8
0469 6464 0460  28        B    @BKLINK           return to caller
     6466 30EA     
0470               *
0471               *  Output is going to the video display
0472               *
0473 6468 0281  22 EMIT0  CI   R1,7            Is it a bell?
     646A 0007     
0474 646C 1607  14        JNE  NOTBEL
0475 646E 04C2  14        CLR  R2
0476 6470 D802  38        MOVB R2,@KYSTAT
     6472 837C     
0477 6474 0420  54        BLWP @GPLLNK
     6476 3784     
0478 6478 0036            DATA >0036           Emit error tone
0479 647A 1060  14        JMP  EMEXIT
0480               *
0481 647C 0281  22 NOTBEL CI   R1,8            Is it a backspace?
     647E 0008     
0482 6480 160B  14        JNE  NOTBS
0483 6482 0201  20        LI   R1,>2000
     6484 2000     
0484 6486 C028  34        MOV  @CURPO$(U),R0
     6488 0016     
0485 648A 0420  54        BLWP @VSBW
     648C 373E     
0486 648E 1501  14        JGT  DECCUR
0487 6490 1055  14        JMP  EMEXIT
0488 6492 0628  34 DECCUR DEC  @CURPO$(U)
     6494 0016     
0489 6496 1052  14        JMP  EMEXIT
0490               *
0491 6498 0281  22 NOTBS  CI   R1,>A           Is it a line feed?
     649A 000A     
0492 649C 162B  14        JNE  NOTLF
0493 649E C1E8  34        MOV  @$SEND(U),R7
     64A0 0034     
0494 64A2 61E8  34        S    @$SWDTH(U),R7
     64A4 0030     
0495 64A6 81E8  34        C    @CURPO$(U),R7
     64A8 0016     
0496 64AA 1404  14        JHE  SCRLL
0497 64AC AA28  54        A    @$SWDTH(U),@CURPO$(u)
     64AE 0030     
     64B0 0016     
0498 64B2 1044  14        JMP  EMEXIT
0499 64B4 C1CB  18 SCRLL  MOV  LINK,R7
0500 64B6 06A0  32        BL   @SCROLL
     64B8 339E     
0501 64BA C2C7  18        MOV  R7,LINK
0502 64BC 103F  14        JMP  EMEXIT
0503               *
0504               *** SCROLLING ROUTINE
0505               *
0506 64BE C028  34 SCROLL MOV  @$SSTRT(U),R0   VRAM addr
     64C0 0032     
0507 64C2 0201  20        LI   R1,LINBUF       Line buffer
     64C4 3A6C     
0508 64C6 C0A8  34        MOV  @$SWDTH(U),R2   Count
     64C8 0030     
0509 64CA A002  18        A    R2,R0           Start at line 2
0510 64CC 0420  54 SCROL1 BLWP @VMBR
     64CE 374A     
0511 64D0 6002  18        S    R2,R0           One line back to write
0512 64D2 0420  54        BLWP @VMBW
     64D4 3742     
0513 64D6 A002  18        A    R2,R0           Two lines ahead for next read
0514 64D8 A002  18        A    R2,R0
0515 64DA 8A00  38        C    R0,@$SEND(U)    End of screen?
     64DC 0034     
0516 64DE 1AF6  14        JL   SCROL1
0517 64E0 C042  18        MOV  R2,R1           Blank bottom row of screen
0518 64E2 0200  20        LI   R0,>2000        Blank
     64E4 2000     
0519 64E6 60A8  34        S    @$SEND(U),R2
     64E8 0034     
0520 64EA 0502  16        NEG  R2              Now contains address of start of last line
0521 64EC C18B  18        MOV  LINK,R6
0522 64EE 06A0  32        BL   @FILL1          Write the blanks
     64F0 3208     
0523 64F2 0456  20        B    *R6
0524               *
0525 64F4 0281  22 NOTLF  CI   R1,>D           Is it a carriage return?
     64F6 000D     
0526 64F8 160D  14        JNE  NOTCR
0527 64FA 04C0  14        CLR  R0
0528 64FC C068  34        MOV  @CURPO$(U),R1
     64FE 0016     
0529 6500 C0C1  18        MOV  R1,R3
0530 6502 6068  34        S    @$SSTRT(U),R1   Adjusted for screen not at 0
     6504 0032     
0531 6506 C0A8  34        MOV  @$SWDTH(U),R2
     6508 0030     
0532 650A 3C02 128        DIV  R2,R0
0533 650C 60C1  18        S    R1,R3
0534 650E CA03  38        MOV  R3,@CURPO$(U)
     6510 0016     
0535 6512 1014  14        JMP  EMEXIT
0536               *
0537 6514 06C1  14 NOTCR  SWPB R1              Assume it is a printable character
0538 6516 C028  34        MOV  @CURPO$(U),R0
     6518 0016     
0539 651A 0420  54        BLWP @VSBW
     651C 373E     
0540 651E C0A8  34        MOV  @$SEND(U),R2
     6520 0034     
0541 6522 0602  14        DEC  R2
0542 6524 8080  18        C    R0,R2
0543 6526 1607  14        JNE  NOTCR1
0544 6528 C028  34        MOV  @$SEND(U),R0
     652A 0034     
0545 652C 6028  34        S    @$SWDTH(U),R0   Was last char on screen. Scroll
     652E 0030     
0546 6530 CA00  38        MOV  R0,@CURPO$(U)
     6532 0016     
0547 6534 10BF  14        JMP  SCRLL
0548 6536 0580  14 NOTCR1 INC  R0              No scroll necessary
0549 6538 CA00  38        MOV  R0,@CURPO$(U)
     653A 0016     
0550               *
0551 653C 0460  28 EMEXIT B    @BKLINK
     653E 30EA     
0552               ;]*
0553               ;[*== CRLF routine                          CODE =  -6  =================
0554               *
0555 6540 C14B  18 CLF    MOV  LINK,R5
0556 6542 0202  20        LI   R2,>000D
     6544 000D     
0557 6546 06A0  32        BL   @EMT            EMT will alter INT mask via B @BKLINK
     6548 3312     
0558 654A 0202  20        LI   R2,>000A
     654C 000A     
0559 654E 0300  24        LIMI 0               Previous call to EMT altered INT mask
     6550 0000     
0560 6552 06A0  32        BL   @EMT
     6554 3312     
0561 6556 C2C5  18        MOV  R5,LINK
0562 6558 0460  28        B    @BKLINK
     655A 30EA     
0563               ;]*
0564               ;[*== ?TERMINAL routine                     CODE =  -8  =================
0565               * scan for <clear>, <break>, FCTN+4 press
0566               *
0567 655C C14B  18 QTM    MOV  LINK,R5         save return
0568 655E 06A0  32        BL   @>0020          branch to console's test for <clear>
     6560 0020     
0569 6562 02C0  12        STST R0              store status in R0
0570 6564 1603  14        JNE  QTM2            exit if not <clear>
0571 6566 06A0  32 QTM1   BL   @>0020          check for <clear> again
     6568 0020     
0572 656A 13FD  14        JEQ  QTM1            loop until not <clear>
0573 656C C2C5  18 QTM2   MOV  R5,LINK         restore return
0574 656E 0240  22        ANDI R0,>2000        keep only EQU bit
     6570 2000     
0575 6572 0460  28        B    @BKLINK         return to caller
     6574 30EA     
0576               ;]*
0577               ;[*== ?KEY routine                          CODE = -10  =================
0578               *
0579 6576 0420  54 QKY    BLWP @KSCAN
     6578 373A     
0580 657A D020  34        MOVB @KYCHAR,R0
     657C 8375     
0581 657E 0980  56        SRL  R0,8
0582 6580 0280  22        CI   R0,>00FF
     6582 00FF     
0583 6584 1601  14        JNE  QKEY1
0584 6586 04C0  14        CLR  R0
0585 6588 0460  28 QKEY1  B    @BKLINK
     658A 30EA     
0586               ;]*
0587               ;[*== GOTOXY routine                        CODE = -12  =================
0588               *
0589 658C 38E8  72 GXY    MPY  @$SWDTH(U),R3
     658E 0030     
0590 6590 A102  18        A    R2,R4           Position within screen
0591 6592 A128  34        A    @$SSTRT(U),R4   Add VRAM offset to screen top
     6594 0032     
0592 6596 CA04  38        MOV  R4,@CURPO$(U)
     6598 0016     
0593 659A 0460  28        B    @BKLINK
     659C 30EA     
0594               ;]
0595               *       ___  __         __     ____  ______
0596               *      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
0597               *     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
0598               *    /____/_/\___/\__/_/\_\ /___/_/  \____/
0599               
0600               *
0601               *== USE blocks file                         CODE = -14  =================
0602               *== CREATE blocks file                      CODE = -16  =================
0603               *== READ block from blocks file             CODE = -18  =================
0604               *== WRITE block to blocks file              CODE = -20  =================
0605               ;[*== Block File I/O Support ============================================
0606               *
0607               * BPTOG utility to toggle one of 2 PABs for block file access
0608               *
0609 659E C028  34 BPTOG  MOV  @$BPOFF(U),R0	   PAB offset to R0
     65A0 0040     
0610 65A2 0201  20        LI	R1,70	            Toggle amount
     65A4 0046     
0611 65A6 2840  18        XOR	R0,R1	            New offset
0612 65A8 CA01  38        MOV	R1,@$BPOFF(U)	   Update offset
     65AA 0040     
0613               *
0614               **xxx** entry point to insure we have correct PAB address
0615 65AC C028  34 BPSET  MOV  @$DKBUF(U),R0	   Get DISK_BUF address
     65AE 002C     
0616 65B0 A028  34        A	   @$BPABS(U),R0	   Get BPABS address
     65B2 003E     
0617               *
0618 65B4 A028  34        A	   @$BPOFF(U),R0     Add current offset
     65B6 0040     
0619 65B8 C800  38        MOV	R0,@BFPAB	      Update current block file's PAB address
     65BA 34BC     
0620 65BC 045B  20        RT
0621               *
0622               * CLOSE blocks file
0623               *
0624 65BE C020  34 BKCLOS MOV  @BFPAB,R0
     65C0 34BC     
0625 65C2 0201  20        LI   R1,$FCLS          Opcode=CLOSE
     65C4 0100     
0626 65C6 0420  54        BLWP @VSBW
     65C8 373E     
0627 65CA 0220  22        AI   R0,9              Address of filename's char count
     65CC 0009     
0628 65CE C800  38        MOV  R0,@SUBPTR        Point to filename's char count
     65D0 8356     
0629 65D2 0420  54        BLWP @DSRLNK           Close the file
     65D4 37BE     
0630 65D6 0008            DATA 8
0631 65D8 045B  20        RT                     Deal with error in caller
0632               *
0633               * storage area
0634               *
0635 65DA 0000     SVBRET DATA 0                 Storage for LINK coming into BRW
0636 65DC 0000     BFPAB  DATA	0	               Storage for current blocks file PAB address...
0637               *	 	 	                     ...will have current PAB on entry
0638               * PAB header storage
0639               *
0640 65DE          PABHD  BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
0641               *              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
0642               *	                	                 >03=OUTPUT mode + "
0643               *	                	                 >01=UPDATE mode + "
0644               *	                         BYTE 2,3: save contents of DISK_BUF here
0645 65E2 80              BYTE	>80	            Record length
0646 65E3   80            BYTE	>80	            Character count of transfer
0647 65E4                 BSS	2	            Record number
0648               *
0649               *** file I/O equates
0650               *
0651      0000     $FOPN  EQU  >0000
0652      0100     $FCLS  EQU  >0100
0653      0200     $FRD   EQU  >0200
0654      0300     $FWRT  EQU  >0300
0655      0400     $FRST  EQU  >0400
0656      0005     $FINP  EQU  5
0657      0003     $FOUT  EQU  3
0658      0001     $FUPD  EQU  1
0659               *
0660               *** BRW -- entry point for block read/write routines
0661               *
0662 65E6 C80B  38 BRW    MOV  LINK,@SVBRET   Save LINK address
     65E8 34BA     
0663 65EA C1C1  18        MOV	R1,R7	         Save CODE {R1 to R7}
0664 65EC 0817  56        SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
0665 65EE 0227  22        AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
     65F0 000C     
0666 65F2 06A0  32        BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
     65F4 348C     
0667 65F6 0287  22        CI	R7,4	         USE or CREATE?
     65F8 0004     
0668 65FA 110D  14        JLT	BRW01	         No
0669 65FC 06A0  32        BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
     65FE 347E     
0670 6600 C020  34        MOV	@BFPAB,R0	   Load PAB address
     6602 34BC     
0671 6604 0220  22        AI	R0,9	         Set to name length byte
     6606 0009     
0672 6608 04C2  14        CLR	R2
0673 660A C079  30        MOV	*SP+,R1	      Pop bfnaddr to R1
0674 660C D811  46        MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
     660E 8305     
0675 6610 0582  14        INC	R2	            Add 1 to # bytes to copy
0676 6612 0420  54        BLWP	@VMBW	         Copy char count & pathname to PAB
     6614 3742     
0677               *
0678               *** set up PAB for OPEN
0679               *
0680 6616 0201  20 BRW01  LI	R1,$FUPD                Opcode=0,mode=update
     6618 0001     
0681 661A 9820  54        CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
     661C 830F     
     661E 830F     
0682 6620 1C02  14        JOP  BRW02                   No
0683 6622 0201  20        LI	R1,$FINP                Yes...change mode=input
     6624 0005     
0684 6626 C801  38 BRW02  MOV  R1,@PABHD               Put in PAB header
     6628 34BE     
0685 662A C828  54        MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
     662C 002C     
     662E 34C0     
0686 6630 04C0  14        CLR  R0
0687 6632 C800  38        MOV  R0,@PABHD+6             Set record#=0
     6634 34C4     
0688 6636 C020  34        MOV  @BFPAB,R0               VRAM destination
     6638 34BC     
0689 663A 0201  20        LI   R1,PABHD                RAM source
     663C 34BE     
0690 663E 0202  20        LI   R2,8                    Copy first 8 bytes of PAB header
     6640 0008     
0691 6642 0420  54        BLWP @VMBW                   Do the copy
     6644 3742     
0692               *
0693               *** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
0694               *
0695 6646 0220  22        AI   R0,9                Address of filename's char count in PAB
     6648 0009     
0696 664A C800  38        MOV  R0,@SUBPTR          Point to-----^^^^
     664C 8356     
0697 664E 0420  54        BLWP @DSRLNK             Open/create the file
     6650 37BE     
0698 6652 0008            DATA 8
0699 6654 135F  14        JEQ  BKERR
0700 6656 0287  22        CI   R7,4                READ or WRITE?
     6658 0004     
0701 665A 1120  14        JLT  BRW04               Yes
0702 665C 156E  14        JGT  BRWDON              No; =USE; we're done
0703               *
0704               *** write blank records to newly created blocks file [CODE = -16,CREATE]
0705               *
0706 665E C179  30        MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
0707 6660 0A35  56        SLA  R5,3                Convert #blocks to #records
0708 6662 C0C5  18        MOV  R5,R3               Save
0709 6664 C105  18        MOV  R5,R4               Set up counter
0710 6666 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     6668 0301     
0711 666A C800  38        MOV  R0,@PABHD           Copy to PAB header
     666C 34BE     
0712 666E 6144  18 BRLOOP S    R4,R5               Calculate next record
0713 6670 C805  38        MOV  R5,@PABHD+6         Copy to PAB header
     6672 34C4     
0714 6674 C020  34        MOV  @BFPAB,R0           VRAM destination
     6676 34BC     
0715 6678 0201  20        LI   R1,PABHD            RAM source
     667A 34BE     
0716 667C 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     667E 0008     
0717 6680 0420  54        BLWP @VMBW               Do the copy
     6682 3742     
0718 6684 0220  22        AI   R0,9                Address of filename's char count
     6686 0009     
0719 6688 C800  38        MOV  R0,@SUBPTR          Point to filename's char count
     668A 8356     
0720 668C 0420  54        BLWP @DSRLNK             Write one record of blanks
     668E 37BE     
0721 6690 0008            DATA 8
0722 6692 1340  14        JEQ  BKERR
0723 6694 C143  18        MOV  R3,R5               Get #blocks
0724 6696 0604  14        DEC  R4                  Count down 1 record
0725 6698 16EA  14        JNE  BRLOOP              Write another record if not done
0726 669A 104F  14        JMP  BRWDON              We're done
0727               *
0728               *** prepare for read/write block
0729               *
0730 669C C179  30 BRW04  MOV  *SP+,R5             Pop block# to write
0731 669E C1B9  30        MOV  *SP+,R6             Pop bufaddr
0732 66A0 0605  14        DEC  R5                  Block#-1
0733 66A2 0A35  56        SLA  R5,3                Convert to starting record#
0734 66A4 0204  20        LI   R4,8                Load counter for 8 records
     66A6 0008     
0735 66A8 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     66AA 0301     
0736 66AC 0203  20        LI   R3,VMBW             WRITE vector
     66AE 3742     
0737 66B0 0287  22        CI   R7,2                Are we writing the block?
     66B2 0002     
0738 66B4 1304  14        JEQ  BRW05               Yup
0739 66B6 0200  20        LI   R0,$FRD+$FINP       Nope...set up for READ
     66B8 0205     
0740 66BA 0203  20        LI   R3,VMBR             READ vector
     66BC 374A     
0741 66BE C800  38 BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
     66C0 34BE     
0742               *
0743               * READ/WRITE block routine [CODE = -18/-20]
0744               *
0745 66C2 C805  38 RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
     66C4 34C4     
0746 66C6 C020  34        MOV  @BFPAB,R0           VRAM destination
     66C8 34BC     
0747 66CA 0201  20        LI   R1,PABHD            RAM source
     66CC 34BE     
0748 66CE 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     66D0 0008     
0749 66D2 0420  54        BLWP @VMBW               Do the copy
     66D4 3742     
0750 66D6 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0
     66D8 002C     
0751 66DA C046  18        MOV  R6,R1               RAM buffer to R1
0752 66DC 0202  20        LI   R2,128              Bytes to copy
     66DE 0080     
0753 66E0 0287  22        CI   R7,3                READ?
     66E2 0003     
0754 66E4 1301  14        JEQ  BRW06               Yup
0755 66E6 0413  42        BLWP *R3                 Nope...copy record to VRAM
0756               *
0757               * temporarily use CRU register---it should be OK
0758               *
0759 66E8 C320  34 BRW06  MOV  @BFPAB,CRU          PAB address
     66EA 34BC     
0760 66EC 022C  22        AI   CRU,9               Address of filename's char count
     66EE 0009     
0761 66F0 C80C  38        MOV  CRU,@SUBPTR         Point to filename's char count
     66F2 8356     
0762 66F4 0420  54        BLWP @DSRLNK             Read/write one record
     66F6 37BE     
0763 66F8 0008            DATA 8
0764 66FA 130C  14        JEQ  BKERR
0765 66FC 0287  22        CI   R7,2                WRITE?
     66FE 0002     
0766 6700 1303  14        JEQ  BRW07               Yup...next record
0767 6702 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
     6704 002C     
0768 6706 0413  42        BLWP *R3                 Nope...copy record to RAM buffer
0769 6708 0585  14 BRW07  INC  R5                  Next record in file
0770 670A 0226  22        AI   R6,128              Next record to/from block RAM buffer
     670C 0080     
0771 670E 0604  14        DEC  R4                  Count down 1 record
0772 6710 16D8  14        JNE  RWLOOP              Read/write another record if not done
0773 6712 1013  14        JMP  BRWDON              We're done
0774               *
0775               *** error handling
0776               *
0777 6714 D000  18 BKERR  MOVB R0,R0               Device error?
0778 6716 1306  14        JEQ  BKERR6              Yes, exit with disk error
0779 6718 0206  20 BKERR9 LI   R6,9                No, exit with file error
     671A 0009     
0780 671C 1005  14        JMP  BKCLN
0781 671E 0206  20 BKERR8 LI   R6,8                Block# <=0!  exit with range error
     6720 0008     
0782 6722 1002  14        JMP  BKCLN
0783 6724 0206  20 BKERR6 LI   R6,6
     6726 0006     
0784 6728 06A0  32 BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
     672A 349E     
0785 672C 0287  22        CI   R7,4                USE or CREATE?
     672E 0004     
0786 6730 1102  14        JLT  BKCLN1              No
0787 6732 06A0  32        BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
     6734 347E     
0788 6736 C006  18 BKCLN1 MOV  R6,R0               Pass error back to caller
0789 6738 100C  14        JMP  BKEXIT
0790 673A 04C6  14 BRWDON CLR  R6
0791 673C 06A0  32        BL   @BKCLOS             Close current blocks file
     673E 349E     
0792 6740 1602  14        JNE  BRWDN1              Error?
0793 6742 0206  20        LI   R6,9                Yes...assume it was a file error
     6744 0009     
0794 6746 0287  22 BRWDN1 CI   R7,4                (no error)...CREATE?
     6748 0004     
0795 674A 1602  14        JNE  BRWDN2              No...we're done
0796 674C 06A0  32        BL   @BPTOG              Yes...revert to correct blocks file
     674E 347E     
0797 6750 C006  18 BRWDN2 MOV  R6,R0               Error to R0
0798 6752 C2E0  34 BKEXIT MOV  @SVBRET,LINK        Restore LINK
     6754 34BA     
0799 6756 0460  28        B    @BKLINK
     6758 30EA     
0800               ;]
0801               ;[* MSGTYP      <<< Support for string typing in various banks >>>
0802               *
0803               * Called with:  BL  @MSGTYP
0804               *
0805               * R4 and R5 are the only registers that will be preserved
0806               * ..after a call to EMIT---
0807               *
0808               * Input:    R4 = Address of length byte of packed string
0809               *
0810               * We will pass the ASCII value of character to EMIT in R2 without
0811               * insuring it is 7 bits wide.
0812               *
0813 675A 064E  14 MSGTYP DECT R           Push return address
0814 675C C78B  30        MOV  LINK,*R     ...to Forth return stack
0815 675E 04C5  14        CLR  R5
0816 6760 D174  28        MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
0817 6762 06C5  14        SWPB R5          Put char count in low byte
0818 6764 04C2  14 MTLOOP CLR  R2
0819 6766 D0B4  28        MOVB *R4+,R2     Copy next char to R2 for EMIT
0820 6768 06C2  14        SWPB R2          Put char in low byte
0821 676A 0300  24        LIMI 0           We need to do this because we're calling EMIT directly
     676C 0000     
0822 676E 06A0  32        BL   @EMT        Call EMIT directly
     6770 3312     
0823 6772 05A8  34        INC  @$OUT(U)    Increment display line character count
     6774 0052     
0824 6776 0605  14        DEC  R5          Decrement character count for this message
0825 6778 16F5  14        JNE  MTLOOP      Are we done?
0826 677A C2FE  30        MOV  *R+,LINK    Yes. Pop return address
0827 677C 045B  20        RT               Return to caller
0828                ;]
0829               ;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
0830 677E CD74  46 R4$5   MOV  *R4+,*R5+
0831 6780 CD74  46        MOV  *R4+,*R5+
0832 6782 CD74  46        MOV  *R4+,*R5+
0833 6784 C554  38        MOV  *R4,*R5
0834 6786 045B  20        RT
0835               ;]
0836               *     __  __              _   __         _      __   __
0837               *    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__
0838               *   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
0839               *   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/
0840               *              ___      ___          ____
0841               *             / _ \___ / _/__ ___ __/ / /____
0842               *            / // / -_) _/ _ `/ // / / __(_-<
0843               *           /____/\__/_/ \_,_/\_,_/_/\__/___/
0844               
0845               ;[*== User Variable defaults ============================================
0846               *
0847 6788          UBASE0 BSS  6                 BASE OF USER VARIABLES
0848 678E 3668            DATA UBASE0            06 USER UCONS$
0849 6790 FFA0            DATA SPBASE            08 USER S0
0850 6792 3FFE            DATA RBASE             0A USER R0 { R0$
0851 6794 36B4            DATA $UVAR             0C USER U0
0852 6796 FFA0            DATA SPBASE            0E USER TIB
0853 6798 001F            DATA 31                10 USER WIDTH
0854 679A A000            DATA DPBASE            12 USER DP
0855 679C 30F6            DATA $SYS$             14 USER SYS$
0856 679E 0000            DATA 0                 16 USER CURPOS
0857 67A0 3020            DATA INT1              18 USER INTLNK
0858 67A2 0001            DATA 1                 1A USER WARNING
0859 67A4 0040            DATA 64                1C USER C/L$ { CL$
0860 67A6 2010            DATA $BUFF             1E USER FIRST$
0861 67A8 3020            DATA $LO               20 USER LIMIT$
0862 67AA 0380            DATA >0380             22 USER COLTAB    Color Table address in VRAM
0863 67AC 0300            DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
0864 67AE 0780            DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
0865 67B0 0800            DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
0866 67B2 0080            DATA >80               2A USER FPB       pushes address of user screen font file PAB
0867               *                                               ...that is this relative distance from DISK_BUF
0868 67B4 1000            DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
0869 67B6 0460            DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
0870 67B8 0028            DATA 40                30 USER SCRN_WIDTH
0871 67BA 0000            DATA 0                 32 USER SCRN_START
0872 67BC 03C0            DATA 960               34 USER SCRN_END
0873 67BE 0000            DATA 0                 36 USER ISR       [Note: This used to be INT1]
0874 67C0 0000            DATA 0                 38 USER ALTIN
0875 67C2 0000            DATA 0                 3A USER ALTOUT
0876 67C4 0001            DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
0877 67C6 00C6            DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
0878               *                                               ...that is this relative distance from DISK_BUF
0879 67C8 0000            DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
0880               *                                               ...always toggled between 0 and 70
0881 67CA 0800            DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
0882 67CC FFFF            DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
0883               *                                                  0 = console font via GPLLNK
0884 67CE 0000            DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
0885 67D0 0000            DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
0886 67D2 0000            DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
0887               *                                                  0 = Symmetric (default)
0888               *                                                 !0 = Floored
0889 67D4          $UVAR  BSS  >80               USER VARIABLE AREA
0890               ;]
0891               ;[*== A Constant ====================================================
0892               *
0893 6854 2000     H2000  DATA >2000
0894               ;]*
0895               *    __  ____  _ ___ __         _   __        __
0896               *   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
0897               *  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
0898               *  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
0899               *                     /___/
0900               *
0901               ;[*== Utility Vectors ===================================================
0902               *
0903               * GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
0904               * DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
0905 6856 3A4C     XMLLNK DATA UTILWS,XMLENT   ; Link to ROM routines
     6858 3756     
0906 685A 3A4C     KSCAN  DATA UTILWS,KSENTR   ; Keyboard scan
     685C 3832     
0907 685E 3A4C     VSBW   DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
     6860 3848     
0908 6862 3A4C     VMBW   DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
     6864 3854     
0909 6866 3A4C     VSBR   DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
     6868 3862     
0910 686A 3A4C     VMBR   DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
     686C 386E     
0911 686E 3A4C     VMOVE  DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
     6870 38AE     
0912 6872 3A4C     VWTR   DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
     6874 387C     
0913               ;]*
0914               ;[*== XMLENT -- Link to system XML utilities ============================
0915               *
0916 6876 C83E  50 XMLENT MOV  *R14+,@GPLWS+2      Get argument
     6878 83E2     
0917 687A 02E0  18        LWPI GPLWS               Select GPL workspace
     687C 83E0     
0918 687E C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6880 3A62     
0919 6882 C081  18        MOV  R1,R2               Make a copy of argument
0920 6884 0281  22        CI   R1,>8000            Direct address in ALC?
     6886 8000     
0921 6888 1B07  14        JH   XML30               We have the address
0922 688A 09C1  56        SRL  R1,12
0923 688C 0A11  56        SLA  R1,1
0924 688E 0A42  56        SLA  R2,4
0925 6890 09B2  56        SRL  R2,11
0926 6892 A0A1  34        A    @XMLTAB(R1),R2
     6894 0CFA     
0927 6896 C092  26        MOV  *R2,R2
0928 6898 0692  24 XML30  BL   *R2
0929 689A 02E0  18        LWPI UTILWS              Get back to right WS
     689C 3A4C     
0930 689E C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     68A0 83F6     
0931 68A2 0380  18        RTWP
0932               ;]*
0933               *    ________  __   __   _  ____ __           __  ________
0934               *   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
0935               *  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ /
0936               *  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
0937               *
0938               *-----------------------------------------------------------------------*
0939               ;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
0940               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
0941               *                                                                       *
0942               * This routine will work with any GROM library slot since it is         *
0943               * indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
0944               * This GPLLNK does NOT require a module to be plugged into the          *
0945               * GROM port so it will work with the Editor/Assembler,                  *
0946               * Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
0947               * CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
0948               * It saves and restores the current GROM Address in case you want       *
0949               * to return back to GROM for Basic or Extended Basic CALL LINKs         *
0950               * or to return to the loading module.                                   *
0951               *                                                                       *
0952               *    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
0953               *                                                 DATA >34              *
0954               *                                                                       *
0955               *    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
0956               *                                                                       *
0957               * 70 Bytes - including the GPLLNK Workspace                             *
0958               *-----------------------------------------------------------------------*
0959               
0960               *  GPLWS (>83E0) is GPL workspace
0961      83E8     G_R4   EQU  GPLWS+8              GPL workspace R4
0962      83EC     G_R6   EQU  GPLWS+12             GPL workspace R6
0963               *  SUBSTK (>8373) is GPL Subroutine stack pointer
0964      0060     LDGADR EQU  >60                  Load & Execute GROM address entry point
0965      200E     XTAB27 EQU  >200E                Low Mem XML table location 27
0966               *                                ..Will contain XMLRTN at startup
0967      166C     GETSTK EQU  >166C
0968               
0969 68A4 3776     GPLLNK DATA GLNKWS     ; R7       Set up BLWP Vectors
0970 68A6 3796            DATA GLINK1     ; R8
0971               * RTNADR     <---don't think we need this label
0972 68A8 37B2            DATA XMLRTN     ; R9       address where GPL XML returns to us...
0973               *                                ...this address will already be in XTAB27,...
0974               *                                ...>200E, so don't really need it here}
0975 68AA 176C     GXMLAD DATA >176C      ; R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
0976 68AC 0050            DATA >50        ; R11      Initialized to >50 where PUTSTK address resides
0977      3776     GLNKWS EQU  $->18      ; GPLLNK's workspace of which only...
0978 68AE                 BSS  >08        ; R12-R15  ...registers R7 through R15 are used
0979               
0980 68B6 C81B  46 GLINK1 MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
     68B8 83E8     
0981 68BA C83E  50        MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
     68BC 83EC     
0982 68BE 02E0  18        LWPI GPLWS                Load GPL WS
     68C0 83E0     
0983 68C2 0694  24        BL   *R4                  Save current GROM Address on stack
0984 68C4 C920  54        MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
     68C6 378A     
     68C8 8302     
0985 68CA 05E0  34        INCT @SUBSTK              Adjust the stack pointer
     68CC 8373     
0986 68CE 0460  28        B    @LDGADR              Execute our GPL Routine
     68D0 0060     
0987               
0988 68D2 C120  34 XMLRTN MOV  @GETSTK,R4           Get GETSTK pointer
     68D4 166C     
0989 68D6 0694  24        BL   *R4                  Restore GROM address off the stack
0990 68D8 02E0  18        LWPI GLNKWS               Load our WS
     68DA 3776     
0991 68DC 0380  18        RTWP                      All Done - Return to Caller
0992               ;]
0993               *     ___  _______  __   _  ____ __           __  ________
0994               *    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
0995               *   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ /
0996               *  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
0997               *
0998               *-----------------------------------------------------------------------*
0999               ;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
1000               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
1001               *                                                                       *
1002               *      (Uses console GROM 0's DSRLNK routine)                           *
1003               *      (Do not REF DSRLNK or GPLLNK when using these routines)          *
1004               *      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
1005               *                                                                       *
1006               *      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
1007               *                                                   DATA 8              *
1008               *                                                                       *
1009               *      NOTES: Must be used with a GPLLNK routine                        *
1010               *             Returns ERRORs the same as the E/A DSRLNK                 *
1011               *             EQ bit set on return if error                             *
1012               *             ERROR CODE in caller's MSB of Register 0 on return        *
1013               *                                                                       *
1014               * 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
1015               *-----------------------------------------------------------------------*
1016               
1017      0050     PUTSTK EQU  >50                     Push GROM Address to stack pointer
1018      836D     TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
1019      8356     NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
1020      8C02     VWA    EQU  >8C02                   VDP Write Address location
1021      8800     VRD    EQU  >8800                   VDP Read Data byte location
1022      83E9     G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
1023      837C     GSTAT  EQU  >837C                   GPL Status byte location
1024               
1025 68DE 37C2     DSRLNK DATA DSRWS,DLINK1            Set BLWP Vectors
     68E0 37C2     
1026               
1027               DSRWS                      ; Start of DSRLNK workspace
1028      37C9     DR3LB  EQU  $+7            ; lower byte of DSRLNK workspace R3
1029 68E2 C30C  18 DLINK1 MOV  R12,R12         R0      Have we already looked up the LINK address?
1030 68E4 161C  14        JNE  DLINK3          R1      YES!  Skip lookup routine
1031               *<<-------------------------------------------------------------------------->>*
1032               * This section of code is only executed once to find the GROM address          *
1033               * for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
1034               * to indicate that the address is found and to be used as a mask for EQ & CND  *
1035               *------------------------------------------------------------------------------*
1036 68E6 02E0  18        LWPI GPLWS           R2,R3   else load GPL workspace
     68E8 83E0     
1037 68EA C120  34        MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
     68EC 0050     
1038 68EE 0694  24        BL   *R4             R6
1039 68F0 0204  20        LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
     68F2 0011     
1040 68F4 DB44  38        MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector
     68F6 0402     
1041               
1042               ***les*** Note on above instruction:
1043               ***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
1044               ***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)
1045               
1046 68F8 1004  14        JMP  DLINK2          R11     Jump around R12-R15
1047 68FA 0000            DATA 0               R12     contains >2000 flag when set
1048 68FC 0000            DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
     68FE 0000     
     6900 0000     
1049 6902 DB60  54 DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
     6904 83E9     
     6906 0402     
1050 6908 C160  34        MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
     690A 166C     
1051 690C D81D  46        MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
     690E 3811     
1052 6910 05E0  34        INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
     6912 3810     
1053 6914 0695  24        BL   *R5                     Restore the GROM address off the stack
1054 6916 02E0  18        LWPI DSRWS                   Reload DSRLNK workspace
     6918 37C2     
1055 691A 020C  20        LI   R12,>2000               Set flag to signify DSRLNK address is set
     691C 2000     
1056               *<<-------------------------------------------------------------------------->>*
1057 691E 058E  14 DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
1058 6920 D83E  48        MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
     6922 836D     
1059 6924 C0E0  34        MOV  @NAMLEN,R3              Save VDP address of Name Length
     6926 8356     
1060 6928 0223  22        AI   R3,-8                   Adjust it to point to PAB Flag byte
     692A FFF8     
1061 692C 0420  54        BLWP @GPLLNK                 Execute DSR LINK
     692E 3784     
1062 6930 03       DSRADR BYTE >03                     High byte of GPL DSRLNK address
1063 6931   00     DSRAD1 BYTE >00                     Lower byte of GPL DSRLNK address
1064               *----Error Check & Report to Caller's R0 and EQU bit-------------------------
1065 6932 D820  54        MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
     6934 37C9     
     6936 8C02     
1066 6938 D803  38        MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
     693A 8C02     
1067 693C 53CC  18        SZCB R12,R15                 Clear EQ bit for Error Report
1068 693E D0E0  34        MOVB @VRD,R3                 Get PAB Error Flag
     6940 8800     
1069 6942 0953  56        SRL  R3,5                    Adjust it to 0-7 error code
1070 6944 D743  30        MOVB R3,*R13                 Put it into Caller's R0 (msb)
1071 6946 1603  14        JNE  SETEQ                   If it's not zero, set EQ bit
1072 6948 2320  38        COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
     694A 837C     
1073 694C 1601  14        JNE  DSREND                  No Error, Just return
1074 694E F3CC  18 SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
1075 6950 0380  18 DSREND RTWP                         All Done - Return to Caller
1076               ;]
1077               ;[*== KSENTR -- Keyboard Scan (entry point) =============================
1078               *
1079 6952 02E0  18 KSENTR LWPI GPLWS
     6954 83E0     
1080 6956 C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6958 3A62     
1081 695A 06A0  32        BL   @SCNKEY             Console keyboard scan routine
     695C 000E     
1082 695E 02E0  18        LWPI UTILWS
     6960 3A4C     
1083 6962 C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     6964 83F6     
1084 6966 0380  18        RTWP
1085               ;]*
1086               *    _   _____  ___    __  ____  _ ___ __  _
1087               *   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
1088               *   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
1089               *   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
1090               *
1091               ;[*== VDP utilities (entry point) =======================================
1092               *
1093               ** VDP single byte write
1094               *
1095 6968 06A0  32 VSBWEN BL   @WVDPWA             Write out address
     696A 388E     
1096 696C D82D  54        MOVB @2(R13),@VDPWD      Write data
     696E 0002     
     6970 8C00     
1097 6972 0380  18        RTWP                     Return to calling program
1098               *
1099               ** VDP multiple byte write
1100               *
1101 6974 06A0  32 VMBWEN BL   @WVDPWA             Write out address
     6976 388E     
1102 6978 D831  48 VWTMOR MOVB *R1+,@VDPWD         Write a byte
     697A 8C00     
1103 697C 0602  14        DEC  R2                  Decrement byte count
1104 697E 16FC  14        JNE  VWTMOR              More to write?
1105 6980 0380  18        RTWP                     Return to calling Program
1106               *
1107               ** VDP single byte read
1108               *
1109 6982 06A0  32 VSBREN BL   @WVDPRA             Write out address
     6984 3894     
1110 6986 DB60  54        MOVB @VDPRD,@2(R13)      Read data
     6988 8800     
     698A 0002     
1111 698C 0380  18        RTWP                     Return to calling program
1112               *
1113               ** VDP multiple byte read
1114               *
1115 698E 06A0  32 VMBREN BL   @WVDPRA             Write out address
     6990 3894     
1116 6992 DC60  48 VRDMOR MOVB @VDPRD,*R1+         Read a byte
     6994 8800     
1117 6996 0602  14        DEC  R2                  Decrement byte count
1118 6998 16FC  14        JNE  VRDMOR              More to read?
1119 699A 0380  18        RTWP                     Return to calling program
1120               *
1121               ** VDP write to register
1122               *
1123 699C C05D  26 VWTREN MOV  *R13,R1             Get register number and value
1124 699E D82D  54        MOVB @1(R13),@VDPWA      Write out value
     69A0 0001     
     69A2 8C02     
1125 69A4 0261  22        ORI  R1,>8000            Set for register write
     69A6 8000     
1126 69A8 D801  38        MOVB R1,@VDPWA           Write out register number
     69AA 8C02     
1127 69AC 0380  18        RTWP                     Return to calling program
1128               *
1129               ** Set up to write to VDP
1130               *
1131 69AE 0201  20 WVDPWA LI   R1,>4000
     69B0 4000     
1132 69B2 1001  14        JMP  WVDPAD
1133               *
1134               ** Set up to read VDP
1135               *
1136 69B4 04C1  14 WVDPRA CLR  R1
1137               *
1138               ** Write VDP address
1139               *
1140 69B6 C09D  26 WVDPAD MOV  *R13,R2             Get VDP address
1141 69B8 D820  54        MOVB @U_R2LB,@VDPWA      Write low byte of address
     69BA 3A51     
     69BC 8C02     
1142 69BE E081  18        SOC  R1,R2               Properly adjust VDP write bit
1143 69C0 D802  38        MOVB R2,@VDPWA           Write high byte of address
     69C2 8C02     
1144 69C4 C06D  34        MOV  @2(R13),R1          Get CPU RAM address
     69C6 0002     
1145 69C8 C0AD  34        MOV  @4(R13),R2          Get byte count
     69CA 0004     
1146 69CC 045B  20        RT                       Return to calling routine
1147               
1148               *
1149               ** VDP-to-VDP move.
1150               *
1151 69CE C05D  26 VMOVEN MOV  *R13,R1             Get cnt to R1
1152 69D0 C0AD  34        MOV  @2(R13),R2          Get vsrc to R2
     69D2 0002     
1153 69D4 C0ED  34        MOV  @4(R13),R3          Get vdst to R3
     69D6 0004     
1154 69D8 0263  22        ORI  R3,>4000            Prepare for VDP write
     69DA 4000     
1155               
1156               ** copy cnt bytes from vsrc to vdst
1157               
1158 69DC D820  54 VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
     69DE 3A51     
     69E0 8C02     
1159 69E2 D802  38        MOVB R2,@VDPWA           Write MSB of VDP read address
     69E4 8C02     
1160 69E6 0582  14        INC  R2                  Next VDP read address
1161 69E8 D020  34        MOVB @VDPRD,R0           Read VDP byte
     69EA 8800     
1162 69EC D820  54        MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
     69EE 3A53     
     69F0 8C02     
1163 69F2 D803  38        MOVB R3,@VDPWA           Write MSB of VDP write address
     69F4 8C02     
1164 69F6 0583  14        INC  R3                  Next VDP write address
1165 69F8 D800  38        MOVB R0,@VDPWD           Write VDP byte
     69FA 8C00     
1166 69FC 0601  14        DEC  R1                  Decrement count
1167 69FE 16EE  14        JNE  VMVMOR              Repeat if not done
1168 6A00 0380  18        RTWP                     Return to calling program
1169               ;]*
1170               ;[*== fbForth Version Message ===========================================
1171               FBFMSG
1172               * This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
1173               * Also, printing the extra blanks overwrites the font-not-found error message.
1174 6A02 11              BYTE 17
1175 6A03   66            TEXT 'fbForth 2.0:     '
     6A04 6246     
     6A06 6F72     
     6A08 7468     
     6A0A 2032     
     6A0C 2E30     
     6A0E 3A20     
     6A10 2020     
     6A12 2020     
1176               ;]
1177               *     __  ___        ___ ____      __   __      _      __            __
1178               *    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
1179               *   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
1180               *  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
1181               *
1182               ;[*== Modifiable words in Resident Dictionary ===========================
1183               ;[*** (ABORT) ***
1184 6A14 73CC            DATA x#VLST_N         <--Last word in ROM
1185 6A16 8728     PABR_N DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT
     6A18 4142     
     6A1A 4F52     
     6A1C 54A9     
1186               
1187 6A1E 8334     PABORT DATA DOCOL
1188 6A20 6ADE            DATA ABORT,SEMIS
     6A22 6358     
1189               ;]*
1190               ;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
1191 6A24 38F6            DATA PABR_N
1192 6A26 C546     FRTH_N DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT
     6A28 4F52     
     6A2A 54C8     
1193               
1194 6A2C 7218     FORTH  DATA DOVOC
1195 6A2E A002     FORTHV DATA DPBASE+2    ; vocabulary link field
1196 6A30 81A0     FORTHP DATA >81A0       ; pseudo name field
1197 6A32 0000     FORTHL DATA 0           ; chronological link field
1198               ;]*
1199               ;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
1200 6A34 3906            DATA FRTH_N
1201 6A36 C941     ASMR_N DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT
     6A38 5353     
     6A3A 454D     
     6A3C 424C     
     6A3E 45D2     
1202               
1203 6A40 7218     ASSM   DATA DOVOC
1204               ; Initially points to last word in ASSEMBLER vocabulary in the kernel
1205 6A42 394A     ASMV   DATA SASM_N   ; vocabulary link field
1206 6A44 81A0            DATA >81A0    ; pseudo name field
1207 6A46 3912     ASML   DATA FORTHL   ; chronological link field
1208               
1209               *
1210               ;]*
1211               ;]*
1212               *    ___                     __   __
1213               *   / _ | ___ ___ ___ __ _  / /  / /__ ____
1214               *  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
1215               * /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/
1216               *     _   __              __        __                _      __            __
1217               *    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
1218               *    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
1219               *    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
1220               *                                           /___/
1221               *
1222               *== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
1223               ;[*** NEXT, ***      ( --- )
1224               * 1st word in ASSEMBLER vocabulary
1225               *
1226 6A48 3910            DATA FORTHP          <--points to PNF of FORTH
1227 6A4A 854E     NXT__N DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT
     6A4C 4558     
     6A4E 54AC     
1228               
1229 6A50 3932     NEXTC  DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
1230 6A52 0200  20 NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
     6A54 045F     
1231 6A56 C068  34        MOV  @$DP(U),R1        HERE to R1
     6A58 0012     
1232 6A5A CC40  34        MOV  R0,*R1+           compile "B *NEXT"
1233 6A5C CA01  38        MOV  R1,@$DP(U)        update HERE
     6A5E 0012     
1234 6A60 CA28  54        MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
     6A62 0058     
     6A64 0056     
1235 6A66 045F  20        B    *NEXT             back to inner interpreter
1236               
1237               * : NEXT,   ( --- )
1238               *    *NEXT B,  ;
1239               ;]*
1240               ;[*** ;ASM ***       ( --- )
1241               * 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
1242               * ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
1243               *
1244 6A68 392A            DATA NXT__N
1245 6A6A 84       SASM_N BYTE 4+TERMBT    <--note different name field format
1246 6A6B   3B            TEXT ';ASM'
     6A6C 4153     
     6A6E 4D       
1247 6A6F   A0            BYTE ' '+TERMBT
1248               
1249 6A70 3952     SASM   DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
1250 6A72 10EF  14        JMP  NXT_P          finish up in NEXT,
1251               
1252               * : ;ASM   ( --- )
1253               *    *NEXT B,  ;
1254               ;]*
1255               
1256               ;[*== Some Variables (KEYCNT etc.) ======================================
1257               
1258 6A74 FFFF     KEYCNT DATA -1              Used in cursor flash logic
1259 6A76 0000     INTACT DATA 0               Non-zero during user's interrupt service routine
1260               *
1261               *++ variables used by some graphics primitives
1262               *
1263 6A78 0000     $DMODE DATA 0                   ; actual location of variable contents
1264 6A7A FFFF     $DCOL  DATA -1                  ; actual location of variable contents
1265               
1266               *===========================================================
1267               ;]*
1268               *   ______                         ___            _____        __
1269               *  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__
1270               *   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
1271               *  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/
1272               *                    /_/
1273               *
1274               ;[*== Trampoline Code ===================================================
1275               *
1276               * MYBANK must be at same location in all banks with the code that appears
1277               * in the following table.  The EQUates for BANK0--BANK3 may also be in the
1278               * same places in each bank for convenience, but they only need to appear once.
1279               *
1280               *       Bank Select MYBANK
1281               *       ---- ------ ------
1282               *       0    >6006  >C000
1283               *       1    >6004  >8000
1284               *       2    >6002  >4000
1285               *       3    >6000  >0000
1286               *
1287               * Bank0 code will look like this
1288               *
1289               * MYBANK DATA >C000
1290               * BANK0  EQU  >C000
1291               * BANK1  EQU  >8000
1292               * BANK2  EQU  >4000
1293               * BANK3  EQU  >0000
1294               *
1295               * Banks 1--3 will look the same, including labels, and the DATA
1296               * instruction at MYBANK's location will correspond to its bank.
1297               *
1298               * Before a bank is selected, the values above will be shifted right 13
1299               * bits and have >6000 added.
1300               *
1301               ;[*** BLBANK ************************************************************
1302               *
1303               * General bank branching routine (32KB ROM, i.e., 4 banks) for a
1304               * branch that is expected to return (not high-level Forth) via RTBANK---
1305               *   --put in scratchpad or low RAM
1306               *   --called by
1307               *       BL    @BLBANK
1308               *       DATA  dst_addr - >6000 + bank# in left 2 bits
1309               *
1310 6A7C 064E  14 BLBANK DECT R               ; reserve space on return stack (R14)
1311 6A7E C33B  30        MOV  *LINK+,CRU      ; copy destination bank address to R12
1312 6A80 C78B  30        MOV  LINK,*R         ; push return address
1313 6A82 064E  14        DECT R               ; reserve space on return stack
1314 6A84 C7A0  46        MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
     6A86 7FFE     
1315 6A88 C2CC  18        MOV  CRU,LINK        ; copy destination bank address to R11
1316 6A8A 024B  22        ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
     6A8C 1FFF     
1317 6A8E 022B  22        AI   LINK,>6000      ; make it a real address
     6A90 6000     
1318 6A92 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1319 6A94 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6A96 6000     
1320 6A98 04DC  26        CLR  *CRU            ; switch to destination bank
1321 6A9A 045B  20        B    *LINK           ; branch to destination address
1322               ;]*
1323               ;[*** RTBANK ************************************************************
1324               *
1325               * General bank return routine (32KB ROM, i.e., 4 banks)---
1326               *   --put in scratchpad or low RAM
1327               *   --called by
1328               *       B   @RTBANK
1329               *
1330 6A9C C33E  30 RTBANK MOV  *R+,CRU         ; pop return bank# from return stack to R12
1331 6A9E 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1332 6AA0 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6AA2 6000     
1333 6AA4 C2FE  30        MOV  *R+,LINK        ; pop return address from return stack
1334 6AA6 04DC  26        CLR  *CRU            ; switch to destination bank
1335 6AA8 045B  20        B    *LINK           ; branch to return address
1336               ;]*
1337               ;[*** BLF2A *************************************************************
1338               *
1339               * High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
1340               * banks) that is expected to return to bank0 via RTNEXT.  This will
1341               * only(?) be used for the ALC payload of Forth stubs in bank0---
1342               *   --put in scratchpad or low RAM
1343               *   --called by
1344               *       BL    @BLF2A
1345               *       DATA  dst_addr - >6000 + bank# in left 2 bits
1346               *
1347 6AAA C2DB  26 BLF2A  MOV  *LINK,LINK      ; copy destination bank address to R11
1348 6AAC C30B  18        MOV  LINK,CRU        ; copy it to R12
1349 6AAE 024B  22        ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
     6AB0 1FFF     
1350 6AB2 022B  22        AI   LINK,>6000      ; make it a real address
     6AB4 6000     
1351 6AB6 09DC  56        SRL  CRU,13          ; shift bank# into bits 1-2 of R12
1352 6AB8 022C  22        AI   CRU,>6000       ; make it a real bank-switch address
     6ABA 6000     
1353 6ABC 04DC  26        CLR  *CRU            ; switch to destination bank
1354 6ABE 045B  20        B    *LINK           ; branch to destination address
1355               ;]*
1356               ;[*** RTNEXT ************************************************************
1357               *
1358               * High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4
1359               * banks)---
1360               *   --put in scratchpad or low RAM
1361               *   --called by
1362               *       B   @RTNEXT
1363               *
1364 6AC0 C320  34 RTNEXT MOV  @INTACT,CRU       Are we in user's ISR?
     6AC2 3956     
1365 6AC4 1602  14        JNE  RTNXT1            Don't enable interrupts if so.
1366 6AC6 0300  24        LIMI 2
     6AC8 0002     
1367 6ACA 04E0  34 RTNXT1 CLR  @>6006          ; switch to bank 0
     6ACC 6006     
1368 6ACE 045F  20        B    *NEXT           ; branch to next CFA (in R15)
1369               ;]*
1370               ;[*** BLA2F *************************************************************
1371               *
1372               * ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
1373               * banks) that is expected to return to calling bank via RTA2F---
1374               *   --put in scratchpad or low RAM
1375               *   --called by
1376               *       BL    @BLA2F
1377               *       DATA <Forth cfa in bank0>
1378               *
1379 6AD0 064E  14 BLA2F  DECT R               ; reserve space on return stack
1380 6AD2 C2BB  30        MOV  *LINK+,W        ; move CFA of Forth routine to W
1381 6AD4 C78B  30        MOV  LINK,*R         ; push return address of calling bank
1382 6AD6 064E  14        DECT R               ; reserve space on return stack
1383 6AD8 C7A0  46        MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
     6ADA 7FFE     
1384 6ADC 064E  14        DECT R               ; reserve spot on return stack
1385 6ADE C78D  30        MOV  IP,*R           ; move current IP to return stack
1386 6AE0 020D  20        LI   IP,RTA2F        ; move address of return procedure to IP
     6AE2 39CC     
1387 6AE4 04E0  34        CLR  @>6006          ; switch to bank0
     6AE6 6006     
1388 6AE8 0460  28        B    @DOEXEC         ; Execute the Forth routine
     6AEA 833C     
1389               ;]*
1390               ;[*** RTA2F *************************************************************
1391               *
1392               * ALC to high-level Forth bank "return" routine from Forth to calling
1393               * ALC (32KB ROM, i.e., 4 banks)---
1394               *   --put in scratchpad or low RAM
1395               *   --called through B *NEXT at end of Forth word's execution in BLA2F
1396               *
1397 6AEC 39CE     RTA2F  DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
1398 6AEE 39D0            DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
1399 6AF0 C37E  30        MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
1400               * Retrieve ALC return info and return to caller...
1401               * ...caller will execute B *NEXT when it finishes
1402 6AF2 0460  28        B    @RTBANK         ; branch to general bank return routine above
     6AF4 397C     
1403               ;]*
1404               ;]***********************************************************************
1405               ;[*++ Bank-specific cell-/byte-reading code ++*
1406               ;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
1407               *++ Read cell contents of address in Bank bank# or RAM.
1408               *++ Register inputs:
1409               *++     R0:  bank-switch address
1410               *++     R1:  address in bank# to be read
1411               
1412 6AF6 04D0  26 _BKAT  CLR  *R0             ; switch banks
1413 6AF8 C651  38        MOV  *R1,*SP         ; get cell contents of address to stack
1414 6AFA 0460  28        B    @RTNEXT         ; return to inner interpreter
     6AFC 39A0     
1415               ;]*
1416               ;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
1417               *++ Read byte contents of address in Bank bank# or RAM.
1418               *++ Register inputs:
1419               *++     R0:  bank-switch address
1420               *++     R1:  address in bank# to be read
1421               
1422 6AFE 04D0  26 _BKCAT CLR  *R0             ; switch banks
1423 6B00 04C2  14        CLR  R2              ; clear R2
1424 6B02 D811  46        MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
     6B04 8305     
1425 6B06 C642  30        MOV  R2,*SP          ; get byte contents of address to stack
1426 6B08 0460  28        B    @RTNEXT         ; return to inner interpreter
     6B0A 39A0     
1427               
1428               ;]*
1429               
1430               ;]*
1431               *         _______   __  _________      ___          __
1432               *        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
1433               *       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
1434               *      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, /
1435               *                                                  /___/
1436               *
1437               ;[*** SAMS! ***      ( --- )
1438               * This calls the SAMS initialization in the startup code in bank 1.
1439               *
1440               *        DATA SMSQ_N
1441               * SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
1442               * SAMSST DATA $+2
1443               *        BL   @BLF2A
1444               *        DATA _SMSST->6000+BANK1
1445               
1446 6B0C 06A0  32 _SMSST BL   @SMSINI           initialize SAMS card
     6B0E 610C     
1447 6B10 0460  28        B    @RTNEXT           back to inner interpreter
     6B12 39A0     
1448               ;]*
1449               ;[*== Required strings, tables, variables... ============================
1450               *
1451               *
1452               * Default blocks filename
1453               *
1454 6B14 0C       DEFNAM BYTE 12
1455 6B15   44            TEXT "DSK1.FBLOCKS "
     6B16 534B     
     6B18 312E     
     6B1A 4642     
     6B1C 4C4F     
     6B1E 434B     
     6B20 5320     
1456               *
1457               * Default colors for all VDP modes---
1458               *     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
1459               *     LSB: Color Table colors (FG/BG)
1460               *
1461 6B22 4F00     DEFCOL DATA >4F00          ; TEXT80    offset=0
1462 6B24 4F00            DATA >4F00          ; TEXT      offset=2
1463 6B26 F4F4            DATA >F4F4          ; GRAPHICS  offset=4
1464 6B28 11F4            DATA >11F4          ; MULTI     offset=6
1465 6B2A FE10            DATA >FE10          ; GRAPHICS2 offset=8
1466 6B2C FEF4            DATA >FEF4          ; SPLIT     offset=10
1467 6B2E FEF4            DATA >FEF4          ; SPLIT2    offset=12
1468               *
1469               * Default text mode
1470               *
1471 6B30 0001     DEFTXT DATA >0001
1472               *
1473               * Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
1474               *
1475 6B32 0000     FNTFLG DATA 0              ; font flag initially 0
1476               *
1477               * Speech variables needing initial value (more below LLVEND)
1478               *
1479 6B34 0000     SPCSVC DATA 0
1480               *
1481               * Sound Table #1 Workspace for sound variables.  Only using R0..R4
1482               *
1483               SND1WS
1484 6B36 0000     SND1ST DATA 0           ; R0 (sound table status) 0=no table..
1485                                       ; ..1=loading sound bytes..-1=counting
1486 6B38 8400     SND1DS DATA SOUND       ; R1 (sound-table byte destination)..
1487                                       ; ..initialized to sound chip
1488 6B3A 0000     SND1AD DATA 0           ; R2 (sound table address)
1489 6B3C 0000     SND1CT DATA 0           ; R3 (# of sound bytes to load or..
1490                                       ; ..sound count = seconds * 60)
1491 6B3E 3AE4     SND1SP DATA SNDST0      ; R4 (pointer to top of sound stack)..
1492                                       ; ..initialized to bottom of sound stack
1493               *
1494               * Sound Table #2 Workspace for sound variables.  Only using R0..R3
1495               *
1496               SND2WS
1497 6B40 0000     SND2ST DATA 0           ; R0 (sound table status) 0=no table..
1498                                       ; ..1=loading sound bytes..-1=counting
1499 6B42 8400     SND2DS DATA SOUND       ; R1 (sound-table byte destination) init to sound chip
1500               ;]*
1501               *
1502               * This is the end of low-level support code that gets copied.
1503               *
1504               LLVEND
1505               
1506               ;[*== Un-initialized Variables and workspaces... =========================
1507               * Start of definitions of variables and workspaces that do not need to
1508               * take up space in ROM because they need no initial values.
1509               *
1510               * Sound Table #2 Workspace for sound variables..continued.
1511               *
1512      3A24     SND2AD EQU  SND2WS+4    ; R2 (sound table address)
1513      3A26     SND2CT EQU  SND2WS+6    ; R3 (# of sound bytes to load or..
1514               *                       ; ..sound count = seconds * 60)
1515      3A28     SDMUTE EQU  SND2WS+8    ; dummy destination for sound byte
1516               *
1517               * Branch Stack for ISR processing of Speech, 2 Sound Tables and return
1518               *
1519      3A2A     BRSTK  EQU  SDMUTE+2
1520               *
1521               * Speech variables (more above LLVEND)
1522               *
1523      3A32     SSFLAG EQU  BRSTK+8
1524      3A34     SPCNT  EQU  SSFLAG+2
1525      3A36     SPADR  EQU  SPCNT+2
1526      3A38     BANKSV EQU  SPADR+2
1527      3A3A     PADSV  EQU  BANKSV+2
1528               *
1529               * Panel window: height, width and screen position...used by PANEL and SCROLL
1530               *
1531      3A46     PANWIN EQU  PADSV+12          panel height, width and screen start
1532               
1533               *== Utility Workspace =================================================
1534               *** General utility workspace registers
1535      3A4C     UTILWS EQU  PANWIN+6
1536      3A51     U_R2LB EQU  UTILWS+5
1537               
1538      3A6C     LINBUF EQU  UTILWS+32
1539      3ABC     CURCHR EQU  LINBUF+80
1540               
1541               *++ variable used by the 40/80-column editor
1542      3ABE     OLDCUR EQU  CURCHR+2
1543               
1544               *++ FILE I/O variables
1545               
1546      3AC6     PBADR  EQU  OLDCUR+8
1547      3AC8     PBBF   EQU  PBADR+2
1548      3ACA     PBVBF  EQU  PBBF+2
1549               
1550               *++ Floating Point Math Library variables
1551      3ACC     FPVARS EQU  PBVBF+2
1552               
1553               *++ SAMS flag
1554      3AE2     SAMSFL EQU  FPVARS+22
1555               
1556               *++ Bottom of Sound Stack
1557               *++      This location marks the top of the low-level support code. The Sound
1558               *++      Stack grows upward toward the Return Stack by moving the entire stack
1559               *++      up one cell to make room for the next new bottom entry.
1560      3AE4     SNDST0 EQU  SAMSFL+2
1561               ;]*
1562               
1563                      AORG
1564                      BANK 1

Here is the code it replaced:

Reveal hidden contents



*     __                  __                __
*    / /  ___ _    ______/ /  ___ _  _____ / /
*   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) / 
*  /____/\___/__,__/   /____/\__/|___/\__/_/  
*                     ____                        __ 
*                    / __/_ _____  ___  ___  ____/ /_
*                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
*                  /___/\_,_/ .__/ .__/\___/_/  \__/ 
*                          /_/  /_/                  
* 
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                   *
* fbForth---                                                        *
*                                                                   *
*       Low-level support routines                                  *
*                                                                   *
*  << Including Trampoline Code, tables & variables:  2606 bytes >> *
*                                                                   *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

LLVSPT   ; <--This is the source copy location for the rest of this code.

$BUFF  EQU  >2010
 
* 4 I/O buffers below ($LO = >3020) 
* Change '4' to number of buffers needed and for which there is room.

$LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers
*       _____   ____         __  __      ___________ 
*      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
*     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
*    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_| 
*
;[*** Interrupt Service =======================================================
* This routine is executed for every interrupt.  It processes any pending
* speech and souind.  It then looks to see whether a user ISR is installed in 
* ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work 
* only if the user has installed an ISR using the following steps in the fol-
* lowing order:
*
*   (1) Write an ISR with entry point, say MYISR.
*   (2) Determine code field address of MYISR with this high-level Forth:
*           ' MYISR CFA
* <<< Maybe need a word to do #3 >>>
*   (3) Write CFA of MYISR into user variable ISR.
*
* Steps (2)-(3) in high-level Forth are shown below:
*           ' MYISR CFA
*           ISR !
* 
* <<< Perhaps last step above should be by a word that disables interrupts >>>
*
* The console ISR branches to the contents of >83C4 because it is non-zero,
* with the address, INT1, of the fbForth ISR entry point below (also, the
* contents of INTLNK).  This means that the console ISR will branch to INT1
* with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
* process any pending speech and sound.
* 
* If the user's ISR is properly installed, the code that processes the user
* ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
* from Forth's workspace (MAINWS), the code at INT2 will process the user's
* ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
* inner interpreter.
*** ==========================================================================

* ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!

INT1   EQU  $LO+$-LLVSPT
       LI   R0,BRSTK          load address of top of Branch Address Stack
* 
* Set up for pending speech
*
       MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
       JEQ  SNDCH1            jump to sound-check if no speech
       INCT R0                increment Branch Stack
*
* Set up for pending sound table #1 (ST#1)
*
SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
       JEQ  SNDCH2            process speech and sound if needed
       LI   R1,x#PLAYT1         load PLAYT1 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
* 
* Set up for pending sound table #2 (ST#2)
*
SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
       JEQ  PRCSPS            process speech and sound if needed
       LI   R1,x#PLAYT2         load PLAYT2 address and...
       MOV  R1,*R0+           ...push it onto Branch Stack
*
* Process sound stack if both sound tables idle
*
PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
       JNE  PRSPS2            nope..skip sound stack processing
       LWPI SND1WS            switch to ST#1 WS
       CI   R4,SNDST0         anything on sound stack?
       JEQ  PRSPS1            no..exit sound stack processing
       DECT R4                pop sound stack position
       MOV  *R4,R2            get sound table address from sound stack
       INC  R0                kick off sound processing of ST#1 (R0=1)
PRSPS1 LWPI GPLWS             switch back to GPL WS
* 
* Check for any pending speech and sound
*
PRSPS2 CI   R0,BRSTK          any speech or sound to process?
       JEQ  USRISR            if not, jump to user ISR processing
       LI   R1,BNKRST         yup..load return address
       MOV  R1,*R0            push return address onto Branch Stack
* 
* Process pending speech and sound
*
       MOV  @x#MYBANK,@BANKSV   save bank at interrupt
       CLR  @>6002            switch to bank 2 for speech & sound services
       LI   R7,BRSTK          load top of Branch Stack
       MOV  *R7+,R8           pop speech/sound ISR
       B    *R8               service speech/sound
*
* Restore interrupted bank
*
BNKRST EQU  $LO+$-LLVSPT      return point for speech and sound ISRs
       MOV  @BANKSV,R0        restore bank at interrupt
       SRL  R0,13             get the bank# to correct position
       AI   R0,>6000          make it a real bank-switch address
       CLR  *R0               switch to the bank at interrupt
*
* Process User ISR if defined
*
USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
       JEQ  INTEX             
*
* Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
* is executed from Forth's WS (MAINWS = >8300), which it does at the end of
* every CODE word, keyboard scan and one or two other places.
* 
       LI   R1,INT2                 Load entry point, INT2
       MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
* 
* The following 2 instructions are copies of the remainder of the console ROM's
* ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
* because we're not going back there!
* 
INTEX  LWPI >83C0             Change to console's ISR WS  
       RTWP                   Return to caller of console ISR
* 
* Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
* before executing user's ISR. INT3 (cleanup routine below) will be inserted
* in address list to get us back here for cleanup after user's ISR has finished.
* User's ISR is executed at the end of this section just before INT3.
* 
INT2   EQU  $LO+$-LLVSPT
       LIMI 0                 Disable interrupts
       MOVB @>83D4,R0         Get copy of VR01
       SRL  R0,8              ...to LSB
       ORI  R0,>100           Set up for VR01
       ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
       BLWP @VWTR             Turn off VDP interrupt
       LI   NEXT,$NEXT        Restore NEXT
       SETO @INTACT           Set Forth "pending interrupt" flag
       DECT R                 Set up return linkage by pushing 
       MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
       LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
       MOV  @$ISR(U),W        Do the user's Forth ISR by executing
       B    @DOEXEC           ...it through Forth's inner interpreter
* 
* Clean up and re-enable interrupts.
*
INT3   EQU  $LO+$-LLVSPT    
       DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
       DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
       MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
       CLR  @INTACT           Clear Forth "pending interrupt" flag
       MOVB @>83D4,R0         Prepare to restore VR01 by...
       SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
       AI   R0,>100           ...VR # (01) to MSB
       MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
       BLWP @VWTR             Write VR01
       LIMI 2                 Re-enable interrupts
       B    *NEXT             Continue normal task
;]*
;[*** BKLINK from SYSTEM calls ==========================================
*
BKLINK EQU  $LO+$-LLVSPT
       MOV  @INTACT,R7        Are we in user's ISR?
       JNE  BKLIN1            Don't enable interrupts if so.
       LIMI 2
BKLIN1 B    *LINK
;]*
*      ____         __              _____     ____  
*     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
*    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
*   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
*       /___/                                          
* 
;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================

*       Entry point for low-level system support functions

$SYS$  EQU  $LO+$-LLVSPT
       LIMI 0
       MOV  @SYSTAB(R1),R0
       B    *R0
;]
;[*** SYSTAB -- Vector table for SYSTEM calls ===========================

       DATA BRW          CODE = -20  write block to blocks file
       DATA BRW          CODE = -18  read block from blocks file
       DATA BRW          CODE = -16  create blocks file
       DATA BRW          CODE = -14  use blocks file
       DATA GXY          CODE = -12  GOTOXY
       DATA QKY          CODE = -10  ?KEY
       DATA QTM          CODE =  -8  ?TERMINAL
       DATA CLF          CODE =  -6  CRLF
       DATA EMT          CODE =  -4  EMIT
       DATA KY           CODE =  -2  KEY
SYSTAB EQU  $LO+$-LLVSPT
       DATA SBW          CODE =   0  VSBW
       DATA MBW          CODE =   2  VMBW
       DATA SBR          CODE =   4  VSBR
       DATA MBR          CODE =   6  VMBR
       DATA WTR          CODE =   8  VWTR
       DATA GPL          CODE =  10  GPLLNK
       DATA XML          CODE =  12  XMLLNK
       DATA DSR          CODE =  14  DSRLNK
       DATA CLS$         CODE =  16  CLS
       DATA MVE          CODE =  18  VMOVE
       DATA FILL$        CODE =  20  VFILL
       DATA AOX          CODE =  22  VAND
       DATA AOX          CODE =  24  VOR
       DATA AOX          CODE =  26  VXOR
;]*
;[*== VDP single byte write.                CODE =   0  =================
*
SBW    EQU  $LO+$-LLVSPT
       MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         Character to write
       SWPB R1              Get in left byte
       BLWP @VSBW
       B    @BKLINK
;]*
;[*== VDP multi byte write.                 CODE =   2  =================
*
MBW    EQU  $LO+$-LLVSPT
       MOV  *SP+,R2         Number of bytes to move
       MOV  *SP+,R0         VRAM address (destination)
       MOV  *SP+,R1         RAM address (source)
       BLWP @VMBW
       B    @BKLINK
;]*
;[*== VDP single byte read.                 CODE =   4  =================
*
SBR    EQU  $LO+$-LLVSPT
       MOV  *SP,R0          VRAM address (source)
       BLWP @VSBR
       SRL  R1,8            Character to right half for Forth
       MOV  R1,*SP          Stack it
       B    @BKLINK
;]*
;[*== VDP multi byte read.                  CODE =   6  =================
*
MBR    EQU  $LO+$-LLVSPT
       MOV  *SP+,R2         Number of bytes to read
       MOV  *SP+,R1         RAM address (destination)
       MOV  *SP+,R0         VRAM address (source)
       BLWP @VMBR
       B    @BKLINK
;]*
;[*== VDP-to-VDP move.                      CODE =  18  =================
*
MVE    EQU  $LO+$-LLVSPT
       MOV  *SP+,R0         Pop cnt to R0
       MOV  *SP+,R2         Pop vdst to R2
       MOV  *SP+,R1         Pop vsrc to R1
       BLWP @VMOVE
       B    @BKLINK
;]*
;[*== VDP register write.                   CODE =   8  =================
*
WTR    EQU  $LO+$-LLVSPT
       MOV  *SP+,R1         VDP register number
       MOV  *SP+,R0         Data for register
       SWPB R1              Get register to left byte
       MOVB R1,R0           Place with data
       BLWP @VWTR
       B    @BKLINK
;]*
;[*== GPL link utility.                     CODE =  10  =================
*
GPL    EQU  $LO+$-LLVSPT
       CLR  R0
       MOVB R0,@KYSTAT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,GPLLNK         to the GPLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== XML link utility.                     CODE =  12  =================
*
XML    EQU  $LO+$-LLVSPT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,XMLLNK         to the XMLLNK utility
       MOV  *SP+,R2           with this datum identifying the routine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== DSR link utility.                     CODE =  14  =================
*
DSR    EQU  $LO+$-LLVSPT
       LI   R0,>0420        Construct the BLWP instruction
       LI   R1,DSRLNK         to the DSRLNK utility
       MOV  *SP+,R2         This datum selects DSR or subroutine
       LI   R3,>045B        Construct the B *LINK instruction
       MOV  LINK,R4         Save LINK address
       BL   @2*R0+MAINWS    Execute the above instructions
       MOV  R4,LINK           and reconstruct LINK
       B    @BKLINK
;]*
;[*== Screen clearing utility.              CODE =  16  =================
*
CLS$   EQU  $LO+$-LLVSPT
       MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
       MOV  @$SEND(U),R1    End of screen in VRAM
       S    R2,R1           Screen size
       LI   R0,>2000        Blank character
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== VDP fill routine.                     CODE =  20  =================
*
FILL$  EQU  $LO+$-LLVSPT
       MOV  *SP+,R0         Fill character
       SWPB R0                to left byte
       MOV  *SP+,R1         Fill count
       MOV  *SP+,R2         Address to start VRAM fill
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
*========================================================================
FILL1  EQU  $LO+$-LLVSPT    R0=char, R1=cnt, R2=vaddr
       ORI  R2,>4000        Set bit for VDP write
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
FLOOP  MOVB R0,@VDPWD       Write a byte
       DEC  R1
       JNE  FLOOP           Not done, fill another
       B    *LINK
;]*======================================================================
*
*==== VAND -- VDP byte AND routine.         CODE =  22  =================
*==== VOR -- VDP byte OR routine.           CODE =  24  =================
;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
*
AOX    EQU  $LO+$-LLVSPT
       MOV  *SP+,R2         VRAM address
       SWPB R2
       MOVB R2,@VDPWA       LS byte first
       SWPB R2
       MOVB R2,@VDPWA       Then MS byte
       NOP                  Kill time
       MOVB @VDPRD,R3       Read byte
       MOV  *SP+,R0         Get data to operate with
       SWPB R0                to left byte
*** Now do requested operation *****************
       CI   R1,24
       JEQ  DOOR
       JGT  DOXOR
       INV  R3              These two instructions
       SZC  R3,R0             perform an 'AND'
       JMP  FINAOX
DOOR   SOC  R3,R0             perform 'OR'
       JMP  FINAOX
DOXOR  XOR  R3,R0             perform 'XOR'
FINAOX LI   R1,1
       MOV  LINK,R7
       BL   @FILL1
       MOV  R7,LINK
       B    @BKLINK
;]*
;[*== KEY routine                           CODE =  -2  =================
*
KY    EQU  $LO+$-LLVSPT
       MOV  @$ALTI(U),R0      alternate input device?
       JEQ  KEY0              jump to keyboard input if not
*
*  R0 now points to PAB for alternate input device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to read one byte.
*
       CLR  R7                prepare to zero status byte
       MOVB R7,@KYSTAT        zero status byte
       INC  R0                point R0 to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       MOV  R0,R1             Set up pointer...
       AI   R1,8              ...to namelength byte of PAB
       MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
       MOV  R0,R3             save pointer (DSRLNK will trash it!)
       BLWP @DSRLNK           get 1 byte from device
       DATA >8
       MOV  R3,R0             restore pointer
       DECT R0                point to one-byte VRAM buffer in front of PAB
       BLWP @VSBR             read character
       SRL  R1,8              move to LSB
       MOV  R1,R0             copy to return register
       B    @BKLINK           return to caller
*
*  Input is comining from the keyboard
*
KEY0   MOV  @KEYCNT,R7
       INC  R7
       JNE  KEY1
       MOV  @CURPO$(U),R0
       BLWP @VSBR             Read character at cursor position...
       MOVB R1,@CURCHR        ...and save it
       LI   R1,>1E00          Place cursor character on screen
       BLWP @VSBW
*
KEY1   BLWP @KSCAN
       MOVB @KYSTAT,R0
       COC  @H2000,R0         check status
       JEQ  KEY2              JMP if key was pressed
*
       CI   R7,100            No key pressed
       JNE  KEY3
       MOVB @CURCHR,R1
       JMP  KEY5
*
KEY3   CI   R7,200
       JNE  KEY4
       CLR  R7
       LI   R1,>1E00          Cursor char
KEY5   MOV  @CURPO$(U),R0
       BLWP @VSBW
KEY4   MOV  R7,@KEYCNT
       MOV  @INTACT,R7        Are we in user's ISR?
       JNE  KEY6              Don't enable interrupts if so.
       LIMI 2
KEY6   DECT IP                This will re-execute KEY
       B    *NEXT
KEY2   SETO @KEYCNT           Key was pressed
       MOV  @CURPO$(U),R0     Restore character at cursor location
       MOVB @CURCHR,R1
       BLWP @VSBW
       MOVB @KYCHAR,R0        Put char in...
       SRL  R0,8              ...LSB of R0
       B    @BKLINK
;]*
;[*== EMIT routine                          CODE =  -4  =================
*
EMT    EQU  $LO+$-LLVSPT
       MOV  R2,R1             copy char to R1 for VSBW
       MOV  @$ALTO(U),R0      alternate output device?
       JEQ  EMIT0             jump to video display output if not
*
*  R0 now points to PAB for alternate output device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to write one byte.
*
       CLR  R7                ALTOUT active
       MOVB R7,@KYSTAT        zero status byte
       DEC  R0                point to one-byte VRAM buffer in front of PAB
       SWPB R1                char to MSB
       BLWP @VSBW             write char to buffer
       INCT R0                point to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       AI   R0,8              Set up pointer to namelength byte of PAB
       MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
       BLWP @DSRLNK           put 1 byte to device
       DATA >8                
       B    @BKLINK           return to caller
*
*  Output is going to the video display
*
EMIT0  CI   R1,7            Is it a bell?
       JNE  NOTBEL
       CLR  R2
       MOVB R2,@KYSTAT
       BLWP @GPLLNK
       DATA >0036           Emit error tone
       JMP  EMEXIT
*
NOTBEL CI   R1,8            Is it a backspace?
       JNE  NOTBS
       LI   R1,>2000
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       JGT  DECCUR
       JMP  EMEXIT
DECCUR DEC  @CURPO$(U)
       JMP  EMEXIT
*
NOTBS  CI   R1,>A           Is it a line feed?
       JNE  NOTLF
       MOV  @$SEND(U),R7
       S    @$SWDTH(U),R7
       C    @CURPO$(U),R7
       JHE  SCRLL
       A    @$SWDTH(U),@CURPO$(u)
       JMP  EMEXIT
SCRLL  MOV  LINK,R7
       BL   @SCROLL
       MOV  R7,LINK
       JMP  EMEXIT
*
*** SCROLLING ROUTINE
*
SCROLL EQU  $LO+$-LLVSPT
       MOV  @$SSTRT(U),R0   VRAM addr
       LI   R1,LINBUF       Line buffer
       MOV  @$SWDTH(U),R2   Count
       A    R2,R0           Start at line 2
SCROL1 BLWP @VMBR
       S    R2,R0           One line back to write
       BLWP @VMBW
       A    R2,R0           Two lines ahead for next read
       A    R2,R0
       C    R0,@$SEND(U)    End of screen?
       JL   SCROL1
       MOV  R2,R1           Blank bottom row of screen
       LI   R0,>2000        Blank
       S    @$SEND(U),R2
       NEG  R2              Now contains address of start of last line
       MOV  LINK,R6
       BL   @FILL1          Write the blanks
       B    *R6
*
NOTLF  CI   R1,>D           Is it a carriage return?
       JNE  NOTCR
       CLR  R0
       MOV  @CURPO$(U),R1
       MOV  R1,R3
       S    @$SSTRT(U),R1   Adjusted for screen not at 0
       MOV  @$SWDTH(U),R2
       DIV  R2,R0
       S    R1,R3
       MOV  R3,@CURPO$(U)
       JMP  EMEXIT
*
NOTCR  SWPB R1              Assume it is a printable character
       MOV  @CURPO$(U),R0
       BLWP @VSBW
       MOV  @$SEND(U),R2
       DEC  R2
       C    R0,R2
       JNE  NOTCR1
       MOV  @$SEND(U),R0
       S    @$SWDTH(U),R0   Was last char on screen. Scroll
       MOV  R0,@CURPO$(U)
       JMP  SCRLL
NOTCR1 INC  R0              No scroll necessary
       MOV  R0,@CURPO$(U)
*
EMEXIT B    @BKLINK
;]*
;[*== CRLF routine                          CODE =  -6  =================
*
CLF    EQU  $LO+$-LLVSPT
       MOV  LINK,R5
       LI   R2,>000D
       BL   @EMT            EMT will alter INT mask via B @BKLINK
       LI   R2,>000A
       LIMI 0               Previous call to EMT altered INT mask
       BL   @EMT
       MOV  R5,LINK
       B    @BKLINK
;]*
;[*== ?TERMINAL routine                     CODE =  -8  =================
* scan for <clear>, <break>, FCTN+4 press
*
QTM    EQU  $LO+$-LLVSPT
       MOV  LINK,R5         save return
       BL   @>0020          branch to console's test for <clear>
       STST R0              store status in R0
       JNE  QTM2            exit if not <clear>
QTM1   BL   @>0020          check for <clear> again
       JEQ  QTM1            loop until not <clear>
QTM2   MOV  R5,LINK         restore return
       ANDI R0,>2000        keep only EQU bit
       B    @BKLINK         return to caller
;]*
;[*== ?KEY routine                          CODE = -10  =================
*
QKY    EQU  $LO+$-LLVSPT
       BLWP @KSCAN
       MOVB @KYCHAR,R0
       SRL  R0,8
       CI   R0,>00FF
       JNE  QKEY1
       CLR  R0
QKEY1  B    @BKLINK
;]*
;[*== GOTOXY routine                        CODE = -12  =================
*
GXY    EQU  $LO+$-LLVSPT
       MPY  @$SWDTH(U),R3
       A    R2,R4           Position within screen
       A    @$SSTRT(U),R4   Add VRAM offset to screen top
       MOV  R4,@CURPO$(U)
       B    @BKLINK
;]
*       ___  __         __     ____  ______ 
*      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
*     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
*    /____/_/\___/\__/_/\_\ /___/_/  \____/ 

*
*== USE blocks file                         CODE = -14  =================
*== CREATE blocks file                      CODE = -16  =================
*== READ block from blocks file             CODE = -18  =================
*== WRITE block to blocks file              CODE = -20  =================
;[*== Block File I/O Support ============================================
*
* BPTOG utility to toggle one of 2 PABs for block file access
*
BPTOG  EQU  $LO+$-LLVSPT
       MOV  @$BPOFF(U),R0	   PAB offset to R0
       LI	R1,70	            Toggle amount
       XOR	R0,R1	            New offset
       MOV	R1,@$BPOFF(U)	   Update offset
*
**xxx** entry point to insure we have correct PAB address
BPSET  EQU  $LO+$-LLVSPT
       MOV  @$DKBUF(U),R0	   Get DISK_BUF address
       A	   @$BPABS(U),R0	   Get BPABS address
*
       A	   @$BPOFF(U),R0     Add current offset
       MOV	R0,@BFPAB	      Update current block file's PAB address
       RT	 	 
*
* CLOSE blocks file
*
BKCLOS EQU  $LO+$-LLVSPT
       MOV  @BFPAB,R0
       LI   R1,$FCLS          Opcode=CLOSE
       BLWP @VSBW
       AI   R0,9              Address of filename's char count
       MOV  R0,@SUBPTR        Point to filename's char count
       BLWP @DSRLNK           Close the file
       DATA 8
       RT                     Deal with error in caller
*
* storage area
*
SVBRET EQU  $LO+$-LLVSPT
       DATA 0                 Storage for LINK coming into BRW
BFPAB  EQU  $LO+$-LLVSPT
       DATA	0	               Storage for current blocks file PAB address...
*	 	 	                     ...will have current PAB on entry
* PAB header storage
*
PABHD  EQU  $LO+$-LLVSPT
       BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
*              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
*	                	                 >03=OUTPUT mode + "
*	                	                 >01=UPDATE mode + "
*	                         BYTE 2,3: save contents of DISK_BUF here
       BYTE	>80	            Record length
       BYTE	>80	            Character count of transfer
       BSS	2	            Record number
*
*** file I/O equates
*
$FOPN  EQU  >0000
$FCLS  EQU  >0100
$FRD   EQU  >0200
$FWRT  EQU  >0300
$FRST  EQU  >0400
$FINP  EQU  5
$FOUT  EQU  3
$FUPD  EQU  1
*
*** BRW -- entry point for block read/write routines
*
BRW    EQU  $LO+$-LLVSPT
       MOV  LINK,@SVBRET   Save LINK address
       MOV	R1,R7	         Save CODE {R1 to R7}
       SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
       AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
       BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
       CI	R7,4	         USE or CREATE?
       JLT	BRW01	         No
       BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
       MOV	@BFPAB,R0	   Load PAB address
       AI	R0,9	         Set to name length byte
       CLR	R2	 
       MOV	*SP+,R1	      Pop bfnaddr to R1
       MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
       INC	R2	            Add 1 to # bytes to copy
       BLWP	@VMBW	         Copy char count & pathname to PAB
*
*** set up PAB for OPEN 
*
BRW01  LI	R1,$FUPD                Opcode=0,mode=update
       CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
       JOP  BRW02                   No
       LI	R1,$FINP                Yes...change mode=input
BRW02  MOV  R1,@PABHD               Put in PAB header
       MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
       CLR  R0
       MOV  R0,@PABHD+6             Set record#=0
       MOV  @BFPAB,R0               VRAM destination
       LI   R1,PABHD                RAM source
       LI   R2,8                    Copy first 8 bytes of PAB header
       BLWP @VMBW                   Do the copy
*
*** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
*
       AI   R0,9                Address of filename's char count in PAB
       MOV  R0,@SUBPTR          Point to-----^^^^
       BLWP @DSRLNK             Open/create the file
       DATA 8
       JEQ  BKERR
       CI   R7,4                READ or WRITE?
       JLT  BRW04               Yes
       JGT  BRWDON              No; =USE; we're done
*
*** write blank records to newly created blocks file [CODE = -16,CREATE]
*
       MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
       SLA  R5,3                Convert #blocks to #records
       MOV  R5,R3               Save
       MOV  R5,R4               Set up counter
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       MOV  R0,@PABHD           Copy to PAB header
BRLOOP S    R4,R5               Calculate next record
       MOV  R5,@PABHD+6         Copy to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       AI   R0,9                Address of filename's char count
       MOV  R0,@SUBPTR          Point to filename's char count
       BLWP @DSRLNK             Write one record of blanks
       DATA 8
       JEQ  BKERR
       MOV  R3,R5               Get #blocks
       DEC  R4                  Count down 1 record
       JNE  BRLOOP              Write another record if not done
       JMP  BRWDON              We're done
*
*** prepare for read/write block
*
BRW04  MOV  *SP+,R5             Pop block# to write
       MOV  *SP+,R6             Pop bufaddr
       DEC  R5                  Block#-1
       SLA  R5,3                Convert to starting record#
       LI   R4,8                Load counter for 8 records
       LI   R0,$FWRT+$FUPD      Set up for WRITE
       LI   R3,VMBW             WRITE vector
       CI   R7,2                Are we writing the block?
       JEQ  BRW05               Yup
       LI   R0,$FRD+$FINP       Nope...set up for READ
       LI   R3,VMBR             READ vector
BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
* 
* READ/WRITE block routine [CODE = -18/-20]
* 
RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
       MOV  @BFPAB,R0           VRAM destination
       LI   R1,PABHD            RAM source
       LI   R2,8                #Bytes of PAB header to copy to PAB
       BLWP @VMBW               Do the copy
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0
       MOV  R6,R1               RAM buffer to R1
       LI   R2,128              Bytes to copy
       CI   R7,3                READ?
       JEQ  BRW06               Yup
       BLWP *R3                 Nope...copy record to VRAM
*
* temporarily use CRU register---it should be OK
*
BRW06  MOV  @BFPAB,CRU          PAB address
       AI   CRU,9               Address of filename's char count
       MOV  CRU,@SUBPTR         Point to filename's char count
       BLWP @DSRLNK             Read/write one record
       DATA 8
       JEQ  BKERR
       CI   R7,2                WRITE?
       JEQ  BRW07               Yup...next record
       MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
       BLWP *R3                 Nope...copy record to RAM buffer
BRW07  INC  R5                  Next record in file
       AI   R6,128              Next record to/from block RAM buffer
       DEC  R4                  Count down 1 record
       JNE  RWLOOP              Read/write another record if not done
       JMP  BRWDON              We're done
*
*** error handling
*
BKERR  MOVB R0,R0               Device error?
       JEQ  BKERR6              Yes, exit with disk error
BKERR9 LI   R6,9                No, exit with file error
       JMP  BKCLN
BKERR8 LI   R6,8                Block# <=0!  exit with range error
       JMP  BKCLN
BKERR6 LI   R6,6
BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
       CI   R7,4                USE or CREATE?
       JLT  BKCLN1              No
       BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
BKCLN1 MOV  R6,R0               Pass error back to caller
       JMP  BKEXIT
BRWDON CLR  R6
       BL   @BKCLOS             Close current blocks file
       JNE  BRWDN1              Error?
       LI   R6,9                Yes...assume it was a file error
BRWDN1 CI   R7,4                (no error)...CREATE?
       JNE  BRWDN2              No...we're done
       BL   @BPTOG              Yes...revert to correct blocks file
BRWDN2 MOV  R6,R0               Error to R0
BKEXIT MOV  @SVBRET,LINK        Restore LINK
       B    @BKLINK
;]
;[* MSGTYP      <<< Support for string typing in various banks >>>
*
* Called with:  BL  @MSGTYP
* 
* R4 and R5 are the only registers that will be preserved
* ..after a call to EMIT---
*
* Input:    R4 = Address of length byte of packed string
*
* We will pass the ASCII value of character to EMIT in R2 without
* insuring it is 7 bits wide.
*
MSGTYP EQU  $LO+$-LLVSPT
       DECT R           Push return address
       MOV  LINK,*R     ...to Forth return stack
       CLR  R5          
       MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
       SWPB R5          Put char count in low byte
MTLOOP CLR  R2
       MOVB *R4+,R2     Copy next char to R2 for EMIT
       SWPB R2          Put char in low byte
       LIMI 0           We need to do this because we're calling EMIT directly
       BL   @EMT        Call EMIT directly
       INC  @$OUT(U)    Increment display line character count
       DEC  R5          Decrement character count for this message
       JNE  MTLOOP      Are we done?
       MOV  *R+,LINK    Yes. Pop return address
       RT               Return to caller
 ;]      
;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
R4$5   EQU  $LO+$-LLVSPT
       MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4+,*R5+
       MOV  *R4,*R5
       RT
;]
*     __  __              _   __         _      __   __   
*    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__ 
*   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
*   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/ 
*              ___      ___          ____    
*             / _ \___ / _/__ ___ __/ / /____
*            / // / -_) _/ _ `/ // / / __(_-<
*           /____/\__/_/ \_,_/\_,_/_/\__/___/

;[*== User Variable defaults ============================================
* 
UBASE0 EQU  $LO+$-LLVSPT
       BSS  6                 BASE OF USER VARIABLES
       DATA UBASE0            06 USER UCONS$
       DATA SPBASE            08 USER S0
       DATA RBASE             0A USER R0 { R0$
       DATA $UVAR             0C USER U0
       DATA SPBASE            0E USER TIB
       DATA 31                10 USER WIDTH
       DATA DPBASE            12 USER DP
       DATA $SYS$             14 USER SYS$
       DATA 0                 16 USER CURPOS
       DATA INT1              18 USER INTLNK
       DATA 1                 1A USER WARNING
       DATA 64                1C USER C/L$ { CL$
       DATA $BUFF             1E USER FIRST$
       DATA $LO               20 USER LIMIT$
       DATA >0380             22 USER COLTAB    Color Table address in VRAM
       DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
       DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
       DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
       DATA >80               2A USER FPB       pushes address of user screen font file PAB
*                                               ...that is this relative distance from DISK_BUF
       DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
       DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
       DATA 40                30 USER SCRN_WIDTH
       DATA 0                 32 USER SCRN_START
       DATA 960               34 USER SCRN_END
       DATA 0                 36 USER ISR       [Note: This used to be INT1]
       DATA 0                 38 USER ALTIN
       DATA 0                 3A USER ALTOUT
       DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
       DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
*                                               ...that is this relative distance from DISK_BUF
       DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
*                                               ...always toggled between 0 and 70
       DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
       DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
*                                                  0 = console font via GPLLNK
       DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
       DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
       DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
*                                                  0 = Symmetric (default)
*                                                 !0 = Floored
$UVAR  EQU  $LO+$-LLVSPT
       BSS  >80               USER VARIABLE AREA
;]
;[*== A Constant ====================================================
*
H2000  EQU  $LO+$-LLVSPT
       DATA >2000
;]*
*    __  ____  _ ___ __         _   __        __             
*   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
*  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
*  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
*                     /___/                                  
* 
;[*== Utility Vectors ===================================================
*
* GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
* DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
XMLLNK EQU  $LO+$-LLVSPT
       DATA UTILWS,XMLENT   ; Link to ROM routines
KSCAN  EQU  $LO+$-LLVSPT
       DATA UTILWS,KSENTR   ; Keyboard scan
VSBW   EQU  $LO+$-LLVSPT
       DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
VMBW   EQU  $LO+$-LLVSPT
       DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
VSBR   EQU  $LO+$-LLVSPT
       DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
VMBR   EQU  $LO+$-LLVSPT
       DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
VMOVE  EQU  $LO+$-LLVSPT
       DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
VWTR   EQU  $LO+$-LLVSPT
       DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
;]*
;[*== XMLENT -- Link to system XML utilities ============================
*
XMLENT EQU  $LO+$-LLVSPT
       MOV  *R14+,@GPLWS+2      Get argument
       LWPI GPLWS               Select GPL workspace
       MOV  R11,@UTILWS+22      Save GPL return address
       MOV  R1,R2               Make a copy of argument
       CI   R1,>8000            Direct address in ALC?
       JH   XML30               We have the address
       SRL  R1,12
       SLA  R1,1
       SLA  R2,4
       SRL  R2,11
       A    @XMLTAB(R1),R2
       MOV  *R2,R2
XML30  BL   *R2
       LWPI UTILWS              Get back to right WS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    ________  __   __   _  ____ __           __  ________
*   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
*  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
* This routine will work with any GROM library slot since it is         *
* indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
* This GPLLNK does NOT require a module to be plugged into the          *
* GROM port so it will work with the Editor/Assembler,                  *
* Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
* CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
* It saves and restores the current GROM Address in case you want       *
* to return back to GROM for Basic or Extended Basic CALL LINKs         *
* or to return to the loading module.                                   *
*                                                                       *
*    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
*                                                 DATA >34              *
*                                                                       *
*    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
*                                                                       *
* 70 Bytes - including the GPLLNK Workspace                             *
*-----------------------------------------------------------------------*

*  GPLWS (>83E0) is GPL workspace
G_R4   EQU  GPLWS+8              GPL workspace R4
G_R6   EQU  GPLWS+12             GPL workspace R6
*  SUBSTK (>8373) is GPL Subroutine stack pointer
LDGADR EQU  >60                  Load & Execute GROM address entry point
XTAB27 EQU  >200E                Low Mem XML table location 27
*                                ..Will contain XMLRTN at startup
GETSTK EQU  >166C              
 
GPLLNK EQU  $LO+$-LLVSPT
       DATA GLNKWS      R7       Set up BLWP Vectors
       DATA GLINK1      R8     
* RTNADR EQU  $LO+$-LLVSPT    <---don't think we need this label
       DATA XMLRTN      R9       address where GPL XML returns to us...
*                                ...this address will already be in XTAB27,...
*                                ...>200E, so don't really need it here}
GXMLAD EQU  $LO+$-LLVSPT
       DATA >176C       R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
       DATA >50         R11      Initialized to >50 where PUTSTK address resides
GLNKWS EQU  $LO+$-LLVSPT->18     GPLLNK's workspace of which only...
       BSS  >08         R12-R15  ...registers R7 through R15 are used

GLINK1 EQU  $LO+$-LLVSPT
       MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
       MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
       LWPI GPLWS                Load GPL WS
       BL   *R4                  Save current GROM Address on stack
       MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
       INCT @SUBSTK              Adjust the stack pointer
       B    @LDGADR              Execute our GPL Routine

XMLRTN EQU  $LO+$-LLVSPT
       MOV  @GETSTK,R4           Get GETSTK pointer
       BL   *R4                  Restore GROM address off the stack
       LWPI GLNKWS               Load our WS
       RTWP                      All Done - Return to Caller
;]
*     ___  _______  __   _  ____ __           __  ________
*    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
*   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
*  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
* 
*-----------------------------------------------------------------------*
;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
* {LES NOTE: Some labels have been modified for fbForth compatibility.} *
*                                                                       *
*      (Uses console GROM 0's DSRLNK routine)                           *
*      (Do not REF DSRLNK or GPLLNK when using these routines)          *
*      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
*                                                                       *
*      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
*                                                   DATA 8              *
*                                                                       *
*      NOTES: Must be used with a GPLLNK routine                        *
*             Returns ERRORs the same as the E/A DSRLNK                 *
*             EQ bit set on return if error                             *
*             ERROR CODE in caller's MSB of Register 0 on return        *
*                                                                       *
* 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
*-----------------------------------------------------------------------*

PUTSTK EQU  >50                     Push GROM Address to stack pointer
TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
VWA    EQU  >8C02                   VDP Write Address location
VRD    EQU  >8800                   VDP Read Data byte location
G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
GSTAT  EQU  >837C                   GPL Status byte location
                                    
DSRLNK EQU  $LO+$-LLVSPT
       DATA DSRWS,DLINK1            Set BLWP Vectors

DSRWS  EQU  $LO+$-LLVSPT            Start of DSRLNK workspace
DR3LB  EQU  DSRWS+7                 lower byte of DSRLNK workspace R3
DLINK1 EQU  $LO+$-LLVSPT
       MOV  R12,R12         R0      Have we already looked up the LINK address?
       JNE  DLINK3          R1      YES!  Skip lookup routine
*<<-------------------------------------------------------------------------->>*
* This section of code is only executed once to find the GROM address          *
* for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
* to indicate that the address is found and to be used as a mask for EQ & CND  *
*------------------------------------------------------------------------------*
       LWPI GPLWS           R2,R3   else load GPL workspace
       MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
       BL   *R4             R6
       LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
       MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector

***les*** Note on above instruction:
***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)

       JMP  DLINK2          R11     Jump around R12-R15
       DATA 0               R12     contains >2000 flag when set
       DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
       MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
       MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
       INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
       BL   *R5                     Restore the GROM address off the stack
       LWPI DSRWS                   Reload DSRLNK workspace
       LI   R12,>2000               Set flag to signify DSRLNK address is set
*<<-------------------------------------------------------------------------->>*
DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
       MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
       MOV  @NAMLEN,R3              Save VDP address of Name Length
       AI   R3,-8                   Adjust it to point to PAB Flag byte
       BLWP @GPLLNK                 Execute DSR LINK
DSRADR EQU  $LO+$-LLVSPT
       BYTE >03                     High byte of GPL DSRLNK address
DSRAD1 EQU  $LO+$-LLVSPT
       BYTE >00                     Lower byte of GPL DSRLNK address
*----Error Check & Report to Caller's R0 and EQU bit-------------------------
       MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
       MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
       SZCB R12,R15                 Clear EQ bit for Error Report
       MOVB @VRD,R3                 Get PAB Error Flag
       SRL  R3,5                    Adjust it to 0-7 error code
       MOVB R3,*R13                 Put it into Caller's R0 (msb)
       JNE  SETEQ                   If it's not zero, set EQ bit
       COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
       JNE  DSREND                  No Error, Just return
SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
DSREND RTWP                         All Done - Return to Caller
;]
;[*== KSENTR -- Keyboard Scan (entry point) =============================
*
KSENTR EQU  $LO+$-LLVSPT
       LWPI GPLWS
       MOV  R11,@UTILWS+22      Save GPL return address
       BL   @SCNKEY             Console keyboard scan routine
       LWPI UTILWS
       MOV  R11,@GPLWS+22       Restore GPL return address
       RTWP
;]*
*    _   _____  ___    __  ____  _ ___ __  _       
*   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
*   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
*   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
* 
;[*== VDP utilities (entry point) =======================================
*
** VDP single byte write
*
VSBWEN EQU  $LO+$-LLVSPT
       BL   @WVDPWA             Write out address
       MOVB @2(R13),@VDPWD      Write data
       RTWP                     Return to calling program
*                            
** VDP multiple byte write   
*                            
VMBWEN EQU  $LO+$-LLVSPT
       BL   @WVDPWA             Write out address
VWTMOR MOVB *R1+,@VDPWD         Write a byte
       DEC  R2                  Decrement byte count
       JNE  VWTMOR              More to write?
       RTWP                     Return to calling Program
*                            
** VDP single byte read      
*                            
VSBREN EQU  $LO+$-LLVSPT
       BL   @WVDPRA             Write out address
       MOVB @VDPRD,@2(R13)      Read data
       RTWP                     Return to calling program
*                            
** VDP multiple byte read    
*                            
VMBREN EQU  $LO+$-LLVSPT
       BL   @WVDPRA             Write out address
VRDMOR MOVB @VDPRD,*R1+         Read a byte
       DEC  R2                  Decrement byte count
       JNE  VRDMOR              More to read?
       RTWP                     Return to calling program
*                            
** VDP write to register     
*                            
VWTREN EQU  $LO+$-LLVSPT
       MOV  *R13,R1             Get register number and value
       MOVB @1(R13),@VDPWA      Write out value
       ORI  R1,>8000            Set for register write
       MOVB R1,@VDPWA           Write out register number
       RTWP                     Return to calling program
*
** Set up to write to VDP
*
WVDPWA EQU  $LO+$-LLVSPT
       LI   R1,>4000
       JMP  WVDPAD
*
** Set up to read VDP
*
WVDPRA EQU  $LO+$-LLVSPT
       CLR  R1
*
** Write VDP address
*
WVDPAD MOV  *R13,R2             Get VDP address
       MOVB @U_R2LB,@VDPWA      Write low byte of address
       SOC  R1,R2               Properly adjust VDP write bit
       MOVB R2,@VDPWA           Write high byte of address
       MOV  @2(R13),R1          Get CPU RAM address
       MOV  @4(R13),R2          Get byte count
       RT                       Return to calling routine

*
** VDP-to-VDP move.
*
VMOVEN EQU  $LO+$-LLVSPT
       MOV  *R13,R1             Get cnt to R1
       MOV  @2(R13),R2          Get vsrc to R2
       MOV  @4(R13),R3          Get vdst to R3
       ORI  R3,>4000            Prepare for VDP write

** copy cnt bytes from vsrc to vdst

VMVMOR MOVB @UTILWS+5,@VDPWA    Write LSB of VDP read address
       MOVB R2,@VDPWA           Write MSB of VDP read address
       INC  R2                  Next VDP read address
       MOVB @VDPRD,R0           Read VDP byte
       MOVB @UTILWS+7,@VDPWA    Write LSB of VDP write address
       MOVB R3,@VDPWA           Write MSB of VDP write address
       INC  R3                  Next VDP write address
       MOVB R0,@VDPWD           Write VDP byte
       DEC  R1                  Decrement count
       JNE  VMVMOR              Repeat if not done
       RTWP                     Return to calling program
;]*
;[*== fbForth Version Message ===========================================
FBFMSG EQU  $LO+$-LLVSPT
* This is 18 bytes to maintain program offset.   ?? DON'T REMEMBER WHY ??
* Also, printing the extra blanks overwrites the font-not-found error message.
       BYTE 17
       TEXT 'fbForth 2.0:     '     
;]
*     __  ___        ___ ____      __   __      _      __            __  
*    /  |/  /__  ___/ (_) _(_)__ _/ /  / /__   | | /| / /__  _______/ /__
*   / /|_/ / _ \/ _  / / _/ / _ `/ _ \/ / -_)  | |/ |/ / _ \/ __/ _  (_-<
*  /_/  /_/\___/\_,_/_/_//_/\_,_/_.__/_/\__/   |__/|__/\___/_/  \_,_/___/
* 
;[*== Modifiable words in Resident Dictionary ===========================
;[*** (ABORT) ***
       DATA x#VLST_N         <--Last word in ROM
PABR_N EQU  $LO+$-LLVSPT
       DATA 7+TERMBT*LSHFT8+'(','AB','OR','T)'+TERMBT

PABORT EQU  $LO+$-LLVSPT
       DATA DOCOL
       DATA ABORT,SEMIS
;]*
;[*** FORTH ***         ( --- )                     [ IMMEDIATE word ]
       DATA PABR_N
FRTH_N EQU  $LO+$-LLVSPT
       DATA 5+TERMBT+PRECBT*LSHFT8+'F','OR','TH'+TERMBT

FORTHV EQU  $LO+$-LLVSPT+2          ; vocabulary link field 
FORTHP EQU  $LO+$-LLVSPT+4          ; pseudo name field
FORTHL EQU  $LO+$-LLVSPT+6          ; chronological link field
FORTH  EQU  $LO+$-LLVSPT
       DATA DOVOC
       DATA DPBASE+2,>81A0,0        ; (may need to modify)
;]*
;[*** ASSEMBLER ***     ( --- )                     [ IMMEDIATE word ]
       DATA FRTH_N
ASMR_N EQU  $LO+$-LLVSPT
       DATA 9+TERMBT+PRECBT*LSHFT8+'A','SS','EM','BL','ER'+TERMBT

ASMV   EQU  $LO+$-LLVSPT+2          ; vocabulary link field
ASML   EQU  $LO+$-LLVSPT+6          ; chronological link field
ASSM   EQU  $LO+$-LLVSPT
       DATA DOVOC
       DATA SASM_N,>81A0,FORTHL     ; <--ASMV initially points to last word in
*                                   ;    ...ASSEMBLER vocabulary in the kernel
;]*
;]*
*    ___                     __   __       
*   / _ | ___ ___ ___ __ _  / /  / /__ ____
*  / __ |(_-<(_-</ -_)  ' \/ _ \/ / -_) __/
* /_/ |_/___/___/\__/_/_/_/_.__/_/\__/_/   
*     _   __              __        __                _      __            __  
*    | | / /__  _______ _/ /  __ __/ /__ _______ __  | | /| / /__  _______/ /__
*    | |/ / _ \/ __/ _ `/ _ \/ // / / _ `/ __/ // /  | |/ |/ / _ \/ __/ _  (_-<
*    |___/\___/\__/\_,_/_.__/\_,_/_/\_,_/_/  \_, /   |__/|__/\___/_/  \_,_/___/
*                                           /___/  
*
*== These are the only 2 words in the kernel in the ASSEMBLER vocabulary
;[*** NEXT, ***      ( --- )
* 1st word in ASSEMBLER vocabulary
*
       DATA FORTHP          <--points to PNF of FORTH
NXT__N EQU  $LO+$-LLVSPT
       DATA 5+TERMBT*LSHFT8+'N','EX','T,'+TERMBT

NEXTC  EQU  $LO+$-LLVSPT
       DATA NEXTC+2     <--Can't use '$' in DATA directive that gets moved!
NXT_P  LI   R0,>045F          load "B *NEXT" in R0 (NEXT=R15)
       MOV  @$DP(U),R1        HERE to R1
       MOV  R0,*R1+           compile "B *NEXT"
       MOV  R1,@$DP(U)        update HERE
       MOV  @$CURNT(U),@$CNTXT(U)   set CONTEXT vocabulary to CURRENT vocabulary
       B    *NEXT             back to inner interpreter

* : NEXT,   ( --- )
*    *NEXT B,  ;
;]*
;[*** ;ASM ***       ( --- ) 
* 2nd and last word in ASSEMBLER vocabulary; points to NEXT, pointed to by
* ASSEMBLER as the last word defined in the ASSEMBLER vocabulary in the kernel.
*
       DATA NXT__N
SASM_N EQU  $LO+$-LLVSPT
       BYTE 4+TERMBT    <--note different name field format
       TEXT ';ASM'
       BYTE ' '+TERMBT

SASM   EQU  $LO+$-LLVSPT
       DATA SASM+2   <--Can't use '$' in DATA directive that gets moved!
       JMP  NXT_P          finish up in NEXT,

* : ;ASM   ( --- )
*    *NEXT B,  ;
;]*

;[*== Some Variables (KEYCNT etc.) ======================================

KEYCNT EQU  $LO+$-LLVSPT
       DATA -1              Used in cursor flash logic
INTACT EQU  $LO+$-LLVSPT
       DATA 0               Non-zero during user's interrupt service routine
*
*++ variables used by some graphics primitives
*
$DMODE EQU  $LO+$-LLVSPT
       DATA 0                   ; actual location of variable contents
$DCOL  EQU  $LO+$-LLVSPT
       DATA -1                  ; actual location of variable contents

*===========================================================
;]*
*   ______                         ___            _____        __   
*  /_  __/______ ___ _  ___  ___  / (_)__  ___   / ___/__  ___/ /__ 
*   / / / __/ _ `/  ' \/ _ \/ _ \/ / / _ \/ -_) / /__/ _ \/ _  / -_)
*  /_/ /_/  \_,_/_/_/_/ .__/\___/_/_/_//_/\__/  \___/\___/\_,_/\__/ 
*                    /_/                                            
* 
;[*== Trampoline Code ===================================================
* 
* MYBANK must be at same location in all banks with the code that appears
* in the following table.  The EQUates for BANK0--BANK3 may also be in the
* same places in each bank for convenience, but they only need to appear once.
* 
*       Bank Select MYBANK
*       ---- ------ ------
*       0    >6006  >C000
*       1    >6004  >8000
*       2    >6002  >4000
*       3    >6000  >0000
* 
* Bank0 code will look like this
*
* MYBANK DATA >C000
* BANK0  EQU  >C000
* BANK1  EQU  >8000
* BANK2  EQU  >4000
* BANK3  EQU  >0000
*
* Banks 1--3 will look the same, including labels, and the DATA
* instruction at MYBANK's location will correspond to its bank.
*
* Before a bank is selected, the values above will be shifted right 13
* bits and have >6000 added.
*
;[*** BLBANK ************************************************************
*
* General bank branching routine (32KB ROM, i.e., 4 banks) for a
* branch that is expected to return (not high-level Forth) via RTBANK---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLBANK
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLBANK EQU  $LO+$-LLVSPT
       DECT R               ; reserve space on return stack (R14)
       MOV  *LINK+,CRU      ; copy destination bank address to R12
       MOV  LINK,*R         ; push return address
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank (leftmost 2 bits)
       MOV  CRU,LINK        ; copy destination bank address to R11
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*
;[*** RTBANK ************************************************************
*
* General bank return routine (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTBANK
*
RTBANK EQU  $LO+$-LLVSPT
       MOV  *R+,CRU         ; pop return bank# from return stack to R12
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       MOV  *R+,LINK        ; pop return address from return stack
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to return address
;]*
;[*** BLF2A *************************************************************
*
* High-level Forth to ALC bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to bank0 via RTNEXT.  This will
* only(?) be used for the ALC payload of Forth stubs in bank0---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLF2A
*       DATA  dst_addr - >6000 + bank# in left 2 bits
*
BLF2A  EQU  $LO+$-LLVSPT
       MOV  *LINK,LINK      ; copy destination bank address to R11
       MOV  LINK,CRU        ; copy it to R12
       ANDI LINK,>1FFF      ; mask off leftmost 3 bits to reveal address - >6000
       AI   LINK,>6000      ; make it a real address
       SRL  CRU,13          ; shift bank# into bits 1-2 of R12
       AI   CRU,>6000       ; make it a real bank-switch address
       CLR  *CRU            ; switch to destination bank
       B    *LINK           ; branch to destination address
;]*                           
;[*** RTNEXT ************************************************************
*
* High-level Forth bank "return" routine from ALC (32KB ROM, i.e., 4 
* banks)---
*   --put in scratchpad or low RAM
*   --called by
*       B   @RTNEXT
*
RTNEXT EQU  $LO+$-LLVSPT
       MOV  @INTACT,CRU       Are we in user's ISR?
       JNE  RTNXT1            Don't enable interrupts if so.
       LIMI 2
RTNXT1 CLR  @>6006          ; switch to bank 0
       B    *NEXT           ; branch to next CFA (in R15)
;]*
;[*** BLA2F *************************************************************
*
* ALC to high-level Forth bank branching routine (32KB ROM, i.e., 4
* banks) that is expected to return to calling bank via RTA2F---
*   --put in scratchpad or low RAM
*   --called by
*       BL    @BLA2F
*       DATA <Forth cfa in bank0>
*
BLA2F  EQU  $LO+$-LLVSPT
       DECT R               ; reserve space on return stack 
       MOV  *LINK+,W        ; move CFA of Forth routine to W
       MOV  LINK,*R         ; push return address of calling bank
       DECT R               ; reserve space on return stack
       MOV  @x#MYBANK,*R      ; push return bank# (leftmost 2 bits)
       DECT R               ; reserve spot on return stack
       MOV  IP,*R           ; move current IP to return stack
       LI   IP,RTA2F        ; move address of return procedure to IP
       CLR  @>6006          ; switch to bank0
       B    @DOEXEC         ; Execute the Forth routine
;]*
;[*** RTA2F *************************************************************
*
* ALC to high-level Forth bank "return" routine from Forth to calling
* ALC (32KB ROM, i.e., 4 banks)---
*   --put in scratchpad or low RAM
*   --called through B *NEXT at end of Forth word's execution in BLA2F
*
RTA2F  EQU  $LO+$-LLVSPT
       DATA RTA2F+2         ; stored in IP by BLA2F (points to W, next instruction)
       DATA RTA2F+4         ; stored in W by NEXT (points to "code field", next instruction)
       MOV  *R+,IP          ; restore previous IP ("code field" executed by NEXT)
* Retrieve ALC return info and return to caller...
* ...caller will execute B *NEXT when it finishes
       B    @RTBANK         ; branch to general bank return routine above
;]*
;]***********************************************************************
;[*++ Bank-specific cell-/byte-reading code ++*
;[*** BANK@ ***     ( bankAddr bank# --- cell_contents )
*++ Read cell contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKAT  EQU  $LO+$-LLVSPT
       CLR  *R0             ; switch banks
       MOV  *R1,*SP         ; get cell contents of address to stack
       B    @RTNEXT         ; return to inner interpreter
;]*
;[*** BANKC@ ***    ( bankAddr bank# --- byte_contents )
*++ Read byte contents of address in Bank bank# or RAM.
*++ Register inputs:
*++     R0:  bank-switch address
*++     R1:  address in bank# to be read

_BKCAT EQU  $LO+$-LLVSPT
       CLR  *R0             ; switch banks
       CLR  R2              ; clear R2
       MOVB *R1,@F_R2LB     ; get byte contents of address to low byte of R2
       MOV  R2,*SP          ; get byte contents of address to stack
       B    @RTNEXT         ; return to inner interpreter

;]*

;]*
*         _______   __  _________      ___          __    
*        / __/ _ | /  |/  / __/ /     / _ )___  ___/ /_ __
*       _\ \/ __ |/ /|_/ /\ \/_/     / _  / _ \/ _  / // /
*      /___/_/ |_/_/  /_/___(_)     /____/\___/\_,_/\_, / 
*                                                  /___/  
* 
;[*** SAMS! ***      ( --- )
* This calls the SAMS initialization in the startup code in bank 1.
* 
*        DATA SMSQ_N
* SMST_N DATA 5+TERMBT*LSHFT8+'S','AM','S!'+TERMBT
* SAMSST DATA $+2
*        BL   @BLF2A
*        DATA _SMSST->6000+BANK1

_SMSST BL   @SMSINI           initialize SAMS card
       B    @RTNEXT           back to inner interpreter
;]*   
;[*== Required strings, tables, variables... ============================
*
*
* Default blocks filename
*
DEFNAM EQU  $LO+$-LLVSPT
       BYTE 12
       TEXT "DSK1.FBLOCKS "
*
* Default colors for all VDP modes---
*     MSB: Screen color (LSN); text FG (MSN), BG (LSN)
*     LSB: Color Table colors (FG/BG)
*
DEFCOL EQU  $LO+$-LLVSPT
       DATA >4F00          ; TEXT80    offset=0
       DATA >4F00          ; TEXT      offset=2
       DATA >F4F4          ; GRAPHICS  offset=4
       DATA >11F4          ; MULTI     offset=6
       DATA >FE10          ; GRAPHICS2 offset=8
       DATA >FEF4          ; SPLIT     offset=10
       DATA >FEF4          ; SPLIT2    offset=12
*
* Default text mode
*
DEFTXT EQU  $LO+$-LLVSPT
       DATA >0001
*
* Font flag is checked by FNT to see whether to copy DSKx.FBFONT to font PAB
*
FNTFLG EQU  $LO+$-LLVSPT
       DATA 0              ; font flag initially 0
*
* Speech variables needing initial value (more below LLVEND)
*
SPCSVC EQU  $LO+$-LLVSPT
       DATA 0
*
* Sound Table #1 Workspace for sound variables.  Only using R0..R4
*
SND1WS EQU  $LO+$-LLVSPT
SND1ST EQU  SND1WS         R0 (sound table status) 0=no table; 1=loading sound...
       DATA 0              ...bytes; -1=counting
SND1DS EQU  SND1WS+2       R1 (sound-table byte destination)...
       DATA SOUND          ...initialized to sound chip
SND1AD EQU  SND1WS+4       R2 (sound table address)
       DATA 0
SND1CT EQU  SND1WS+6       R3 (# of sound bytes to load or...
       DATA 0              ...sound count = seconds * 60)
SND1SP EQU  SND1WS+8       R4 (pointer to top of sound stack)
       DATA SNDST0         initialized to bottom of sound stack              
* 
* Sound Table #2 Workspace for sound variables.  Only using R0..R3
*
SND2WS EQU  $LO+$-LLVSPT
SND2ST EQU  SND2WS         R0 (sound table status) 0=no table  ; 1=loading sound...
       DATA 0              ...bytes; -1=counting
SND2DS EQU  SND2WS+2       R1 (sound-table byte destination)...
       DATA SOUND          ...initialized to sound chip
;]*
* 
* This is the end of low-level support code that gets copied.
*
LLVEND

;[*== Un-initialized Variables and workspaces... =========================
* Start of definitions of variables and workspaces that do not need to
* take up space in ROM because they need no initial values.
*
* Sound Table #2 Workspace for sound variables..continued.
*
SND2AD EQU  SND2WS+4       R2 (sound table address)
SND2CT EQU  SND2WS+6       R3 (# of sound bytes to load or...
*                          ...sound count = seconds * 60)
SDMUTE EQU  SND2WS+8       dummy destination for sound byte
* 
* Branch Stack for ISR processing of Speech, 2 Sound Tables and return
*
BRSTK  EQU  SDMUTE+2
*
* Speech variables (more above LLVEND)
* 
SSFLAG EQU  BRSTK+8
SPCNT  EQU  SSFLAG+2
SPADR  EQU  SPCNT+2
BANKSV EQU  SPADR+2
PADSV  EQU  BANKSV+2
*
* Panel window: height, width and screen position...used by PANEL and SCROLL
*
PANWIN EQU  PADSV+12          panel height, width and screen start
 
*== Utility Workspace =================================================
*** General utility workspace registers
UTILWS EQU  PANWIN+6
U_R2LB EQU  UTILWS+5

LINBUF EQU  UTILWS+32
CURCHR EQU  LINBUF+80

*++ variable used by the 40/80-column editor
OLDCUR EQU  CURCHR+2

*++ FILE I/O variables
 
PBADR  EQU  OLDCUR+8
PBBF   EQU  PBADR+2
PBVBF  EQU  PBBF+2
 
*++ Floating Point Math Library variables
FPVARS EQU  PBVBF+2
 
*++ SAMS flag
SAMSFL EQU  FPVARS+22

*++ Bottom of Sound Stack 
*++      This location marks the top of the low-level support code. The Sound
*++      Stack grows upward toward the Return Stack by moving the entire stack
*++      up one cell to make room for the next new bottom entry.
SNDST0 EQU  SAMSFL+2
;]*

and its listing:

Reveal hidden contents



0105                      COPY "Bank1\fbForth101_LowLevelSupport.a99"
     **** ****     > fbForth101_LowLevelSupport.a99
0001               *     __                  __                __
0002               *    / /  ___ _    ______/ /  ___ _  _____ / /
0003               *   / /__/ _ \ |/|/ /___/ /__/ -_) |/ / -_) /
0004               *  /____/\___/__,__/   /____/\__/|___/\__/_/
0005               *                     ____                        __
0006               *                    / __/_ _____  ___  ___  ____/ /_
0007               *                   _\ \/ // / _ \/ _ \/ _ \/ __/ __/
0008               *                  /___/\_,_/ .__/ .__/\___/_/  \__/
0009               *                          /_/  /_/
0010               *
0011               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0012               *                                                                   *
0013               * fbForth---                                                        *
0014               *                                                                   *
0015               *       Low-level support routines                                  *
0016               *                                                                   *
0017               *  << Including Trampoline Code, tables & variables:  2606 bytes >> *
0018               *                                                                   *
0019               * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
0020               
0021               LLVSPT   ; <--This is the source copy location for the rest of this code.
0022               
0023      2010     $BUFF  EQU  >2010
0024               
0025               * 4 I/O buffers below ($LO = >3020)
0026               * Change '4' to number of buffers needed and for which there is room.
0027               
0028      3020     $LO    EQU  4*>404+$BUFF      start of low-level routines after I/O buffers
0029               *       _____   ____         __  __      ___________
0030               *      / _/ /  / __/__  ____/ /_/ /     /  _/ __/ _ \
0031               *     / _/ _ \/ _// _ \/ __/ __/ _ \   _/ /_\ \/ , _/
0032               *    /_//_.__/_/  \___/_/  \__/_//_/  /___/___/_/|_|
0033               *
0034               ;[*** Interrupt Service =======================================================
0035               * This routine is executed for every interrupt.  It processes any pending
0036               * speech and souind.  It then looks to see whether a user ISR is installed in
0037               * ISR.  If so, it sets up NEXT for execution of the user ISR.  This will work
0038               * only if the user has installed an ISR using the following steps in the fol-
0039               * lowing order:
0040               *
0041               *   (1) Write an ISR with entry point, say MYISR.
0042               *   (2) Determine code field address of MYISR with this high-level Forth:
0043               *           ' MYISR CFA
0044               * <<< Maybe need a word to do #3 >>>
0045               *   (3) Write CFA of MYISR into user variable ISR.
0046               *
0047               * Steps (2)-(3) in high-level Forth are shown below:
0048               *           ' MYISR CFA
0049               *           ISR !
0050               *
0051               * <<< Perhaps last step above should be by a word that disables interrupts >>>
0052               *
0053               * The console ISR branches to the contents of >83C4 because it is non-zero,
0054               * with the address, INT1, of the fbForth ISR entry point below (also, the
0055               * contents of INTLNK).  This means that the console ISR will branch to INT1
0056               * with BL *R12 from WP = GPLWS (>83E0), R12 containing INT1 below to first
0057               * process any pending speech and sound.
0058               *
0059               * If the user's ISR is properly installed, the code that processes the user
0060               * ISR modifies NEXT so that the very next time B *NEXT or B *R15 is executed
0061               * from Forth's workspace (MAINWS), the code at INT2 will process the user's
0062               * ISR just before branching to the normal NEXT entry ($NEXT) in fbForth's
0063               * inner interpreter.
0064               *** ==========================================================================
0065               
0066               * ¡¡¡ MUST REMEMBER THAT WE ARE IN GPL WORKSPACE UPON ENTRY. !!!
0067               
0068      3020     INT1   EQU  $LO+$-LLVSPT
0069 6140 0200  20        LI   R0,BRSTK          load address of top of Branch Address Stack
     6142 3A2A     
0070               *
0071               * Set up for pending speech
0072               *
0073 6144 C420  46        MOV  @SPCSVC,*R0       save Speech service address onto Branch Stack
     6146 3A14     
0074 6148 1301  14        JEQ  SNDCH1            jump to sound-check if no speech
0075 614A 05C0  14        INCT R0                increment Branch Stack
0076               *
0077               * Set up for pending sound table #1 (ST#1)
0078               *
0079 614C C0A0  34 SNDCH1 MOV  @SND1ST,R2        sound table ST#1 to service?
     614E 3A16     
0080 6150 1303  14        JEQ  SNDCH2            process speech and sound if needed
0081 6152 0201  20        LI   R1,x#PLAYT1         load PLAYT1 address and...
     6154 7C68     
0082 6156 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0083               *
0084               * Set up for pending sound table #2 (ST#2)
0085               *
0086 6158 C0E0  34 SNDCH2 MOV  @SND2ST,R3        sound table ST#2 to service?
     615A 3A20     
0087 615C 1303  14        JEQ  PRCSPS            process speech and sound if needed
0088 615E 0201  20        LI   R1,x#PLAYT2         load PLAYT2 address and...
     6160 7C6E     
0089 6162 CC01  34        MOV  R1,*R0+           ...push it onto Branch Stack
0090               *
0091               * Process sound stack if both sound tables idle
0092               *
0093 6164 E0C2  18 PRCSPS SOC  R2,R3             OR R2 and R3..both sound tables idle?
0094 6166 160A  14        JNE  PRSPS2            nope..skip sound stack processing
0095 6168 02E0  18        LWPI SND1WS            switch to ST#1 WS
     616A 3A16     
0096 616C 0284  22        CI   R4,SNDST0         anything on sound stack?
     616E 3AE4     
0097 6170 1303  14        JEQ  PRSPS1            no..exit sound stack processing
0098 6172 0644  14        DECT R4                pop sound stack position
0099 6174 C094  26        MOV  *R4,R2            get sound table address from sound stack
0100 6176 0580  14        INC  R0                kick off sound processing of ST#1 (R0=1)
0101 6178 02E0  18 PRSPS1 LWPI GPLWS             switch back to GPL WS
     617A 83E0     
0102               *
0103               * Check for any pending speech and sound
0104               *
0105 617C 0280  22 PRSPS2 CI   R0,BRSTK          any speech or sound to process?
     617E 3A2A     
0106 6180 1312  14        JEQ  USRISR            if not, jump to user ISR processing
0107 6182 0201  20        LI   R1,BNKRST         yup..load return address
     6184 307A     
0108 6186 C401  30        MOV  R1,*R0            push return address onto Branch Stack
0109               *
0110               * Process pending speech and sound
0111               *
0112 6188 C820  54        MOV  @x#MYBANK,@BANKSV   save bank at interrupt
     618A 7FFE     
     618C 3A38     
0113 618E 04E0  34        CLR  @>6002            switch to bank 2 for speech & sound services
     6190 6002     
0114 6192 0207  20        LI   R7,BRSTK          load top of Branch Stack
     6194 3A2A     
0115 6196 C237  30        MOV  *R7+,R8           pop speech/sound ISR
0116 6198 0458  20        B    *R8               service speech/sound
0117               *
0118               * Restore interrupted bank
0119               *
0120      307A     BNKRST EQU  $LO+$-LLVSPT      return point for speech and sound ISRs
0121 619A C020  34        MOV  @BANKSV,R0        restore bank at interrupt
     619C 3A38     
0122 619E 09D0  56        SRL  R0,13             get the bank# to correct position
0123 61A0 0220  22        AI   R0,>6000          make it a real bank-switch address
     61A2 6000     
0124 61A4 04D0  26        CLR  *R0               switch to the bank at interrupt
0125               *
0126               * Process User ISR if defined
0127               *
0128 61A6 C020  34 USRISR MOV  @$ISR+$UVAR,R0     User ISR installed?
     61A8 36EA     
0129 61AA 1304  14        JEQ  INTEX
0130               *
0131               * Fix NEXT so that the user's ISR is processed the next time B *NEXT (B *R15)
0132               * is executed from Forth's WS (MAINWS = >8300), which it does at the end of
0133               * every CODE word, keyboard scan and one or two other places.
0134               *
0135 61AC 0201  20        LI   R1,INT2                 Load entry point, INT2
     61AE 309A     
0136 61B0 C801  38        MOV  R1,@2*NEXT+MAINWS       Copy it to Forth's NEXT (R15)
     61B2 831E     
0137               *
0138               * The following 2 instructions are copies of the remainder of the console ROM's
0139               * ISR (except that 'CLR R8' was removed because it is only needed by TI Basic)
0140               * because we're not going back there!
0141               *
0142 61B4 02E0  18 INTEX  LWPI >83C0             Change to console's ISR WS
     61B6 83C0     
0143 61B8 0380  18        RTWP                   Return to caller of console ISR
0144               *
0145               * Branch through above-modified NEXT (R15) gets us here. NEXT will be restored
0146               * before executing user's ISR. INT3 (cleanup routine below) will be inserted
0147               * in address list to get us back here for cleanup after user's ISR has finished.
0148               * User's ISR is executed at the end of this section just before INT3.
0149               *
0150      309A     INT2   EQU  $LO+$-LLVSPT
0151 61BA 0300  24        LIMI 0                 Disable interrupts
     61BC 0000     
0152 61BE D020  34        MOVB @>83D4,R0         Get copy of VR01
     61C0 83D4     
0153 61C2 0980  56        SRL  R0,8              ...to LSB
0154 61C4 0260  22        ORI  R0,>100           Set up for VR01
     61C6 0100     
0155 61C8 0240  22        ANDI R0,>FFDF          Clear VDP-interrupt-enable bit
     61CA FFDF     
0156 61CC 0420  54        BLWP @VWTR             Turn off VDP interrupt
     61CE 3752     
0157 61D0 020F  20        LI   NEXT,$NEXT        Restore NEXT
     61D2 833A     
0158 61D4 0720  34        SETO @INTACT           Set Forth "pending interrupt" flag
     61D6 3956     
0159 61D8 064E  14        DECT R                 Set up return linkage by pushing
0160 61DA C78D  30        MOV  IP,*R             ...IP (R13, next Forth CFA) to return stack and
0161 61DC 020D  20        LI   IP,INT3           ...setting IP to INT3 (below) for cleanup
     61DE 30C8     
0162 61E0 C2A8  34        MOV  @$ISR(U),W        Do the user's Forth ISR by executing
     61E2 0036     
0163 61E4 0460  28        B    @DOEXEC           ...it through Forth's inner interpreter
     61E6 833C     
0164               *
0165               * Clean up and re-enable interrupts.
0166               *
0167      30C8     INT3   EQU  $LO+$-LLVSPT
0168 61E8 30CA            DATA INT3+2            $NEXT (or $SEMIS) puts INT3+2 in W (R10)
0169 61EA 30CC            DATA INT3+4            DOEXEC (or $SEMIS) will branch to *W = INT3+4 (next instr)
0170 61EC C37E  30        MOV  *R+,IP            Start cleanup: pop IP from before call to user's ISR
0171 61EE 04E0  34        CLR  @INTACT           Clear Forth "pending interrupt" flag
     61F0 3956     
0172 61F2 D020  34        MOVB @>83D4,R0         Prepare to restore VR01 by...
     61F4 83D4     
0173 61F6 0980  56        SRL  R0,8              ...moving payload to LSB (enabling VDP interrupt) and
0174 61F8 0220  22        AI   R0,>100           ...VR # (01) to MSB
     61FA 0100     
0175 61FC D060  34        MOVB @VDPSTA,R1        Remove pending VDP interrupt by reading VDP status
     61FE 8802     
0176 6200 0420  54        BLWP @VWTR             Write VR01
     6202 3752     
0177 6204 0300  24        LIMI 2                 Re-enable interrupts
     6206 0002     
0178 6208 045F  20        B    *NEXT             Continue normal task
0179               ;]*
0180               ;[*** BKLINK from SYSTEM calls ==========================================
0181               *
0182      30EA     BKLINK EQU  $LO+$-LLVSPT
0183 620A C1E0  34        MOV  @INTACT,R7        Are we in user's ISR?
     620C 3956     
0184 620E 1602  14        JNE  BKLIN1            Don't enable interrupts if so.
0185 6210 0300  24        LIMI 2
     6212 0002     
0186 6214 045B  20 BKLIN1 B    *LINK
0187               ;]*
0188               *      ____         __              _____     ____
0189               *     / __/_ ______/ /____ __ _    / ___/__ _/ / /__
0190               *    _\ \/ // (_-</ __/ -_)  ' \  / /__/ _ `/ / (_-<
0191               *   /___/\_, /___/\__/\__/_/_/_/  \___/\_,_/_/_/___/
0192               *       /___/
0193               *
0194               ;[*** $SYS$ -- Called by fbForth's SYSTEM ===============================
0195               
0196               *       Entry point for low-level system support functions
0197               
0198      30F6     $SYS$  EQU  $LO+$-LLVSPT
0199 6216 0300  24        LIMI 0
     6218 0000     
0200 621A C021  34        MOV  @SYSTAB(R1),R0
     621C 3114     
0201 621E 0450  20        B    *R0
0202               ;]
0203               ;[*** SYSTAB -- Vector table for SYSTEM calls ===========================
0204               
0205 6220 34C6            DATA BRW          CODE = -20  write block to blocks file
0206 6222 34C6            DATA BRW          CODE = -18  read block from blocks file
0207 6224 34C6            DATA BRW          CODE = -16  create blocks file
0208 6226 34C6            DATA BRW          CODE = -14  use blocks file
0209 6228 346C            DATA GXY          CODE = -12  GOTOXY
0210 622A 3456            DATA QKY          CODE = -10  ?KEY
0211 622C 343C            DATA QTM          CODE =  -8  ?TERMINAL
0212 622E 3420            DATA CLF          CODE =  -6  CRLF
0213 6230 3312            DATA EMT          CODE =  -4  EMIT
0214 6232 3260            DATA KY           CODE =  -2  KEY
0215      3114     SYSTAB EQU  $LO+$-LLVSPT
0216 6234 3130            DATA SBW          CODE =   0  VSBW
0217 6236 313E            DATA MBW          CODE =   2  VMBW
0218 6238 314C            DATA SBR          CODE =   4  VSBR
0219 623A 315A            DATA MBR          CODE =   6  VMBR
0220 623C 3176            DATA WTR          CODE =   8  VWTR
0221 623E 3186            DATA GPL          CODE =  10  GPLLNK
0222 6240 31A6            DATA XML          CODE =  12  XMLLNK
0223 6242 31C0            DATA DSR          CODE =  14  DSRLNK
0224 6244 31DA            DATA CLS$         CODE =  16  CLS
0225 6246 3168            DATA MVE          CODE =  18  VMOVE
0226 6248 31F4            DATA FILL$        CODE =  20  VFILL
0227 624A 3224            DATA AOX          CODE =  22  VAND
0228 624C 3224            DATA AOX          CODE =  24  VOR
0229 624E 3224            DATA AOX          CODE =  26  VXOR
0230               ;]*
0231               ;[*== VDP single byte write.                CODE =   0  =================
0232               *
0233      3130     SBW    EQU  $LO+$-LLVSPT
0234 6250 C039  30        MOV  *SP+,R0         VRAM address (destination)
0235 6252 C079  30        MOV  *SP+,R1         Character to write
0236 6254 06C1  14        SWPB R1              Get in left byte
0237 6256 0420  54        BLWP @VSBW
     6258 373E     
0238 625A 0460  28        B    @BKLINK
     625C 30EA     
0239               ;]*
0240               ;[*== VDP multi byte write.                 CODE =   2  =================
0241               *
0242      313E     MBW    EQU  $LO+$-LLVSPT
0243 625E C0B9  30        MOV  *SP+,R2         Number of bytes to move
0244 6260 C039  30        MOV  *SP+,R0         VRAM address (destination)
0245 6262 C079  30        MOV  *SP+,R1         RAM address (source)
0246 6264 0420  54        BLWP @VMBW
     6266 3742     
0247 6268 0460  28        B    @BKLINK
     626A 30EA     
0248               ;]*
0249               ;[*== VDP single byte read.                 CODE =   4  =================
0250               *
0251      314C     SBR    EQU  $LO+$-LLVSPT
0252 626C C019  26        MOV  *SP,R0          VRAM address (source)
0253 626E 0420  54        BLWP @VSBR
     6270 3746     
0254 6272 0981  56        SRL  R1,8            Character to right half for Forth
0255 6274 C641  30        MOV  R1,*SP          Stack it
0256 6276 0460  28        B    @BKLINK
     6278 30EA     
0257               ;]*
0258               ;[*== VDP multi byte read.                  CODE =   6  =================
0259               *
0260      315A     MBR    EQU  $LO+$-LLVSPT
0261 627A C0B9  30        MOV  *SP+,R2         Number of bytes to read
0262 627C C079  30        MOV  *SP+,R1         RAM address (destination)
0263 627E C039  30        MOV  *SP+,R0         VRAM address (source)
0264 6280 0420  54        BLWP @VMBR
     6282 374A     
0265 6284 0460  28        B    @BKLINK
     6286 30EA     
0266               ;]*
0267               ;[*== VDP-to-VDP move.                      CODE =  18  =================
0268               *
0269      3168     MVE    EQU  $LO+$-LLVSPT
0270 6288 C039  30        MOV  *SP+,R0         Pop cnt to R0
0271 628A C0B9  30        MOV  *SP+,R2         Pop vdst to R2
0272 628C C079  30        MOV  *SP+,R1         Pop vsrc to R1
0273 628E 0420  54        BLWP @VMOVE
     6290 374E     
0274 6292 0460  28        B    @BKLINK
     6294 30EA     
0275               ;]*
0276               ;[*== VDP register write.                   CODE =   8  =================
0277               *
0278      3176     WTR    EQU  $LO+$-LLVSPT
0279 6296 C079  30        MOV  *SP+,R1         VDP register number
0280 6298 C039  30        MOV  *SP+,R0         Data for register
0281 629A 06C1  14        SWPB R1              Get register to left byte
0282 629C D001  18        MOVB R1,R0           Place with data
0283 629E 0420  54        BLWP @VWTR
     62A0 3752     
0284 62A2 0460  28        B    @BKLINK
     62A4 30EA     
0285               ;]*
0286               ;[*== GPL link utility.                     CODE =  10  =================
0287               *
0288      3186     GPL    EQU  $LO+$-LLVSPT
0289 62A6 04C0  14        CLR  R0
0290 62A8 D800  38        MOVB R0,@KYSTAT
     62AA 837C     
0291 62AC 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62AE 0420     
0292 62B0 0201  20        LI   R1,GPLLNK         to the GPLLNK utility
     62B2 3784     
0293 62B4 C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0294 62B6 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62B8 045B     
0295 62BA C10B  18        MOV  LINK,R4         Save LINK address
0296 62BC 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62BE 8300     
0297 62C0 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0298 62C2 0460  28        B    @BKLINK
     62C4 30EA     
0299               ;]*
0300               ;[*== XML link utility.                     CODE =  12  =================
0301               *
0302      31A6     XML    EQU  $LO+$-LLVSPT
0303 62C6 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62C8 0420     
0304 62CA 0201  20        LI   R1,XMLLNK         to the XMLLNK utility
     62CC 3736     
0305 62CE C0B9  30        MOV  *SP+,R2           with this datum identifying the routine
0306 62D0 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62D2 045B     
0307 62D4 C10B  18        MOV  LINK,R4         Save LINK address
0308 62D6 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62D8 8300     
0309 62DA C2C4  18        MOV  R4,LINK           and reconstruct LINK
0310 62DC 0460  28        B    @BKLINK
     62DE 30EA     
0311               ;]*
0312               ;[*== DSR link utility.                     CODE =  14  =================
0313               *
0314      31C0     DSR    EQU  $LO+$-LLVSPT
0315 62E0 0200  20        LI   R0,>0420        Construct the BLWP instruction
     62E2 0420     
0316 62E4 0201  20        LI   R1,DSRLNK         to the DSRLNK utility
     62E6 37BE     
0317 62E8 C0B9  30        MOV  *SP+,R2         This datum selects DSR or subroutine
0318 62EA 0203  20        LI   R3,>045B        Construct the B *LINK instruction
     62EC 045B     
0319 62EE C10B  18        MOV  LINK,R4         Save LINK address
0320 62F0 06A0  32        BL   @2*R0+MAINWS    Execute the above instructions
     62F2 8300     
0321 62F4 C2C4  18        MOV  R4,LINK           and reconstruct LINK
0322 62F6 0460  28        B    @BKLINK
     62F8 30EA     
0323               ;]*
0324               ;[*== Screen clearing utility.              CODE =  16  =================
0325               *
0326      31DA     CLS$   EQU  $LO+$-LLVSPT
0327 62FA C0A8  34        MOV  @$SSTRT(U),R2   Beginning of screen in VRAM
     62FC 0032     
0328 62FE C068  34        MOV  @$SEND(U),R1    End of screen in VRAM
     6300 0034     
0329 6302 6042  18        S    R2,R1           Screen size
0330 6304 0200  20        LI   R0,>2000        Blank character
     6306 2000     
0331 6308 C1CB  18        MOV  LINK,R7
0332 630A 06A0  32        BL   @FILL1
     630C 3208     
0333 630E C2C7  18        MOV  R7,LINK
0334 6310 0460  28        B    @BKLINK
     6312 30EA     
0335               ;]*
0336               ;[*== VDP fill routine.                     CODE =  20  =================
0337               *
0338      31F4     FILL$  EQU  $LO+$-LLVSPT
0339 6314 C039  30        MOV  *SP+,R0         Fill character
0340 6316 06C0  14        SWPB R0                to left byte
0341 6318 C079  30        MOV  *SP+,R1         Fill count
0342 631A C0B9  30        MOV  *SP+,R2         Address to start VRAM fill
0343 631C C1CB  18        MOV  LINK,R7
0344 631E 06A0  32        BL   @FILL1
     6320 3208     
0345 6322 C2C7  18        MOV  R7,LINK
0346 6324 0460  28        B    @BKLINK
     6326 30EA     
0347               *========================================================================
0348      3208     FILL1  EQU  $LO+$-LLVSPT    R0=char, R1=cnt, R2=vaddr
0349 6328 0262  22        ORI  R2,>4000        Set bit for VDP write
     632A 4000     
0350 632C 06C2  14        SWPB R2
0351 632E D802  38        MOVB R2,@VDPWA       LS byte first
     6330 8C02     
0352 6332 06C2  14        SWPB R2
0353 6334 D802  38        MOVB R2,@VDPWA       Then MS byte
     6336 8C02     
0354 6338 1000  14        NOP                  Kill time
0355 633A D800  38 FLOOP  MOVB R0,@VDPWD       Write a byte
     633C 8C00     
0356 633E 0601  14        DEC  R1
0357 6340 16FC  14        JNE  FLOOP           Not done, fill another
0358 6342 045B  20        B    *LINK
0359               ;]*======================================================================
0360               *
0361               *==== VAND -- VDP byte AND routine.         CODE =  22  =================
0362               *==== VOR -- VDP byte OR routine.           CODE =  24  =================
0363               ;[*== VXOR -- VDP byte XOR routine.         CODE =  26  =================
0364               *
0365      3224     AOX    EQU  $LO+$-LLVSPT
0366 6344 C0B9  30        MOV  *SP+,R2         VRAM address
0367 6346 06C2  14        SWPB R2
0368 6348 D802  38        MOVB R2,@VDPWA       LS byte first
     634A 8C02     
0369 634C 06C2  14        SWPB R2
0370 634E D802  38        MOVB R2,@VDPWA       Then MS byte
     6350 8C02     
0371 6352 1000  14        NOP                  Kill time
0372 6354 D0E0  34        MOVB @VDPRD,R3       Read byte
     6356 8800     
0373 6358 C039  30        MOV  *SP+,R0         Get data to operate with
0374 635A 06C0  14        SWPB R0                to left byte
0375               *** Now do requested operation *****************
0376 635C 0281  22        CI   R1,24
     635E 0018     
0377 6360 1304  14        JEQ  DOOR
0378 6362 1505  14        JGT  DOXOR
0379 6364 0543  14        INV  R3              These two instructions
0380 6366 4003  18        SZC  R3,R0             perform an 'AND'
0381 6368 1003  14        JMP  FINAOX
0382 636A E003  18 DOOR   SOC  R3,R0             perform 'OR'
0383 636C 1001  14        JMP  FINAOX
0384 636E 2803  18 DOXOR  XOR  R3,R0             perform 'XOR'
0385 6370 0201  20 FINAOX LI   R1,1
     6372 0001     
0386 6374 C1CB  18        MOV  LINK,R7
0387 6376 06A0  32        BL   @FILL1
     6378 3208     
0388 637A C2C7  18        MOV  R7,LINK
0389 637C 0460  28        B    @BKLINK
     637E 30EA     
0390               ;]*
0391               ;[*== KEY routine                           CODE =  -2  =================
0392               *
0393      3260     KY    EQU  $LO+$-LLVSPT
0394 6380 C028  34        MOV  @$ALTI(U),R0      alternate input device?
     6382 0038     
0395 6384 131B  14        JEQ  KEY0              jump to keyboard input if not
0396               *
0397               *  R0 now points to PAB for alternate input device, the one-byte buffer
0398               *  for which must immediately precede its PAB.  PAB must have been set up
0399               *  to read one byte.
0400               *
0401 6386 04C7  14        CLR  R7                prepare to zero status byte
0402 6388 D807  38        MOVB R7,@KYSTAT        zero status byte
     638A 837C     
0403 638C 0580  14        INC  R0                point R0 to Flag/Status byte
0404 638E 0420  54        BLWP @VSBR             read it
     6390 3746     
0405 6392 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6394 1F00     
0406 6396 0420  54        BLWP @VSBW             write it back to PAB
     6398 373E     
0407 639A C040  18        MOV  R0,R1             Set up pointer...
0408 639C 0221  22        AI   R1,8              ...to namelength byte of PAB
     639E 0008     
0409 63A0 C801  38        MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
     63A2 8356     
0410 63A4 C0C0  18        MOV  R0,R3             save pointer (DSRLNK will trash it!)
0411 63A6 0420  54        BLWP @DSRLNK           get 1 byte from device
     63A8 37BE     
0412 63AA 0008            DATA >8
0413 63AC C003  18        MOV  R3,R0             restore pointer
0414 63AE 0640  14        DECT R0                point to one-byte VRAM buffer in front of PAB
0415 63B0 0420  54        BLWP @VSBR             read character
     63B2 3746     
0416 63B4 0981  56        SRL  R1,8              move to LSB
0417 63B6 C001  18        MOV  R1,R0             copy to return register
0418 63B8 0460  28        B    @BKLINK           return to caller
     63BA 30EA     
0419               *
0420               *  Input is comining from the keyboard
0421               *
0422 63BC C1E0  34 KEY0   MOV  @KEYCNT,R7
     63BE 3954     
0423 63C0 0587  14        INC  R7
0424 63C2 160A  14        JNE  KEY1
0425 63C4 C028  34        MOV  @CURPO$(U),R0
     63C6 0016     
0426 63C8 0420  54        BLWP @VSBR             Read character at cursor position...
     63CA 3746     
0427 63CC D801  38        MOVB R1,@CURCHR        ...and save it
     63CE 3ABC     
0428 63D0 0201  20        LI   R1,>1E00          Place cursor character on screen
     63D2 1E00     
0429 63D4 0420  54        BLWP @VSBW
     63D6 373E     
0430               *
0431 63D8 0420  54 KEY1   BLWP @KSCAN
     63DA 373A     
0432 63DC D020  34        MOVB @KYSTAT,R0
     63DE 837C     
0433 63E0 2020  38        COC  @H2000,R0         check status
     63E2 3734     
0434 63E4 1319  14        JEQ  KEY2              JMP if key was pressed
0435               *
0436 63E6 0287  22        CI   R7,100            No key pressed
     63E8 0064     
0437 63EA 1603  14        JNE  KEY3
0438 63EC D060  34        MOVB @CURCHR,R1
     63EE 3ABC     
0439 63F0 1006  14        JMP  KEY5
0440               *
0441 63F2 0287  22 KEY3   CI   R7,200
     63F4 00C8     
0442 63F6 1607  14        JNE  KEY4
0443 63F8 04C7  14        CLR  R7
0444 63FA 0201  20        LI   R1,>1E00          Cursor char
     63FC 1E00     
0445 63FE C028  34 KEY5   MOV  @CURPO$(U),R0
     6400 0016     
0446 6402 0420  54        BLWP @VSBW
     6404 373E     
0447 6406 C807  38 KEY4   MOV  R7,@KEYCNT
     6408 3954     
0448 640A C1E0  34        MOV  @INTACT,R7        Are we in user's ISR?
     640C 3956     
0449 640E 1602  14        JNE  KEY6              Don't enable interrupts if so.
0450 6410 0300  24        LIMI 2
     6412 0002     
0451 6414 064D  14 KEY6   DECT IP                This will re-execute KEY
0452 6416 045F  20        B    *NEXT
0453 6418 0720  34 KEY2   SETO @KEYCNT           Key was pressed
     641A 3954     
0454 641C C028  34        MOV  @CURPO$(U),R0     Restore character at cursor location
     641E 0016     
0455 6420 D060  34        MOVB @CURCHR,R1
     6422 3ABC     
0456 6424 0420  54        BLWP @VSBW
     6426 373E     
0457 6428 D020  34        MOVB @KYCHAR,R0        Put char in...
     642A 8375     
0458 642C 0980  56        SRL  R0,8              ...LSB of R0
0459 642E 0460  28        B    @BKLINK
     6430 30EA     
0460               ;]*
0461               ;[*== EMIT routine                          CODE =  -4  =================
0462               *
0463      3312     EMT    EQU  $LO+$-LLVSPT
0464 6432 C042  18        MOV  R2,R1             copy char to R1 for VSBW
0465 6434 C028  34        MOV  @$ALTO(U),R0      alternate output device?
     6436 003A     
0466 6438 1317  14        JEQ  EMIT0             jump to video display output if not
0467               *
0468               *  R0 now points to PAB for alternate output device, the one-byte buffer
0469               *  for which must immediately precede its PAB.  PAB must have been set up
0470               *  to write one byte.
0471               *
0472 643A 04C7  14        CLR  R7                ALTOUT active
0473 643C D807  38        MOVB R7,@KYSTAT        zero status byte
     643E 837C     
0474 6440 0600  14        DEC  R0                point to one-byte VRAM buffer in front of PAB
0475 6442 06C1  14        SWPB R1                char to MSB
0476 6444 0420  54        BLWP @VSBW             write char to buffer
     6446 373E     
0477 6448 05C0  14        INCT R0                point to Flag/Status byte
0478 644A 0420  54        BLWP @VSBR             read it
     644C 3746     
0479 644E 0241  22        ANDI R1,>1F00          clear error bits without disturbing flag bits
     6450 1F00     
0480 6452 0420  54        BLWP @VSBW             write it back to PAB
     6454 373E     
0481 6456 0220  22        AI   R0,8              Set up pointer to namelength byte of PAB
     6458 0008     
0482 645A C800  38        MOV  R0,@SUBPTR        copy to DSR subroutine name-length pointer
     645C 8356     
0483 645E 0420  54        BLWP @DSRLNK           put 1 byte to device
     6460 37BE     
0484 6462 0008            DATA >8
0485 6464 0460  28        B    @BKLINK           return to caller
     6466 30EA     
0486               *
0487               *  Output is going to the video display
0488               *
0489 6468 0281  22 EMIT0  CI   R1,7            Is it a bell?
     646A 0007     
0490 646C 1607  14        JNE  NOTBEL
0491 646E 04C2  14        CLR  R2
0492 6470 D802  38        MOVB R2,@KYSTAT
     6472 837C     
0493 6474 0420  54        BLWP @GPLLNK
     6476 3784     
0494 6478 0036            DATA >0036           Emit error tone
0495 647A 1060  14        JMP  EMEXIT
0496               *
0497 647C 0281  22 NOTBEL CI   R1,8            Is it a backspace?
     647E 0008     
0498 6480 160B  14        JNE  NOTBS
0499 6482 0201  20        LI   R1,>2000
     6484 2000     
0500 6486 C028  34        MOV  @CURPO$(U),R0
     6488 0016     
0501 648A 0420  54        BLWP @VSBW
     648C 373E     
0502 648E 1501  14        JGT  DECCUR
0503 6490 1055  14        JMP  EMEXIT
0504 6492 0628  34 DECCUR DEC  @CURPO$(U)
     6494 0016     
0505 6496 1052  14        JMP  EMEXIT
0506               *
0507 6498 0281  22 NOTBS  CI   R1,>A           Is it a line feed?
     649A 000A     
0508 649C 162B  14        JNE  NOTLF
0509 649E C1E8  34        MOV  @$SEND(U),R7
     64A0 0034     
0510 64A2 61E8  34        S    @$SWDTH(U),R7
     64A4 0030     
0511 64A6 81E8  34        C    @CURPO$(U),R7
     64A8 0016     
0512 64AA 1404  14        JHE  SCRLL
0513 64AC AA28  54        A    @$SWDTH(U),@CURPO$(u)
     64AE 0030     
     64B0 0016     
0514 64B2 1044  14        JMP  EMEXIT
0515 64B4 C1CB  18 SCRLL  MOV  LINK,R7
0516 64B6 06A0  32        BL   @SCROLL
     64B8 339E     
0517 64BA C2C7  18        MOV  R7,LINK
0518 64BC 103F  14        JMP  EMEXIT
0519               *
0520               *** SCROLLING ROUTINE
0521               *
0522      339E     SCROLL EQU  $LO+$-LLVSPT
0523 64BE C028  34        MOV  @$SSTRT(U),R0   VRAM addr
     64C0 0032     
0524 64C2 0201  20        LI   R1,LINBUF       Line buffer
     64C4 3A6C     
0525 64C6 C0A8  34        MOV  @$SWDTH(U),R2   Count
     64C8 0030     
0526 64CA A002  18        A    R2,R0           Start at line 2
0527 64CC 0420  54 SCROL1 BLWP @VMBR
     64CE 374A     
0528 64D0 6002  18        S    R2,R0           One line back to write
0529 64D2 0420  54        BLWP @VMBW
     64D4 3742     
0530 64D6 A002  18        A    R2,R0           Two lines ahead for next read
0531 64D8 A002  18        A    R2,R0
0532 64DA 8A00  38        C    R0,@$SEND(U)    End of screen?
     64DC 0034     
0533 64DE 1AF6  14        JL   SCROL1
0534 64E0 C042  18        MOV  R2,R1           Blank bottom row of screen
0535 64E2 0200  20        LI   R0,>2000        Blank
     64E4 2000     
0536 64E6 60A8  34        S    @$SEND(U),R2
     64E8 0034     
0537 64EA 0502  16        NEG  R2              Now contains address of start of last line
0538 64EC C18B  18        MOV  LINK,R6
0539 64EE 06A0  32        BL   @FILL1          Write the blanks
     64F0 3208     
0540 64F2 0456  20        B    *R6
0541               *
0542 64F4 0281  22 NOTLF  CI   R1,>D           Is it a carriage return?
     64F6 000D     
0543 64F8 160D  14        JNE  NOTCR
0544 64FA 04C0  14        CLR  R0
0545 64FC C068  34        MOV  @CURPO$(U),R1
     64FE 0016     
0546 6500 C0C1  18        MOV  R1,R3
0547 6502 6068  34        S    @$SSTRT(U),R1   Adjusted for screen not at 0
     6504 0032     
0548 6506 C0A8  34        MOV  @$SWDTH(U),R2
     6508 0030     
0549 650A 3C02 128        DIV  R2,R0
0550 650C 60C1  18        S    R1,R3
0551 650E CA03  38        MOV  R3,@CURPO$(U)
     6510 0016     
0552 6512 1014  14        JMP  EMEXIT
0553               *
0554 6514 06C1  14 NOTCR  SWPB R1              Assume it is a printable character
0555 6516 C028  34        MOV  @CURPO$(U),R0
     6518 0016     
0556 651A 0420  54        BLWP @VSBW
     651C 373E     
0557 651E C0A8  34        MOV  @$SEND(U),R2
     6520 0034     
0558 6522 0602  14        DEC  R2
0559 6524 8080  18        C    R0,R2
0560 6526 1607  14        JNE  NOTCR1
0561 6528 C028  34        MOV  @$SEND(U),R0
     652A 0034     
0562 652C 6028  34        S    @$SWDTH(U),R0   Was last char on screen. Scroll
     652E 0030     
0563 6530 CA00  38        MOV  R0,@CURPO$(U)
     6532 0016     
0564 6534 10BF  14        JMP  SCRLL
0565 6536 0580  14 NOTCR1 INC  R0              No scroll necessary
0566 6538 CA00  38        MOV  R0,@CURPO$(U)
     653A 0016     
0567               *
0568 653C 0460  28 EMEXIT B    @BKLINK
     653E 30EA     
0569               ;]*
0570               ;[*== CRLF routine                          CODE =  -6  =================
0571               *
0572      3420     CLF    EQU  $LO+$-LLVSPT
0573 6540 C14B  18        MOV  LINK,R5
0574 6542 0202  20        LI   R2,>000D
     6544 000D     
0575 6546 06A0  32        BL   @EMT            EMT will alter INT mask via B @BKLINK
     6548 3312     
0576 654A 0202  20        LI   R2,>000A
     654C 000A     
0577 654E 0300  24        LIMI 0               Previous call to EMT altered INT mask
     6550 0000     
0578 6552 06A0  32        BL   @EMT
     6554 3312     
0579 6556 C2C5  18        MOV  R5,LINK
0580 6558 0460  28        B    @BKLINK
     655A 30EA     
0581               ;]*
0582               ;[*== ?TERMINAL routine                     CODE =  -8  =================
0583               * scan for <clear>, <break>, FCTN+4 press
0584               *
0585      343C     QTM    EQU  $LO+$-LLVSPT
0586 655C C14B  18        MOV  LINK,R5         save return
0587 655E 06A0  32        BL   @>0020          branch to console's test for <clear>
     6560 0020     
0588 6562 02C0  12        STST R0              store status in R0
0589 6564 1603  14        JNE  QTM2            exit if not <clear>
0590 6566 06A0  32 QTM1   BL   @>0020          check for <clear> again
     6568 0020     
0591 656A 13FD  14        JEQ  QTM1            loop until not <clear>
0592 656C C2C5  18 QTM2   MOV  R5,LINK         restore return
0593 656E 0240  22        ANDI R0,>2000        keep only EQU bit
     6570 2000     
0594 6572 0460  28        B    @BKLINK         return to caller
     6574 30EA     
0595               ;]*
0596               ;[*== ?KEY routine                          CODE = -10  =================
0597               *
0598      3456     QKY    EQU  $LO+$-LLVSPT
0599 6576 0420  54        BLWP @KSCAN
     6578 373A     
0600 657A D020  34        MOVB @KYCHAR,R0
     657C 8375     
0601 657E 0980  56        SRL  R0,8
0602 6580 0280  22        CI   R0,>00FF
     6582 00FF     
0603 6584 1601  14        JNE  QKEY1
0604 6586 04C0  14        CLR  R0
0605 6588 0460  28 QKEY1  B    @BKLINK
     658A 30EA     
0606               ;]*
0607               ;[*== GOTOXY routine                        CODE = -12  =================
0608               *
0609      346C     GXY    EQU  $LO+$-LLVSPT
0610 658C 38E8  72        MPY  @$SWDTH(U),R3
     658E 0030     
0611 6590 A102  18        A    R2,R4           Position within screen
0612 6592 A128  34        A    @$SSTRT(U),R4   Add VRAM offset to screen top
     6594 0032     
0613 6596 CA04  38        MOV  R4,@CURPO$(U)
     6598 0016     
0614 659A 0460  28        B    @BKLINK
     659C 30EA     
0615               ;]
0616               *       ___  __         __     ____  ______
0617               *      / _ )/ /__  ____/ /__  /  _/_/_/ __ \
0618               *     / _  / / _ \/ __/  '_/ _/ /_/_// /_/ /
0619               *    /____/_/\___/\__/_/\_\ /___/_/  \____/
0620               
0621               *
0622               *== USE blocks file                         CODE = -14  =================
0623               *== CREATE blocks file                      CODE = -16  =================
0624               *== READ block from blocks file             CODE = -18  =================
0625               *== WRITE block to blocks file              CODE = -20  =================
0626               ;[*== Block File I/O Support ============================================
0627               *
0628               * BPTOG utility to toggle one of 2 PABs for block file access
0629               *
0630      347E     BPTOG  EQU  $LO+$-LLVSPT
0631 659E C028  34        MOV  @$BPOFF(U),R0	   PAB offset to R0
     65A0 0040     
0632 65A2 0201  20        LI	R1,70	            Toggle amount
     65A4 0046     
0633 65A6 2840  18        XOR	R0,R1	            New offset
0634 65A8 CA01  38        MOV	R1,@$BPOFF(U)	   Update offset
     65AA 0040     
0635               *
0636               **xxx** entry point to insure we have correct PAB address
0637      348C     BPSET  EQU  $LO+$-LLVSPT
0638 65AC C028  34        MOV  @$DKBUF(U),R0	   Get DISK_BUF address
     65AE 002C     
0639 65B0 A028  34        A	   @$BPABS(U),R0	   Get BPABS address
     65B2 003E     
0640               *
0641 65B4 A028  34        A	   @$BPOFF(U),R0     Add current offset
     65B6 0040     
0642 65B8 C800  38        MOV	R0,@BFPAB	      Update current block file's PAB address
     65BA 34BC     
0643 65BC 045B  20        RT
0644               *
0645               * CLOSE blocks file
0646               *
0647      349E     BKCLOS EQU  $LO+$-LLVSPT
0648 65BE C020  34        MOV  @BFPAB,R0
     65C0 34BC     
0649 65C2 0201  20        LI   R1,$FCLS          Opcode=CLOSE
     65C4 0100     
0650 65C6 0420  54        BLWP @VSBW
     65C8 373E     
0651 65CA 0220  22        AI   R0,9              Address of filename's char count
     65CC 0009     
0652 65CE C800  38        MOV  R0,@SUBPTR        Point to filename's char count
     65D0 8356     
0653 65D2 0420  54        BLWP @DSRLNK           Close the file
     65D4 37BE     
0654 65D6 0008            DATA 8
0655 65D8 045B  20        RT                     Deal with error in caller
0656               *
0657               * storage area
0658               *
0659      34BA     SVBRET EQU  $LO+$-LLVSPT
0660 65DA 0000            DATA 0                 Storage for LINK coming into BRW
0661      34BC     BFPAB  EQU  $LO+$-LLVSPT
0662 65DC 0000            DATA	0	               Storage for current blocks file PAB address...
0663               *	 	 	                     ...will have current PAB on entry
0664               * PAB header storage
0665               *
0666      34BE     PABHD  EQU  $LO+$-LLVSPT
0667 65DE                 BSS  4                 BYTE 0: opcode 0=OPEN,1=CLOSE,2=READ,3=WRITE,4=RESTORE
0668               *              	            BYTE 1: >05=INPUT  mode + clear error,fixed,display,relative
0669               *	                	                 >03=OUTPUT mode + "
0670               *	                	                 >01=UPDATE mode + "
0671               *	                         BYTE 2,3: save contents of DISK_BUF here
0672 65E2 80              BYTE	>80	            Record length
0673 65E3   80            BYTE	>80	            Character count of transfer
0674 65E4                 BSS	2	            Record number
0675               *
0676               *** file I/O equates
0677               *
0678      0000     $FOPN  EQU  >0000
0679      0100     $FCLS  EQU  >0100
0680      0200     $FRD   EQU  >0200
0681      0300     $FWRT  EQU  >0300
0682      0400     $FRST  EQU  >0400
0683      0005     $FINP  EQU  5
0684      0003     $FOUT  EQU  3
0685      0001     $FUPD  EQU  1
0686               *
0687               *** BRW -- entry point for block read/write routines
0688               *
0689      34C6     BRW    EQU  $LO+$-LLVSPT
0690 65E6 C80B  38        MOV  LINK,@SVBRET   Save LINK address
     65E8 34BA     
0691 65EA C1C1  18        MOV	R1,R7	         Save CODE {R1 to R7}
0692 65EC 0817  56        SRA  R7,1           Divide CODE by 2 (now -7,-8,-9,-10)
0693 65EE 0227  22        AI   R7,12          CODE + 12 (now 5,4,3,2, with OP for output, but not input)
     65F0 000C     
0694 65F2 06A0  32        BL   @BPSET         Insure correct PAB address in BFPAB (it may have moved)
     65F4 348C     
0695 65F6 0287  22        CI	R7,4	         USE or CREATE?
     65F8 0004     
0696 65FA 110D  14        JLT	BRW01	         No
0697 65FC 06A0  32        BL	@BPTOG	      Yes...toggle BPOFF & BFPAB
     65FE 347E     
0698 6600 C020  34        MOV	@BFPAB,R0	   Load PAB address
     6602 34BC     
0699 6604 0220  22        AI	R0,9	         Set to name length byte
     6606 0009     
0700 6608 04C2  14        CLR	R2
0701 660A C079  30        MOV	*SP+,R1	      Pop bfnaddr to R1
0702 660C D811  46        MOVB	*R1,@MAINWS+5	Copy length byte to low byte of R2
     660E 8305     
0703 6610 0582  14        INC	R2	            Add 1 to # bytes to copy
0704 6612 0420  54        BLWP	@VMBW	         Copy char count & pathname to PAB
     6614 3742     
0705               *
0706               *** set up PAB for OPEN
0707               *
0708 6616 0201  20 BRW01  LI	R1,$FUPD                Opcode=0,mode=update
     6618 0001     
0709 661A 9820  54        CB   @MAINWS+15,@MAINWS+15   Set mode=input (OP)?
     661C 830F     
     661E 830F     
0710 6620 1C02  14        JOP  BRW02                   No
0711 6622 0201  20        LI	R1,$FINP                Yes...change mode=input
     6624 0005     
0712 6626 C801  38 BRW02  MOV  R1,@PABHD               Put in PAB header
     6628 34BE     
0713 662A C828  54        MOV  @$DKBUF(U),@PABHD+2     VRAM buffer location to PAB header
     662C 002C     
     662E 34C0     
0714 6630 04C0  14        CLR  R0
0715 6632 C800  38        MOV  R0,@PABHD+6             Set record#=0
     6634 34C4     
0716 6636 C020  34        MOV  @BFPAB,R0               VRAM destination
     6638 34BC     
0717 663A 0201  20        LI   R1,PABHD                RAM source
     663C 34BE     
0718 663E 0202  20        LI   R2,8                    Copy first 8 bytes of PAB header
     6640 0008     
0719 6642 0420  54        BLWP @VMBW                   Do the copy
     6644 3742     
0720               *
0721               *** open new blocks file [CODE = -14, USE; CODE = -16,CREATE]
0722               *
0723 6646 0220  22        AI   R0,9                Address of filename's char count in PAB
     6648 0009     
0724 664A C800  38        MOV  R0,@SUBPTR          Point to-----^^^^
     664C 8356     
0725 664E 0420  54        BLWP @DSRLNK             Open/create the file
     6650 37BE     
0726 6652 0008            DATA 8
0727 6654 135F  14        JEQ  BKERR
0728 6656 0287  22        CI   R7,4                READ or WRITE?
     6658 0004     
0729 665A 1120  14        JLT  BRW04               Yes
0730 665C 156E  14        JGT  BRWDON              No; =USE; we're done
0731               *
0732               *** write blank records to newly created blocks file [CODE = -16,CREATE]
0733               *
0734 665E C179  30        MOV  *SP+,R5             No; = CREATE; pop #blocks from stack
0735 6660 0A35  56        SLA  R5,3                Convert #blocks to #records
0736 6662 C0C5  18        MOV  R5,R3               Save
0737 6664 C105  18        MOV  R5,R4               Set up counter
0738 6666 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     6668 0301     
0739 666A C800  38        MOV  R0,@PABHD           Copy to PAB header
     666C 34BE     
0740 666E 6144  18 BRLOOP S    R4,R5               Calculate next record
0741 6670 C805  38        MOV  R5,@PABHD+6         Copy to PAB header
     6672 34C4     
0742 6674 C020  34        MOV  @BFPAB,R0           VRAM destination
     6676 34BC     
0743 6678 0201  20        LI   R1,PABHD            RAM source
     667A 34BE     
0744 667C 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     667E 0008     
0745 6680 0420  54        BLWP @VMBW               Do the copy
     6682 3742     
0746 6684 0220  22        AI   R0,9                Address of filename's char count
     6686 0009     
0747 6688 C800  38        MOV  R0,@SUBPTR          Point to filename's char count
     668A 8356     
0748 668C 0420  54        BLWP @DSRLNK             Write one record of blanks
     668E 37BE     
0749 6690 0008            DATA 8
0750 6692 1340  14        JEQ  BKERR
0751 6694 C143  18        MOV  R3,R5               Get #blocks
0752 6696 0604  14        DEC  R4                  Count down 1 record
0753 6698 16EA  14        JNE  BRLOOP              Write another record if not done
0754 669A 104F  14        JMP  BRWDON              We're done
0755               *
0756               *** prepare for read/write block
0757               *
0758 669C C179  30 BRW04  MOV  *SP+,R5             Pop block# to write
0759 669E C1B9  30        MOV  *SP+,R6             Pop bufaddr
0760 66A0 0605  14        DEC  R5                  Block#-1
0761 66A2 0A35  56        SLA  R5,3                Convert to starting record#
0762 66A4 0204  20        LI   R4,8                Load counter for 8 records
     66A6 0008     
0763 66A8 0200  20        LI   R0,$FWRT+$FUPD      Set up for WRITE
     66AA 0301     
0764 66AC 0203  20        LI   R3,VMBW             WRITE vector
     66AE 3742     
0765 66B0 0287  22        CI   R7,2                Are we writing the block?
     66B2 0002     
0766 66B4 1304  14        JEQ  BRW05               Yup
0767 66B6 0200  20        LI   R0,$FRD+$FINP       Nope...set up for READ
     66B8 0205     
0768 66BA 0203  20        LI   R3,VMBR             READ vector
     66BC 374A     
0769 66BE C800  38 BRW05  MOV  R0,@PABHD           Copy opcode&mode to PAB header
     66C0 34BE     
0770               *
0771               * READ/WRITE block routine [CODE = -18/-20]
0772               *
0773 66C2 C805  38 RWLOOP MOV  R5,@PABHD+6         Copy record# to PAB header
     66C4 34C4     
0774 66C6 C020  34        MOV  @BFPAB,R0           VRAM destination
     66C8 34BC     
0775 66CA 0201  20        LI   R1,PABHD            RAM source
     66CC 34BE     
0776 66CE 0202  20        LI   R2,8                #Bytes of PAB header to copy to PAB
     66D0 0008     
0777 66D2 0420  54        BLWP @VMBW               Do the copy
     66D4 3742     
0778 66D6 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0
     66D8 002C     
0779 66DA C046  18        MOV  R6,R1               RAM buffer to R1
0780 66DC 0202  20        LI   R2,128              Bytes to copy
     66DE 0080     
0781 66E0 0287  22        CI   R7,3                READ?
     66E2 0003     
0782 66E4 1301  14        JEQ  BRW06               Yup
0783 66E6 0413  42        BLWP *R3                 Nope...copy record to VRAM
0784               *
0785               * temporarily use CRU register---it should be OK
0786               *
0787 66E8 C320  34 BRW06  MOV  @BFPAB,CRU          PAB address
     66EA 34BC     
0788 66EC 022C  22        AI   CRU,9               Address of filename's char count
     66EE 0009     
0789 66F0 C80C  38        MOV  CRU,@SUBPTR         Point to filename's char count
     66F2 8356     
0790 66F4 0420  54        BLWP @DSRLNK             Read/write one record
     66F6 37BE     
0791 66F8 0008            DATA 8
0792 66FA 130C  14        JEQ  BKERR
0793 66FC 0287  22        CI   R7,2                WRITE?
     66FE 0002     
0794 6700 1303  14        JEQ  BRW07               Yup...next record
0795 6702 C028  34        MOV  @$DKBUF(U),R0       VRAM buffer address to R0 (DSRLNK trashed it!)
     6704 002C     
0796 6706 0413  42        BLWP *R3                 Nope...copy record to RAM buffer
0797 6708 0585  14 BRW07  INC  R5                  Next record in file
0798 670A 0226  22        AI   R6,128              Next record to/from block RAM buffer
     670C 0080     
0799 670E 0604  14        DEC  R4                  Count down 1 record
0800 6710 16D8  14        JNE  RWLOOP              Read/write another record if not done
0801 6712 1013  14        JMP  BRWDON              We're done
0802               *
0803               *** error handling
0804               *
0805 6714 D000  18 BKERR  MOVB R0,R0               Device error?
0806 6716 1306  14        JEQ  BKERR6              Yes, exit with disk error
0807 6718 0206  20 BKERR9 LI   R6,9                No, exit with file error
     671A 0009     
0808 671C 1005  14        JMP  BKCLN
0809 671E 0206  20 BKERR8 LI   R6,8                Block# <=0!  exit with range error
     6720 0008     
0810 6722 1002  14        JMP  BKCLN
0811 6724 0206  20 BKERR6 LI   R6,6
     6726 0006     
0812 6728 06A0  32 BKCLN  BL   @BKCLOS             Close current blocks file; ignore error
     672A 349E     
0813 672C 0287  22        CI   R7,4                USE or CREATE?
     672E 0004     
0814 6730 1102  14        JLT  BKCLN1              No
0815 6732 06A0  32        BL   @BPTOG	            Yes...toggle BPOFF & BFPAB
     6734 347E     
0816 6736 C006  18 BKCLN1 MOV  R6,R0               Pass error back to caller
0817 6738 100C  14        JMP  BKEXIT
0818 673A 04C6  14 BRWDON CLR  R6
0819 673C 06A0  32        BL   @BKCLOS             Close current blocks file
     673E 349E     
0820 6740 1602  14        JNE  BRWDN1              Error?
0821 6742 0206  20        LI   R6,9                Yes...assume it was a file error
     6744 0009     
0822 6746 0287  22 BRWDN1 CI   R7,4                (no error)...CREATE?
     6748 0004     
0823 674A 1602  14        JNE  BRWDN2              No...we're done
0824 674C 06A0  32        BL   @BPTOG              Yes...revert to correct blocks file
     674E 347E     
0825 6750 C006  18 BRWDN2 MOV  R6,R0               Error to R0
0826 6752 C2E0  34 BKEXIT MOV  @SVBRET,LINK        Restore LINK
     6754 34BA     
0827 6756 0460  28        B    @BKLINK
     6758 30EA     
0828               ;]
0829               ;[* MSGTYP      <<< Support for string typing in various banks >>>
0830               *
0831               * Called with:  BL  @MSGTYP
0832               *
0833               * R4 and R5 are the only registers that will be preserved
0834               * ..after a call to EMIT---
0835               *
0836               * Input:    R4 = Address of length byte of packed string
0837               *
0838               * We will pass the ASCII value of character to EMIT in R2 without
0839               * insuring it is 7 bits wide.
0840               *
0841      363A     MSGTYP EQU  $LO+$-LLVSPT
0842 675A 064E  14        DECT R           Push return address
0843 675C C78B  30        MOV  LINK,*R     ...to Forth return stack
0844 675E 04C5  14        CLR  R5
0845 6760 D174  28        MOVB *R4+,R5     Put string length in R5 and point R4 to 1st char
0846 6762 06C5  14        SWPB R5          Put char count in low byte
0847 6764 04C2  14 MTLOOP CLR  R2
0848 6766 D0B4  28        MOVB *R4+,R2     Copy next char to R2 for EMIT
0849 6768 06C2  14        SWPB R2          Put char in low byte
0850 676A 0300  24        LIMI 0           We need to do this because we're calling EMIT directly
     676C 0000     
0851 676E 06A0  32        BL   @EMT        Call EMIT directly
     6770 3312     
0852 6772 05A8  34        INC  @$OUT(U)    Increment display line character count
     6774 0052     
0853 6776 0605  14        DEC  R5          Decrement character count for this message
0854 6778 16F5  14        JNE  MTLOOP      Are we done?
0855 677A C2FE  30        MOV  *R+,LINK    Yes. Pop return address
0856 677C 045B  20        RT               Return to caller
0857                ;]
0858               ;[*-- R4$5 --*      Space-saving routine to copy FP nums (Now in low RAM)
0859      365E     R4$5   EQU  $LO+$-LLVSPT
0860 677E CD74  46        MOV  *R4+,*R5+
0861 6780 CD74  46        MOV  *R4+,*R5+
0862 6782 CD74  46        MOV  *R4+,*R5+
0863 6784 C554  38        MOV  *R4,*R5
0864 6786 045B  20        RT
0865               ;]
0866               *     __  __              _   __         _      __   __
0867               *    / / / /__ ___ ____  | | / /__ _____(_)__ _/ /  / /__
0868               *   / /_/ (_-</ -_) __/  | |/ / _ `/ __/ / _ `/ _ \/ / -_)
0869               *   \____/___/\__/_/     |___/\_,_/_/ /_/\_,_/_.__/_/\__/
0870               *              ___      ___          ____
0871               *             / _ \___ / _/__ ___ __/ / /____
0872               *            / // / -_) _/ _ `/ // / / __(_-<
0873               *           /____/\__/_/ \_,_/\_,_/_/\__/___/
0874               
0875               ;[*== User Variable defaults ============================================
0876               *
0877      3668     UBASE0 EQU  $LO+$-LLVSPT
0878 6788                 BSS  6                 BASE OF USER VARIABLES
0879 678E 3668            DATA UBASE0            06 USER UCONS$
0880 6790 FFA0            DATA SPBASE            08 USER S0
0881 6792 3FFE            DATA RBASE             0A USER R0 { R0$
0882 6794 36B4            DATA $UVAR             0C USER U0
0883 6796 FFA0            DATA SPBASE            0E USER TIB
0884 6798 001F            DATA 31                10 USER WIDTH
0885 679A A000            DATA DPBASE            12 USER DP
0886 679C 30F6            DATA $SYS$             14 USER SYS$
0887 679E 0000            DATA 0                 16 USER CURPOS
0888 67A0 3020            DATA INT1              18 USER INTLNK
0889 67A2 0001            DATA 1                 1A USER WARNING
0890 67A4 0040            DATA 64                1C USER C/L$ { CL$
0891 67A6 2010            DATA $BUFF             1E USER FIRST$
0892 67A8 3020            DATA $LO               20 USER LIMIT$
0893 67AA 0380            DATA >0380             22 USER COLTAB    Color Table address in VRAM
0894 67AC 0300            DATA >0300             24 USER SATR      Sprite Attribute Table address in VRAM
0895 67AE 0780            DATA >0780             26 USER SMTN      Sprite Motion Table address in VRAM
0896 67B0 0800            DATA >0800             28 USER PDT       Character Pattern Descriptor Table address in VRAM
0897 67B2 0080            DATA >80               2A USER FPB       pushes address of user screen font file PAB
0898               *                                               ...that is this relative distance from DISK_BUF
0899 67B4 1000            DATA >1000       >1B80 2C USER DISK_BUF  (buffer loc in VRAM, size = 128 bytes)
0900 67B6 0460            DATA >460  >1152 >1CD2 2E USER PABS      (area for PABs etc.)
0901 67B8 0028            DATA 40                30 USER SCRN_WIDTH
0902 67BA 0000            DATA 0                 32 USER SCRN_START
0903 67BC 03C0            DATA 960               34 USER SCRN_END
0904 67BE 0000            DATA 0                 36 USER ISR       [Note: This used to be INT1]
0905 67C0 0000            DATA 0                 38 USER ALTIN
0906 67C2 0000            DATA 0                 3A USER ALTOUT
0907 67C4 0001            DATA 1                 3C USER VDPMDE    permanent location for VDPMDE
0908 67C6 00C6            DATA >80+>46           3E USER BPB       pushes address of PAB area for blocks files
0909               *                                               ...that is this relative distance from DISK_BUF
0910 67C8 0000            DATA 0                 40 USER BPOFF     offset into BPABS for current blocks file's PAB
0911               *                                               ...always toggled between 0 and 70
0912 67CA 0800            DATA >0800             42 USER SPDTAB    Sprite Descriptor Table address in VRAM
0913 67CC FFFF            DATA -1                44 USER SCRFNT      !0 = default = font file (DSKx.FBFONT or user file)
0914               *                                                  0 = console font via GPLLNK
0915 67CE 0000            DATA 0                 46 USER JMODE     0 = TI Forth, ~0 = CRU
0916 67D0 0000            DATA 0                 48 USER WRAP      for fbForth SCROLL word, 0 = no wrap, ~0 = wrap
0917 67D2 0000            DATA 0                 4A USER S|F       Flag for Symmetric or Floored Integer Division..
0918               *                                                  0 = Symmetric (default)
0919               *                                                 !0 = Floored
0920      36B4     $UVAR  EQU  $LO+$-LLVSPT
0921 67D4                 BSS  >80               USER VARIABLE AREA
0922               ;]
0923               ;[*== A Constant ====================================================
0924               *
0925      3734     H2000  EQU  $LO+$-LLVSPT
0926 6854 2000            DATA >2000
0927               ;]*
0928               *    __  ____  _ ___ __         _   __        __
0929               *   / / / / /_(_) (_) /___ __  | | / /__ ____/ /____  _______
0930               *  / /_/ / __/ / / / __/ // /  | |/ / -_) __/ __/ _ \/ __(_-<
0931               *  \____/\__/_/_/_/\__/\_, /   |___/\__/\__/\__/\___/_/ /___/
0932               *                     /___/
0933               *
0934               ;[*== Utility Vectors ===================================================
0935               *
0936               * GPLLNK DATA GLNKWS,GLINK1 <--located with its routine at GPLLNK
0937               * DSRLNK DATA DSRWS,DLINK1  <--located with its routine at DSRLNK
0938      3736     XMLLNK EQU  $LO+$-LLVSPT
0939 6856 3A4C            DATA UTILWS,XMLENT   ; Link to ROM routines
     6858 3756     
0940      373A     KSCAN  EQU  $LO+$-LLVSPT
0941 685A 3A4C            DATA UTILWS,KSENTR   ; Keyboard scan
     685C 3832     
0942      373E     VSBW   EQU  $LO+$-LLVSPT
0943 685E 3A4C            DATA UTILWS,VSBWEN   ; VDP single byte write (R0=vaddr, R1[MSB]=value)
     6860 3848     
0944      3742     VMBW   EQU  $LO+$-LLVSPT
0945 6862 3A4C            DATA UTILWS,VMBWEN   ; VDP multiple byte write (R0=vaddr, R1=addr, R2=cnt)
     6864 3854     
0946      3746     VSBR   EQU  $LO+$-LLVSPT
0947 6866 3A4C            DATA UTILWS,VSBREN   ; VDP single byte read  (R0=vaddr, R1[MSB]=value read)
     6868 3862     
0948      374A     VMBR   EQU  $LO+$-LLVSPT
0949 686A 3A4C            DATA UTILWS,VMBREN   ; VDP multiple byte read (R0=vaddr, R1=addr, R2=cnt)
     686C 386E     
0950      374E     VMOVE  EQU  $LO+$-LLVSPT
0951 686E 3A4C            DATA UTILWS,VMOVEN   ; VDP-to-VDP move (R0=cnt, R1=vsrc,R2=vdst)
     6870 38AE     
0952      3752     VWTR   EQU  $LO+$-LLVSPT
0953 6872 3A4C            DATA UTILWS,VWTREN   ; VDP write to register (R0[MSB]=VR#, R0[LSB]=value)
     6874 387C     
0954               ;]*
0955               ;[*== XMLENT -- Link to system XML utilities ============================
0956               *
0957      3756     XMLENT EQU  $LO+$-LLVSPT
0958 6876 C83E  50        MOV  *R14+,@GPLWS+2      Get argument
     6878 83E2     
0959 687A 02E0  18        LWPI GPLWS               Select GPL workspace
     687C 83E0     
0960 687E C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6880 3A62     
0961 6882 C081  18        MOV  R1,R2               Make a copy of argument
0962 6884 0281  22        CI   R1,>8000            Direct address in ALC?
     6886 8000     
0963 6888 1B07  14        JH   XML30               We have the address
0964 688A 09C1  56        SRL  R1,12
0965 688C 0A11  56        SLA  R1,1
0966 688E 0A42  56        SLA  R2,4
0967 6890 09B2  56        SRL  R2,11
0968 6892 A0A1  34        A    @XMLTAB(R1),R2
     6894 0CFA     
0969 6896 C092  26        MOV  *R2,R2
0970 6898 0692  24 XML30  BL   *R2
0971 689A 02E0  18        LWPI UTILWS              Get back to right WS
     689C 3A4C     
0972 689E C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     68A0 83F6     
0973 68A2 0380  18        RTWP
0974               ;]*
0975               *    ________  __   __   _  ____ __           __  ________
0976               *   / ___/ _ \/ /  / /  / |/ / //_/          /  |/  / ___/
0977               *  / (_ / ___/ /__/ /__/    / ,<      _ _ _ / /|_/ / (_ /
0978               *  \___/_/  /____/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
0979               *
0980               *-----------------------------------------------------------------------*
0981               ;[*== GPLLNK- A universal GPLLNK - 6/21/85 - MG =========================
0982               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
0983               *                                                                       *
0984               * This routine will work with any GROM library slot since it is         *
0985               * indexed off of R13 in the GPLWS.  (It does require Mem Expansion)     *
0986               * This GPLLNK does NOT require a module to be plugged into the          *
0987               * GROM port so it will work with the Editor/Assembler,                  *
0988               * Mini Memory (with Mem Expansion), Extended Basic, the Myarc           *
0989               * CALL LR("DSKx.xxx") or the CorComp Disk Manager Loaders.              *
0990               * It saves and restores the current GROM Address in case you want       *
0991               * to return back to GROM for Basic or Extended Basic CALL LINKs         *
0992               * or to return to the loading module.                                   *
0993               *                                                                       *
0994               *    ENTER: The same way as the E/A GPLLNK, i.e., BLWP @GPLLNK          *
0995               *                                                 DATA >34              *
0996               *                                                                       *
0997               *    NOTES: Do Not REF GPLLNK when using this routine in your code.     *
0998               *                                                                       *
0999               * 70 Bytes - including the GPLLNK Workspace                             *
1000               *-----------------------------------------------------------------------*
1001               
1002               *  GPLWS (>83E0) is GPL workspace
1003      83E8     G_R4   EQU  GPLWS+8              GPL workspace R4
1004      83EC     G_R6   EQU  GPLWS+12             GPL workspace R6
1005               *  SUBSTK (>8373) is GPL Subroutine stack pointer
1006      0060     LDGADR EQU  >60                  Load & Execute GROM address entry point
1007      200E     XTAB27 EQU  >200E                Low Mem XML table location 27
1008               *                                ..Will contain XMLRTN at startup
1009      166C     GETSTK EQU  >166C
1010               
1011      3784     GPLLNK EQU  $LO+$-LLVSPT
1012 68A4 3776            DATA GLNKWS      R7       Set up BLWP Vectors
1013 68A6 3796            DATA GLINK1      R8
1014               * RTNADR EQU  $LO+$-LLVSPT    <---don't think we need this label
1015 68A8 37B2            DATA XMLRTN      R9       address where GPL XML returns to us...
1016               *                                ...this address will already be in XTAB27,...
1017               *                                ...>200E, so don't really need it here}
1018      378A     GXMLAD EQU  $LO+$-LLVSPT
1019 68AA 176C            DATA >176C       R10      GROM Address for GPL 'XML >27' (>0F27 Opcode)
1020 68AC 0050            DATA >50         R11      Initialized to >50 where PUTSTK address resides
1021      3776     GLNKWS EQU  $LO+$-LLVSPT->18     GPLLNK's workspace of which only...
1022 68AE                 BSS  >08         R12-R15  ...registers R7 through R15 are used
1023               
1024      3796     GLINK1 EQU  $LO+$-LLVSPT
1025 68B6 C81B  46        MOV  *R11,@G_R4           Put PUTSTK Address into R4 of GPL WS
     68B8 83E8     
1026 68BA C83E  50        MOV  *R14+,@G_R6          Put GPL Routine Address in R6 of GPL WS
     68BC 83EC     
1027 68BE 02E0  18        LWPI GPLWS                Load GPL WS
     68C0 83E0     
1028 68C2 0694  24        BL   *R4                  Save current GROM Address on stack
1029 68C4 C920  54        MOV  @GXMLAD,@>8302(R4)   Push GPL XML Address on stack for GPL Return
     68C6 378A     
     68C8 8302     
1030 68CA 05E0  34        INCT @SUBSTK              Adjust the stack pointer
     68CC 8373     
1031 68CE 0460  28        B    @LDGADR              Execute our GPL Routine
     68D0 0060     
1032               
1033      37B2     XMLRTN EQU  $LO+$-LLVSPT
1034 68D2 C120  34        MOV  @GETSTK,R4           Get GETSTK pointer
     68D4 166C     
1035 68D6 0694  24        BL   *R4                  Restore GROM address off the stack
1036 68D8 02E0  18        LWPI GLNKWS               Load our WS
     68DA 3776     
1037 68DC 0380  18        RTWP                      All Done - Return to Caller
1038               ;]
1039               *     ___  _______  __   _  ____ __           __  ________
1040               *    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
1041               *   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ /
1042               *  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/
1043               *
1044               *-----------------------------------------------------------------------*
1045               ;[*== DSRLNK - A Universal Device Service Routine Link - MG =============
1046               * {LES NOTE: Some labels have been modified for fbForth compatibility.} *
1047               *                                                                       *
1048               *      (Uses console GROM 0's DSRLNK routine)                           *
1049               *      (Do not REF DSRLNK or GPLLNK when using these routines)          *
1050               *      (This DSRLNK will also handle Subprograms and CS1, CS2)          *
1051               *                                                                       *
1052               *      ENTER: The same way as the E/A DSRLNK, i.e., BLWP @DSRLNK        *
1053               *                                                   DATA 8              *
1054               *                                                                       *
1055               *      NOTES: Must be used with a GPLLNK routine                        *
1056               *             Returns ERRORs the same as the E/A DSRLNK                 *
1057               *             EQ bit set on return if error                             *
1058               *             ERROR CODE in caller's MSB of Register 0 on return        *
1059               *                                                                       *
1060               * 186 Bytes total - including GPLLNK, DSRLNK and both Workspaces        *
1061               *-----------------------------------------------------------------------*
1062               
1063      0050     PUTSTK EQU  >50                     Push GROM Address to stack pointer
1064      836D     TYPE$  EQU  >836D                   DSRLNK Type byte for GPL DSRLNK
1065      8356     NAMLEN EQU  >8356                   Device name length pointer in VDP PAB
1066      8C02     VWA    EQU  >8C02                   VDP Write Address location
1067      8800     VRD    EQU  >8800                   VDP Read Data byte location
1068      83E9     G_R4LB EQU  >83E9                   GPL Workspace R4 Lower byte
1069      837C     GSTAT  EQU  >837C                   GPL Status byte location
1070               
1071      37BE     DSRLNK EQU  $LO+$-LLVSPT
1072 68DE 37C2            DATA DSRWS,DLINK1            Set BLWP Vectors
     68E0 37C2     
1073               
1074      37C2     DSRWS  EQU  $LO+$-LLVSPT            Start of DSRLNK workspace
1075      37C9     DR3LB  EQU  DSRWS+7                 lower byte of DSRLNK workspace R3
1076      37C2     DLINK1 EQU  $LO+$-LLVSPT
1077 68E2 C30C  18        MOV  R12,R12         R0      Have we already looked up the LINK address?
1078 68E4 161C  14        JNE  DLINK3          R1      YES!  Skip lookup routine
1079               *<<-------------------------------------------------------------------------->>*
1080               * This section of code is only executed once to find the GROM address          *
1081               * for the GPL DSRLNK - which is placed at DSRADR and R12 is set to >2000       *
1082               * to indicate that the address is found and to be used as a mask for EQ & CND  *
1083               *------------------------------------------------------------------------------*
1084 68E6 02E0  18        LWPI GPLWS           R2,R3   else load GPL workspace
     68E8 83E0     
1085 68EA C120  34        MOV  @PUTSTK,R4      R4,R5   Store current GROM address on the stack
     68EC 0050     
1086 68EE 0694  24        BL   *R4             R6
1087 68F0 0204  20        LI   R4,>11          R7,R8   Load R4 with address of LINK routine vector
     68F2 0011     
1088 68F4 DB44  38        MOVB R4,@>402(R13)   R9,R10  Set up GROM with address for vector
     68F6 0402     
1089               
1090               ***les*** Note on above instruction:
1091               ***les***    1. R13 of GPLWS has >9800=GRMRD (GROM Read Data)
1092               ***les***    2. >402 added to GRMRD yields >9C02=GRMWA (GROM Write Address)
1093               
1094 68F8 1004  14        JMP  DLINK2          R11     Jump around R12-R15
1095 68FA 0000            DATA 0               R12     contains >2000 flag when set
1096 68FC 0000            DATA 0,0,0           R13-R15 contains WS, PC & ST for RTWP
     68FE 0000     
     6900 0000     
1097 6902 DB60  54 DLINK2 MOVB @G_R4LB,@>402(R13)      Finish setting up GROM address
     6904 83E9     
     6906 0402     
1098 6908 C160  34        MOV  @GETSTK,R5              Take some time & set up GETSTK pointer
     690A 166C     
1099 690C D81D  46        MOVB *R13,@DSRAD1            Get the GPL DSR LINK vector
     690E 3811     
1100 6910 05E0  34        INCT @DSRADR                 Adjust it to get past GPL FETCH instruction
     6912 3810     
1101 6914 0695  24        BL   *R5                     Restore the GROM address off the stack
1102 6916 02E0  18        LWPI DSRWS                   Reload DSRLNK workspace
     6918 37C2     
1103 691A 020C  20        LI   R12,>2000               Set flag to signify DSRLNK address is set
     691C 2000     
1104               *<<-------------------------------------------------------------------------->>*
1105 691E 058E  14 DLINK3 INC  R14                     Adjust R14 to point to caller's DSR Type byte
1106 6920 D83E  48        MOVB *R14+,@TYPE$            Move it into >836D for GPL DSRLNK
     6922 836D     
1107 6924 C0E0  34        MOV  @NAMLEN,R3              Save VDP address of Name Length
     6926 8356     
1108 6928 0223  22        AI   R3,-8                   Adjust it to point to PAB Flag byte
     692A FFF8     
1109 692C 0420  54        BLWP @GPLLNK                 Execute DSR LINK
     692E 3784     
1110      3810     DSRADR EQU  $LO+$-LLVSPT
1111 6930 03              BYTE >03                     High byte of GPL DSRLNK address
1112      3811     DSRAD1 EQU  $LO+$-LLVSPT
1113 6931   00            BYTE >00                     Lower byte of GPL DSRLNK address
1114               *----Error Check & Report to Caller's R0 and EQU bit-------------------------
1115 6932 D820  54        MOVB @DR3LB,@VWA             Set up LSB of VDP Address for Error Flag
     6934 37C9     
     6936 8C02     
1116 6938 D803  38        MOVB R3,@VWA                 Set up MSB of VDP Address for Error Flag
     693A 8C02     
1117 693C 53CC  18        SZCB R12,R15                 Clear EQ bit for Error Report
1118 693E D0E0  34        MOVB @VRD,R3                 Get PAB Error Flag
     6940 8800     
1119 6942 0953  56        SRL  R3,5                    Adjust it to 0-7 error code
1120 6944 D743  30        MOVB R3,*R13                 Put it into Caller's R0 (msb)
1121 6946 1603  14        JNE  SETEQ                   If it's not zero, set EQ bit
1122 6948 2320  38        COC  @GSTAT,R12              Else, test CND bit for Link Error (00)
     694A 837C     
1123 694C 1601  14        JNE  DSREND                  No Error, Just return
1124 694E F3CC  18 SETEQ  SOCB R12,R15                 Error, so set Caller's EQ bit
1125 6950 0380  18 DSREND RTWP                         All Done - Return to Caller
1126               ;]
1127               ;[*== KSENTR -- Keyboard Scan (entry point) =============================
1128               *
1129      3832     KSENTR EQU  $LO+$-LLVSPT
1130 6952 02E0  18        LWPI GPLWS
     6954 83E0     
1131 6956 C80B  38        MOV  R11,@UTILWS+22      Save GPL return address
     6958 3A62     
1132 695A 06A0  32        BL   @SCNKEY             Console keyboard scan routine
     695C 000E     
1133 695E 02E0  18        LWPI UTILWS
     6960 3A4C     
1134 6962 C80B  38        MOV  R11,@GPLWS+22       Restore GPL return address
     6964 83F6     
1135 6966 0380  18        RTWP
1136               ;]*
1137               *    _   _____  ___    __  ____  _ ___ __  _
1138               *   | | / / _ \/ _ \  / / / / /_(_) (_) /_(_)__ ___
1139               *   | |/ / // / ___/ / /_/ / __/ / / / __/ / -_|_-<
1140               *   |___/____/_/     \____/\__/_/_/_/\__/_/\__/___/
1141               *
1142               ;[*== VDP utilities (entry point) =======================================
1143               *
1144               ** VDP single byte write
1145               *
1146      3848     VSBWEN EQU  $LO+$-LLVSPT
1147 6968 06A0  32        BL   @WVDPWA             Write out address
     696A 388E     
1148 696C D82D  54        MOVB @2(R13),@VDPWD      Write data
     696E 0002     
     6970 8C00     
1149 6972 0380  18        RTWP                     Return to calling program
1150               *
1151               ** VDP multiple byte write
1152               *
1153      3854     VMBWEN EQU  $LO+$-LLVSPT
1154 6974 06A0  32        BL   @WVDPWA             Write out address
     6976 388E     
1155 6978 D831  48 VWTMOR MOVB *R1+,@VDPWD         Write a byte
     697A 8C00     
1156 697C 0602  14        DEC  R2                  Decrement byte count
1157 697E 16FC  14        JNE  VWTMOR              More to write?
1158 6980 0380  18        RTWP                     Return to calling Program
1159               *
1160               ** VDP single byte read
1161               *
1162      3862     VSBREN EQU  $LO+$-LLVSPT
1163 6982 06A0  32        BL   @WVDPRA             Write out address
     6984 3894     
1164 6986 DB60  54        MOVB @VDPRD,@2(R13)      Read data
     6988 8800     
     698A 0002     
1165 698C 0380  18        RTWP                     Return to calling program
1166               *
1167               ** VDP

xdt99: New TI 99 cross-development tools available

Recommended Posts

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites